如何在 R Shiny App 中显示存储在列表中的数据表并格式化数据表

Question

我想输出存储在RShiny列表中的几个数据tables。该列表始终包含不同的数据 table，因此 RShiny 中的输出必须是动态的并呈现。在 server.R 中调用的我的函数称为 priceInfo <- function(){} 并生成数据列表 tables，其中数据 tables 以宽格式转换。

priceInfo() 函数如下所示：（注意：这只是一个示例，该函数有时 returns 不仅仅是包含两个数据 table 的列表）

priceInfo <- function(){
  
  set.seed(123)
  dt.data <- data.table(date = seq(as.Date('2020-01-01'), by = '1 day', length.out = 365),
                        'EEX DEB CAL-2021' = rnorm(365, 2, 1), 'PEGAS TTF CAL-2021' = rnorm(365, 2, 1),
                        check.names = FALSE)
  
  foo <- function(DT, colname){
    DT <- DT[, c("date", colname), with = FALSE]
    DT <- DT %>%
      mutate(month = format(date, '%b'), 
             date = format(date, '%d')) %>%
      tidyr::pivot_wider(names_from = date, values_from = colname) %>%
      relocate(`01`, .after = month)
    
    ## Calculate monthly and quarterly mean values: ##
    DT <- setDT(DT)[, monthAvg := rowMeans(.SD, na.rm = TRUE), .SDcols = -1]
    DT <- DT[, quartAvg := mean(monthAvg), ceiling(seq_len(nrow(DT))/3)]
    DT <- DT[, yearAvg := mean(monthAvg), ceiling(seq_len(nrow(DT))/12)]
    
    ## Round all values of the data table to 2 digits: ##
    DT <- DT %>% mutate_if(is.numeric, round, 2)
    
  }
  
  l.testList <- lapply(names(dt.data)[names(dt.data) != "date"], 
                       foo, DT = dt.data)
  setNames(l.testList, names(dt.data)[names(dt.data) != "date"])
  
  
  
}

我尝试了以下方法来显示列表的所有数据 tables：

服务器：

server <- function(input, output, session){
  tables <- priceInfo()$l.testList
  
  output$maPriceInformationTABLES <- renderUI({
  tableList <- imap(tables, ~ {
    tagList(
      h4(.y), # Note we can sprinkle in other UI elements
      tableOutput(outputId = paste0("table_", .y))
    )
  })
  tagList(tableList)
  })

  # Now render each output
  iwalk(tables, ~{
    output_name <- paste0("table_", .y)
    output[[output_name]] <- renderTable(.x)
  })
}
shinyApp(ui, server)

UI:

uiOutput(outputId = "maPriceInformationTABLES")

基本上，tables 的输出几乎符合我的要求。 但是： 我想使用 DT::renderDataTable({})，因为所有 table 都相对较宽并且从未完全显示（缺少 11 列）。

我必须进行哪些更改才能确保所有数据 table 都正确显示？

我也知道数据 table 最后应该是什么样子（这里只是单个 table 的示例）：

output$maPriceInformationTABLES<- DT::renderDataTable({

  DT::datatable(dt.tables, rownames = FALSE, escape = FALSE, class = 'cell-border stripe', # 'display cell-border stripe'
                options = list(pageLength = 10, autoWidth = TRUE, scrollX = TRUE,
                               columnDefs = list(list(className = 'dt-center', targets = c(0,1,2,3), width = '200px')),
                               initComplete = JS("function(settings, json) {",
                                                 "$(this.api().table().header()).css({'background-color': '#007d3c', 'color': '#fff'});",
                                                  "}")
                        )
          )
})

编辑：

将 tableOutput 更改为 DTOutput 并将 renderTable 更改为 renderDT 时，table 将如下所示：

table 再次显示不正确（缺少 11 列）。

我也想要数据tables如下（上面的代码已经是针对单个数据table）：

而且我不知道如何将此格式应用于所有数据 tables。

pageLength = 12不行，这里截图：

Answer 1

这就是我认为你想要的：

library(dplyr)
library(purrr)
library(data.table)
library(DT)
library(shiny)

