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

Question

I have a dataset with categorical data (let's use Arthritis from vcd package for exmaple purposes).

I want to obtain a barplot where for two variables and colouring by a third one.

You can find a RepEx below:

# 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)

For Outcome as X variable and Treatment as Y variable, we would obtain:

I want to change the color of the plot (and eventually allow the user to do so), but for now I have trouble changing it manually, as for example the next code may work:

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

But I need to specify the name of the factors, which I may not know as the variable is selected dynamically.

Answer 1

You can use pickerInput from shinywidgets package. Try this

# 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)