communication for ShinyModules for generating Rmarkdown report - r

I have a fully functioning shiny, constructed of four different modules, in the first module, we upload the dataset we have, and in the second and third modules, we can plot based on the first module, and in the fourth module, we should be able to generate a report, connected to an rmd. file.
However I would like to render an HTML or PDF report from this, how can it be done? In an ordinary shiny we put the reactive function for the plots in the "report.Rmd" file and it will render the report.
However, it's not that easy with modules, what could be the solution, in order to generate reports based on several modules?
Thanks in advance!
file_upload_UI <- function(id) {
ns <- NS(id)
tabPanel(
"Upload File",
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput(ns("file1"), "Choose CSV File",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
)
),
tags$br(),
checkboxInput(ns("header"), "Header", TRUE),
radioButtons(
ns("sep"),
"Separator",
c(
Comma = ",",
Semicolon = ";",
Tab = "\t"
),
","
),
radioButtons(
ns("quote"),
"Quote",
c(
None = "",
"Double Quote" = '"',
"Single Quote" = "'"
),
'"'
)
),
mainPanel(
tableOutput(ns("contents"))
)
)
)
}
file_upload_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
data <- reactive({
req(input$file1)
inFile <- input$file1
df <- read.csv(inFile$datapath,
header = input$header, sep = input$sep,
quote = input$quote
)
return(df)
})
output$contents <- renderTable({
data()
})
# return data
data
}
)
}
first_page_UI <- function(id) {
ns <- NS(id)
tabPanel(
"First Tab",
titlePanel("My First Plot"),
sidebarPanel(
selectInput(ns("xcol"), "X Variable", ""),
selectInput(ns("ycol"), "Y Variable", "", selected = "")
),
mainPanel(
plotOutput(ns("MyPlot"))
)
)
}
first_page_Server <- function(id, df) {
stopifnot(is.reactive(df))
moduleServer(
id,
function(input, output, session) {
observeEvent(df(), {
updateSelectInput(session,
inputId = "xcol", label = "X Variable",
choices = names(df()), selected = names(df())
)
updateSelectInput(session,
inputId = "ycol", label = "Y Variable",
choices = names(df()), selected = names(df())[2]
)
})
graph_2 <- reactive({
graph_w<- ggplot(df(), aes(.data[[input$xcol]], .data[[input$ycol]])) +
geom_point()
graph_w
})
output$MyPlot <- renderPlot({
graph_2()
})
}
)
}
mod_ggplot_ui <- function(id){
ns <- NS(id)
tabPanel("ggplot Tab",
pageWithSidebar(
headerPanel('My second Plot'),
sidebarPanel(
selectInput(ns('xcol_1'), 'X Variable', ""),
selectInput(ns('ycol_1'), 'Y Variable', "", selected = ""),
checkboxInput(ns("typeplotly"), "Use interactivity", FALSE)
),
mainPanel(
conditionalPanel(
ns = NS(id),
"input.typeplotly == true", plotlyOutput(ns("plotly"))),
conditionalPanel(
ns = NS(id),
"input.typeplotly == false", plotOutput(ns("plot")))
)
)
)
}
mod_ggplot_server <- function(id, df){
stopifnot(is.reactive(df))
moduleServer( id, function(input, output, session){
ns <- session$ns
observeEvent(df(), {
updateSelectInput(session,inputId = "xcol_1",label = "X Variable",choices = names(df()), selected = names(df())
)
updateSelectInput(session,inputId = "ycol_1",label = "y Variable",choices = names(df()), selected = names(df())[2])
}
)
graph <- reactive({
graph_res <- ggplot(df(), aes(.data[[input$xcol_1]], .data[[input$ycol_1]])) +
geom_point()
graph_res
})
output$plot <- renderPlot({
graph()
})
output$plotly <- renderPlotly({
ggplotly(graph())
})
})
}
mod_Report_ui <- function(id){
ns <- NS(id)
tabPanel("Report ",
mainPanel(
width=12,title="Reporting information", solidHeader = TRUE, status = "primary",collapsible = F,
# # Set title of report
fluidRow(
column(4, HTML('Report title')),
column(8,textInput(ns("title"), placeholder='Report title',label=NULL))
),
fluidRow(
column(4, HTML('author')),
column(8,textInput(ns("author"), placeholder='Modeler name',label=NULL))
),
# Start report rendering
fluidRow(
hr(),
column(6,radioButtons(ns('format'), 'Document format', c('PDF', 'HTML', 'Word'),
inline = TRUE)),
column(6, downloadButton(ns("report"), "Generate report",width='100%'))
)
)
)
}
mod_Report_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
output$report <- downloadHandler(
filename = function() {
paste('My_report', Sys.Date(), sep = '.', switch(
input$format, PDF = 'pdf', HTML = 'html', Word = 'docx'
))
},
content = function(file) {
src <- normalizePath('report.Rmd')
withProgress(message = 'Report generating in progress',
detail = 'This may take a while...', value = 0, {
for (i in 1:10) {
incProgress(1/10)
Sys.sleep(0.40)
}
})
owd <- setwd(tempdir())
on.exit(setwd(owd))
file.copy(src, 'report.Rmd', overwrite = TRUE)
library(rmarkdown)
out <- render('report.Rmd', switch(
input$format,
PDF = pdf_document(), HTML = html_document(), Word = word_document()
))
file.rename(out, file)
}
)
})
}
library(shiny)
library(ggplot2)
library(plotly)
library(datasets)
ui <- shinyUI(fluidPage(
titlePanel("Column Plot"),
tabsetPanel(
file_upload_UI("upload_file"),
first_page_UI("first_page"),
mod_ggplot_ui("ggplot_1"),
mod_Report_ui("Report_1")
)
))
server <- shinyServer(function(input, output, session) {
upload_data <- file_upload_Server("upload_file")
first_page_Server("first_page", upload_data)
mod_ggplot_server("ggplot_1",upload_data)
mod_Report_server("Report_1")
})
shinyApp(ui, server)
Rmarkdown file
title: "r input$title"
author: "r input$author"
output: pdf_document
knitr::opts_chunk$set(echo = TRUE)
library(ggplot2)
library(shiny)
library(rmarkdown)
library(knitr)
graph_2()
graph()

