How to use user uploaded xlsx on shiny app which would use that data to generate choices for filter-CodePudding

I have a shiny app that takes a dataframe from which some filter options are generated so that users can pick one, and a table is generated as the output. That dataframe originates from an .xlsx file which is read at the beginig of the app. But i would like the user to upload the file. The data has the following structure:

ID    <- c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19)
Provincia <- c("Santa Fe",  "Santa Fe", "Cordoba"   ,"Santa Fe" ,"Santa Fe",    "Cordoba",  "Cordoba"   ,"Santa Fe",    "Cordoba"   ,"Cordoba"  ,"Santa Fe",    "Santa Fe", "Santa Fe"  ,"Santa Fe",    "Santa Fe", "Cordoba",  "Cordoba"   ,"Cordoba","Santa Fe")
Ciudad <- c("Carlos Paz",   "Esperanza" ,"Rafaela"  ,"Carlos Paz",  "Carlos Paz"    ,"Rafaela"  ,"Villa General" ,"Belgrano"    ,"Villa General Belgrano",  "Rafaela","Esperanza",  "Rafaela",  "Esperanza" ,"Esperanza",   "Villa General" ,"Belgrano",    "Carlos Paz",   "Carlos Paz",   "Esperanza")
Valor1 <- rpois(n = 19, lambda = 10) 
Valor2 <- runif(n = 19, min = 1, max = 10)
Color <- c("Rojo",  "Azul", "Rojo", "Azul","Rojo",  "Azul","Rojo",  "Azul","Rojo",  "Azul","Rojo",  "Azul","Rojo",  "Azul","Rojo",  "Azul","Rojo",  "Azul","Rojo")
df <- data.frame(ID,Provincia,Ciudad,Valor1,Valor2,Color)

This is the working shiny app:

library(shiny)
library(tidyverse)
library(readxl)
library(arsenal)

base <- read_excel("Libro1.xlsx")

prov_list <- base %>% distinct(Provincia)%>%arrange(Provincia)
todos <- " ALL"
prov_list <- rbind(todos, prov_list)
prov_list <- split(prov_list,prov_list$Provincia)

