r语言 - 分类精度表(以闪亮为单位)

Question

我正在尝试在shiny中显示一个表格，该表格显示了每个组分类的准确性。目前，我只能设法使其显示每组的总数。

理想情况下，我希望它执行以下操作：

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

然后显示to_display

这是shiny代码。

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 -----------------------------------------------------------
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

Answer 1

嗨，您需要更改output$accTab(出于测试目的，您还可以在加载数据时添加set.seed(。

这里有一个工作示例：

library(shiny)
#load("mock_data.Rdata")

# data -----------------------------------------------------------
n<-20 #number of users
threshold <- 60 #threshold in risk score for referral to YS
#set.seed(10) #check a seed for reproducibility
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

# 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]]))
output$accTab <- renderTable(table(df[df$correct == 1,c(input$group)])/table(df[,c(input$group)]))
}
shinyApp(ui, server)