I came up with the solution. Now there is communication with all the modules and the rmd. file for rendering the report. Took some good time.
file_upload_UI <- function(id) {
ns <- NS(id)
tabPanel(
"Upload File",
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput(ns("file1"), "Choose CSV File",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
)
),
tags$br(),
checkboxInput(ns("header"), "Header", TRUE),
radioButtons(
ns("sep"),
"Separator",
c(
Comma = ",",
Semicolon = ";",
Tab = "\t"
),
","
),
radioButtons(
ns("quote"),
"Quote",
c(
None = "",
"Double Quote" = '"',
"Single Quote" = "'"
),
'"'
)
),
mainPanel(
tableOutput(ns("contents"))
)
)
)
}
file_upload_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
data <- reactive({
req(input$file1)
inFile <- input$file1
df <- read.csv(inFile$datapath,
header = input$header, sep = input$sep,
quote = input$quote
)
return(df)
})
output$contents <- renderTable({
data()
})
# return data
data
}
)
}
first_page_UI <- function(id) {
ns <- NS(id)
tabPanel(
"First Tab",
titlePanel("My First Plot"),
sidebarPanel(
selectInput(ns("xcol"), "X Variable", ""),
selectInput(ns("ycol"), "Y Variable", "", selected = "")
),
mainPanel(
plotOutput(ns("MyPlot"))
)
)
}
first_page_Server <- function(id, df) {
stopifnot(is.reactive(df))
moduleServer(
id,
function(input, output, session) {
observeEvent(df(), {
updateSelectInput(session,
inputId = "xcol", label = "X Variable",
choices = names(df()), selected = names(df())
)
updateSelectInput(session,
inputId = "ycol", label = "Y Variable",
choices = names(df()), selected = names(df())[2]
)
})
graph_2 <- reactive({
graph_w<- ggplot(df(), aes(.data[[input$xcol]], .data[[input$ycol]])) +
geom_point()
graph_w
})
output$MyPlot <- renderPlot({
graph_2()
})
return(graph_2)
}
)
}
mod_ggplot_ui <- function(id){
ns <- NS(id)
tabPanel("ggplot Tab",
pageWithSidebar(
headerPanel('My second Plot'),
sidebarPanel(
selectInput(ns('xcol_1'), 'X Variable', ""),
selectInput(ns('ycol_1'), 'Y Variable', "", selected = ""),
checkboxInput(ns("typeplotly"), "Use interactivity", FALSE)
),
mainPanel(
conditionalPanel(
ns = NS(id),
"input.typeplotly == true", plotlyOutput(ns("plotly"))),
conditionalPanel(
ns = NS(id),
"input.typeplotly == false", plotOutput(ns("plot")))
)
)
)
}
mod_ggplot_server <- function(id, df){
stopifnot(is.reactive(df))
moduleServer( id, function(input, output, session){
ns <- session$ns
observeEvent(df(), {
updateSelectInput(session,inputId = "xcol_1",label = "X Variable",choices = names(df()), selected = names(df())
)
updateSelectInput(session,inputId = "ycol_1",label = "y Variable",choices = names(df()), selected = names(df())[2])
}
)
graph <- reactive({
graph_res <- ggplot(df(), aes(.data[[input$xcol_1]], .data[[input$ycol_1]])) +
geom_point()
graph_res
})
output$plot <- renderPlot({
graph()
})
output$plotly <- renderPlotly({
ggplotly(graph())
})
return(graph)
})
}
mod_Report_ui <- function(id){
ns <- NS(id)
tabPanel("Report ",
mainPanel(
width=12,title="Reporting information", solidHeader = TRUE, status = "primary",collapsible = F,
# # Set title of report
fluidRow(
column(4, HTML('Report title')),
column(8,textInput(ns("title"), placeholder='Report title',label=NULL))
),
fluidRow(
column(4, HTML('author')),
column(8,textInput(ns("author"), placeholder='Modeler name',label=NULL))
),
# Start report rendering
fluidRow(
hr(),
column(6,radioButtons(ns('format'), 'Document format', c('PDF', 'HTML', 'Word'),
inline = TRUE)),
column(6, downloadButton(ns("report"), "Generate report",width='100%'))
)
)
)
}
mod_Report_server <- function(id, graph_2, graph){
stopifnot(is.reactive(graph_2))
stopifnot(is.reactive(graph))
moduleServer( id, function(input, output, session){
ns <- session$ns
output$report <- downloadHandler(
filename = function() {
paste('My_report', Sys.Date(), sep = '.', switch(
input$format, PDF = 'pdf', HTML = 'html', Word = 'docx'
))
},
content = function(file) {
src <- normalizePath('report.Rmd')
withProgress(message = 'Report generating in progress',
detail = 'This may take a while...', value = 0, {
for (i in 1:10) {
incProgress(1/10)
Sys.sleep(0.40)
}
})
# Set up parameters to pass to Rmd document
params_for_rmd = list(plot_1=graph_2(),
plot_2=graph(),
set_title=input$title,
set_author=input$author)
owd <- setwd(tempdir())
on.exit(setwd(owd))
file.copy(src, 'report.Rmd', overwrite = TRUE)
library(rmarkdown)
out <- render('report.Rmd', switch(
input$format,
PDF = pdf_document(), HTML = html_document(), Word = word_document()
))
file.rename(out, file)
}
)
})
}
library(shiny)
library(ggplot2)
library(plotly)
library(datasets)
ui <- shinyUI(fluidPage(
titlePanel("Column Plot"),
tabsetPanel(
file_upload_UI("upload_file"),
first_page_UI("first_page"),
mod_ggplot_ui("ggplot_1"),
mod_Report_ui("Report_1")
)
))
server <- shinyServer(function(input, output, session) {
upload_data <- file_upload_Server("upload_file")
gplot_1 <- first_page_Server("first_page", upload_data)
gplot_2 <- mod_ggplot_server("ggplot_1",upload_data)
mod_Report_server("Report_1",graph_2 =gplot_1, graph = gplot_2)
})
shinyApp(ui, server)
the rmd. file
---
output: pdf_document
params:
plot_1: NA
plot_2: NA
set_title:
set_author:
title: "`r input$title`"
author: "`r input$author`"
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(ggplot2)
library(shiny)
library(rmarkdown)
library(knitr)
my first plot
graph_2()
params$plot_1
my second plot
graph()
params$plot_2