ui <- fluidPage(
  
  titlePanel("Título"),
  
  sidebarLayout(
    sidebarPanel(
      selectInput(
        inputId = "var1",
        label = "Select province",
        choices = ls(prov_list),
        selected = " ALL",
        multiple = FALSE
      ),
      selectInput(
        inputId = "var2",
        label = "Select city",
        choices = NULL
      )
    ),
    
    mainPanel(
      tabsetPanel(
        type = "tabs",
        tabPanel(
          "Tabla 1",
          htmlOutput("table")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  
  observeEvent(input$var1,{
    updateSelectInput(session,'var2',
                      choices=c(" ALL",unique(base$Ciudad[base$Provincia==input$var1])))
  })
  
  My_Uploaded_Data <- reactive({
    My_Uploaded_Data<-base
    My_Uploaded_Data
  })
  
  filtered_data_0 <- reactive({
    filtered_data_0<-My_Uploaded_Data()
    filtered_data_0 %>%filter(if(input$var1!= ' ALL')  (Provincia == input$var1) else TRUE)
  })
  
  filtered_data <- reactive({
    filtered_data<-filtered_data_0()
    filtered_data %>%filter(if(input$var2!= ' ALL')  (Ciudad == input$var2) else TRUE)
  })
  
  
  controles <- reactive({
    tableby.control(
      test = T,
      total = T,
      numeric.test = "anova", cat.test = "chisq",
      numeric.stats = c("meanCI"),
      cat.stats = c("countpct"),
      stats.labels = list(
        meanCI = "Media (95%CI)",
        countpct = "n (%)")
    )
  })
  
  output$table <- function(){
    
    x <- filtered_data()
    
    my_controls <- controles()
    
    tab1 <- tableby(Color ~ Valor1 Valor2,
                    data=x,
                    control=my_controls)
    
    aver <- as.data.frame(summary(tab1,digits=1,
                                  text = "html"))
    
    kable(aver,align = "lccc", escape = FALSE)%>%
      kable_styling(bootstrap_options = c("striped", "hover","condensed","responsive"), full_width = TRUE)
    
  }
}

shinyApp(ui = ui, server = server)

And here i tried to get the user to upload the file:

library(shiny)
library(tidyverse)
library(readxl)
library(arsenal)

ui <- fluidPage(
  
  titlePanel("Título"),
  
  sidebarLayout(
    sidebarPanel(
      fileInput("upload", "Please select file", accept = c(".xlsx")),
      selectInput(
        inputId = "var1",
        label = "Select province",
        choices = ls(prov_list),
        selected = " ALL",
        multiple = FALSE
      ),
      selectInput(
        inputId = "var2",
        label = "Select city",
        choices = NULL
      )
    ),
    
    mainPanel(
      tabsetPanel(
        type = "tabs",
        tabPanel(
          "Tabla 1",
          htmlOutput("table")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  
  base <- reactive({
    upload <- input$upload
    base <- read_excel(upload$datapath)
  })
  
  prov_list <- base() %>% distinct(Provincia)%>%arrange(Provincia)
  todos <- " ALL"
  prov_list <- rbind(todos, prov_list)
  prov_list <- split(prov_list,prov_list$Provincia)
  
  
  observeEvent(input$var1,{
    updateSelectInput(session,'var2',
                      choices=c(" ALL",unique(base()$Ciudad[base()$Provincia==input$var1])))
  })
  
  My_Uploaded_Data <- reactive({
    My_Uploaded_Data<-base()
    My_Uploaded_Data
  })
  
  filtered_data_0 <- reactive({
    filtered_data_0<-My_Uploaded_Data()
    filtered_data_0 %>%filter(if(input$var1!= ' ALL')  (Provincia == input$var1) else TRUE)
  })
  
  filtered_data <- reactive({
    filtered_data<-filtered_data_0()
    filtered_data %>%filter(if(input$var2!= ' ALL')  (Ciudad == input$var2) else TRUE)
  })
  
  
  controles <- reactive({
    tableby.control(
      test = T,
      total = T,
      numeric.test = "anova", cat.test = "chisq",
      numeric.stats = c("meanCI"),
      cat.stats = c("countpct"),
      stats.labels = list(
        meanCI = "Media (95%CI)",
        countpct = "n (%)")
    )
  })
  
  output$table <- function(){
    
    x <- filtered_data()
    
    my_controls <- controles()
    
    tab1 <- tableby(Color ~ Valor1 Valor2,
                    data=x,
                    control=my_controls)
    
    aver <- as.data.frame(summary(tab1,digits=1,
                                  #labelTranslations = my_labels,
                                  text = "html"))
    
    kable(aver,align = "lccc", escape = FALSE)%>%
      kable_styling(bootstrap_options = c("striped", "hover","condensed","responsive"), full_width = TRUE)
    
  }
}

shinyApp(ui = ui, server = server)

But i get the error : 'Operation not allowed without an active reactive context. You tried to do something that can only be done from inside a reactive consumer', which i'm not sure how to go about fixing. Any help would be much apreciated!

CodePudding user response：

Besides the issue mentioned in the comment by @stomper uploading the data from an xlsx file requires some more work, e.g. you have to take care that the reactives are only triggered after the choices are set. Otherwise you will get a bunch of errors popping up. This could for example achieved using req. Also, I added an observeEvent to update the choices for the first selectInput as these are only known after the xlsx file is uploaded. Finally I simplified your code a bit.

library(shiny)
library(tidyverse)
library(readxl)
library(arsenal)
library(kableExtra)

ui <- fluidPage(
  titlePanel("Título"),
  sidebarLayout(
    sidebarPanel(
      fileInput("upload", "Please select file", accept = c(".xlsx")),
      selectInput(
        inputId = "var1",
        label = "Select province",
        choices = NULL,
        selected = " ALL",
        multiple = FALSE
      ),
      selectInput(
        inputId = "var2",
        label = "Select city",
        choices = NULL
      )
    ),
    mainPanel(
      tabsetPanel(
        type = "tabs",
        tabPanel(
          "Tabla 1",
          htmlOutput("table")
        )
      )
    )
  )
)

server <- function(input, output, session) {
  base <- reactive({
    req(input$upload)

    upload <- input$upload

    read_excel(upload$datapath)
  })

  prov_list <- reactive({
    req(base())
    prov_list <- unique(base()$Provincia)
    c(" ALL", prov_list)
  })

  observeEvent(prov_list(), {
    updateSelectInput(session, "var1", choices = prov_list())
  })

  observeEvent(input$var1, {
    choices <- base()$Ciudad
    if (input$var1 != " ALL") choices <- choices[base()$Provincia == input$var1]
    choices <- c(" ALL", unique(choices))
    
    updateSelectInput(session, "var2", choices = choices)
  })

  filtered_data <- reactive({
    req(base(), input$var1, input$var2)
    base() %>%
      {
        if (input$var1 != " ALL") filter(., Provincia == input$var1) else .
      } %>%
      {
        if (input$var2 != " ALL") filter(., Ciudad == input$var2) else .
      }
  })

  controles <- reactive({
    tableby.control(
      test = T,
      total = T,
      numeric.test = "anova", cat.test = "chisq",
      numeric.stats = c("meanCI"),
      cat.stats = c("countpct"),
      stats.labels = list(
        meanCI = "Media (95%CI)",
        countpct = "n (%)"
      )
    )
  })

  output$table <- function() {
    req(nrow(filtered_data()) > 0, controles())
    
    x <- filtered_data()

    my_controls <- controles()

    tab1 <- tableby(Color ~ Valor1   Valor2,
      data = x,
      control = my_controls
    )

    aver <- as.data.frame(summary(tab1,
      digits = 1,
      text = "html"
    ))

    kable(aver, align = "lccc", escape = FALSE) %>%
      kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive"), full_width = TRUE)
  }
}

shinyApp(ui = ui, server = server)

DATA

ID <- c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19)
Provincia <- c("Santa Fe", "Santa Fe", "Cordoba", "Santa Fe", "Santa Fe", "Cordoba", "Cordoba", "Santa Fe", "Cordoba", "Cordoba", "Santa Fe", "Santa Fe", "Santa Fe", "Santa Fe", "Santa Fe", "Cordoba", "Cordoba", "Cordoba", "Santa Fe")
Ciudad <- c("Carlos Paz", "Esperanza", "Rafaela", "Carlos Paz", "Carlos Paz", "Rafaela", "Villa General", "Belgrano", "Villa General Belgrano", "Rafaela", "Esperanza", "Rafaela", "Esperanza", "Esperanza", "Villa General", "Belgrano", "Carlos Paz", "Carlos Paz", "Esperanza")
Valor1 <- rpois(n = 19, lambda = 10)
Valor2 <- runif(n = 19, min = 1, max = 10)
Color <- c("Rojo", "Azul", "Rojo", "Azul", "Rojo", "Azul", "Rojo", "Azul", "Rojo", "Azul", "Rojo", "Azul", "Rojo", "Azul", "Rojo", "Azul", "Rojo", "Azul", "Rojo")

df <- data.frame(ID, Provincia, Ciudad, Valor1, Valor2, Color)

writexl::write_xlsx(df, "temp.xlsx")