Related
I am trying to create a script to generate heatmaps in R shiny. I attach the script below
library(shiny)
options(shiny.maxRequestSize = 50*1024^2)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput('expression_table','Expression file (xlsx format)'),
selectInput('normalization','Normalize the values with', choices = c('None','CPM','LogCPM','Z-score','Log only')),
fileInput('metadata','Metadata file (xlsx format)'),
textInput('annotcol', 'Annotation column of metadata file', value = NULL),
textInput('gene_list','List of genes to plot (1 gene per line)', value = NULL),
textInput('heatmap_title','Heatmap title', value = 'Heatmap title'),
selectInput('color_scale','Choose your color scale', choices = c('Blue-White-Red',
'Red-White-Blue',
'Green-Black-Purple',
'Purple-Black-Green')
),
sliderInput('colsize','Column labels size', min=0, max=20, step=1, value=8 ),
sliderInput('colkm','Number of Column clusters', min=0, max=10, step=1, value=1 ),
selectInput('coldend','Show column dendrogram', choices = c(TRUE,FALSE)),
sliderInput('rowsize','Row labels size', min=0, max=20, step=1, value=8 ),
sliderInput('rowkm','Number of Row clusters', min=0, max=10, step=1, value=1 ),
selectInput('rowdend','Show row dendrogram', choices = c(TRUE,FALSE)),
actionButton('click','Generate Heatmap')
),
mainPanel(
plotOutput('heatmap')
)
)
)
server <- function(input, output, session) {
library(ComplexHeatmap)
library(circlize)
library(dplyr)
library(openxlsx)
library(edgeR)
library(stringr)
expression <- reactive({
read.xlsx(input$expression_table, rowNames = TRUE, colNames=TRUE)
})
expression_normalized <- reactive({
if(input$normalization == 'CPM'){
as.data.frame(cpm(expression))
} else if(input$normalization == 'LogCPM'){
as.data.frame(log(cpm(expression)+1))
} else if(input$normalization == 'Z-score'){
as.data.frame(t(scale(t(cpm(expression)))))
} else if(input$normalization == 'None'){
read.xlsx(input$expression_table, rowNames = TRUE, colNames=TRUE)
} else if(input$normalization == 'Log only'){
as.data.frame(log(expression + 1))
}
})
metadata <- reactive({
read.xlsx(input$metadata, rowNames = TRUE, colNames=TRUE)
})
expression_isolated <- reactive({
if(!is.null(input$gene_list)){
genes_list <- unlist(strsplit(input$gene_list, split = '\n'))
expression_normalized %>% filter(rownames(.) %in% genes_list)
} else {
expression_normalized
}
})
CS <- reactive({
if(input$color_scale == 'Blue-White-Red'){
colorRamp2(c(min(expression_isolated),0,max(expression_isolated)),
c("steelblue3","white","firebrick3"))
} else if(input$color_scale == 'Red-White-Blue'){
colorRamp2(c(min(expression_isolated),0,max(expression_isolated)),
c("firebrick3","white","steelblue3"))
} else if(input$color_scale == 'Green-Black-Purple'){
colorRamp2(c(min(expression_isolated),0,max(expression_isolated)),
c("olivedrab3","black","mediumorchid3"))
} else if(input$color_scale == 'Purple-Black-Green'){
colorRamp2(c(min(expression_isolated),0,max(expression_isolated)),
c("mediumorchid3","black","olivedrab3"))
}
})
#output
eventReactive(input$click, {
output$heatmap <- renderPlot({
if(!is.null(input$annotcol)) {
Heatmap(as.matrix(expression_isolated),
col = CS,
row_names_gp = gpar(fontsize = input$rowsize),
column_names_gp = gpar(fontsize = input$colsize),
column_km = input$colkm,
row_km= input$rowkm,
show_row_dend = input$rowdend,
show_column_dend = input$coldend,
column_title = input$heatmap_title,
top_annotation = HeatmapAnnotation(Condition = metadata[,input$annotcol], which = 'column')
)
} else {
Heatmap(as.matrix(expression_isolated),
col = CS,
row_names_gp = gpar(fontsize = input$rowsize),
column_names_gp = gpar(fontsize = input$colsize),
column_km = input$colkm,
row_km= input$rowkm,
show_row_dend = input$rowdend,
show_column_dend = input$coldend,
column_title = input$heatmap_title
)
}
})
})
}
shinyApp(ui, server)`
The application runs fine and generates the UI. However, when I upload the excel file with the data and press 'Generate Heatmap' I get no response and no error.
I also used observeEvent instead of eventReactive. When I used observeEvent for the click handling I get the following error:
"Error in as.vector: cannot coerce type 'closure' to vector of type 'any'"
The file input is a standard excel file with rownames in the first column, headers in the first row and numeric values for data, i.e.
SAMPLE1 SAMPLE2 SAMPLE3
IFNI 10 11 13
IFNII 11 16 15
TP53 45 22 56
Anyone know what's going on?
> sessionInfo()
R version 4.2.0 (2022-04-22)
Platform: x86_64-apple-darwin17.0 (64-bit)
Running under: macOS Monterey 12.4
Matrix products: default
LAPACK: /Library/Frameworks/R.framework/Versions/4.2/Resources/lib/libRlapack.dylib
locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
attached base packages:
[1] grid stats graphics grDevices utils datasets methods base
other attached packages:
[1] stringr_1.5.0 edgeR_3.38.4 limma_3.52.4 openxlsx_4.2.5.1
[5] dplyr_1.0.10 circlize_0.4.15 ComplexHeatmap_2.13.1 shiny_1.7.4
loaded via a namespace (and not attached):
[1] Rcpp_1.0.10 locfit_1.5-9.7 lattice_0.20-45 png_0.1-8
[5] assertthat_0.2.1 digest_0.6.31 foreach_1.5.2 utf8_1.2.2
[9] mime_0.12 R6_2.5.1 stats4_4.2.0 pillar_1.8.1
[13] GlobalOptions_0.1.2 rlang_1.0.6 rstudioapi_0.14 jquerylib_0.1.4
[17] S4Vectors_0.36.1 GetoptLong_1.0.5 textshaping_0.3.6 compiler_4.2.0
[21] httpuv_1.6.8 systemfonts_1.0.4 pkgconfig_2.0.3 BiocGenerics_0.44.0
[25] shape_1.4.6 htmltools_0.5.4 tidyselect_1.2.0 tibble_3.1.8
[29] IRanges_2.32.0 codetools_0.2-18 matrixStats_0.63.0 fansi_1.0.4
[33] crayon_1.5.2 later_1.3.0 jsonlite_1.8.4 xtable_1.8-4
[37] lifecycle_1.0.3 DBI_1.1.3 magrittr_2.0.3 zip_2.2.2
[41] cli_3.6.0 stringi_1.7.12 cachem_1.0.6 promises_1.2.0.1
[45] doParallel_1.0.17 bslib_0.4.2 ellipsis_0.3.2 ragg_1.2.5
[49] generics_0.1.3 vctrs_0.5.2 rjson_0.2.21 RColorBrewer_1.1-3
[53] iterators_1.0.14 tools_4.2.0 glue_1.6.2 parallel_4.2.0
[57] fastmap_1.1.0 clue_0.3-63 colorspace_2.1-0 cluster_2.1.4
[61] memoise_2.0.1 sass_0.4.5
BLUF: change input$metadata to input$metadata$datapath.
If you read ?shiny::fileInput and go down to the "Server value:" section, it reads:
Server value:
A 'data.frame' that contains one row for each selected file, and
following columns:
'name' The filename provided by the web browser. This is *not* the
path to read to get at the actual data that was uploaded (see
'datapath' column).
'size' The size of the uploaded data, in bytes.
'type' The MIME type reported by the browser (for example,
'text/plain'), or empty string if the browser didn't know.
'datapath' The path to a temp file that contains the data that was
uploaded. This file may be deleted if the user performs
another upload operation.
By using read.xlsx(input$metadata, ...), you are passing a data.frame to read.xlsx, which obviously doesn't work. There will likely be nothing in the shiny app, since you're not capturing warnings or errors. You should have seen something like:
read.xlsx(data.frame(name="myfile", datapath="myfile.xlsx"))
# Error in file(description = xlsxFile) : invalid 'description' argument
Multiple recommendations:
Change your code to use input$metadata$datapath;
Use req and possible validate/need, since you can avoid trying to read NULL (which can happen due to the order of reactivity) and, if not met, sometimes you can provide clear verbiage in the app interface itself.
Use tryCatch for anything that is even somewhat out of your control. By doing so, you give yourself more information and ability to recover when something goes wrong.
At a minimum, this is your fix.
metadata <- reactive({
read.xlsx(input$metadata$datapath, rowNames = TRUE, colNames=TRUE)
})
But perhaps this app presents the other recommendations clearly:
library(shiny)
shinyApp(
ui = fluidPage(
fileInput("metadata", "MetaData"),
plotOutput("plot")
),
server = function(input, output, session) {
mydata <- reactive({
req(input$metadata)
res <- tryCatch(
openxlsx::read.xlsx(input$metadata$datapath, rowNames = TRUE, colNames = TRUE),
error = function(e) e
)
validate(
need(
!inherits(res, "error"),
paste("There was a problem reading your file:",
paste(conditionMessage(res), collapse = "; "))
)
)
})
output$plot <- renderPlot({
req(mydata())
plot(y ~ x, data = mydata())
})
}
)
The error message is in the place the plot should normally show up. If there are multiple components that use mydata(), the error message in this example will be shown in all of the components (that support validate/need rendering). You can limit this by moving the validate(..) statement out of mydata <- and into one (or more) dependent components, though all components would then need to either check for req(!inherits(mydata(), "error")) or some other way communicate what happened.
Cross-posted from https://community.rstudio.com/t/reactive-input-to-module/143679, if that's not okay feel free to let me know! I'm new to posting here.
I'm using a module to handle file uploading. It allows the user to upload a CSV or an RDS, or to use the dataframe produced in a previous stage of the app. The call to the module takes the name of this previous dataframe as an argument, to know what to return if the user selects this option.
My issue is that this previous dataframe doesn't seem to update reactively. For one of the steps (we'll call it step 3), users can select whether they want to continue by using the dataframe from step 1, or from step 2. I've tried to code this by creating a server-side object, for_use_prev(), which stores the DF from step 1 if a checkbox is checked, and stores the DF from step 2 of the checkbox is unchecked. for_use_prev() is then called by the module.
The module call, however, does not update when for_use_prev() changes. It only takes the original value of the dataframe, and does not reset even when for_use_prev() changes. Clicking the upload button again also does not force it to take the new value of for_use_prev().
Why does the module call not change reactively to the reactive dataframe? I have tried various ways of calling it:
without parentheses:
loadFileServer("calc_input", prev_file=for_use_prev)
with parentheses:
loadFileServer("calc_input", prev_file=for_use_prev())
wrapped in reactive, with and without parentheses:
loadFileServer("calc_input", prev_file=reactive(for_use_prev()))
loadFileServer("calc_input", prev_file=reactive(for_use_prev))
None of them change the module output, although for_use_prev() itself is definitely changing. Additionally, when for_use_prev is called without parentheses as suggested here, the module returns the function behind for_use_prev rather than the dataframe.
Wrapping the whole module call in reactive() also does not work.
Does anyone have an idea how I can get the module call to react to changing input?
Below is a minimal example. To reproduce the issue, you can upload any two random CSV files in steps 1 and 2. In step 3, the current value of for_use_prev() is shown under "Current dataframe for_use_prev() is using". When you click the action button "Use file from previous step", the file upload module should output the same dataframe as for_use_prev() which will be displayed next to for_use_prev(). It does this for the first value of for_use_prev(), but if you uncheck the checkbox above the action button, you should be able to observe that for_use_prev() changes accordingly, but the value doesn't change from its initial one even as for_use_prev() changes.
EDIT: This is what it looks like when using the reactive (without parentheses) instead of its value (with parentheses).
The module returns the function rather than the dataframe.
I'm reluctant to change the module itself, since it's used multiple times throughout my app, and this is the only instance in which the user must be given a choice between two different previous DFs.
If more details or explanation are necessary please let me know!
Reprex:
library(shiny)
library(shinydashboard)
# Define the module
# Module UI function
loadFileUI <- function(id) {
# `NS(id)` returns a namespace function, which was save as `ns` and will
# invoke later.
ns <- NS(id)
tagList(
actionButton(ns("file_from_prev"),"Use file from previous step"),
h5("Or upload a saved file:"),
fileInput(ns("file_rds"), "RDS file",accept=".rds"),
fileInput(ns("file_csv"),"CSV File",accept=".csv"),
actionButton(ns("file_load_rds"),"Load RDS"),
actionButton(ns("file_load_csv"),"Load CSV"),
actionButton(ns("file_clear"),"Remove file upload")
)
}
# Module server function
loadFileServer <- function(id, prev_file) {
moduleServer(
id,
## Below is the module function
function(input, output, session) {
# initiate reactive values object to store what type of upload you want, or to clear your upload
upload_file <- reactiveValues(state=NULL)
observeEvent(input$file_from_prev,{ # take file from previous step
upload_file$state <- "prev"
})
observeEvent(input$file_load_rds,{ # load file from rds
upload_file$state <- "rds"
})
observeEvent(input$file_load_csv,{ # load file from csv
upload_file$state <- "csv"
})
observeEvent(input$file_clear,{ # clear file
upload_file$state <- "clear"
})
# actually upload the file (source depends on setting of upload_file$state as set above)
file_full <- reactive(
if(upload_file$state=="prev"){
prev_file
} else if(upload_file$state=="rds" & !is.null(input$file_rds)){
readRDS(input$file_rds$datapath)
} else if(upload_file$state=="csv" & !is.null(input$file_csv)){
read.csv(input$file_csv$datapath)
} else if(upload_file$state=="clear"){
NULL
}
)
# Return the reactive that yields the data frame
return(
list(df=(file_full),
status=reactive(upload_file$state))
)
}
)
}
# Set up the app
ui <- dashboardPage(
dashboardHeader(
title = "Reactive module input"
),
dashboardSidebar(
sidebarMenu(
menuItem("Step 1",tabName = "upload1"),
menuItem("Step 2",tabName = "upload2"),
menuItem("Step 3",tabName = "upload3")
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "upload1",
fileInput("file_up1",label = "Upload file",accept = ".csv"),
tableOutput("input1_preview")
),
tabItem(
tabName = "upload2",
fileInput("file_up2",label = "Upload file",accept = ".csv"),
tableOutput("input2_preview")
),
tabItem(
tabName = "upload3",
fluidRow(
column(width = 6,
box(width = NULL,
checkboxInput("which_prev_input","If checked, use input 1 as previous, otherwise input 2",value=T),
loadFileUI("step3_input")
)
)
),
fluidRow(
column(width = 6,
box(width = NULL,
title = "Current dataframe for_use_prev() is using",
tableOutput("prev_df_preview")
)
),
column(width = 6,
box(width = NULL,
title = "Dataframe being uploaded by the module",
tableOutput("step3_preview")
)
)
)
)
)
)
)
server <- function(input, output) {
# First file upload
upload1 <- reactive({
read.csv(input$file_up1$datapath)
})
output$input1_preview <- renderTable(upload1())
# Second file upload
upload2 <- reactive({
read.csv(input$file_up2$datapath)
})
output$input2_preview <- renderTable(upload2())
# Choose whether to use the first or second file
for_use_prev <- reactive({
if(input$which_prev_input){
upload1()
} else{
upload2()
}
})
# Call file upload module to give the possibility to upload a CSV, RDS, or use a previously uploaded file
upload_step3_raw <- loadFileServer("step3_input", prev_file=for_use_prev()) # the call to for_use_prev doesn't update
upload_step3_df <- reactive(upload_step3_raw$df())
# Preview the DF chosen to be the previous dataframe (for_use_prev)
output$prev_df_preview <- renderTable(head(for_use_prev()))
# Preview the uploaded dataframe
output$step3_preview <- renderTable(head(upload_step3_df()))
}
shinyApp(ui, server)
sessionInfo:
R version 4.2.1 (2022-06-23 ucrt)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 19042)
Matrix products: default
locale:
[1] LC_COLLATE=English_Germany.utf8 LC_CTYPE=English_Germany.utf8 LC_MONETARY=English_Germany.utf8
[4] LC_NUMERIC=C LC_TIME=English_Germany.utf8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] shinydashboard_0.7.2 shiny_1.7.1
loaded via a namespace (and not attached):
[1] Rcpp_1.0.8 jquerylib_0.1.4 bslib_0.3.1 later_1.3.0 pillar_1.7.0 compiler_4.2.1
[7] plyr_1.8.6 bitops_1.0-7 tools_4.2.1 digest_0.6.29 jsonlite_1.7.3 lifecycle_1.0.1
[13] tibble_3.1.6 gtable_0.3.0 pkgconfig_2.0.3 rlang_1.0.1 cli_3.1.1 DBI_1.1.2
[19] fastmap_1.1.0 dplyr_1.0.8 httr_1.4.2 xml2_1.3.3 sass_0.4.0 generics_0.1.2
[25] vctrs_0.3.8 htmlwidgets_1.5.4 grid_4.2.1 tidyselect_1.1.2 fontawesome_0.2.2 reshape_0.8.8
[31] glue_1.6.2 data.table_1.14.2 R6_2.5.1 fansi_1.0.2 purrr_0.3.4 ggplot2_3.3.5
[37] magrittr_2.0.3 promises_1.2.0.1 scales_1.1.1 ellipsis_0.3.2 htmltools_0.5.2 assertthat_0.2.1
[43] rvest_1.0.2 xtable_1.8-4 mime_0.12 colorspace_2.0-2 httpuv_1.6.5 utf8_1.2.2
[49] munsell_0.5.0 RCurl_1.98-1.6 cachem_1.0.6 crayon_1.5.0
I'm not entirely clear what you are trying to do, and your reprex contained many small errors (most notably the incorrect definition of the return value from the upload server function and confusion between a reactive function (myReactive) and its current value (myReactive()), but this is my best guess at what you want.
On the Step 3 tab:
The left hand box ("Current dataframe for_use_prev() is using") updates depending on whether the "If checked ..." chekbox is checked or not
The right hand box is initially empty
The right hand box displays the same data as the left hand box when the "use file from previous step" button is clicked and updates in response to checking and unchecking the "If checked..." checkbox
The right hand box displays different data to the right hand box once the "Load CSV" button is clicked after loading a third scv file in the "CSV file" fileInput.
The right hand checkbox is empty after the "remove file upload" button is checked.
I believe all I have done is implement the changes I indicated were necessary in my original comment.
library(shiny)
library(shinydashboard)
# Define the module
# Module UI function
loadFileUI <- function(id) {
# `NS(id)` returns a namespace function, which was save as `ns` and will
# invoke later.
ns <- NS(id)
tagList(
actionButton(ns("file_from_prev"),"Use file from previous step"),
h5("Or upload a saved file:"),
fileInput(ns("file_rds"), "RDS file",accept=".rds"),
fileInput(ns("file_csv"),"CSV File",accept=".csv"),
actionButton(ns("file_load_rds"),"Load RDS"),
actionButton(ns("file_load_csv"),"Load CSV"),
actionButton(ns("file_clear"),"Remove file upload")
)
}
# Module server function
loadFileServer <- function(id, prev_file) {
moduleServer(
id,
## Below is the module function
function(input, output, session) {
# initiate reactive values object to store what type of upload you want, or to clear your upload
upload_file <- reactiveValues(state=NULL)
observeEvent(input$file_from_prev,{ # take file from previous step
upload_file$state <- "prev"
})
observeEvent(input$file_load_rds,{ # load file from rds
upload_file$state <- "rds"
})
observeEvent(input$file_load_csv,{ # load file from csv
upload_file$state <- "csv"
})
observeEvent(input$file_clear,{ # clear file
upload_file$state <- "clear"
})
# actually upload the file (source depends on setting of upload_file$state as set above)
file_full <- reactive(
if(upload_file$state=="prev"){
prev_file()
} else if(upload_file$state=="rds" & !is.null(input$file_rds)){
readRDS(input$file_rds$datapath)
} else if(upload_file$state=="csv" & !is.null(input$file_csv)){
read.csv(input$file_csv$datapath)
} else if(upload_file$state=="clear"){
NULL
}
)
rv <- reactive({
req(input$file_from_prev)
list(df=file_full(), status=upload_file$state)
})
# Return the reactive that yields the data frame
return(rv)
}
)
}
# Set up the app
ui <- dashboardPage(
dashboardHeader(
title = "Reactive module input"
),
dashboardSidebar(
sidebarMenu(
menuItem("Step 1",tabName = "upload1"),
menuItem("Step 2",tabName = "upload2"),
menuItem("Step 3",tabName = "upload3")
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "upload1",
fileInput("file_up1",label = "Upload file",accept = ".csv"),
tableOutput("input1_preview")
),
tabItem(
tabName = "upload2",
fileInput("file_up2",label = "Upload file",accept = ".csv"),
tableOutput("input2_preview")
),
tabItem(
tabName = "upload3",
fluidRow(
column(width = 6,
box(width = NULL,
checkboxInput("which_prev_input","If checked, use input 1 as previous, otherwise input 2",value=T),
loadFileUI("step3_input")
)
)
),
fluidRow(
column(width = 6,
box(width = NULL,
title = "Current dataframe for_use_prev() is using",
tableOutput("prev_df_preview")
)
),
column(width = 6,
box(width = NULL,
title = "Dataframe being uploaded by the module",
tableOutput("step3_preview")
)
)
)
)
)
)
)
server <- function(input, output) {
# First file upload
upload1 <- reactive({
req (input$file_up1)
read.csv(input$file_up1$datapath)
})
output$input1_preview <- renderTable(upload1())
# Second file upload
upload2 <- reactive({
req (input$file_up2)
read.csv(input$file_up2$datapath)
})
output$input2_preview <- renderTable(upload2())
# Choose whether to use the first or second file
for_use_prev <- reactive({
if(input$which_prev_input){
upload1()
} else{
upload2()
}
})
# Call file upload module to give the possibility to upload a CSV, RDS, or use a previously uploaded file
upload_step3_raw <- loadFileServer("step3_input", prev_file=for_use_prev) # the call to for_use_prev doesn't update
upload_step3_df <- reactive({ upload_step3_raw()$df })
# Preview the DF chosen to be the previous dataframe (for_use_prev)
output$prev_df_preview <- renderTable(head(for_use_prev()))
# Preview the uploaded dataframe
output$step3_preview <- renderTable({
req(upload_step3_df())
head(upload_step3_df())
})
}
shinyApp(ui, server)
You may very well have to change the module because the way you defined its return value was, I believe, fundamentally incorrect because the original definition did not allow other parts of the app to respond reactively.
One way of avoiding this situation arising in the future is to thoroughly test that the way the module is behaving is correct before beginning to use it in many different places within your app.
Welcome to SO.
In this Shiny app, the user can upload a .csv file, get the results as a table and plot. I want to be able to download the results as PDF document.
Input file
#I created the input .csv file to be used in the app from diamonds data.frame
library(ggplot2)
df <- diamonds[1:5000, ]
head(df)
write.csv(df, "df.csv")
App
library(tidyverse)
library(shiny)
library(rmarkdown)
library(knitr)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(fileInput("file","Upload your file"),
width =2),
mainPanel(
width = 10,
downloadButton("report", "Download report"),
tableOutput("table"),
tags$br(),
tags$hr(),
plotOutput("plot1"),
tags$br(),
tags$hr(),
plotOutput("plot2")
)
)
)
server <- function(input,output){
data <- reactive({
file1 <- input$file
if(is.null(file1)){return()}
read.csv(file1$datapath, header=TRUE, sep=',')
})
output$table <- renderTable({
if (is.null(data())) { return() }
df <- data() %>%
dplyr::select(cut, color, price) %>%
dplyr::group_by(cut, color) %>%
dplyr::summarise_all(funs(min(.), mean(.), median(.),max(.),sd(.), n() ))
})
table_rmd <- reactive({
df <- data() %>%
dplyr::select(cut, color, price) %>%
dplyr::group_by(cut, color) %>%
dplyr::summarise_all(funs(min(.), mean(.), median(.),max(.),sd(.), n() ))
})
output$plot1 <- renderPlot({
if (is.null(data())) { return() }
ggplot(data(), aes (x =carat, y = price, col = color))+
geom_point()+
facet_wrap(~cut)
}
)
plot_rmd <- reactive({
chart <- ggplot(data(), aes (x =carat, y = price, col = color))+
geom_point()+
facet_wrap(~cut)
chart
}
)
#https://shiny.rstudio.com/articles/generating-reports.html
output$report <- downloadHandler(
filename = "report.pdf",
content = function(file) {
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = TRUE)
params <- list(table1 = table_rmd(),
plot1 = plot_rmd())
rmarkdown::render(tempReport, output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
}
shinyApp(ui=ui, server = server)
report.Rmd
---
title: "Dynamic report"
output: pdf_document
params:
table1: NA
plot1: NA
---
This is the firs plot
```{r}
params$plot1
```
This is the first table
```{r}
kable(params$table1)
```
I have tried different ways to pass the table and the plot from Shiny as params to R Markdown but none worked.
I will highly appreciate your suggestions to fix this.
Update
I have tried #BigDataScientist's answer and I got this error
"C:/Program Files/RStudio/bin/pandoc/pandoc" +RTS -K512m -RTS report.utf8.md --to latex --from markdown+autolink_bare_uris+ascii_identifiers+tex_math_single_backslash --output pandoc20e043232760.tex --template "C:\PROGRA~1\R\R-35~1.2\library\RMARKD~1\rmd\latex\DEFAUL~3.TEX" --highlight-style tango --pdf-engine pdflatex --variable graphics=yes --variable "geometry:margin=1in" --variable "compact-title:yes"
Warning: Error in : Failed to compile C:\Users\user\AppData\Local\Temp\RtmpYvWn8M\file20e042326267.tex. See https://yihui.name/tinytex/r/#debugging for debugging tips.
[No stack trace available]
Here is the sessionInfo()
> sessionInfo()
R version 3.5.2 (2018-12-20)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 7 x64 (build 7601) Service Pack 1
Matrix products: default
locale:
[1] LC_COLLATE=English_New Zealand.1252 LC_CTYPE=English_New Zealand.1252 LC_MONETARY=English_New Zealand.1252 LC_NUMERIC=C
[5] LC_TIME=English_New Zealand.1252
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] bindrcpp_0.2.2 forcats_0.3.0 stringr_1.4.0 dplyr_0.7.8 purrr_0.2.5 readr_1.3.1 tidyr_0.8.2 tibble_2.0.1 tidyverse_1.2.1 ggplot2_3.1.0
[11] shiny_1.2.0
loaded via a namespace (and not attached):
[1] tinytex_0.15.2 tidyselect_0.2.5 xfun_0.9 haven_2.0.0 lattice_0.20-38 colorspace_1.4-0 generics_0.0.2 htmltools_0.3.6 yaml_2.2.0
[10] utf8_1.1.4 rlang_0.4.0 later_0.8.0 pillar_1.3.1 glue_1.3.0 withr_2.1.2 readxl_1.2.0 modelr_0.1.2 bindr_0.1.1
[19] plyr_1.8.4 cellranger_1.1.0 munsell_0.5.0 gtable_0.2.0 rvest_0.3.2 evaluate_0.12 labeling_0.3 knitr_1.21 httpuv_1.4.5.1
[28] fansi_0.4.0 broom_0.5.1 Rcpp_1.0.0 xtable_1.8-3 promises_1.0.1 scales_1.0.0 backports_1.1.3 jsonlite_1.6 mime_0.6
[37] hms_0.4.2 digest_0.6.18 stringi_1.2.4 grid_3.5.2 cli_1.0.1 tools_3.5.2 magrittr_1.5 lazyeval_0.2.1 crayon_1.3.4
[46] pkgconfig_2.0.2 xml2_1.2.0 rsconnect_0.8.13 lubridate_1.7.4 assertthat_0.2.0 rmarkdown_1.11 httr_1.4.0 rstudioapi_0.9.0 R6_2.3.0
[55] nlme_3.1-137 compiler_3.5.2
You can pass an R object as part of the params list to a parametrized Rmd. Here is an example in a regular interactive session (no Shiny). report.Rmd is the same as in the question. df and pl are generated by some R script and are available in your environment. Then you can wrap them in list and pass them as params to render.
library(rmarkdown)
library(ggplot2)
df <- head(iris)
pl <- ggplot(iris, aes(x = Sepal.Width)) + geom_histogram(color = "white")
render(
input = "report.Rmd",
params = list("table1" = df, "plot1" = pl),
output_file = "rendered-from-session.pdf"
)
Screen shot of rendered-from-session.pdf
Whether this is a good strategy is another question. If the code making the tables and plots is the same for the app and Rmd, then it is better to have that in a separate script sourced both by the app and Rmd. That way you only need to edit one document when you want to change table/plot code. In this case, you would pass the arguments to plotting functions rather than the plots themselves. The downside of this is if you have many different plots that require many different parameters to keep track of. Or if the calculations / plotting takes long, so you don't want to do it twice.
Coming back to your Shiny app. In fact, your app code works for me as is through Shiny as well. I can make the pdf (even though table_rmd() reactive is not explicitly returning df). So it most likely is an issue with pandoc or latex not figuring out where the temporary file/folder is. Since you are still testing, I would try to save to a known location rather than a tempdir to see if this isn't some kind of permissions issue.
You could modify your handler like so. Remove the calls to tempdir and give the full path to report.Rmd to render. You could also try to give a full path for output_file. The first case should work just fine. In the second case ("PATH/TO/OUTPUT" instead of file passed to output_file), the browser might give you a download error, but the pdf should still render in the background with the file name you provided.
output$report <- downloadHandler(
filename = "report.pdf",
content = function(file) {
# tempReport <- file.path(tempdir(), "report.Rmd")
# file.copy("report.Rmd", tempReport, overwrite = TRUE)
params <- list(table1 = table_rmd(),
plot1 = plot_rmd())
rmarkdown::render(input = "PATH/TO/report.Rmd",
output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
This might at least confirm that your code is working, except for the tempdir() stuff. If you have an option, try your app on a linux machine or a mac.
Not sure if you can pass table and plots as parameters in/to rmarkdown. (Please also consider teofil´s answer here).
All standard R types that can be parsed by yaml::yaml.load() can be
included as parameters, including character, numeric, integer, and
logical types.
Source: https://bookdown.org/yihui/rmarkdown/params-declare.html
So you have two options.
Pass the relevant data as a parameter and include the code to produce the plot/table in the markdown template (here: report.Rmd).
if, for some reason, one would insist on defining the code for the plot/table on the shiny side you could send this code as a character and use eval(parse(text = params$...)) to evaluate it on rmarkdown side.
I could imagine you dont want to specify the code for plot/table twice in shiny + rmarkdown, but i guess you would have to choose between both options and the first one is probably cleaner.
(But feel free to leave the question open in case someone else has another idea).
Reproducbile example: (including an example for both options - on the basis of your code)
report.Rmd
---
title: "Dynamic report"
output: pdf_document
params:
plotData: NA
tableData: NA
plotCode: NA
---
```{r}
params$tableData
```
```{r}
eval(parse(text = params$plotCode))
```
```{r}
library(ggplot2)
ggplot(params$plotData, aes (x = carat, y = price, col = color)) +
geom_point() +
facet_wrap(~cut)
```
app.R
library(shiny)
library(ggplot2)
df <- diamonds[1:5000, ]
head(df)
write.csv(df, "df.csv")
#setwd("....") #be sure to be in same directory
shinyApp(
ui = fluidPage(
sliderInput(inputId = "slider", label = "Slider", min = 1, max = 100, value = 50),
fileInput(inputId = "file", label = "Upload your file"),
downloadButton(outputId = "report", label = "Generate report")
),
server = function(input, output) {
data <- reactive({
file1 <- input$file
if(is.null(file1)){return()}
read.csv(file1$datapath, header = TRUE, sep = ',')
})
table_rmd <- reactive({
data() %>%
dplyr::select(cut, color, price) %>%
dplyr::group_by(cut, color) %>%
dplyr::summarise_all(funs(min(.), mean(.), median(.),max(.),sd(.), n() ))
})
output$report <- downloadHandler(
filename = "report.pdf",
content = function(file) {
tempReport <- file.path(tempdir(), "report.Rmd")
file.copy("report.Rmd", tempReport, overwrite = TRUE)
params <- list(plotData = data(), tableData = table_rmd(), plotCode = "plot(1)")
rmarkdown::render(tempReport, output_file = file,
params = params,
envir = new.env(parent = globalenv())
)
}
)
}
)
I am generating a cross table output (contingency table). My requirement is to have column percentages along with row and column totals. I found this package "sjPlot" which gives very good output with colour features and was meeting my requirement. I used this package to generate the output in Shiny. But to my surprise the output is getting generated only in the viewer pane and not in the app. Below is a small part of my code.
library("shiny")
library("sjPlot")
ui <- shinyUI(fluidPage(
tabPanel("First Page"),
mainPanel(tabsetPanel(id='mytabs',
tabPanel("Table",tags$b(tags$br("Table Summary" )),tags$br(),dataTableOutput("crosstab2"))
)
)
))
server <- shinyServer(function(input, output,session){
updateTabsetPanel(session = session
,inputId = 'myTabs')
output$crosstab2 <- renderDataTable({
with(mtcars,sjt.xtab(mpg, cyl,
var.labels = c("mpg","cyl"),
show.col.prc = T,
show.summary = F,
show.na = F,
wrap.labels = 50,
tdcol.col = "#f90477",
emph.total = T,
emph.color = "#3aaee0",
#use.viewer = T ##when this is false it generates a html output. Can we capture the html output and display in Shiny?
CSS = list(css.table = "border: 1px solid;",
css.tdata = "border: 1px solid;")))
})
print("created crosstab1")
})
shinyApp(ui = ui, server = server)
This generates the needed output in viewer pane. How can I get this output displayed in the app. I can not save this output as a image as in my actual program the variables are getting selected dynamically and the table output accordingly changes.
sjt.xtabinvisibly returns a list that contains the html and css used to generate the table that you see in the viewer.
You can use htmlOutput on the ui side and renderUI on the server side to display it.
In your ui.R, you can use:
htmlOutput("crosstab2")
In your server.R:
output$crosstab2 <- renderUI({
custom_table <- sjt.xtab(mtcars$mpg, mtcars$cyl,variableLabels = c("mpg","cyl"),showColPerc = T,
showSummary = F,showNA=F,highlightTotal = T,tdcol.col = "#f90477", highlightColor ="#3aaee0",
CSS = list(css.table = "border: 1px solid;",
css.tdata = "border: 1px solid;"))
HTML(custom_table$knitr)
})
Here's (part of) my sessionInfo()
R version 3.1.2 (2014-10-31)
Platform: x86_64-apple-darwin13.4.0 (64-bit)
locale:
[1] en_GB.UTF-8/en_GB.UTF-8/en_GB.UTF-8/C/en_GB.UTF-8/en_GB.UTF-8
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] sjPlot_1.9.2 shiny_0.13.1
I suspect we don't have the same version of sjPlot as the arguments of the sjt.xtab you use in your example have changed names.
When I create a sankey diagram in a regular R session the output looks ok. The tooltip shows an arrow between the connections:
require(rCharts)
require(rjson)
links <- matrix(unlist(
rjson::fromJSON(
file = "http://bost.ocks.org/mike/sankey/energy.json"
)$links
),ncol = 3, byrow = TRUE)
nodes <- unlist(
rjson::fromJSON(
file = "http://bost.ocks.org/mike/sankey/energy.json"
)$nodes
)
links <- data.frame(links)
colnames(links) <- c("source", "target", "value")
links$source <- sapply(links$source, FUN = function(x) {return(as.character(nodes[x+1]))}) #x+1 since js starts at 0
links$target <- sapply(links$target, FUN = function(x) {return(nodes[x+1])}) #x+1 since js starts at 0
sankeyPlot <- rCharts$new()
sankeyPlot$setLib('http://timelyportfolio.github.io/rCharts_d3_sankey')
sankeyPlot$set(
data = links,
nodeWidth = 15,
nodePadding = 10,
layout = 32,
width = 960,
height = 500,
units = "TWh",
title = "Sankey Diagram"
)
sankeyPlot
When I create it in shiny, the arrow in the tooltip is replaced by unusual characters. Also below the plot an unusual character is printed. I needed to download the d3_sankey library to make the shiny app version work, so if you want to reproduce it you have to change the path in the setLib statement. How can this be fixed?
require(shiny)
runApp(list(
ui = pageWithSidebar(
headerPanel('Test'),
sidebarPanel( 'Test' ),
mainPanel(
chartOutput("Plot", 'C:/R-3.0.1/library/rCharts/libraries/sankey')
)
),
server = function(input, output, session){
output$Plot <- renderChart2({
sankeyPlot2 <- rCharts$new()
sankeyPlot2$setLib('C:/R-3.0.1/library/rCharts/libraries/sankey')
sankeyPlot2$set(
data = links,
nodeWidth = 15,
nodePadding = 10,
layout = 32,
width = 960,
height = 500,
units = "TWh",
title = "Sankey Diagram"
)
return(sankeyPlot2)
})
}
))
> sessionInfo()
R version 3.0.2 (2013-09-25)
Platform: x86_64-w64-mingw32/x64 (64-bit)
locale:
[1] LC_COLLATE=Dutch_Belgium.1252 LC_CTYPE=Dutch_Belgium.1252
[3] LC_MONETARY=Dutch_Belgium.1252 LC_NUMERIC=C
[5] LC_TIME=Dutch_Belgium.1252
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] shiny_0.8.0.99 rjson_0.2.13 rCharts_0.4.2
loaded via a namespace (and not attached):
[1] bitops_1.0-6 caTools_1.16 digest_0.6.4 grid_3.0.2
[5] httpuv_1.2.1 lattice_0.20-23 plyr_1.8 Rcpp_0.10.6
[9] RCurl_1.95-4.1 RJSONIO_1.0-3 tools_3.0.2 whisker_0.3-2
[13] xtable_1.7-1 yaml_2.1.10
The problem is related to character encoding in multiple files. This is how I resolved the issues on my Windows 7 machine.
Mouseover tooltip issue
An arrow character is used to construct the "link" between source and target. It occurs in these files:
example_build_network_sankey.html
layouts\chart.html
layouts\chart_static_title.html
layouts\chart.html
Replace the arrow with the ASCii characters ->
so the code looks like:
.text(function (d) { return d.source.name + " -> " + d.target.name + "\n" + format(d.value); });
Characters below the chart
 is found in:
\libraries\highlighters\prettify\css\sunburst.css
\layouts\chart.html
\libraries\widgets\d3_sankey\layouts\chart.html
I used the Search and Replace in Files facility in UltraEdit to replace this special character with a blank space. This one is tricky because I could not see the character in the UE editor. If I highlighted the blank space it appears as a backtick. The character is also found in jquery-1.8.2.min.js.