data.table 和 dateRangeInput() 的反应性

Question

我有一个函数

shinyApp

，其中一个 data.table 根据

dateRangeInput()

中给出的日期汇总来自其他两个 data.table 的数据。

dateRangeInput()

的默认格式为

"yyyy-mm-dd"

。我已将相关 data.tables 的

dateRangeInput()

和

date

列中的日期格式更改为

"dd/mm/yyyy"

。日期格式更改成功，但摘要 data.table 已失去对其他 data.table 更改的反应性。摘要 data.table 也不会对 dateRangeInput() 中的日期更改做出反应。

我尝试过多种方法，但都没有成功。我在这个论坛上浏览了很多问题，但找不到解决此类情况的问题。如果有人可以向我展示如何操作或参考此论坛中解决的类似问题，我将不胜感激。

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

df1 <- data.table(
            "tableNames" = as.character(c("Pool 1", 
                                          "Pool 2",
                                          "Total")),
            "score1" = as.numeric(c(0,0,0)),
            "score2" = as.numeric(c(0,0,0)),
            stringsAsFactors = FALSE)

df2 <- data.table(
            "date" = as.character(c("01/06/2024", "01/06/2024", "03/06/2024", "03/06/2024")),
            "names" = as.character(c("Bob", "Ali","Bob", "Ali")),
            "score1" = as.numeric(c(10, 20, 20, 10)),
            "score2" = as.numeric(c(15, 25, 25, 15)),
            stringsAsFactors = FALSE)

df3 <- data.table(
            "date" = as.character(c("02/06/2024", "02/06/2024", "04/06/2024", "04/06/2024")),
            "names" = as.character(c("Bob", "Ali","Bob", "Ali")),
            "score1" = as.numeric(c(30, 40, 40, 30)),
            "score2" = as.numeric(c(15, 25, 25, 15)),
            stringsAsFactors = FALSE)


ui <- fluidPage(
   dashboardPage(
    dashboardHeader(),
    dashboardSidebar(
      sidebarMenu(
        menuItem("Scores", tabName = "scores",
              menuSubItem("ScoreSummary", tabName = "table_df1"),
              menuSubItem("Scores_df2", tabName = "table_df2"),
              menuSubItem("Scores_df3", tabName = "table_df3")
        )
      )
    ),

    dashboardBody(
      tabItems(
        tabItem(tabName = "table_df1",
            column(
                width=8,
                dateRangeInput("dates", "Choose a period:", format= "dd/mm/yyyy",
                     start = "2024-01-01", end = Sys.Date()),
                uiOutput("nested_ui")),
            column(
                width=8,
                "Summary of scores",
                rHandsontableOutput("table1"))
        ),
        tabItem(tabName = "table_df2",
            column(
                width=8,
                "Pool 1",
                rHandsontableOutput("table2")
          )
        ),
        tabItem(tabName = "table_df3",
            column(
                width=8,
                "Pool 2",
                rHandsontableOutput("table3")
          )
        )
      )
    )
  )
)


