Download shiny report (from renderDataTables and plots) to pdf

shiny
, ,
1

So, I have a code that deploys 3 tabs and different data tables and a plot. I want to see if it's possible to create a report in PDF that downloads all information for a given date.

Here is the code:


rm(list = ls())
# setwd("C:/Users/mb84498/Documents/Trabajo/Riesgo mercado y estructurales/Estructurales/Dashboard")

#if(!require('DT', lib.loc=dir2)){install.packages('DT')}

require(DT)
require(shiny)
require(pixiedust)
require(dplyr)
require(ggplot2)
require(formattable)
require(shinydashboard)
require(gcookbook)


#setwd(dir)

dat = read.table(file="./Data/historico_metricas_rie.csv",header=T,sep=",",dec=".", fileEncoding="latin1")
des_bca = read.table(file="./Data/desglose_bancas.csv",header=T,sep=",",dec=".", fileEncoding="latin1")
datos_core_int = read.table(file= "./Data/tabla_core_limits_int.csv", header=T, sep=",", dec=".", fileEncoding = "latin1")
datos_core_liq = read.table(file= "./Data/tabla_core_limits_liq.csv", header=T, sep=",", dec=".", fileEncoding = "latin1")

fechas = as.Date(as.character(dat[,1]),"%m/%d/%Y"); fechas2 = unique(fechas)
n = length(fechas2)
nom_met = as.character(dat[,2])
val_met = dat[,3]
val_rel = dat[,4]
por_uso = dat[,5]
niv_ale = dat[,6]

fec_des = as.Date(as.character(des_bca[,1]),"%m/%d/%Y")
des_bca$Fecha = fec_des
cre_des = as.character(des_bca[,2])
des_bca$Banca = cre_des

fechas_core_int = as.Date(as.character(datos_core_int[,1]),"%d/%m/%Y"); fechas_core_int2 = unique(fechas_core_int)
n_int = length(fechas_core_int)
nom_met_int = as.character(datos_core_int[,2])
val_met_int = datos_core_int[,3]
val_rel_int = datos_core_int[,4]
por_uso_int = datos_core_int[,5]
core_limit_int = datos_core_int[,6]

fechas_core_liq = as.Date(as.character(datos_core_liq[,1]),"%d/%m/%Y"); fechas_core_liq2 = unique(fechas_core_liq)
n_liq = length(fechas_core_liq)
nom_met_liq = as.character(datos_core_liq[,2])
val_met_liq = datos_core_liq[,3]
val_rel_liq = datos_core_liq[,4]
por_uso_liq = datos_core_liq[,5]
core_limit_liq = datos_core_liq[,6]


options(pixiedust_print_method = "html", encoding = "UTF-8")


header <- dashboardHeader(title = "REyL")
sidebar <- dashboardSidebar(uiOutput("sidebarpanel"), disable = T)
body <- dashboardBody(uiOutput("body"))
ui <- dashboardPage(header, sidebar, body)
#ui <- dashboardPage(header, body)

login_details <- data.frame(user = c("Sigrid", "sam", "ron"),
                            pswd = c("123456", "123", "122"))
login <- box(
  title = "Login",
  textInput("userName", "Username"),
  passwordInput("passwd", "Password"),
  br(),
  actionButton("Login", "Log in")
)

