根据用户在 Rshiny 中的输入创建动态条形图

Posted 2023-02-16

【中文标题】根据用户在 Rshiny 中的输入创建动态条形图

【英文标题】：Create dynamic barplot based on users input in Rshiny

【发布时间】：2022-01-19 10:58:48

【问题描述】：

我有一个包含多个分类变量的数据框。

>library(vcd)
>data(Arthritis)
>colnames(Arthritis)
"ID"        "Treatment" "Sex"       "Age"       "Improved" 

我想查看（条形图）“显着”改善（“改善”）的患者数量以及“治疗”组之间的差异。 （你可以在下面看到它）

Arthritis1 <- Arthritis %>%
  filter(Improved == "Marked") %>%
  count(Treatment) %>%
  mutate(n = n / sum(n) * 100) 


ggplot(data = Arthritis1, aes(Treatment, n)) + 
  geom_bar(stat = "identity") +
  labs(y = "Percentage") + 
  ylim(0, 100)

这是我得到的：

在我正在构建的 shinyApp 中，用户应该能够选择变量（并过滤其中的一些）：

X 变量（例如“治疗”） Y 变量（例如“改进”和过滤器“标记”） 标记变量（例如“性别”和过滤器“男性”）

用户界面如下所示：

但是，我没有设法获得情节。

这就是我所拥有的 (RepEx)

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

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

# Plots
library(ggplot2)

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



################# --------------------------------------------------------------
# Create functions
################# --------------------------------------------------------------


not_sel <- "Not Selected"

# main page display in the shiny app where user will input variables and plots will be displayed
main_page <- 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)),
      selectInput("num_var_2", "Variable Y axis", choices = c(not_sel)), uiOutput("binning"),
      selectInput("biomarker", "Select biomarker", choices = c(not_sel)),uiOutput("factor"), 
      br(),
      actionButton("run_button", "Run Analysis", icon = icon("play"))
    ),
    mainPanel(
      tabsetPanel(
        tabPanel(
          title = "Plot",
          plotOutput("plot_1")
        )
      )
    )
  )
)



# Function for printing the plots with two different options
draw_barplot <- function(data_input, num_var_1, num_var_2, biomarker)
  print(num_var_1)
  
  if(num_var_1 != not_sel & num_var_2 != not_sel & biomarker == not_sel)
    ggplot(data = data_input, aes(x = .data[[num_var_1]])) +
      geom_bar(stat = "identity") +
      labs(y = "Percentage") + 
      ylim(0, 100)
    
  
  
  else if(num_var_1 != not_sel & num_var_2 != not_sel & biomarker != not_sel)
    ggplot(data = data_input, aes(x = .data[[num_var_1]])) +
      geom_bar(stat = "identity") +
      labs(y = "Percentage") + 
      ylim(0, 100)
    
  



################# --------------------------------------------------------------
# User interface
################# --------------------------------------------------------------

ui <- navbarPage(
  main_page
)


################# --------------------------------------------------------------
# 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)
  )
  
  
  # We select the binning level that we want for the plot of the Y axis
  output$binning <- renderUI(
    req(input$num_var_2, data_input())
    a <- unique(data_input()[[input$num_var_2]])
    pickerInput(inputId = 'selected_bins',
                label = 'Select binning for plot',
                choices = c(a[1:length(a)]), selected=a[1], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  
  # We select the factor level that we want for our 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"))
    
  )
  
  

  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)
  
  ## Obtain plots dynamically --------------------------------------------------
  ##### Barlot -----------------------------------------------------------------
  
  # The barplot has two steps:
    # 1. Create de new df 
    # 2. Apply the function
  
  
  data_plot <- reactive(
    req(data_input(), input$levels, input$num_var_1, input$biomarker)
    # 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()
    df %>%
      dplyr::filter(num_var_1() ==  input$num_var_1())
      count(unput$num_var_1()) %>%
      dplyr::mutate(n = n / sum(n) * 100) 
  )
    
  observe(print(data_plot()))
  
  plot_1 <- eventReactive(input$run_button,
    req(input$selected_bins, data_plot(), input$num_var_2, input$num_var_1)
    draw_barplot(df, num_var_1(), num_var_2(), biomarker = "selected")
  )
  
  output$plot_1 <- renderPlot(plot_1())




  
# Connection for the shinyApp
shinyApp(ui = ui, server = server)

【参考方案1】：

您在 NSE（非标准评估）中的数据整理需要一些工作。试试这个

# Function for printing the plots with two different options
draw_barplot <- function(data_input, num_var_1, num_var_2, biomarker)
  print(num_var_1)
  
  if(num_var_1 != not_sel & num_var_2 != not_sel & biomarker == not_sel)
    ggplot(data = data_input, aes(x = .data[[num_var_1]], y=n)) +
      geom_bar(stat = "identity") +
      labs(y = "Percentage") + 
      ylim(0, 100)
    
  
  
  else if(num_var_1 != not_sel & num_var_2 != not_sel & biomarker != not_sel)
    ggplot(data = data_input, aes(x = .data[[num_var_1]], y=n)) +
      geom_bar(stat = "identity") +
      labs(y = "Percentage") + 
      ylim(0, 100)
    
  


################# --------------------------------------------------------------
# User interface
################# --------------------------------------------------------------

ui <- navbarPage(
  main_page
)

################# --------------------------------------------------------------
# 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)
  )
  
  
  # We select the binning level that we want for the plot of the Y axis
  output$binning <- renderUI(
    req(input$num_var_2, data_input())
    a <- unique(data_input()[[input$num_var_2]])
    print(a)
    pickerInput(inputId = 'selected_bins',
                label = 'Select binning for plot',
                choices = c(a), selected=a[3], multiple = TRUE,
                options = list(`actions-box` = TRUE)) #options = list(`style` = "btn-warning"))
  )
  
  
  # We select the factor level that we want for our 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"))
    
  )
  
  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)
  
  ## Obtain plots dynamically --------------------------------------------------
  ##### Barlot -----------------------------------------------------------------
  
  # The barplot has two steps:
  # 1. Create de new df 
  # 2. Apply the function

  data_plot <- reactive(
    req(data_input(), input$num_var_1, input$num_var_2, input$biomarker, input$selected_bins) 
    # 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()
    df1 <- df %>%
      dplyr::filter(.data[[input$num_var_2]] %in% input$selected_bins ) %>% 
      count(.data[[input$num_var_1]]) %>%
      dplyr::mutate(n = n / sum(n) * 100) 
    df1
  )
  
  observe(print(data_plot()))
  
  plot_1 <- eventReactive(input$run_button,
    req(input$selected_bins, data_plot(), input$num_var_2, input$num_var_1)
    draw_barplot(data_plot(), num_var_1(), num_var_2(), biomarker = "selected")
  )
  
  output$plot_1 <- renderPlot(plot_1())
  


# Connection for the shinyApp
shinyApp(ui = ui, server = server)

【讨论】：

太棒了。谢谢你@YBS