I have the shiny dashboard below in which if I give a name except of the default consent.name
, then press Continue
and will be moved in the tabItem Password
in which I give the password makis
and press the Get started
actionbutton in either Welcome
or Run Project
tab an rmd output is generated. Then the user can press 'Generate report'
in order to download this as pdf. Basically what I want to do is to display the 'Generate report' downloadButton()
only when the report is created and displayed in the body because otherwise it has no meaning and is confusing. I tried to applied the observeEvent()
method which I used for the report creation as well but it does not work and the downloadButton()
is always there.
the ex.rmd
---
title: "An example Knitr/R Markdown document"
output: pdf_document
---
{r chunk_name, include=FALSE}
x <- rnorm(100)
y <- 2*x + rnorm(100)
cor(x, y)
and the app
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(knitr)
mytitle <- paste0("Life, Death & Statins")
dbHeader <- dashboardHeaderPlus(
titleWidth = "0px",
tags$li(a(
div(style="display: inline;margin-top:-35px; padding: 0px 90px 0px 1250px ;font-size: 58px ;color: black;font-family:Times-New Roman;font-weight: bold; width: 500px;",HTML(mytitle)),
div(style="display: inline;margin-top:25px; padding: 0px 0px 0px 1250px;vertical-align:top; width: 150px;", actionButton("well", "Welcome")),
div(style="display: inline;padding: 0px 0px 0px 0px;vertical-align:top; width: 150px;", actionButton("conse", "Consent")),
div(style="display: inline;padding: 0px 0px 0px 0px;vertical-align:top; width: 150px;", actionButton("pswd", "Password")),
div(style="display: inline;padding: 0px 0px 0px 0px;vertical-align:top; width: 150px;", actionButton("rp", "Run Project")),
div(style="display: inline;padding: 0px 0px 0px 0px;vertical-align:top; width: 150px;", actionButton("res", "Results"))
),
class = "dropdown")
)
shinyApp(
ui = dashboardPagePlus(
header = dbHeader,
sidebar = dashboardSidebar(width = "0px",
sidebarMenu(id = "sidebar", # id important for updateTabItems
menuItem("Welcome", tabName = "well", icon = icon("house")),
menuItem("Consent", tabName = "conse", icon = icon("line-chart")),
menuItem("Password", tabName = "pswd", icon = icon("house")),
menuItem("Run Project", tabName = "rp", icon = icon("table")),
menuItem("Results", tabName = "res", icon = icon("line-chart"))
) ),
body = dashboardBody(
useShinyjs(),
tags$script(HTML("$('body').addClass('fixed');")),
tags$head(tags$style(".skin-blue .main-header .logo { padding: 0px;}")),
tabItems(
tabItem("well",
fluidRow(),
tags$hr(),
tags$hr(),
fluidRow(
column(5,),
column(6,
actionButton("button", "Get started",style='padding:4px; font-size:140%')))),
tabItem("conse",
tags$hr(),
fluidRow(column(3,textInput("name", label = ("Name"), value = "consent.name"))),
fluidRow(column(3,actionButton('continue', "Continue",style='padding:4px; font-size:180%')))
),
tabItem("pswd",
tags$hr(),
tags$hr(),
fluidRow(
column(5,),
column(6,passwordInput("pwd", "Enter the Database browser password")
)) ),
tabItem("rp"),
tabItem("res",
tags$hr(),
tags$hr(),
fluidRow(
column(3,
uiOutput("downloadbtn")
),
column(6,
uiOutput('markdown'))))
),
)
),
server<-shinyServer(function(input, output,session) {
hide(selector = "body > div > header > nav > a")
observeEvent(input$button,{
if (input$name=="consent.name"){
return(NULL)
}
else{
if(input$pwd=="makis"){
output$markdown <- renderUI({
HTML(markdown::markdownToHTML(knit('ex.rmd', quiet = TRUE)))
})
}
else{
return(NULL)
}
}
})
observeEvent(input$well, {
updateTabItems(session, "sidebar", "well")
})
observeEvent(input$conse, {
updateTabItems(session, "sidebar", "conse")
})
observeEvent(input$pswd, {
updateTabItems(session, "sidebar", "pswd")
})
observeEvent(input$rp, {
updateTabItems(session, "sidebar", "well")
})
observeEvent(input$res, {
updateTabItems(session, "sidebar", "res")
})
observeEvent(input$button, {
if (input$name=="consent.name") {
updateTabItems(session, "sidebar",
selected = "conse")
}
else{
if(input$pwd==""){
updateTabItems(session, "sidebar",
selected = "pswd")
}
else if(input$pwd=="makis"){
updateTabItems(session, "sidebar",
selected = "res")
}
else{
updateTabItems(session, "sidebar",
selected = "pswd")
}
}
})
observeEvent(input$continue, {
if (input$name=="consent.name") {
updateTabItems(session, "sidebar",
selected = "conse")
}
else{
if(input$pwd==""){
updateTabItems(session, "sidebar",
selected = "pswd")
}
else if(input$pwd=="makis"){
updateTabItems(session, "sidebar",
selected = "res")
}
else{
updateTabItems(session, "sidebar",
selected = "pswd")
}
}
})
output$downloadbtn <- renderUI({
if (input$pwd=="makis" & input$button>0 ) { ## condition under which you would like to display download button
downloadButton("report", "Generate report",style='padding:4px; font-size:180%')
}else{
return(NULL)
}
})
observeEvent(input$report,{
output$report <- downloadHandler(
# For PDF output, change this to "report.pdf"
filename = "report.pdf",
content = function(file) {
tempReport <- file.path(tempdir(), "ex.Rmd")
file.copy("ex.Rmd", tempReport, overwrite = TRUE)
rmarkdown::render(tempReport, output_file = file,
envir = new.env(parent = globalenv())
)
}
)
})
}
)
)
One way to do it is to use renderUI
on the server side to display the downloadButton
. Then you can use the condition under which you want to display the Generate Report button. You need to replace downloadButton
with uiOutput("downloadbtn")
in the ui
. Try this in the server.
output$downloadbtn <- renderUI({
if (input$pwd=="makis" & input$button>0 ) { ## condition under which you would like to display download button
div(style="display: block; padding: 5px 10px 15px 10px ;",
downloadButton("report",
HTML(" PDF"),
style = "fill",
color = "danger",
size = "lg",
block = TRUE,
no_outline = TRUE
) )
}else{
return(NULL)
}
})
observe({
if (input$name=="consent.name"){
return(NULL)
}
else{
if(input$pwd=="makis"){
output$report <- downloadHandler(
filename = "report.pdf",
content = function(file) {
src <- normalizePath('ex.Rmd')
# temporarily switch to the temp dir, in case you do not have write
# permission to the current working directory
owd <- setwd(tempdir())
on.exit(setwd(owd))
file.copy(src, 'ex.Rmd', overwrite = TRUE)
library(rmarkdown)
out <- render(input = 'ex.Rmd',
output_format = pdf_document(),
params = list(data = data)
)
file.rename(out, file)
}
)
}
else{
return(NULL)
}
}
})
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.