0

I am creating a dynamic shiny app that works like a look up table -- it allows users to select input values and in return gives two corresponding output values (one numeric and one character) which exist in the same table.

My code needs to be dynamic, so that when the data frame changes, the user interface changes accordingly. For example, if the data table contains 3 input variables instead of 2, there needs to be one more selectInput box in the sidebar. If one variable ends up having 3 possible values instead of 2, there needs to be another option.

Thus, my code needs to:

  1. check the updated table,
  2. see how many variables there are and update input options in the sidebar accordingly
  3. update range of values each of these variables has
  4. Update the output accordingly.

Below is a simplified code:

{
  library(shiny)
  library(shinydashboard)
  library(shinyjs)
}

Test <- data.frame(
  stringsAsFactors = FALSE,
  input1 = c("precarious", "precarious", "good"),
  input2 = c("precarious", "moderate", "precarious"),
  NumericOutput = c(3.737670877,6.688008306,8.565495761),
  CharacterOutput = c("precarious", "moderate", "good")
)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    useShinyjs(),
    selectInput("a", label = colnames(Test[1]),
                choices = unique(Test[[1]])),
    selectInput("b", colnames(Test[2]),
                choices = unique(Test[[2]]))
  ),
  dashboardBody(fluidRow(valueBoxOutput("info_box1", width = 6)),
                fluidRow(valueBoxOutput("info_box2", width = 6)))
)

server <- function(input, output) {
  
  output$info_box1 <- renderValueBox({
    valueBox(
      value = paste0("Score in %: ",
                     Test$NumericOutput[Test$input1 == input$a & Test$input2 == input$b],
                     collapse = ", "),
      subtitle = NULL)
  })
  
  
  output$info_box2 <- renderValueBox({
    valueBox(value = paste0(
      "Assessment: ",
      Test$CharacterOutput[Test$input1 == input$a & Test$input2 == input$b], 
      collapse = ", "),
      subtitle = NULL)
  })
}

shinyApp(ui, server)
Anam Iqbal
  • 1
  • 1
  • can you describe what is the idea behind values in `valueBox` because it's not obvious to me what should be in them. – det May 10 '21 at 11:04
  • Hey, @det. These are the output values i.e. the assessment score and one word description. These are based on the input values the user selects. – Anam Iqbal May 10 '21 at 12:24
  • One option is to make the `Test` data frame a reactive and then everything should follow. My answer [here](https://stackoverflow.com/questions/67416620/how-can-i-create-reactive-datasets-dynamically-via-a-loop-in-the-server-section/67422105#67422105) demonstrates how to update `selectInput`s depending on the columns and values of an underlying dataframe, albeit in a slightly different context. You don't seem to have explained how the underlying table (`Test` in your code?) gets updated. – Limey May 10 '21 at 14:55
  • Hey, @Limey your code gives the option to add columns. I need the columns to show up as selectInput by default whenever the data is updated. The data is not updated by the user, it is updated in the background -- in the same place as the source code. – Anam Iqbal May 10 '21 at 15:37

1 Answers1

0

Here is the outline of code. I've adopted logic you provided - input cols are the ones on which filtering is done, ouput cols are the ones on which some aggregation is done. You requested only dynamic filtering and not the output. data is reactive because from your text it's obvious you want to change datasets. Code inside its reactivity is something you need to come up with because you didn't provide any information beside Test data.frame.

library(shiny)
library(shinydashboard)
library(shinyjs)

Test <- data.frame(
  stringsAsFactors = FALSE,
  input1 = c("precarious", "precarious", "good"),
  input2 = c("precarious", "moderate", "precarious"),
  NumericOutput = c(3.737670877,6.688008306,8.565495761),
  CharacterOutput = c("precarious", "moderate", "good")
)

ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    uiOutput("dynamicSidebar")
  ),
  dashboardBody(fluidRow(valueBoxOutput("info_box1", width = 6)),
                fluidRow(valueBoxOutput("info_box2", width = 6)))
)

server <- function(input, output){
  
  rv <- reactiveValues()
  data <- reactive({Test})
  
  output$dynamicSidebar <- renderUI({

    req(data())
    
    rv$input_cols <- names(data()) %>% str_subset("^input")
    input_values <- data() %>%
      select(rv$input_cols) %>% 
      map(unique)
    
    rv$input_cols %>%
      map2(input_values, ~selectInput(.x, .x, choices = .y))
  })
  
  observe({
    
    cond <- reactiveValuesToList(input) %>%
      .[rv$input_cols] %>%
      imap(~str_c(.y, "=='", .x, "'")) %>%
      str_c(collapse = "&")
    
    rv$filtered_data <- data() %>%
      filter(eval(parse(text = cond))) 
  })
  
  output$info_box1 <- renderValueBox({
    
    req(rv$filtered_data)
    
    my_value <- if(nrow(rv$filtered_data) > 0){
      str_c(rv$filtered_data[["NumericOutput"]],collapse = ", ")
    } else {
      "empty data"
    }
    
    valueBox(
      subtitle = "Score in %: ",
      value = my_value
    )
  })


  output$info_box2 <- renderValueBox({
    
    req(rv$filtered_data)
    
    my_value <- if(nrow(rv$filtered_data) > 0){
      str_c(rv$filtered_data[["CharacterOutput"]], collapse = ", ")
    } else {
      "empy data"
    }
    
    valueBox(
      subtitle = "Assessment:",
      value = my_value
    )
  })
}

shinyApp(ui, server)
det
  • 5,013
  • 1
  • 8
  • 16