Related

How to use downloadButton and downloadHandler inside a shiny module?

I am trying to build a shiny module that I can use to download different files from a shiny app. But the downloadButton is not working as I want them to. It is responding with a html file which is not what I want. Here is my code:
library(shiny)
downloadUI <- function(id, label){
ns <- NS(id)
actionButton(
inputId = ns("action"),
label = label,
icon = icon("download")
)
}
downloadServer <- function(id, filename){
moduleServer(
id,
function(input, output, session){
observeEvent(
input$action,
{
showModal(
modalDialog(
title = NULL,
h3("Download the file?", style = "text-align: center;"),
footer = tagList(
downloadButton(
outputId = "download",
label = "Yes"
),
modalButton("Cancel")
),
size = "m"
)
)
}
)
output$download <- downloadHandler(
filename = paste0(filename, ".csv"),
content = function(file){
write.csv(iris, file = file, row.names = FALSE)
}
)
}
)
}
ui <- fluidPage(
downloadUI("irisDownload", label = "Download Iris data")
)
server <- function(input, output, session) {
downloadServer("irisDownload", filename = "iris")
}
shinyApp(ui, server)
Can anyone help me understand what I am doing wrong here?
You just need a namespace ns on the server side for the downloadButton. Try this
library(shiny)
downloadUI <- function(id, label){
ns <- NS(id)
actionButton(
inputId = ns("action"),
label = label,
icon = icon("download")
)
}
downloadServer <- function(id, filename){
moduleServer(
id,
function(input, output, session){
ns <- session$ns
observeEvent(
input$action,
{
showModal(
modalDialog(
title = NULL,
h3("Download the file?", style = "text-align: center;"),
footer = tagList(
downloadButton(
outputId = ns("download"),
label = "Yes"
),
modalButton("Cancel")
),
size = "m"
)
)
}
)
output$download <- downloadHandler(
filename = paste0(filename, ".csv"),
content = function(file){
write.csv(iris, file = file, row.names = FALSE)
}
)
}
)
}
ui <- fluidPage(
downloadUI("irisDownload", label = "Download Iris data")
)
server <- function(input, output, session) {
downloadServer("irisDownload", filename = "iris")
}
shinyApp(ui, server)

