在动态变量-Rshiny 中更改条形图的颜色

Question

我有一个包含分类数据的数据集（我们以 vcd 包中的关节炎为例）。

我想获得一个条形图，其中两个变量和第三个变量着色。

您可以在下面找到 RepEx：

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

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

# Plots
library(ggplot2)

not_sel <- "Not Selected"

ui <- navbarPage(
  title = "Plotter",
  windowTitle = "Plotter",
  tabPanel(
    "Plotter",
    fluidPage(
      fluidRow(
        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("factor"),
          br(),
          actionButton("run_button", "Run Analysis", icon = icon("play"))
        ),
        
        # Main panel
        mainPanel(
          tabsetPanel(
            tabPanel(
              "Plot",
              br(),
              plotOutput("plot_1")
            ) 
          )
        )
      )
    )
  )
)

################# --------------------------------------------------------------
# Server
################# --------------------------------------------------------------
server <- function(input, output){
  
  # Dynamic selection of the data 
  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)
  })
  
  num_var_1 <- eventReactive(input$run_button, input$num_var_1)
  num_var_2 <- eventReactive(input$run_button, input$num_var_2)
  
  # data
  data_discrete_plot <- reactive({
    req(data_input(), input$num_var_1, input$num_var_2) 
    df <- data_input()
    df1 <- as.data.frame(prop.table(table(df[[input$num_var_1]], df[[input$num_var_2]]), margin = 1))
    df1
  })
  
  # Function for printing the plots
  
  draw_barplot <- function(data_input) {
    ggplot(data = data_input, aes(x = Var1, y = Freq, fill = Var2, label = round(Freq, 3))) +
      geom_bar(stat = "identity") +
      scale_fill_discrete(guide = guide_legend(reverse = TRUE)) +
      ylim(0, 1) +
      theme_bw()
  }
  
  ## BarPlot -------------------------------------------------------------------
  plot_1 <- eventReactive(input$run_button,{
    req(data_input())
    draw_barplot(data_discrete_plot())
  })
  
  output$plot_1 <- renderPlot(plot_1())
}

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

Outcome 作为 X 变量，Treatment 作为 Y 变量，我们会得到：

我想更改绘图的颜色（并最终允许用户这样做），但现在 我无法手动更改它，例如下一个代码可能会起作用：

values = c("Treated"="blue", "Placebo"="orange")

但我需要指定因子的名称，因为变量是动态选择的，我可能不知道。

Answer 1

您可以使用来自shinywidgets 包的pickerInput。试试这个

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

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

# Plots
library(ggplot2)

not_sel <- "Not Selected"

ui <- navbarPage(
  title = "Plotter",
  windowTitle = "Plotter",
  tabPanel(
    "Plotter",
    fluidPage(
      fluidRow(
        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("factor"),
          br(),
          actionButton("run_button", "Run Analysis", icon = icon("play"))
        ),
        
        # Main panel
        mainPanel(
          tabsetPanel(
            tabPanel(
              "Plot",
              br(),
              plotOutput("plot_1")
            ) 
          )
        )
      )
    )
  )
)

################# --------------------------------------------------------------
# Server
################# --------------------------------------------------------------
server <- function(input, output){
  
  # Dynamic selection of the data 
  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)
  })
  
  num_var_1 <- eventReactive(input$run_button, input$num_var_1)
  num_var_2 <- eventReactive(input$run_button, input$num_var_2)
  
  # data
  data_discrete_plot <- reactive({
    req(data_input(), input$num_var_1, input$num_var_2) 
    df <- data_input()
    df1 <- as.data.frame(prop.table(table(df[[input$num_var_1]], df[[input$num_var_2]]), margin = 1))
    df1
  })
  
  output$factor <- renderUI({
    #req(input$num_var_2,data_input())
    if (is.null(input$num_var_2) | (input$num_var_2=="Not Selected")) return(NULL)
    df <- data_input()
    uvalues <- unique(df[[input$num_var_2]])
    n <- length(uvalues)
    choices <- as.list(uvalues)
    myorder  <- as.list(1:n)
    mycolors <- list("red", "green", "blue", "steelblue", "brown", "grey", "black", "purple", "cyan",
                     "darkblue", "darkgreen", "orange", "maroon", "yellow", "gray20",  "gray50", "gray80")
    nk <- length(mycolors)  ## to repeat colors when there are more bars than the number of colors
    tagList(
      div(br()),
      div(
        lapply(1:n, function(i){
          k <- i %% nk
          if (k==0) k=nk
          pickerInput(paste0("colorvar",i),
                      label = paste0(uvalues[i], ": " ),
                      choices = list(# DisplayOrder = myorder,
                                     FillColor = mycolors),
                      selected = list( i, mycolors[[k]]),
                      multiple = T,
                      options = list('max-options-group' = 1, `style` = "btn-primary"))
        })
      )
    )
      
  })
  
  #observe({print(input$colorvar1)})
  
  output$t1 <- renderDT(data_discrete_plot())
  # Function for printing the plots
  
  draw_barplot <- function(data_input) {
    n <- length(unique(data_input[,"Var2"]))
    val <- list()
    myvaluesx <- lapply(1:n, function(i) {
      input[[paste0("colorvar",i)]]
      if (i==1) val <- list(input[[paste0("colorvar",i)]])
      else val <<- list(val,input[[paste0("colorvar",i)]])
    })
    print(myvaluesx)
    ggplot(data = data_input, aes(x = Var1, y = Freq, fill = factor(Var2), label = round(Freq, 3))) +
      geom_bar(stat = "identity") +
      #scale_fill_discrete(guide = guide_legend(fill = myvaluesx, reverse = TRUE)) +
      scale_fill_manual( values = unlist(myvaluesx)) +
      ylim(0, 1) +
      theme_bw()
  }
  
  ## BarPlot -------------------------------------------------------------------
  plot_1 <- eventReactive(input$run_button,{
    req(data_input())
    draw_barplot(data_discrete_plot())
  })
  
  output$plot_1 <- renderPlot(plot_1())
}

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