根据用户的输入创建列联表 - R Shiny

Posted 2023-02-14

技术标签:

【中文标题】根据用户的输入创建列联表 - R Shiny【英文标题】：Create contingency tablel based on users input - Rshiny 【发布时间】：2022-01-20 19:02:21 【问题描述】：

对于数据框中的两个分类变量，我想根据用户对变量的选择、这些变量的特定因素（以及另一列过滤）来计算 Fisher 检验。

为此，我需要获取列联表，然后应用fisher.test函数。

只是为了形象化，这里是如何在 R 基础中完成的：

library(vcd)
library(dplyr)

a <- Arthritis %>%
  dplyr::filter(Treatment == "Treated") %>%
  dplyr::filter(Improved == "Some") %>%
  count() %>%
  as.numeric()
b <- Arthritis %>%
  dplyr::filter(Treatment == "Treated") %>%
  dplyr::filter(Improved != "Some") %>%
  count() %>%
  as.numeric()
c <- Arthritis %>%
  dplyr::filter(Treatment == "Placebo") %>%
  dplyr::filter(Improved == "Some") %>%
  count() %>%
  as.numeric()
d <- Arthritis %>%
  dplyr::filter(Treatment == "Placebo") %>%
  dplyr::filter(Improved != "Some") %>%
  count() %>%
  as.numeric()

data <- as.data.frame(matrix(c(a,b,c,d), nrow= 2, ncol = 2, byrow = TRUE))

fisher.test(data)

对于下面的 RepEx，我只想获取列联表。

你可以看得很清楚，但只是稍微解释一下：

首先我们创建 UI，允许用户在其中选择多个变量（var1、var2、biomarker），然后选择统计因素。然后我们根据用户输入更新这些变量我们根据用户选择创建列联表（数据框）

# Shiny
library(shiny)
library(shinyWidgets)
library(shinyjqui)

# Data
library(vcd)
library(readxl)
library(dplyr)

# Plots
library(ggplot2)

# Stats cohen.d wilcox.test
library(effsize)


not_sel <- "Not selected"


## UI
ui <- navbarPage(
  tabPanel(
    title = "Plotter",
    titlePanel("Plotter"),
    sidebarLayout(
      sidebarPanel(
        title = "Inputs",
        fileInput("xlsx_input", "Select XLSX file to import", accept = c(".xlsx")),
        selectInput("num_var_1", "Variable X axis", choices = c(not_sel)),                        # X variable num_var_1
        selectInput("num_var_2", "Variable Y axis", choices = c(not_sel)), 
        selectInput("biomarker", "Select biomarker", choices = c(not_sel)), uiOutput("factor"),
        uiOutput("Xgroup1"),uiOutput("Xgroup2"), uiOutput("Ygroup1"), uiOutput("Ygroup2"),
        br(),
        actionButton("run_button", "Run Analysis", icon = icon("play"))
      ),
      mainPanel(
        tabsetPanel(
         tabPanel(
            title = "Statistics",
            verbatimTextOutput("test")
          )
        )
      )
    )
  )
)



## Server

