1

Tengo una shiny app hecha en RStudio donde a partir de un dataframe se generan opciones de filtro para los usuarios, y como output se genera una tabla resumen. La idea es que los datos del dataframe surgen de un archivo de excel .xlsx. Si leo el archivo al inicio de la app, funciona correctamente. Pero me gustaría cambiar eso, de manera que sea el usuario el que cargue el archivo con los datos.

Los datos en el excel tienen la siguiente estructura:

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)

La app funcionando es la siguiente:

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)

Y mi intento de implementar la carga por el usuario es el siguiente:

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)

Pero me da el error "Error : Operation not allowed without an active reactive context. You tried to do something that can only be done from inside a reactive consumer", que no estoy segura cómo solucionar. Les agradecería mucho cualquier ayuda!

1 respuesta 1

2

esos errores de reactividad son muy comunes, el problema está exactamente aquí:

 prov_list <- base() %>% distinct(Provincia)%>%arrange(Provincia)

Donde lo correcto seria:

reactive({
  prov_list <- base() %>% distinct(Provincia)%>%arrange(Provincia)
})

Ya que estás generando valores reactivos a partir de base() que también es reactivo

Dicho esto, podríamos hacer los siguientes cambios:

  prov_list_pre <- reactive({
    rbind("ALL",base() %>% distinct(Provincia)%>%arrange(Provincia))
  })  
  prov_list <- reactive({
    split(prov_list_pre(),prov_list_pre()$Provincia)
  })

Por otro lado una vez corregido lo anterior, aprovecho el post para mencionar que te encontraras frente a otro error aquí:

 base <- reactive({
    upload <- input$upload
    base <- read_excel(upload$datapath)
  })

Donde debemos hacer lo siguiente para tratarlo:

  base <- reactive({
    if(is.null(input$upload))
      return(NULL)
    else{
      upload <- input$upload
      base <- read_excel(upload$datapath)
    }
  })

Básicamente, esto es retornar un nulo en la ruta del archivo a cargar por el usuario, mientras no se haya cargado ningún archivo

El código final quedaría así:

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

base <- read_excel("Libro1.xlsx")

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({
    if(is.null(input$upload))
      return(NULL)
    else{
      upload <- input$upload
      base <- read_excel(upload$datapath)
    }
  })
  
  
  prov_list_pre <- reactive({
    rbind("ALL",base() %>% distinct(Provincia)%>%arrange(Provincia))
  })  
  prov_list <- reactive({
    split(prov_list_pre(),prov_list_pre()$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)

Te faltaría resolver el problema en el ui en

choices = ls(prov_list)

Ya que ahora eso no existiría

Espero haberte ayudado

2
  • Escelente, gracias por las explicaciones! Supongo que por ahora voy a hacer un simple vector para choices, aunque lo ideal sería que esas opciones se generaran a partir de la base, ya que es probable que fueran las mismas en distintas bases. Voy a pensarlo un poco, pero dirías que es algo posible?
    – Natalias
    Commented el 17 sept. 2022 a las 9:39
  • si se puede, me cuentas si no lo logras hacer y te puedo dar algunas ideas Commented el 19 sept. 2022 a las 17:15

Tu Respuesta

By clicking “Publica tu respuesta”, you agree to our terms of service and acknowledge you have read our privacy policy.

¿No es la respuesta que buscas? Examina otras preguntas con la etiqueta o formula tu propia pregunta.