如何将反应式 object 添加到输出 table 中的辅助列 header？

Question

我正在开发一个转换 table 模块，并且正在努力研究如何让用户可以理解输出。我曾经在 Excel 中准备过渡 tables；使 table 清晰易读非常容易，但导出 table 输出的数据需要数小时。现在我的问题与 R 相反：需要几秒钟才能从数百万行数据中生成 table 输出，但 table 表示远非简单。

首先，我想在此反应式 table 的辅助列 header 中反映用户的“发件人”输入 (object transFrom)，如图所示在下图中；有关如何执行此操作的任何建议？我对 html 完全一无所知。我在这里找到了这个解决方案，我喜欢它，因为它使用了我一直使用的 DT（虽然我更喜欢使用 Shiny renderTable() 的基本 R table，但我无法使该工作）。我对此进行了研究，并找到了其他用于起草漂亮 tables 的软件包，但我正在避免“软件包膨胀”，而宁愿坚持使用基础 R、Shiny、data.table 和DT 如果可能的话打包。

请注意，列反映了 FROM 的过渡状态，行反映了 TO 的过渡状态。

这里是主动渲染上面的MWE代码：

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

# custom table container
sketch = htmltools::withTags(table(
  class = 'display',
  thead(
    tr(
      th(colspan = 1, ''),
      th(colspan = 10, 'From state where initial period is =  ')
    ),
    tr(
      lapply(colnames(results), th)
    )
  )
))


data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
    State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
  )

ui <- fluidPage(
  tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
  h4(strong("Base data frame:")), 
  tableOutput("data"),
  h4(strong("Transition table inputs:")),
  numericInput("transFrom", "From period:", 1, min = 1, max = 3),
  numericInput("transTo", "To period:", 2, min = 1, max = 3),
  h4(strong("Output transition table:")), 
  DTOutput("results"),
)

server <- function(input, output) {

  numTransit <- function(x, from=1, to=3){
    setDT(x)
    unique_state <- unique(x$State)
    all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
    dcast(x[, .(from_state = State[from], 
                to_state = State[to]), 
            by = ID]
          [,.N, c("from_state", "to_state")]
          [all_states,on = c("from_state", "to_state")], 
          to_state ~ from_state, value.var = "N"
    )
  }
  
  results <- 
    reactive({
      results <- numTransit(data,input$transFrom,input$transTo) %>% 
        replace(is.na(.), 0) %>%
        bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
      results <- cbind(results, Sum = rowSums(results[,-1]))
    })

  output$data <- renderTable(data)
  
  output$results <- renderDT(server=FALSE,{
    results() %>% 
      datatable(rownames = FALSE,
                filter = 'none',
                container = sketch,
                options = list(scrollX = F
                               , dom = 'ft'
                               , lengthChange = T
                               , pagingType = "numbers"  # hides Next and Previous buttons
                               , autoWidth = T
                               , info = FALSE #  hide the "Showing 1 of 2..." at bottom of table
                               ,searching = FALSE  # removes search box
                          ),
                class = "display"
              )
  })

}

shinyApp(ui, server)

Answer 1

似乎 htmltools::withTags 不能很好地使用闪亮的输入（我提交了一个问题 here）。

请检查以下内容：

library(DT)
library(shiny)
library(htmltools)
library(data.table)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
    State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
  )

numTransit <- function(x, from=1, to=3){
  setDT(x)
  unique_state <- unique(x$State)
  all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
  dcast(x[, .(from_state = State[from], 
              to_state = State[to]), 
          by = ID]
        [,.N, c("from_state", "to_state")]
        [all_states,on = c("from_state", "to_state")], 
        to_state ~ from_state, value.var = "N"
  )
}

ui <- fluidPage(
  tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
  h4(strong("Base data frame:")), 
  tableOutput("data"),
  h4(strong("Transition table inputs:")),
  numericInput("transFrom", "From period:", 1, min = 1, max = 3),
  numericInput("transTo", "To period:", 2, min = 1, max = 3),
  h4(strong("Output transition table:")), 
  DTOutput("resultsDT"),
)

server <- function(input, output, session) {
  results <- 
    reactive({
      results <- numTransit(data, input$transFrom, input$transTo) %>% 
        replace(is.na(.), 0) %>%
        bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
      results <- cbind(results, Sum = rowSums(results[,-1]))
    })
  
  output$data <- renderTable(data)
  
  output$resultsDT <- renderDT(server=FALSE, {
    req(results())
    datatable(
      data = results(),
      rownames = FALSE,
      filter = 'none',
      container = tags$table(
        class = 'display',
        tags$thead(
          tags$tr(
            tags$th(colspan = 1, ''),
            tags$th(colspan = 10, sprintf('From state where initial period is = %s', input$transFrom))
          ),
          tags$tr(
            lapply(colnames(results()), tags$th)
          )
        )
      ),
      options = list(scrollX = F
                     , dom = 'ft'
                     , lengthChange = T
                     , pagingType = "numbers"  # hides Next and Previous buttons
                     , autoWidth = T
                     , info = FALSE #  hide the "Showing 1 of 2..." at bottom of table
                     , searching = FALSE  # removes search box
      ),
      class = "display"
    )
  })
  
}

shinyApp(ui, server)

如何将反应式 object 添加到输出 table 中的辅助列 header？

How to add reactive object to secondary column header in output table?

html

transition

r

shiny

dt