server <- function(input, output)
  
  # Dynamic selection of the data. We allow the user to input the data that they want 
  data_input <- reactive(
    #req(input$xlsx_input)
    #inFile <- input$xlsx_input
    #read_excel(inFile$datapath, 1)
    Arthritis
  )
  
  # We update the choices available for each of the variables
  observeEvent(data_input(),
    choices <- c(not_sel, names(data_input()))
    updateSelectInput(inputId = "num_var_1", choices = choices)
    updateSelectInput(inputId = "num_var_2", choices = choices)
    updateSelectInput(inputId = "biomarker", choices = choices)
  )
  
  num_var_1 <- eventReactive(input$run_button, input$num_var_1)
  num_var_2 <- eventReactive(input$run_button, input$num_var_2)
  biomarker <- eventReactive(input$run_button, input$biomarker)
  
  ## Update variables
  
  # Factor for the biomarker
  output$factor <- renderUI(
    req(input$biomarker, data_input())
    if (input$biomarker != not_sel) 
      b <- unique(data_input()[[input$biomarker]])
      pickerInput(inputId = 'selected_factors',
                  label = 'Select factors',
                  choices = c(b[1:length(b)]), selected=b[1], multiple = TRUE,
                  # choices = c("NONE",b[1:length(b)]), selected="NONE", If we want "NONE" to appear as the first option
                  # multiple = TRUE,  ##  if you wish to select multiple factor values; then deselect NONE
                  options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
    
  )
  
  output$Xgroup1 <- renderUI(
    req(input$num_var_1, data_input())
    c <- unique(data_input()[[input$num_var_1]])
    pickerInput(inputId = 'selected_Xgroup1',
                label = 'Select group for statistics',
                choices = c(c[1:length(c)]), selected=c[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  
  output$Xgroup2 <- renderUI(
    req(input$num_var_1, data_input())
    d <- unique(data_input()[[input$num_var_1]])
    pickerInput(inputId = 'selected_Xgroup2',
                label = 'Select group for statistics',
                choices = c(d[1:length(d)]), selected=d[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  
  output$Ygroup1 <- renderUI(
    req(input$num_var_2, data_input())
    c <- unique(data_input()[[input$num_var_2]])
    pickerInput(inputId = 'selected_Ygroup1',
                label = 'Select group for statistics',
                choices = c(c[1:length(c)]), selected=c[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  output$Ygroup2 <- renderUI(
    req(input$num_var_2, data_input())
    c <- unique(data_input()[[input$num_var_2]])
    pickerInput(inputId = 'selected_Ygroup1',
                label = 'Select group for statistics',
                choices = c(c[1:length(c)]), selected=c[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  


  ##############################################################################
  
  data_stats <- reactive(
    req(data_input(), input$num_var_1, input$num_var_2, input$biomarker, input$selected_factors) 
    # We filter by biomarker in case user selected, otherwise data_input() remains the same
    if (input$biomarker != "Not Selected") df <- data_input()[data_input()[[input$biomarker]] %in% input$selected_factors,]
    else df <- data_input()
    a <- df %>%
      dplyr:filter(.data[[input$num_var_1]] %in% input$Xgroup1) %>%
      dplyr:filter(.data[[input$num_var_2]] %in% input$Ygroup1) %>%
      count()
    b <- df %>%
      dplyr:filter(.data[[input$num_var_1]] %in% input$Xgroup2) %>%
      dplyr:filter(.data[[input$num_var_2]] %in% input$Ygroup1) %>%
      count()
    c <- df %>%
      dplyr:filter(.data[[input$num_var_1]] %in% input$Xgroup1) %>%
      dplyr:filter(.data[[input$num_var_2]] %in% input$Ygroup2) %>%
      count()
    d <- df %>%
      dplyr:filter(.data[[input$num_var_1]] %in% input$Xgroup2) %>%
      dplyr:filter(.data[[input$num_var_2]] %in% input$Ygroup2) %>%
      count()
    
    data <- as.data.frame(matrix(c(a,b,c,d), nrow= 2, ncol = 2, byrow = TRUE))
  )
  
  output$test <- renderPrint(data_stats())
  


shinyApp(ui = ui, server = server)

但是，这个应用程序没有产生任何结果。

【问题讨论】：

请注意input$Xgroup1实际上应该是input$selected_Xgroup1，以此类推... 非常感谢@YBS 的回答，但它不起作用。 output$test 没有打印任何东西，螺母也没有出现错误消息 【参考方案1】：

您有一些语法错误。首先，Ygroup2 的 inputID 仍然是 selected_Ygroup1。其次，dplyr:filter() 不会引用 dplyr 包，因为它应该是 dplyr::filter() - 即双冒号。最后，你的变量不应该是input$Xgroup1，而应该是input$selected_Xgroup1，等等。此外，最好使用 eventReactive 而不是响应式。试试这个

# Shiny
library(shiny)
library(shinyWidgets)
library(shinyjqui)

# Data
library(vcd)
library(readxl)
library(dplyr)

# Plots
library(ggplot2)

# Stats cohen.d wilcox.test
library(effsize)


not_sel <- "Not selected"


## UI
ui <- navbarPage(
  tabPanel(
    title = "Plotter",
    titlePanel("Plotter"),
    sidebarLayout(
      sidebarPanel(
        title = "Inputs",
        fileInput("xlsx_input", "Select XLSX file to import", accept = c(".xlsx")),
        selectInput("num_var_1", "Variable X axis", choices = c(not_sel)),                        # X variable num_var_1
        selectInput("num_var_2", "Variable Y axis", choices = c(not_sel)), 
        selectInput("biomarker", "Select biomarker", choices = c(not_sel)), uiOutput("factor"),
        uiOutput("Xgroup1"),uiOutput("Xgroup2"), uiOutput("Ygroup1"), uiOutput("Ygroup2"),
        br(),
        actionButton("run_button", "Run Analysis", icon = icon("play"))
      ),
      mainPanel(
        tabsetPanel(
          tabPanel(
            title = "Statistics",
            verbatimTextOutput("test")
          )
        )
      )
    )
  )
)


## Server

server <- function(input, output)
  
  # Dynamic selection of the data. We allow the user to input the data that they want 
  data_input <- reactive(
    #req(input$xlsx_input)
    #inFile <- input$xlsx_input
    #read_excel(inFile$datapath, 1)
    Arthritis
  )
  
  # We update the choices available for each of the variables
  observeEvent(data_input(),
    choices <- c(not_sel, names(data_input()))
    updateSelectInput(inputId = "num_var_1", choices = choices)
    updateSelectInput(inputId = "num_var_2", choices = choices)
    updateSelectInput(inputId = "biomarker", choices = choices)
  )
  
  num_var_1 <- eventReactive(input$run_button, input$num_var_1)
  num_var_2 <- eventReactive(input$run_button, input$num_var_2)
  biomarker <- eventReactive(input$run_button, input$biomarker)
  
  ## Update variables
  
  # Factor for the biomarker
  output$factor <- renderUI(
    req(input$biomarker, data_input())
    if (input$biomarker != not_sel) 
      b <- unique(data_input()[[input$biomarker]])
      pickerInput(inputId = 'selected_factors',
                  label = 'Select factors',
                  choices = c(b[1:length(b)]), selected=b[1], multiple = TRUE,
                  # choices = c("NONE",b[1:length(b)]), selected="NONE", If we want "NONE" to appear as the first option
                  # multiple = TRUE,  ##  if you wish to select multiple factor values; then deselect NONE
                  options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
    
  )
  
  output$Xgroup1 <- renderUI(
    req(input$num_var_1, data_input())
    c <- unique(data_input()[[input$num_var_1]])
    pickerInput(inputId = 'selected_Xgroup1',
                label = 'Select group for statistics',
                choices = c(c[1:length(c)]), selected=c[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  
  output$Xgroup2 <- renderUI(
    req(input$num_var_1, data_input())
    d <- unique(data_input()[[input$num_var_1]])
    pickerInput(inputId = 'selected_Xgroup2',
                label = 'Select group for statistics',
                choices = c(d[1:length(d)]), selected=d[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  
  output$Ygroup1 <- renderUI(
    req(input$num_var_2, data_input())
    c <- unique(data_input()[[input$num_var_2]])
    pickerInput(inputId = 'selected_Ygroup1',
                label = 'Select group for statistics',
                choices = c(c[1:length(c)]), selected=c[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  output$Ygroup2 <- renderUI(
    req(input$num_var_2, data_input())
    c <- unique(data_input()[[input$num_var_2]])
    pickerInput(inputId = 'selected_Ygroup2',
                label = 'Select group for statistics',
                choices = c(c[1:length(c)]), selected=c[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  
  
  ##############################################################################
  
  data_stats <- eventReactive(input$run_button, 
    req(data_input(), input$num_var_1, input$num_var_2, input$biomarker, input$selected_factors) 
    req(input$selected_Xgroup1,input$selected_Xgroup2,input$selected_Ygroup1,input$selected_Ygroup2)
    # We filter by biomarker in case user selected, otherwise data_input() remains the same
    if (input$biomarker != "Not Selected") df <- data_input()[data_input()[[input$biomarker]] %in% input$selected_factors,]
    else df <- data_input()
    a <- df %>%
      dplyr::filter(.data[[input$num_var_1]] %in% input$selected_Xgroup1) %>%
      dplyr::filter(.data[[input$num_var_2]] %in% input$selected_Ygroup1) %>%
      count()
    b <- df %>%
      dplyr::filter(.data[[input$num_var_1]] %in% input$selected_Xgroup2) %>%
      dplyr::filter(.data[[input$num_var_2]] %in% input$selected_Ygroup1) %>%
      count()
    c <- df %>%
      dplyr::filter(.data[[input$num_var_1]] %in% input$selected_Xgroup1) %>%
      dplyr::filter(.data[[input$num_var_2]] %in% input$selected_Ygroup2) %>%
      count()
    d <- df %>%
      dplyr::filter(.data[[input$num_var_1]] %in% input$selected_Xgroup2) %>%
      dplyr::filter(.data[[input$num_var_2]] %in% input$selected_Ygroup2) %>%
      count()
    
    data <- as.data.frame(matrix(c(a,b,c,d), nrow= 2, ncol = 2, byrow = TRUE))
    m <- matrix(unlist(data), 2)
    fisher.test(m)
  )
  
  output$test <- renderPrint(data_stats())
  


shinyApp(ui = ui, server = server)

【讨论】：

谢谢@YBS。你帮了我很多，因为这不是我问的第一个问题。但是，您是否尝试过运行代码？至少我的没有任何反应，没有出现错误，但也没有出现任何信息，不是output$test <- renderPrint(data_stats())，不是我添加后的fisher.test函数好的，我会发布我得到的输出。请尝试更新后的代码进行fisher测试。谢谢@YBS。但是，您知道为什么不先选择 Biomarker 就无法获得统计数据吗？从req() 中的eventReactive() 中删除input$biomarker。

以上是关于根据用户的输入创建列联表 - R Shiny的主要内容，如果未能解决你的问题，请参考以下文章

R语言dplyr包和tidyr包创建交叉表（列联表crosstab）实战

R-Shiny 中的 circlepackeR - 根据用户输入创建圆形包装图

使用R中数据框中的多列创建列联表

spss怎么进行列联分析

R语言进行制表

R构建列联表（Contingency Table or crosstabs）