EnriqueGG
EnriqueGG

Reputation: 189

communication for ShinyModules for generating Rmarkdown report

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()

Upvotes: 7

Views: 384

Answers (1)

EnriqueGG
EnriqueGG

Reputation: 189

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

Upvotes: 4

Related Questions