Quantcast
Channel: Active questions tagged r - Stack Overflow
Viewing all articles
Browse latest Browse all 201945

Table of classification accuracy in shiny

$
0
0

I'm trying to display a table in shiny that shows the accuracy of classifications for each group. Currently I can only manage to make it display the total count per group.

Ideally, I'd like it to do something like:

t<-table(df$age,df$correct)
row.sums <- apply(t, 1, sum)
t<-t/row.sums
to_display<-t[,2]

And then display to_display

This is the shiny code.

library(shiny)
load("mock_data.Rdata")
# Define UI ----
ui <- fluidPage(

  # Application title
  titlePanel("Group fairness analysis"),

  # Sidebar 
  sidebarLayout(
    sidebarPanel(
      selectInput("group", "Group:", 
                  c("Age" = "age",
                    "Gender" = "gender",
                    "Region" = "region",
                    "Ethnicity"="ethnicity"))
      ),

    # Show a table of accuracy per group
    mainPanel(
      tableOutput("accTab")
    )
  )
)

# Define server logic ----
server <- function(input, output) {

  output$accTab <- renderTable(table(df[[input$group]]))

}

shinyApp(ui, server)

DATA

# data -----------------------------------------------------------
n<-20 #number of users
threshold <- 60 #threshold in risk score for referral to YS
df <- data.frame(age = rep(0,n),
                 gender = rep(0,n),
                 ethnicity = rep(0,n),
                 region = rep(0,n),
                 score = rep(0,n),
                 referred = rep(0,n),
                 target = rep(0,n))

df$age <- as.factor(sample(c(15,16,17),size=n,replace=TRUE))
df$gender <- as.factor(sample(c('M','F'),size=n,replace=TRUE))
df$ethnicity<- as.factor(sample(c('European','Maori','Pacific','other'),size=n,replace=TRUE))
df$region<-as.factor(sample(c('North','Mid','South'),size=n,replace=TRUE))
df$score<-runif(n,min=0,max=100)
df$target<-sample(c(0,1),size=n,replace = TRUE)

df[which(df$score>=threshold),"referred"]<-1

df$colour<-rep(0,n)
df[which(df$referred==1 & df$target==1),"colour"]<-1
df[which(df$referred==1 & df$target==0),"colour"]<-2
df[which(df$referred==0 & df$target==1),"colour"]<-3
df[which(df$referred==0 & df$target==0),"colour"]<-4

df$correct<-rep(0,n)
df[which(df$referred==0 & df$target==0),"correct"]<-1
df[which(df$referred==1 & df$target==1),"correct"]<-1
df[which(df$referred==0 & df$target==1),"correct"]<-0
df[which(df$referred==1 & df$target==0),"correct"]<-0

Viewing all articles
Browse latest Browse all 201945

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>