Create contingency tablel based on users input - Rshiny - r

Question

For two categorical variables inside a dataframe I want to compute the fisher test based on the user selection for the variables, specific factors of these variables (and also filtering by another column).
For this, I need to obtain the contingency table, and then apply the fisher.test function.
Just to visualize it, here is how it can be done in R base:
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)
For the RepEx below I just want to obtain the contingency table.
You can see it clearly, but just to explain a little bit:
First we create the UI, where we allow the user to select several variables (var1, var2, biomarker) and then the factors for the statistics.
Then we update this variables based on user input
We create the contingency table (dataframe) based on the users selection
# 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)
However, this app is not generating any results.

Answer 1

You have a few syntax errors. First, the inputID for Ygroup2 was still selected_Ygroup1. Second, dplyr:filter() will not reference the dplyr package as it should be dplyr::filter() - that is double colon. Lastly, your variables should not be input$Xgroup1 but actually be input$selected_Xgroup1, and so on. Also, it is better to have eventReactive instead of reactive. Try this
# 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)