Modularize reactiveUI with interdependent filters in shiny with {golem}

The following shiny app works well but has a problem: it displays errors or warnings because of the dynamic filtering.
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
),
fluidRow(),
hr(),
fluidRow(style = 'background: white;',
div(
box(
title= "Much filters",
style = 'height:420px; background: gainsboro; margin-top: 5vw;',
width=3,
solidHeader = TRUE,
uiOutput("continent"),
uiOutput("country")
),
tabBox(
width = 9,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",
DT::dataTableOutput("awesometable")
)
)
)
)
)
)
)
)
library(data.table)
library(shiny)
library(gapminder
server <- function(input, output, session) {
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
# #
datasub <- reactive({
df[df$continent == input$continent,]
})
output$country = renderUI({
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
#
datasub2 <- reactive({
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
datasub2()
})
}
shinyApp(ui, server)
First part of the problem:
Errors started displaying once I included a filtering method I found here:
https://stackoverflow.com/a/51153769/12131069
After trying different methods, this is the one that works pretty close to what I am looking for.
However, once the app is loaded, this appears in the console:
Logical subscripts must match the size of the indexed input.
Input has size 392 but subscript datasub2()$country== input$country has size 0.
Second part of the problem:
The app is being developed with the {golem} package, which is really helpful when building scalable and maintainable shiny infrastructure. However, I don't get what I am expecting (and I get the errors). How can I solve that? How can I "modularize" the workaround I found to create interdependent filters?
I have been trying something like:
#' awesome_app_ui UI Function
#'
#' #description A shiny Module.
#'
#' #param id,input,output,session Internal parameters for {shiny}.
#'
#' #noRd
#'
#' #import DT
#' #import plotly
#' #import htmltools
#' #import shinydashboard
#' #importFrom reactable JS
#' #importFrom shiny NS tagList
mod_chiffres_cles_ts_ui <- function(id){
ns <- NS(id)
df <- gapminder::gapminder
tabBox(width = 9,title = "Results",d = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",DT::dataTableOutput("awesometable"))
}
#' awesome_app Server Functions
#'
#' #noRd
mod_chiffres_cles_ts_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
# #
datasub <- reactive({
df[df$continent == input$continent,]
})
output$country = renderUI({
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
#
datasub2 <- reactive({
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
datasub2()
})
}
Thanks!
Once you use req() appropriately, your program works fine.
library(shiny)
library(data.table)
library(shiny)
library(gapminder)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
),
fluidRow(),
hr(),
fluidRow(style = 'background: white;',
div(
box(
title= "Much filters",
style = 'height:420px; background: gainsboro; margin-top: 5vw;',
width=3,
solidHeader = TRUE,
uiOutput("continent"),
uiOutput("country")
),
tabBox(
width = 9,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",
DT::dataTableOutput("awesometable")
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
datasub <- reactive({
req(input$continent)
df[df$continent == input$continent,]
})
output$country = renderUI({
req(datasub())
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
datasub2 <- reactive({
req(datasub(),input$country)
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
req(datasub2())
datasub2()
})
}
shinyApp(ui, server)
You can also use modules as shown below. You may need to adjust where you want to place your selectInputs.
library(shiny)
library(data.table)
library(shiny)
library(gapminder)
moduleServer <- function(id, module) {
callModule(module, id)
}
mod_chiffres_cles_ts_ui <- function(id){
ns <- NS(id)
tagList(
box(
title= "Filter",
style = 'height:420px; background: gainsboro; margin-top: 3vw;',
#width=3,
solidHeader = TRUE,
uiOutput(ns("mycontinent"))
)
)
}
mod_chiffres_cles_ts_server <- function(id,dat,var){
moduleServer( id, function(input, output, session){
ns <- session$ns
df <- isolate(dat())
output$mycontinent = renderUI({
selectizeInput(inputId = ns("continent"),
label = paste(var, ":"),
choices = unique(df[,var]),
selected = unique(df[,var])[1])
})
#print(var)
return(reactive(input$continent))
})
}
mod_chiffres_cles_ds_server <- function(id,dat,var,value){
moduleServer( id, function(input, output, session){
df <- isolate(dat())
datasub <- reactive({
val = as.character(value())
df[df[[as.name(var)]] == val,]
})
#print(var)
return(reactive(as.data.frame(datasub())))
})
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
column(6,mod_chiffres_cles_ts_ui("gap1"),
mod_chiffres_cles_ts_ui("gap2")
),
column(6,style = 'background: white;',
div(
tabBox(
width = 12,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:560px;',"Awesome results !",
style="zoom: 90%;",
DTOutput("awesometable")
)
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
dfa <- reactive(gapminder)
session$userData$settings <- reactiveValues(df1=NULL,df2=NULL)
rv <- reactiveValues()
var1 <- mod_chiffres_cles_ts_server("gap1",dfa,"continent")
observeEvent(var1(), {
data1 <- mod_chiffres_cles_ds_server("gap1",dfa,"continent", var1 )
session$userData$settings$df1 <- data1()
var21 <- mod_chiffres_cles_ts_server("gap2",data1,"country")
df21 <- mod_chiffres_cles_ds_server("gap2",data1,"country", var21 )
session$userData$settings$df2 <- df21()
print(var21)
})
df22 <- reactive(session$userData$settings$df1)
var22 <- mod_chiffres_cles_ts_server("gap2",df22,"country")
observeEvent(var22(), {
print(var22())
data2 <- mod_chiffres_cles_ds_server("gap2",df22,"country",var22)
session$userData$settings$df2 <- data2()
})
output$awesometable <- renderDT({
datatable(session$userData$settings$df2)
})
}
shinyApp(ui, server)

How to create a button that will create a pdf file of a table

I currently have a table being generated and I would like the user to be able to create a pdf file when they click the download button.
I am currently getting an error where when I click the download button I get an html file that downloads the entire page of the app. I thought that using pdf(file) would work but it ignores the function.
Here is currently what I have.
library(shiny)
library(xlsx)
library(shinyWidgets)
population <- read.xlsx("population.xlsx", 1)
fieldsMandatory <- c("selectedCountry")
labelMandatory <- function(label) {
tagList(
label,
span("*", class = "mandatory_star")
)
}
appCSS <-
".mandatory_star {color: red;}"
ui <- fluidPage(
navbarPage(title = span("Spatial Tracking of COVID-19 using Mathematical Models", style = "color:#000000; font-weight:bold; font-size:15pt"),
tabPanel(title = "Model",
sidebarLayout(
sidebarPanel(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
div(
id = "dashboard",
pickerInput(
inputId = "selectedCountry",
labelMandatory ("Country"),
choices = population$Country,
multiple = FALSE,
options = pickerOptions(
actionsBox = TRUE,
title = "Please select a country")
),
sliderInput(inputId = "agg",
label = "Aggregation Factor",
min = 0, max = 50, step = 5, value = 10),
actionButton("go","Run Simulation"),
)
),
mainPanel(
tabsetPanel(
tabPanel("Input Summary", verbatimTextOutput("summary"),
tableOutput("table"),
downloadButton(outputId = "downloadSummary", label = "Save Summary"))
)
)
)
)
)
)
server <- function(input, output, session){
observeEvent(input$resetAll, {
shinyjs::reset("dashboard")
})
values <- reactiveValues()
values$df <- data.frame(Variable = character(), Value = character())
observeEvent(input$go, {
row1 <- data.frame(Variable = "Country", Value = input$selectedCountry)
row2 <- data.frame(Variable = "Aggregation Factor", Value = input$agg)
values$df <- rbind(row1, row2)
})
output$table <- renderTable(values$df)
observe({
# check if all mandatory fields have a value
mandatoryFilled <-
vapply(fieldsMandatory,
function(x) {
!is.null(input[[x]]) && input[[x]] != ""
},
logical(1))
mandatoryFilled <- all(mandatoryFilled)
# enable/disable the submit button
shinyjs::toggleState(id = "go", condition = mandatoryFilled)
})
output$downloadSummary <- downloadHandler(
filename = function(file) {
paste('my-report.pdf', )
},
content = function(file) {
pdf(file)
}
)
}
shinyApp(ui,server)
Here's a minimal example:
library(shiny)
ui <- fluidPage(
downloadButton("savepdf", "Save pdf")
)
server <- function(input, output, session) {
output$savepdf <- downloadHandler(
filename = "test.pdf",
content = function(file) {
pdf(file)
plot(iris$Sepal.Length, iris$Sepal.Width)
dev.off()
}
)
}
shinyApp(ui, server)
Also see here.
Here is a minimal example with the package latexpdf. It will create the pdf table in the folder of the app.
library(shiny)
library(latexpdf)
dat <- head(iris, 5)
ui <- fluidPage(
br(),
actionButton("dwnld", "Create pdf"),
tableOutput("mytable")
)
server <- function(input, output, session){
output[["mytable"]] <- renderTable({
dat
})
observeEvent(input[["dwnld"]], {
as.pdf(dat)
})
}
shinyApp(ui, server)

R shiny observeEvent() cannot isolate the reactivity when input$files parameters changes

I met a problem abount R shiny observeEvent(). I have to upload three csv table files to separately show at different tabpanels. And I set a selectInput to set if to show header of table. At last I give a actionButton(ui)-observeEvent(server) to decide whether to run the showing process. But I find the selectInput just skip the observeEvent(), dynamicly change the show.That is observeEvent is invalidted.I dont'know why.I want selectInput can be under control of actionButton(). I doubt if observeEvent() is a good option to execute the job. Hope somebody can help me! Thanks in advance. Here is my demo code
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- reactive({
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
observe({
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
})
observeEvent(input$update, {
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)
The problem is that you wrap output$mytabs in an observe. I'm not sure why this influences also the content of the output$Group1 etc. you generate in the renderUI call and overrules the observeEvent. Anyway, you don't need the observe, outputs are automatically updated when a dependency changes:
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- reactive({
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
observeEvent(input$update, {
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)
Edit
I think this solution is more what you want. Maybe one can optimise the last observe statement to a better coding pattern:
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- eventReactive(input$update, {
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
observe({
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)

Shiny do.call, lapply and modules

I'm trying to display a navlistPanel with several tabs and for each of those tabs a tabsetPanel with again several tabs. I manage to do so using the function do.call and two lapply to display the required number of tabs in the navlistPanel and tabsetPanel. However I can no longer display a table when a .csv file is uploaded.
Do anyone knows what I'm doing wrong here?
Here's my code:
library(shiny)
library(shinydashboard)
moduleUI <- function(id){
ns <- NS(id)
tagList(
sidebarLayout(
sidebarPanel(
fileInput(ns("file"), label = "", multiple = TRUE,
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv'))
),
mainPanel(div( dataTableOutput(ns('table')), style = "font-size: 70% ;width: 70"))
))}
module <- function(input, output, session){
output$table <- renderDataTable({
inFile <- input$file
if (is.null(inFile))
return(NULL)
read.csv(inFile$datapath)
})
}
moduleUI2 <- function(id){
ns <- NS(id)
tagList(
do.call(navlistPanel, args = c( id = "tabs", lapply(1:4, function(i) {
tabPanel(title = paste("tab", i), style = 'overflow-x: scroll',
mainPanel(
do.call(tabsetPanel, c(id = paste0("versions",i), lapply(1:5, function(n){
tabPanel(title = paste("version", n),
moduleUI(paste("base",i, n, sep = "_")),
h4(paste("tab", n))
)
}))),
width = 12)
)
})))
)}
module2 <- function(input, output, session){
lapply(1:4,function(i) {
lapply(1:5, function(n) {
callModule(module, paste("base",i,n, sep = "_"))
})
})
}
ui <- dashboardPage(
dashboardHeader(title = "App"),
dashboardSidebar(
sidebarMenu(id = "tabs",
menuItem("Tab1", tabName = "Tab1")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "Tab1",
moduleUI2("base")
))
))
server <- function(input, output, session){
callModule(module2, "base")
}
shinyApp(ui = ui, server = server)
I've found the error, just add a ns() to the following line and the data will display properly:
ns(paste("base",i, n, sep = "_"))

Resources