server <- function(input, output, session) {
  # To logout back to login page
  login.page = paste(
    isolate(session$clientData$url_protocol),
    "//",
    isolate(session$clientData$url_hostname),
    ":",
    isolate(session$clientData$url_port),
    sep = ""
  )
  histdata <- rnorm(500)
  USER <- reactiveValues(Logged = F)
  observe({
    if (USER$Logged == FALSE) {
      if (!is.null(input$Login)) {
        if (input$Login > 0) {
          Username <- isolate(input$userName)
          Password <- isolate(input$passwd)
          Id.username <- which(login_details$user %in% Username)
          Id.password <- which(login_details$pswd %in% Password)
          if (length(Id.username) > 0 & length(Id.password) > 0){
            if (Id.username == Id.password) {
              USER$Logged <- TRUE
            }
          }
        }
      }
    }
  })
  
  ##########################################################
  
  # Tabla core limits interés estructural
    
  output$tableint<- renderDataTable({
    
    fe = input$f33
    
    sketch = htmltools::withTags(table(
      class = 'display',
      thead(
        tr(
          th(class = 'dt-center', rowspan = 2, 'Core limits intéres estructural'),
          th(class = 'dt-center',colspan = 3, 'Sepal'),
          th(class = 'dt-center',colspan = 3, 'Petal')
        ),
        tr(
          lapply(c("Fecha","","Valor Métrica","Métrica relativa", "% Uso", "Core Limit"), th)
        )
      )
    ))
    
    df <- data.frame(met = nom_met_int[fechas_core_int==fe],
                     fec = format(fe,"%d %b %y"),
                     cond = c("90%","-100 pb"),
                     val  = sprintf("$ %.2f", datos_core_int[fechas_core_int==fe,3]),
                     rel  = sprintf("%.1f %%", datos_core_int[fechas_core_int==fe,4]*100),
                     uso  = sprintf("%.1f %%", datos_core_int[fechas_core_int==fe,5]*100), 
                     limite  = datos_core_int[fechas_core_int==fe,6])
    
    datatable(df, rownames = FALSE, container = sketch,
              options = list(dom='t',initComplete = JS(
                "function(settings, json) {",
                "$('body').css({'font-family': 'Calibri'});",
                "$(this.api().table().header()).css({'background-color': 'rgb(0,68,129)', 'color': 'rgb(256,256,256)'});",
                "}"), ordering = F, autoWidth = T, scrollX = TRUE,
                columnDefs = list(list(width = '150px', targets = c(0)),
                                  list(width = '50px', targets = c(1)),
                                  list(width = '50px', targets = c(2)),
                                  list(width = '50px', targets = c(3)),
                                  list(width = '2px', targets = c(4)),
                                  list(width = '20px', targets = c(5)),
                                  list(width = '20px', targets = c(6))) 
              ),  class = 'cell-border stripe') %>%
      formatStyle(columns = "cond", target = 'row',
                  background = styleEqual(c("90%","99%"), c("rgb(234,234,234)", "rgb(234,234,234)"))) %>%
      formatStyle(columns = "limite", 
                  background = styleEqual(c("5.4%", 16300), c("rgb(216,190,117)", "rgb(216,190,117)")))
    #formatStyle(columns = "alerta", target = 'row',
    #            background = styleEqual(c("5.4%", 16300), c("rgb(253,189,44)", "lightblue")))
    
  })
  
  #######################################
  
  # Tabla core limits liquidez
  
  output$tableliq<- renderDataTable({
    
    fe = input$f33
    
    sketch = htmltools::withTags(table(
      class = 'display',
      thead(
        tr(
          th(class = 'dt-center', rowspan = 2, 'Core limits liquidez'),
          th(class = 'dt-center',colspan = 3, 'Sepal'),
          th(class = 'dt-center',colspan = 3, 'Petal')
        ),
        tr(
          lapply(c("Fecha","","Valor Métrica","Métrica relativa", "% Uso", "Core Limit"), th)
        )
      )
    ))
    
    df <- data.frame(met = nom_met_liq[fechas_core_liq==fe],
                     fec = format(fe,"%d %b %y"),
                     cond = c("90%","-100 pb", "1", "90%","-100 pb"),
                     val  = sprintf("$ %.2f", datos_core_liq[fechas_core_liq==fe,3]),
                     rel  = sprintf("%.1f %%", datos_core_liq[fechas_core_liq==fe,4]*100),
                     uso  = sprintf("%.1f %%", datos_core_liq[fechas_core_liq==fe,5]*100), 
                     limite  = datos_core_liq[fechas_core_liq==fe,6])
    
    datatable(df, rownames = FALSE, container = sketch,
              options = list(dom='t',initComplete = JS(
                "function(settings, json) {",
                "$('body').css({'font-family': 'Calibri'});",
                "$(this.api().table().header()).css({'background-color': 'rgb(0,68,129)', 'color': 'rgb(256,256,256)'});",
                "}"), ordering = F, autoWidth = T, scrollX = TRUE,
                columnDefs = list(list(width = '150px', targets = c(0)),
                                  list(width = '50px', targets = c(1)),
                                  list(width = '50px', targets = c(2)),
                                  list(width = '50px', targets = c(3)),
                                  list(width = '2px', targets = c(4)),
                                  list(width = '20px', targets = c(5)),
                                  list(width = '20px', targets = c(6))) 
              ),  class = 'cell-border stripe') %>%
      formatStyle(columns = "cond", target = 'row',
                  background = styleEqual(c("90%","99%"), c("rgb(234,234,234)", "rgb(234,234,234)"))) %>%
      formatStyle(columns = "limite", 
                  background = styleEqual(c("5.4%", 16300), c("rgb(216,190,117)", "rgb(216,190,117)")))
    #formatStyle(columns = "alerta", target = 'row',
    #            background = styleEqual(c("5.4%", 16300), c("rgb(253,189,44)", "lightblue")))
    
  })
  
  
  
  output$table1<- renderDataTable({
    
    fe = input$f33
    
    sketch = htmltools::withTags(table(
      class = 'display',
      thead(
        tr(
          th(class = 'dt-center', rowspan = 2, 'Métricas Balance Estructural'),
          th(class = 'dt-center',colspan = 3, 'Sepal'),
          th(class = 'dt-center',colspan = 3, 'Petal')
        ),
        tr(
          lapply(c("Fecha","","Valor Métrica","Métrica relativa", "% Uso Alerta", "Alerta"), th)
        )
      )
    ))
    
    df <- data.frame(met = nom_met[fechas==fe],
                     fec = format(fe,"%d %b %y"),
                     cond = c("90%","-100 pb", "99%","-100 pb"),
                     val  = sprintf("$ %.2f", dat[fechas==fe,3]),
                     rel  = sprintf("%.1f %%", dat[fechas==fe,4]*100),
                     uso  = sprintf("%.1f %%", dat[fechas==fe,5]*100), 
                     alerta  = dat[fechas==fe,6])
    
    datatable(df, rownames = FALSE, container = sketch,
              options = list(dom='t',initComplete = JS(
                "function(settings, json) {",
                "$('body').css({'font-family': 'Calibri'});",
                "$(this.api().table().header()).css({'background-color': 'rgb(0,68,129)', 'color': 'rgb(256,256,256)'});",
                "}"), ordering = F, autoWidth = T, scrollX = TRUE,
                columnDefs = list(list(width = '150px', targets = c(0)),
                                  list(width = '50px', targets = c(1)),
                                  list(width = '50px', targets = c(2)),
                                  list(width = '50px', targets = c(3)),
                                  list(width = '2px', targets = c(4)),
                                  list(width = '20px', targets = c(5)),
                                  list(width = '20px', targets = c(6))) 
              ),  class = 'cell-border stripe') %>%
      formatStyle(columns = "cond", target = 'row',
                  background = styleEqual(c("90%","99%"), c("rgb(234,234,234)", "rgb(234,234,234)"))) %>%
      formatStyle(columns = "alerta", 
                  background = styleEqual(c("5.4%", 16300), c("rgb(216,190,117)", "rgb(216,190,117)")))
    #formatStyle(columns = "alerta", target = 'row',
    #            background = styleEqual(c("5.4%", 16300), c("rgb(253,189,44)", "lightblue")))
    
  })
  
  ###############################################################
  
  # Tabla de comparación
  
  output$table11<- renderDataTable({
    
    fe1 = input$fcom1
    fe2 = input$fcom2
    
    sketch = htmltools::withTags(table(
      class = 'display',
      thead(
        tr(
          th(class = 'dt-center', rowspan = 2, 'Métricas Balance Estructural'),
          th(class = 'dt-center',colspan = 1, 'Sepal'),
          th(class = 'dt-center',colspan = 2, 'Petal')
        ),
        tr(
          lapply(c("Valor Métrica", "% Uso Alerta", "Cambio"), th)
        )
      )
    ))
    
    df1 <- data.frame(met = nom_met[fechas==fe1],
                      val  = sprintf("$ %.2f", dat[fechas==fe1,3]),
                      uso  = sprintf("%.1f %%", dat[fechas==fe1,5]*100), 
                      alerta  = dat[fechas==fe1,6])
    
    df2 <- data.frame(met = nom_met[fechas==fe2],
                      val  = sprintf("$ %.2f", dat[fechas==fe2,3]),
                      uso  = sprintf("%.1f %%", dat[fechas==fe2,5]*100), 
                      alerta  = dat[fechas==fe2,6])
    
    df <- data.frame(met = nom_met[fechas==fe1],
                     val  = dat[fechas==fe2,3],
                     uso  = dat[fechas==fe2,5], 
                     cambio  = dat[fechas==fe1,3]-dat[fechas==fe2,3])
    #cambio  = sprintf("$ %.2f", dat[fechas==fe1,3]-dat[fechas==fe2,3]))
    
    datatable(df, rownames = FALSE, container = sketch,
              options = list(dom='t',initComplete = JS(
                "function(settings, json) {",
                "$('body').css({'font-family': 'Calibri'});",
                "$(this.api().table().header()).css({'background-color': 'rgb(0,68,129)', 'color': 'rgb(256,256,256)'});",
                "}"), ordering = F, autoWidth = T, scrollX = TRUE,
                columnDefs = list(list(width = '150px', targets = c(0)),
                                  list(width = '50px', targets = c(1)),
                                  list(width = '50px', targets = c(2)),
                                  list(width = '50px', targets = c(3)))
                
              ),  class = 'cell-border stripe') %>%
      #formatStyle(columns = "cambio", 
      #            background = styleEqual(c("5.4%", 16300), c("rgb(216,190,117)", "rgb(216,190,117)")))
      formatStyle(columns = "cambio", color = JS("value < 0 ? 'red' : value > 0 ? 'green' : 'blue'")) %>%
      formatCurrency(columns = "cambio", currency = '$', interval=3, mark=',',digits = 2) %>%
      formatCurrency(columns = "val", currency = '$', interval=3, mark=',',digits = 2) %>%
      formatPercentage(columns = "uso", digits = 2, interval = 3, mark = ",", 
                     dec.mark = getOption("OutDec"))
  })
  
  ###############################################################

  
  output$table3<- renderDataTable({
    
    fe = input$f1
    
    sketch = htmltools::withTags(table(
      class = 'display',
      thead(
        tr(
          th(class = 'dt-center', rowspan = 2, 'Métricas Balance Estructural'),
          th(class = 'dt-center',colspan = 3, 'Sepal'),
          th(class = 'dt-center',colspan = 3, 'Petal')
        ),
        tr(
          lapply(c("Fecha","","Valor Métrica","Métrica relativa", "% Uso Alerta", "Alerta"), th)
        )
      )
    ))
    
    df <- data.frame(met = nom_met[fechas==fe],
                     fec = format(fe,"%d %b %y"),
                     cond = c("90%","-100 pb", "99%","-100 pb"),
                     val  = sprintf("$ %.2f", dat[fechas==fe,3]),
                     rel  = sprintf("%.1f %%", dat[fechas==fe,4]*100),
                     uso  = sprintf("%.1f %%", dat[fechas==fe,5]*100), 
                     alerta  = dat[fechas==fe,6])
    
    datatable(df, rownames = FALSE, container = sketch,
              options = list(dom='t',initComplete = JS(
                "function(settings, json) {",
                "$('body').css({'font-family': 'Calibri'});",
                "$(this.api().table().header()).css({'background-color': 'rgb(0,68,129)', 'color': 'rgb(256,256,256)'});",
                "}"), ordering = F, autoWidth = T, scrollX = TRUE,
                columnDefs = list(list(width = '150px', targets = c(0)),
                                  list(width = '50px', targets = c(1)),
                                  list(width = '50px', targets = c(2)),
                                  list(width = '50px', targets = c(3)),
                                  list(width = '2px', targets = c(4)),
                                  list(width = '20px', targets = c(5)),
                                  list(width = '20px', targets = c(6))) 
              ),  class = 'cell-border stripe') %>%
      formatStyle(columns = "cond", target = 'row',
                  background = styleEqual(c("90%","99%"), c("rgb(234,234,234)", "rgb(234,234,234)"))) %>%
      formatStyle(columns = "alerta", 
                  background = styleEqual(c("5.4%", 16300), c("rgb(216,190,117)", "rgb(216,190,117)")))
    
    
  })
  
  output$plot1<-renderPlot({
    ap = ggplot(des_bca, aes(x=Fecha, y=SVE, fill=Banca)) + geom_area() 
    ap + scale_fill_manual(values=
                             c('#004481', '#2A86CA',
                               '#F7893B', '#48AE64','#F35E61'))})
  
  output$body <- renderUI({
    if (USER$Logged == TRUE) {
      ###############################################
      
      ## UI
      
      navbarPage("RIEyL",
                 tabPanel("Principal",
                          fluidPage(
                            
                            fluidRow(
                              h4("Fecha del informe: "),
                              dateInput("f33", "Date:", value = fechas2[n])
                            ),
                            
                            fluidRow(
                              column(6,
                                     br(),
                                     h4("Core limits int estructural"),
                                     DT::dataTableOutput("tableint", width='680px') 
                              ),
                              column(5, offset = 1,
                                     br()
                                     #formattableOutput("table2")
                              )
                            ),
                            
                            fluidRow(
                              column(6, 
                                     br(),
                                     h4("Core limits liq"),
                                     DT::dataTableOutput("tableliq", width='680px'),
                                     br()
                              )
                            )
                          )
                 ),
                 tabPanel("Riesgo de Interés Estructural",
                          fluidPage(
                            
                            fluidRow(
                              h4("Fecha del informe: "),
                              dateInput("f33", "Date:", value = fechas2[n])
                            ),
                            
                            fluidRow(
                              column(6,
                                     br(),
                                     DT::dataTableOutput("table1", width='680px') 
                              ),
                              column(5, offset = 1,
                                     br()
                                     #formattableOutput("table2")
                              )
                            ),
                            
                            fluidRow(
                              column(6, br(),
                                     h4("Comparativo"),
                                     DT::dataTableOutput("table11", width='500px'),
                                     br()
                              ),
                              column(1),
                              column(4, offset = 1, br(), br(),
                                     #selectInput('fecha', 'Fecha', fechas, fechas[length(fechas)])
                                     dateInput("fcom1", "Date:", value = fechas2[n-1]),
                                     dateInput("fcom2", "Date:", value = fechas2[n]),
                                     selectInput(inputId = 'tabla', label = 'Tabla', choices =  c('DF1','DF2' ))
                              )
                            )
                          )
                 ),
                 tabPanel("Riesgo de Liquidez",
                          fluidRow(
                            column(6,
                                   br(),
                                   h4("Diamonds Explorer"),
                                   DT::dataTableOutput("table3", width='680px')
                            ),
                            column(4, offset = 1,
                                   br(),
                                   dateInput("f1", "Date:", value = fechas2[n]),
                                   #selectInput('m1', 'Métrica', names(dataset), names(dataset)[[2]]),
                                   selectInput(inputId = 'ta1', label = 'Tabla', choices =  c('DF1','DF2' ))
                            )
                          ),
                          
                          fluidRow(
                            column(6, br(),
                                   h4("Riesgo por créditos por banca"),
                                   plotOutput("plot1", height = 250)
                            ),
                            column(4, br(),offset = 1,
                                   h4("Diamonds Explorer"),
                                   #sliderInput('sampleSize', 'Sample Size', 
                                   #            min=1, max=nrow(dataset), value=min(1000, nrow(dataset)), 
                                   #            step=500, round=0),
                                   br(),
                                   checkboxInput('jitter', 'Jitter'),
                                   checkboxInput('smooth', 'Smooth')
                            )
                          )
                 )
      )
      
      ####################################################
      
    } else {
      login
    }
  })
}


shinyApp(ui, server)
2

Just happened to see a few submissions to the shiny contest the other day that might serve as good models for you here:

1 Like
3

Great! Thanks @mara! Hopefully they are useful. Also, there is another submission that capture interactive htmlwidget from shiny and you can insert a comment box for your users using noteMD package!

1 Like
4

This topic was automatically closed 54 days after the last reply. New replies are no longer allowed.

If you have a query related to it or one of the replies, start a new topic and refer back with a link.