priceInfo <- function(){
  set.seed(123)
  dt.data <- data.table(date = seq(as.Date('2020-01-01'), by = '1 day', length.out = 365),
                        'DEB Cal-2019' = rnorm(365, 2, 1), 'DEB Cal-2021' = rnorm(365, 2, 1),
                        'DEB Cal-2022' = rnorm(365, 2, 1), 'DEB Cal-2023' = rnorm(365, 2, 1),
                        'ATB Cal-2019' = rnorm(365, 2, 1), 'ATB Cal-2021' = rnorm(365, 2, 1),
                        'ATB Cal-2022' = rnorm(365, 2, 1), 'ATB Cal-2023' = rnorm(365, 2, 1),
                        'TTF Cal-2019' = rnorm(365, 2, 1), 'TTF Cal-2021' = rnorm(365, 2, 1),
                        'TTF Cal-2022' = rnorm(365, 2, 1), 'TTF Cal-2023' = rnorm(365, 2, 1),
                        'NCG Cal-2019' = rnorm(365, 2, 1), 'NCG Cal-2021' = rnorm(365, 2, 1),
                        'NCG Cal-2022' = rnorm(365, 2, 1), 'NCG Cal-2023' = rnorm(365, 2, 1),
                        'AUTVTP Cal-2019' = rnorm(365, 2, 1), 'AUTVTP Cal-2021' = rnorm(365, 2, 1),
                        'AUTVTP Cal-2022' = rnorm(365, 2, 1), 'AUTVTP Cal-2023' = rnorm(365, 2, 1),
                        'ATW Cal-2019' = rnorm(365, 2, 1), 'ATW Cal-2021' = rnorm(365, 2, 1),
                        'ATW Cal-2022' = rnorm(365, 2, 1), 'ATW Cal-2023' = rnorm(365, 2, 1),
                        'BRN Cal-2019' = rnorm(365, 2, 1), 'BRN Cal-2021' = rnorm(365, 2, 1),
                        'BRN Cal-2022' = rnorm(365, 2, 1), 'BRN Cal-2023' = rnorm(365, 2, 1),
                        'FEUA MDEC1' = rnorm(365, 2, 1),
                        check.names = FALSE)
  
  foo <- function(DT, colname){
    DT <- DT[, c("date", colname), with = FALSE]
    DT <- DT %>%
      mutate("2020" = format(date, '%b'), 
             date = format(date, '%d')) %>%
      tidyr::pivot_wider(names_from = date, values_from = colname) %>%
      relocate(`01`, .after = "2020")
    
    ## Calculate monthly and quarterly mean values: ##
    DT <- setDT(DT)[, monthAvg := rowMeans(.SD, na.rm = TRUE), .SDcols = -1]
    DT <- DT[, quartAvg := mean(monthAvg), ceiling(seq_len(nrow(DT))/3)]
    DT <- DT[, yearAvg := mean(monthAvg), ceiling(seq_len(nrow(DT))/12)]
    
    ## Round all values of the data table to 2 digits: ##
    DT <- DT %>% mutate_if(is.numeric, round, 2)
    
  }
  
  l.testList <- lapply(names(dt.data)[names(dt.data) != "date"], foo, DT = dt.data)
  l.testList <- setNames(l.testList, names(dt.data)[names(dt.data) != "date"])
  
  return(l.testList)
  
}

ui <- fluidPage(
  uiOutput(outputId = "maPriceInformationTABLES")
)

server <- function(input, output, session){
  tables <- priceInfo()
  
  output$maPriceInformationTABLES <- renderUI({
    tableList <- imap(tables, ~ {
      tagList(
        h4(.y), # Note we can sprinkle in other UI elements
        DTOutput(outputId = paste0("table_", .y))
      )
    })
    tagList(lapply(tableList, br))
  })
  
  # Now render each output
  iwalk(tables, ~{
    output_name <- paste0("table_", .y)
    output[[output_name]] <- renderDT({
      DT::datatable(.x, rownames = FALSE, escape = FALSE, class = 'cell-border stripe', # 'display cell-border stripe'
                    options = list(pageLength = 12, autoWidth = TRUE, scrollX = TRUE,
                                   initComplete = JS("function(settings, json) {",
                                                     "$(this.api().table().header()).css({'background-color': '#007d3c', 'color': '#fff'});",
                                                     "}")
                    )
      )
    })
  })
}
shinyApp(ui, server)

如何在 R Shiny App 中显示存储在列表中的数据表并格式化数据表

How to display data tables stored in a list in RShiny App and formating the data tables

r

list

shiny

dt