Enr*_*eGG 7 r r-markdown shiny
我有一个功能齐全的闪亮的，由四个不同的模块构成，在第一个模块中，我们上传我们拥有的数据集，在第二个和第三个模块中，我们可以基于第一个模块进行绘图，在第四个模块中，我们应该能够生成连接到 rmd 的报告。文件。但是我想从中渲染 HTML 或 PDF 报告，如何才能完成？在普通的闪亮中，我们将绘图的反应函数放入“report.Rmd”文件中，它将呈现报告。然而，对于模块来说并不是那么容易，为了基于多个模块生成报告，有什么解决方案吗？提前致谢！
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 文件
r input$title” 作者：“ r input$author” 输出：pdf_documentknitr::opts_chunk$set(echo = TRUE)
library(ggplot2)
library(shiny)
library(rmarkdown)
library(knitr)
graph_2()
graph()
我想出了解决办法。现在所有模块和 rmd 都可以通信。用于呈现报告的文件。花了一些时间。
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)
rmd。文件
---
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)
graph_2()
params$plot_1
graph()
params$plot_2