server = function(input, output) {

  data <- reactiveValues()

  observe({
    data$dt1 <- as.data.table(df1)
    data$dt2 <- as.data.table(df2)
    data$dt3 <- as.data.table(df3)

  })

  observe({
    if(!is.null(input$table1))
      data$dt1<- hot_to_r(input$table1)
  })

  observe({
    if(!is.null(input$table2))
      data$dt2<- hot_to_r(input$table2)
  })

  observe({
    if(!is.null(input$table3))
      data$dt3<- hot_to_r(input$table3)
  })

  observe({
    if (!any(is.na(input$dates))) {
      dt2_1 <- data$dt2
      selected_dates1 <- seq(as.Date(input$dates[1L]),
                             as.Date(input$dates[2L]), by = "day")
      data$dt2_2 <- dt2_1[as.Date(dt2_1$date) %in% selected_dates1, ]
    } else {
      selected_dates2 <- unique(data$dt2$date)
      data$dt2_2 <- data$dt2[data$dt2$date %in% selected_dates2, ]
    }
  })

  observe({
    if(!is.null(input$table2))
      data$dt2_2<- hot_to_r(input$table2)
  })

  observe({
    if (!any(is.na(input$dates))) {
      dt3_1 <- data$dt3
      selected_dates1 <- seq(as.Date(input$dates[1L]),
                             as.Date(input$dates[2L]), by = "day")
      data$dt3_2 <- dt3_1[as.Date(dt3_1$date) %in% selected_dates1, ]
    } else {
      selected_dates2 <- unique(data$dt3$date)
      data$dt3_2 <- data$dt3[data$dt3$date %in% selected_dates2, ]
    }
  })

  observe({
    if(!is.null(input$table3))
      data$dt3_2<- hot_to_r(input$table3)
  })


  observe({
    data$dt1[1, 2:3] <- data$dt2_2[, list(
      score1 = sum(score1, na.rm = TRUE),
      score2 = sum(score2, na.rm = TRUE)
    ), by=`names`][, .(
      score1 = sum(score1, na.rm = TRUE),
      score2 = sum(score2, na.rm = TRUE))]
  })

  observe({
    data$dt1[2, 2:3] <- data$dt3_2[, list(
      score1 = sum(score1, na.rm = TRUE),
      score2 = sum(score2, na.rm = TRUE)
    ), by=`names`][, .(
      score1 = sum(score1, na.rm = TRUE),
      score2 = sum(score2, na.rm = TRUE))]
  })

  observe({ data$dt1[3, 2:3] <- data$dt1[, .SD[1:2, lapply(.SD, sum)], .SDcols = 2:3] })

  output$nested_ui <- renderUI(!any(is.na(input$dates)))

  output$table1 <- renderRHandsontable({
    rhandsontable(data$dt1, stretchH = "all")
  })

  output$table2 <- renderRHandsontable({
    rhandsontable(data$dt2, stretchH = "all") |>
    hot_col(1, format="dd/mm/yyyy", type="date")
  })

  output$table3 <- renderRHandsontable({
    rhandsontable(data$dt3, stretchH = "all")|>
    hot_col(1, format="dd/mm/yyyy", type="date")
  })

}

shinyApp(ui = ui, server = server)

Answer 1

请在下面找到一种提供核心功能的方法（无需完善生成的表格和 UI）。

注：

• 只剩下一个

  observe

  r，正在听数据选择。这个观察者包裹了整个逻辑。

  Map

  应用所需的过滤，更新UI并返回每个“池”表的单行汇总数据表的列表。通过

  do.call

  ing

  bind_rows

  将结果列表组合成“总计”数据表。无需预先创建组合数据表。
• 由于缺乏经验和时间，我使用了 {dplyr} 的

  filter

  和

  between

  而不是 {data.table} 的等效项。

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


ui <- fluidPage(
  dateRangeInput("dates", "Choose a period:", format= "dd/mm/yyyy",
                 start = "2024-01-01", end = Sys.Date()
  ),
  
  mainPanel(
    tableOutput("Total"),
    tableOutput("Pool 1"),
    tableOutput("Pool 2"),
  )
)


server <- function(input, output) {

  the_datatables <- reactiveValues(
    "Pool 1" = data.table(date = as.Date(x = c("01/06/2024", "01/06/2024", 
                                               "03/06/2024", "03/06/2024"),
                                         format = "%d/%m/%Y"
    ),
    names = c("Bob", "Ali","Bob", "Ali"),
    score1 = c(10, 20, 20, 10), score2 = c(15, 25, 25, 15)
    ),
    
    
    "Pool 2" = data.table(date = as.Date(x = c("02/06/2024", "02/06/2024",
                                               "04/06/2024", "04/06/2024"),
                                         format = "%d/%m/%Y"
    ),
    names = c("Bob", "Ali","Bob", "Ali"),
    score1 = c(10, 20, 20, 10), score2 = c(15, 25, 25, 15)
    ) 

  )
  
  
  observe({
    Total <- 
      do.call('bind_rows', ## bind summary rows (1 per table) of the following `Map`
              Map(c('Pool 1', 'Pool 2'), ## do the following for each 'Pool'-table
                  f = function(dt_name){
                    table_filtered <- the_datatables[[dt_name]] %>%
                      filter(between(date, min(input$dates), max(input$dates)))
                    
                    ## update output per table:
                    output[[dt_name]] <- renderTable(table_filtered)
                    
                    ## return summary row per table:
                    data.table(tableNames = dt_name,
                    summarise(table_filtered,
                              across(where(is.numeric), ~ sum(.x, na.rm = TRUE)))
                    )
                  }
              )
      )
    
    ## add grand total and update output:
    output$Total <- 
      bind_rows(Total,
                data.frame(tableNames = 'Total',
                           summarise(Total,
                                     across(where(is.numeric), ~ sum(.x))
                           )
                )
      ) %>% 
      renderTable()
    
  }) %>% bindEvent(input$dates)
  
  
}

shinyApp(ui = ui, server = server)