#r #shiny
#r #блестящий
Вопрос:
У меня есть блестящая панель инструментов ниже, в которой, если я укажу имя, отличное от значения по умолчанию consent.name , затем нажмите Continue и будет перемещен в TabItem Password , в котором я даю пароль makis и нажимаю кнопку Get started actionbutton на вкладке Welcome or Run Project , генерируется вывод rmd. Затем пользователь может нажать 'Generate report' , чтобы загрузить это в формате pdf. По сути, я хочу отображать 'Generate report' downloadButton() только тогда, когда отчет создается и отображается в теле, потому что в противном случае он не имеет смысла и сбивает с толку. Я попытался применить observeEvent() метод, который я также использовал для создания отчета, но он не работает, и downloadButton() он всегда есть.
пример 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)
и приложение
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(knitr)
mytitle <- paste0("Life, Death amp; 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" amp; 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())
)
}
)
})
}
)
)
Ответ №1:
Один из способов сделать это — использовать renderUI на стороне сервера для отображения downloadButton . Затем вы можете использовать условие, при котором вы хотите отобразить кнопку создания отчета. Вам нужно downloadButton заменить uiOutput("downloadbtn") на ui . Попробуйте это на сервере.
output$downloadbtn <- renderUI({
if (input$pwd=="makis" amp; 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)
}
}
})
Комментарии:
1. и как это связано с downloadhandler()?
2. Я отредактировал на основе вашего метода, но я не думаю, что кнопка работает сейчас.
3. Пожалуйста, измените условие в инструкции
if (input$pwd=="makis" amp; input$button>0 ) {...на условие, при котором вы хотели бы, чтобы кнопка загрузки отображалась.4. но почему, когда я нажимаю кнопку загрузки, она больше не загружается, независимо от того, когда отображается кнопка?
5. Извините, я не проверял downloadhandler, поскольку я не очень хорошо знаком с Rmarkdown. Это работало раньше? Пожалуйста, обратите внимание, что мой ответ предназначался только для отображения кнопки загрузки при определенных условиях.