I have a functional shinyApp where one data.table summarizes data from two other data.tables based on dates given in dateRangeInput(). Default format for dateRangeInput() is "yyyy-mm-dd". I have changed date formats in dateRangeInput() and date columns of relevant data.tables to "dd/mm/yyyy". Date formats changed successfully, but the summary data.table has lost reactivity to changes of other data.tables. The summary data.table also is not reacting to changes of dates in dateRangeInput().
I have tried it in several ways but unsuccessful. I went thru many questions in this forum but could not find the one which tackled such kind of situation. I would appreciate if someone can show me how to do it or refer to similar questions solved in this forum.
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)
Please find below an approach to provide the core functionality (w/o polishing the resulting tables and UI).
Note:
observer left, listening to the data selection. This observer wraps the whole logistic. Map applies the desired filtering, updates the UI and returns a list of one-row summary datatables per "Pool"-table. The resulting list is combined into a "Total" data table by do.calling bind_rows. No need to create a combined data table front up.filter and between instead of {data.table}'s equivalents.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)