I am trying to create a number of tabs based on some list and create similar fields in those tabs with their own identity. Can we create and use reactives like
eval(paste0("Updated_files_list_",Some_List[k], "()"))
I have used following code and one location but that will be different for different tabs it seems that reactives are created for the lists but I am unable to either assign values to it or call it -
Some_List <- list("AGG", "CMP1", "CMP2")
Some_Long_List <- list("Aggregated Things", "Component 1", "Component 2")
sidebar <- dashboardSidebar(
do.call(sidebarMenu, c(lapply(1:length(Some_List), function(i) {
menuItem(Some_Long_List[i], tabName = paste0(Some_List[i],"_tab"))
}))))
uibody <- dashboardBody(
do.call(tabItems, c(lapply(1:length(Some_List), function(i) {
tabItem(tabName = paste0(Some_List[i],"_tab"), h2(Some_Long_List[i]),
fluidPage(fluidRow(column(3,
dateInput(paste0("ME_DATE_output_",Some_List[i]),label=h2("Select a Date"), value="2020-05-29"))
,column(9,column(verbatimTextOutput(paste0("file_path_",Some_List[i])),width=12),hr(),
selectInput(paste0('select_file_',Some_List[i]),'Select a File to display', choices=NULL),hr(),
column(dataTableOutput(paste0('selected_table_',Some_List[i])),width=12)))))
}))))
ui = dashboardPage(dashboardHeader(title = "Results"), sidebar, uibody)
server = function(input, output, session) {
# Location for Source Inputs
Some_loc <- "K:/Outputs"
lapply (1:length(Some_List), function(k){
ME_DATE_GUI <- reactive({input[[paste0("ME_DATE_output_",Some_List[k])]]})
# Files Path
output[[paste0("file_path_",Some_List[k])]] <- renderPrint({ req(Some_loc) })
# Updated Files list
assign(paste0("Updated_files_list_",Some_List[k]), reactive({
lf_some <- list.files(Some_loc,full.names = TRUE)
names(lf_some) <- basename(lf_some)
lf_some
}))
# Fetch selection of file
observeEvent(eval(paste0("Updated_files_list_",Some_List[k], "()")), {
updateSelectInput(session, paste0("select_file_",Some_List[k]), choices=eval(paste0("Updated_files_list_", Some_List[k],"()")))
})
# Display Selected file
output[[paste0("selected_table_",Some_List[k])]] <- renderDataTable({
req(input[[paste0("select_file_", Some_List[k])]])
read.csv(input[[paste0("select_file_", Some_List[k])]], header=T)
})
})
}
shinyApp(ui, server)
In the selectInput field, I can see Update_files_list_AGG(), ("AGG", "CMP1" and "CMP2" in respective tabs) but not the list of files in the assigned location. The error I get is Error: cannot open the connection
Related
My goal is that user uploads an Excel file. Then, the user selects which sheets wants to be summarised, after the selection has been updated. I have managed to update selectInput with the name of the sheets but I have not been able to find\understand how to summarise based on what the sheet selected by the user. Thanks for any help.
library(shiny)
library(shinythemes)
library(data.table)
library(ggplot2)
library(dplyr)
library(readxl)
not_sel <- "Not Selected"
# Define UI for application that draws a histogram
ui <- fluidPage('MAIN TITLE',
theme = shinytheme('flatly'),
tabsetPanel(
sidebarLayout(
sidebarPanel(
fileInput('files','Import File', accept = c('.csv','.xlsx'),
multiple = F),
actionButton('boton1', 'Load', icon = icon('table')),
br(),
selectInput("indices", "Select SHEET:", choices = c(not_sel))
),
mainPanel(
tabsetPanel(
tabPanel('Data',
tableOutput('tabla'),
tableOutput('cabeza')),
tabPanel('Stats',
# selectInput('var01', 'Variable to summarise', choices = c(not_sel)),
tableOutput('stats')),
)
)
)
)
)
##############
server <- function(input, output, session) {
options(shiny.maxRequestSize=10*1024^2)
df <- eventReactive(input$boton1, {
req(input$files)
if(is.null(input$files))return(NULL)
# else{
read_excel(input$files$datapath)
# }
})
# Sheets of file uploaded
sheets_name <- reactive({
if (!is.null(input$files)) {
return(excel_sheets(path = input$files$datapath))
} else {
return(NULL)
}
})
# Update inputSelector with sheet names
observeEvent(df(),{
choices <- c(sheets_name())
updateSelectInput(inputId = "indices", choices = choices)
})
# DATA Tab
## This will show the name of the file
output$tabla <- renderTable({
input$files$name
})
## This Shows the head() but it is only showing the first sheet
output$cabeza <- renderTable({
tabla <- as_tibble(bind_cols(Date = format(as.Date(df()$Date),"%Y-%m-%d"),
Close.Price = df()$Close))
head(tabla)
})
# HERE is where I do not know how to calculate based on selection
# Table for STATS
output$stats <- renderTable({
datos <- df()
Value <- c(round(mean(datos$Close,na.rm = T),2)
)
Statistic <- c("Mean")
data.table(Statistic, Value)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I want to assume that by knowing how to calculate mean based on the sheet selected, I. can replicate the code for the top rows (head()) shown in the Data Panel.
If I missed a similar question asked, I would appreciate any link and I will try the solution proposed first.
As I cannot share the file, this is how the file would look:
After working with this answer I made my app work. If there is a 'cleaner'/'better' answer, I will be happy to read.
Following the recommendation in the linked answer my server ended up like this:
ui <-fluidPage{
#My UI stayed the same with the exception of adding
uiOutput("dropdownUI") #Whererever I needed to appear
}
server <- function(input, output, session) {
...ANSWER FROM THE LINK...
## STATS Tab
output$stats <- renderTable({
Values <- c(round(mean(Dat()[,2],na.rm = T),2)
)
Statistics <- c("Mean")
data.table(Statistics, Values)
})
}
So far I made a Shiny app that has three inputs connected to the database and a final download button. Everything works well except the download button. The actual data downloading part works but I want to add one last logic that hides the download button if myvars$input3 is empty:
observe({
if (is.null(myvars$var3)) {shinyjs::hide("???")}
else {shinyjs::show("???")}
})
server_tab2.R:
Function1 dropdownTab2Server:
Defined the date range logic with id daterange_tab2
Defined the last input dropdown logic with id var_list_tab2
Function2 downloadTab2Server:
Defined the logic for download button
server.R: (This part is not working)
Want to only show the download button if the third input (myvars$input3) is not empty
ui_tab2.R: Defined the three inputs explained in ui.R:
var_lab_tab2: A static dropdown input with only two choices Choice1 and Choice2
daterange_tab2_ui: A date range
subid_dropdown_tab2_ui: The last dropdown input that depends on the first two
##### server_tab2.R
#### Function 1 - A dropdown input dependent on the date range
dropdownTab2Server <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
rv <- reactiveValues()
output$daterange_tab2_ui <- renderUI({
req(input$var_lab_tab2)
dateRangeInput(ns("daterange_tab2"), "Date Range:", start = min_max_date_df$min_date, end = min_max_date_df$max_date) # Retrieved from "global.R"
})
unique_lists_tab2 <- reactive({
sql <- glue_sql("
SELECT
DISTINCT list AS unique_list
FROM table1
WHERE date BETWEEN date ({dateid1_tab2*}) AND date ({dateid2_tab2*})
",
dateid1_tab2 = input$daterange_tab2[1],
dateid2_tab2 = input$daterange_tab2[2],
.con = pool
)
dbGetQuery(pool, sql)
})
output$subid_dropdown_tab2_ui <- renderUI({
req(input$daterange_tab2[1], input$daterange_tab2[2])
shinyWidgets::pickerInput(
ns("var_list_tab2"),
"Stations:",
choices = unique_lists_tab2(),
multiple = T
)
})
observe({
rv$var1 <- input$daterange_tab2[1]
rv$var2 <- input$daterange_tab2[2]
rv$var3 <- input$var_list_tab2
})
return(rv)
}
)
}
#### Function 2 - download button
downloadTab2Server <- function(id, df, filename) {
moduleServer(id, function(input, output, session) {
output$downloadbttn_tab2 <- downloadHandler(
filename = function() {
paste0(filename, ".xlsx")
},
content = function(file) {
WriteXLS::WriteXLS(df, file)
}
)
}
)
}
##### server.R => Struggling with this part
function(input, output, session) {
dropdownTab2Server("dropdown_ui_tab2")
myvars <- dropdownTab2Server("dropdown_ui_tab2")
### download button layout => Struggling with this part
observe({
if (is.null(myvars$var3)) {shinyjs::hide("???")}
else {shinyjs::show("???")}
})
downloadTab2Server(
id = "download_ui_tab2",
df = fake_data(), # reactive
filename = "data"
)
}
##### ui_tab2.R
downloadTab2UI <- function(id) {
ns <- NS(id)
tagList(
shinyWidgets::pickerInput(
ns("var_lab_tab2"),
"ID:",
choices = c("Choice1", "Choice2"), multiple = T
),
uiOutput(ns("daterange_tab2_ui")),
uiOutput(ns("subid_dropdown_tab2_ui")),
downloadButton(ns("downloadbttn_tab2"), "Download Data")
)
}
##### ui.R
downloadTab2UI("download_ui_tab2")
You could the following in the main server part (I've changed it to an observeEvent because I think it's easier to reason what exactly it listens to):
observeEvent(myvars$var3, {
if (is.null(myvars$var3)) {shinyjs::hide("download_ui_tab2-downloadbttn_tab2")}
else {shinyjs::show("download_ui_tab2-downloadbttn_tab2")}
}, ignoreNULL = FALSE)
You need to prefix the download button id with the correct namespace, in your case "download_ui_tab2".
However, this is not great style as you need to manually handle the namespace. A cleaner solution would be to pass myvars to the downloadTab2Server module as an argument and then have the observeEvent in the module code. Then you can directly use downloadbttn_tab2 and don't need to manually prefix the namespace.
I have an R shiny app that gets a .csv import from a user and searches the imported data across a built-in data frame, then gives the % match in the output. The UI is very simple, with a few different inputs (import .csv, a slider, and some radio buttons). What I want is to be able to take the reactive table output and print this to a .csv that the user can download to their machine. The server side of the app looks something like this:
server <- function(input, output){
rvals <- reactiveValues()
observeEvent(input$file_1,{
req(input$file_1)
rvals$csv <<- read.csv(input$file_1$datapath, header = TRUE)
#some data processing here
})
output$contents <- renderTable({
if(input$select == 1){
x <- function
}else if(input$select == 2){
x <- function
}else if(input$select == 3){x <- function}
#some more data processing and formatting here
return(x)
},digits = 4)
}
I would like to have the data table x be able to become a .csv that can be downloaded by clicking a download button. In the server, I added the following code, but when I try to download the data it just downloads a blank file and says "SERVER ERROR" in my downloads manager on my machine.
output$downloadData <- downloadHandler(
filename = "thename.csv",
content = function(file){
write.csv(x, file)
}
In the console I also get the error message:
Warning: Error in is.data.frame: object 'x' not found [No stack trace available]
The object you create inside the expression of renderTable is not available outside of it. Instead you could assign it to the reactive values you set up. Below is a working example (note that I have tried to replicate your code so the data will not be available until you click on "Upload CSV", which here just calls mtcars).
library(shiny)
ui = fluidPage(
sidebarPanel(
actionButton(inputId = "uploadCsv", label = "Upload CSV:", icon = icon("upload")),
selectInput(inputId = "preProc", label = "Pre-processing", choices = c("Mean"=1,"Sum"=2)),
downloadButton("downloadData", label = "Download table")
),
mainPanel(
h4("My table:"),
tableOutput("contents")
)
)
server <- function(input, output) {
rvals <- reactiveValues(
csv=NULL,
x=NULL
)
observeEvent(input$uploadCsv,{
rvals$csv <- mtcars # using example data since I don't have your .csv
# rvals$csv <- read.csv(input$file_1$datapath, header = TRUE)
#some data processing here
})
output$contents <- renderTable({
# Assuing the below are functions applied to your data
req(
input$preProc,
!is.null(rvals$csv)
)
if(input$preProc == 1){
rvals$x <- data.frame(t(colMeans(mtcars)))
}else {
rvals$x <- data.frame(t(colSums(mtcars)))
}
return(rvals$x)
},digits = 4)
output$downloadData <- downloadHandler(
filename = "myFile.csv",
content = function(file){
write.csv(rvals$x, file)
}
)
}
shinyApp(ui,server)
EventReactive already outputs a reactive value, you don't need to create an extra reactiveVal, see example below :
library(shiny)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Test"),
mainPanel(
actionButton("show", "Download"),
textOutput("result")
)
)
server <- function(input, output) {
csvfile <- eventReactive(req(input$show), ignoreNULL = T, {
"Content of file"
})
output$result <- reactive(
paste("result : ",csvfile()))
}
# Run the application
shinyApp(ui = ui, server = server)
I would also avoid to use <<-operator in a reactive expression.
Hello Shiny dashboard experts,
Following reprex works.
i.e. Once the file is uploaded in sidebar: mod1,
we can navigate to sidebar: mod2 and see the uploaded data displayed.
Below is the code:
1. Module to display with its UI
2. Module to read data with its UI
Server and UI for calling modules.
Can we automate this ?
i.e. Once the data is uploaded in sidebar: mod1,
sidebar: mod2 should be seen to the user with uploaded data.
library(shiny)
library(tidyverse)
# Module UI to read content
mod_readUI <- function(id) {
ns <- shiny::NS(id)
shiny::tagList(
fileInput(ns("file1"),
h3("Choose xlsx file"),
accept=c(".xlsx")),
actionButton(ns("ref"), "Refresh")
)
}
# Server modules of reading content
mod_read <- function(input, output, session){
# Uploaded data as reactive element
getData <- reactive({
req(input$file1) # Ensure file is uploaded
if(!is.null(input$file1)){
my_data <- readxl::read_excel(input$file1$datapath)
my_data
}
else{
my_data <- "nothing" %>% as.data.frame()
my_data
}
})
### In order to pass data as reactive elements to other module:
# Created list
reactive({
# browser()
list("excl" = getData())
})
}
# Module UI to display content
mod_displayUI <- function(id) {
ns <- shiny::NS(id)
shiny::tagList(
DT::dataTableOutput(ns("contents"))
)
}
# Server functions
mod_display <- function(input, output, session, file) {
output$contents <- DT::renderDataTable({
req(file())
DT::datatable(file()$excl,
options = list(pageLength = 7,scrollX = TRUE))
})
}
ui <-
shinydashboard::dashboardPage(
shinydashboard::dashboardHeader(),
shinydashboard::dashboardSidebar(
shinydashboard::sidebarMenu(id = "menu1",
shinydashboard::menuItem('mod1',
tabName = 'mod1',
icon = shiny::icon('file')),
shinydashboard::menuItem('mod2',
tabName = 'mod2',
icon = shiny::icon('file'))
)),
shinydashboard::dashboardBody(
shinydashboard::tabItems(
shinydashboard::tabItem("mod1",
mod_readUI("sidemod1")),
shinydashboard::tabItem("mod2",
mod_displayUI("bodymod2")
)
)))
server <- function(input, output) {
# storing mod_read in a variable
readFile1 <- shiny::callModule(mod_read, "sidemod1")
# passing the output of readFile into mod_display module
displayFile <- shiny::callModule(mod_display, "bodymod2", file = readFile1)
}
shinyApp(ui,server)
I suppose you can add an observe to see when the sidemod1-file1 input is not NULL or changes. When that happens, you can use updateTabItems. Note you need to have session as a server function argument as well.
server <- function(input, output, session) {
# storing mod_read in a variable
readFile1 <- shiny::callModule(mod_read, "sidemod1")
# passing the output of readFile into mod_display module
displayFile <- shiny::callModule(mod_display, "bodymod2", file = readFile1)
observe({
req(input$`sidemod1-file1`)
updateTabItems(session, "menu1", "mod2")
})
}
Here is the context :
library(shiny)
liste_statut <- c("A","B","C")
ui <- shinyUI(fluidPage(uiOutput("testUI")))
server <- function(input, output, session) {
output$testUI <- renderUI({
navbarPage(
title = "Test",
tabPanel(icon = icon("users"), 'Test',
sidebarPanel(
# Statut
checkboxGroupInput("statut", "Statut", liste_statut, liste_statut),
checkboxInput('selectall_statut', 'Tout / Aucun', T))))
})
# observe({
# updateCheckboxGroupInput(
# session, 'statut', choices = liste_statut,
# selected = if (input$selectall_statut) liste_statut
# )
# })
}
shinyApp(ui = ui, server = server)
I would like to use my checkbox All/None (in comment lines) properly cause in this case i have a "Warning: Error in if: argument is of length zero". Where should i put it or maybe should i redefine properly something in the UI part?
I willingly use the renderUI/uiOutput option (contrary to the "standard mode" ui/server) because in future, i will add an authentification module, so be able to display several "panels" according to user.
Thanks and sorry for my terrible english :).
The following works for me:
library(shiny)
liste_statut <- c("A","B","C")
ui <- shinyUI(fluidPage(uiOutput("testUI")))
server <- function(input, output, session) {
output$testUI <- renderUI({
navbarPage(
title = "Test",
tabPanel(icon = icon("users"), 'Test',
sidebarPanel(
# Statut
checkboxGroupInput("statut", "Statut", liste_statut, liste_statut),
checkboxInput('selectall_statut', 'Tout / Aucun', T))))
})
observeEvent(input$selectall_statut,{
val <- liste_statut
if(!input$selectall_statut)
val <- character(0)
updateCheckboxGroupInput(
session, 'statut',
selected = val
)
})
}
I initially tried selected = ifelse(input$selectall_statut, liste_statut, character(0)) instead of the intermediate variable val. However, ifelse() only returned a single value, not a vector.
If you are going to do this many times over, then I would recommend a custom ifelse function. Perhaps something like the following:
ifelse2 <- function(test, yes, no){
if(test)
return(yes)
return(no)
}