Question

我正在尝试创建一个shiny应用，您可以在其中选择输入（年龄，性别，区域等），并使用输入中每个因素的分类阈值（例如，对于性别而言，因素是男性和女性）查看按因子对分类准确性的影响。目前，我有一个shiny应用，可让我为所有因素调整一般阈值，但我希望每个因素都可以使用一个滑块。例如，如果用户选择了“性别”输入，则将有一个用于男性和女性的滑块，而如果用户选择了“地区”输入，则将有一个针对“中，北和南”的滑块。

我已经附上了当前应用程序的屏幕截图，其中包含一些我想进行的更改的标记：

这是我的代码：

library(shiny)
library(ggplot2)
library(tidyverse)
library(reshape2)
load("mock_data.Rdata")
# Define UI for miles per gallon app ----
ui <- fluidPage(

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

  # Sidebar 
  sidebarLayout(
    sidebarPanel(
      selectInput("group", "Group:", 
                  c("Age" = "age",
                    "Gender" = "gender",
                    "Region" = "region",
                    "Ethnicity"="ethnicity")),
      sliderInput("thres","Referred Threshold:", min = 0, max = 100, value = 60)
      ),

    # Show a plot of the generated distribution
    mainPanel(
      h3("Groups"),
      plotOutput("distPlot"),
     # h3("Accuracy table"),
      #tableOutput("accTab"),
      h3("Accuracy"),
      plotOutput("accPlot")
    )
  )
)

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



  output$distPlot <- renderPlot({
   df2<- df
   df2[which(df2$score>=input$thres),"referred"]<-1
   #Set a variable for colouring/filtering by TP,TN,FP,FN
   df2[which(df2$referred==1 & df2$target==1),"colour"]<-1
   df2[which(df2$referred==1 & df2$target==0),"colour"]<-2
   df2[which(df2$referred==0 & df2$target==1),"colour"]<-3
   df2[which(df2$referred==0 & df2$target==0),"colour"]<-4
  gg <- ggplot(df2, aes(x=score, fill = as.factor(colour)))+
      geom_dotplot(stackgroups = TRUE,alpha=0.6,  method = "histodot")+
      theme_bw(base_size = 20)+
      theme(axis.title.y=element_blank(),
               axis.text.y=element_blank(),
               axis.ticks.y=element_blank())+
      facet_wrap(~get(input$group),scales="free_y")+
      xlab('Risk score')+
      geom_vline(data = df2, mapping = aes(xintercept = input$thres))+
      scale_fill_manual(name="", labels=c("referred|NEET", "referred|Not NEET","Not referred|NEET","Not referred|Not NEET"),
                      values = c("seagreen4","lightgreen","darkorange4","lightsalmon"))
      gg

  })

  output$accPlot <- renderPlot({  
    df3<- df
    df3[which(df3$score>=input$thres),"referred"]<-1
    df3[which(df3$referred==0 & df3$target==0),"correct"]<-1
    df3[which(df3$referred==1 & df3$target==1),"correct"]<-1
    df3[which(df3$referred==0 & df3$target==1),"correct"]<-0
    df3[which(df3$referred==1 & df3$target==0),"correct"]<-0

    df3$correct <- factor(df3$correct,labels = c("Incorrect","Correct"))
    t1<- table(df3$correct,df3[,c(input$group)]) #table(df[df$correct,c(input$group)]) 
    t2<-table(df3[,input$group])
    t3<-sweep(t1, 2, t2, `/`)
    t4<-melt(t3)
    g2 <- ggplot(df3 %>% count(!!rlang::sym(input$group),correct) , aes_string(x=c(input$group),y="n",fill="correct")) +
      geom_bar(stat="identity",position=position_fill())+
      scale_y_continuous(labels = scales::percent) +
      geom_text(aes(label = paste0(round(t4$value*100, digits = 2),"%")), position = position_fill(vjust = 0.5), size = 5)+
      theme_bw(base_size = 20)+
      scale_fill_discrete(name="")+
      ylab("")+
      xlab(str_to_title(input$group))+
      coord_flip()
    g2

  })

}

shinyApp(ui, server)

模拟数据：

n<-200 #number of users
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 <- factor(sample(c('M','F'),size=n,replace=TRUE), labels = c("Male","Female"))
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)

选择输入中每个系数的闪亮滑块

0 个答案: