How do I insert days that are holidays into a Shiny app?

Question

I would like to know if you can help me with the following question:

I've inserted an executable app below just to give you a sense of what I want to do. When running the APP, you will notice that it has a field called SelectDate. It's a calendar. It is from January to December 2021, as it is contemplating 01/01 and 05/12 which refers to my df database. However, I would like the calendar to show the holidays days. Leave the holiday days in a different color or highlighted on the calendar, something like that. By any chance, is there any way to do this?

library(shiny)
library(shinythemes)

function.cl<-function(df,date, d1,d2){
  df <- structure(
    list(date = c("2021-01-01","2021-03-02","2021-04-03","2021-09-04","2021-12-05"),
         d1 = c(0,1,4,5,6), d2 = c(2,4,5,6,7)),class = "data.frame", row.names = c(NA, -5L))
}    
ui <- fluidPage(
  
  ui <- shiny::navbarPage(theme = shinytheme("flatly"), collapsible = TRUE,
                          br(),
                          
                          tabPanel("",
                                   sidebarLayout(
                                     sidebarPanel(
                                       
                                       uiOutput("date"),
                                       selectInput("d1", label = h4("D1"),""),
                                       selectInput("d2", label = h4("D2"),""),
                                       br(),
                                       actionButton("reset", "Reset"),
                                     ),
                                     
                                     mainPanel(
                                     ))
                          )))


server <- function(input, output,session) {
  data <- reactive(function.cl())
  
  output$date <- renderUI({
    all_dates <- seq(as.Date('2021-01-01'), as.Date('2021-01-15'), by = "day")
    disabled <- as.Date(setdiff(all_dates, as.Date(data()$date)), origin = "1970-01-01")
    
    dateInput(input = "date", 
              label = "Select Date",
              min = min(data()$date),
              max = max(data()$date),
              value = max(data()$date),
              format = "dd-mm-yyyy",
              datesdisabled = disabled)
  })
  
  observe({
    updateSelectInput(session, "d1", label = "D1", unique(data()$d1))
    updateSelectInput(session, "d2", label = "D2", unique(data()$d2))
  })
}

shinyApp(ui = ui, server = server)

Answer 1

Since holidays are disabled in your dateInput, they have the custom class td.disabled.day (open the app in browser and check in the Inspector). Therefore, you can customize the CSS just for these dates.

Example: put a red background for holidays. The CSS is:

td.disabled.day {
  background-color: red !important;
}

You need to put it in tags$head(tags$style(HTML(...))) in your app, here's the example:

library(shiny)
library(shinythemes)

function.cl<-function(df,date, d1,d2){
  df <- structure(
    list(date = c("2021-01-01","2021-03-02","2021-04-03","2021-09-04","2021-12-05"),
         d1 = c(0,1,4,5,6), d2 = c(2,4,5,6,7)),class = "data.frame", row.names = c(NA, -5L))
}    

  ui <- shiny::fluidPage(
    tags$head(
      tags$style(
        HTML("td.disabled.day {
              background-color: red !important
              }")
      )
    ),
    theme = shinytheme("flatly"), collapsible = TRUE,
                          
                          br(),
                          
                          tabPanel("",
                                   sidebarLayout(
                                     sidebarPanel(
                                       
                                       uiOutput("date"),
                                       selectInput("d1", label = h4("D1"),""),
                                       selectInput("d2", label = h4("D2"),""),
                                       br(),
                                       actionButton("reset", "Reset"),
                                     ),
                                     
                                     mainPanel(
                                     ))
                          ))


server <- function(input, output,session) {
  data <- reactive(function.cl())
  
  output$date <- renderUI({
    all_dates <- seq(as.Date('2021-01-01'), as.Date('2021-01-15'), by = "day")
    disabled <- as.Date(setdiff(all_dates, as.Date(data()$date)), origin = "1970-01-01")
    
    dateInput(input = "date", 
              label = "Select Date",
              min = min(data()$date),
              max = max(data()$date),
              value = max(data()$date),
              format = "dd-mm-yyyy",
              datesdisabled = disabled)
  })
  
  observe({
    updateSelectInput(session, "d1", label = "D1", unique(data()$d1))
    updateSelectInput(session, "d2", label = "D2", unique(data()$d2))
  })
}

shinyApp(ui = ui, server = server)

Answer 2

Highlighing specific days on the calendar using one of the pre-existing dateInput widgets is going to be quite difficult to do (if it's even possible) unfortunately. You will certainly need some custom CSS, and most likely need some custom javascript as well that would enable you to do this.

However, one alternative alternative option is that you could actually create a calendar as a plot, and then have the user select days from the plot rather than a real dateInput() field by registering clicks on the plot. This would give you much more control over the layout and styling of the calendar/plot, but the downside is it would potentially not be as smooth as the widget version.

Another option would be a completely custom dateInput UI element, but that's likely to be a difficult task as well.