Way to select numerous non-continuous dates with dateInput in Shiny?

Question

dateInput seems to be restricted to selecting a single date.

dateRangeInput only allows you to select a range of dates in a row.

Is there a way to select multiple dates that do not fall in a row (i.e., dates that are non-continuous)?

What I really want is a calendar in which I can select (click-on) multiple dates resulting in all of those dates being selected as separate input values.

For example, if possible, I'd like to be able to do this:

Answer 1

In shinyWidgets package, you have airDatepicker which does just that, using argument multiple=TRUE. Have a look at this page for details.

Answer 2

Maybe this will help someone in need. You can select multiple dates from the date picker. The dates are kept in an ordered timeline. A click on the selected date removes that date from the list. The dates in the list can be accessed by dates$df$date. The observe code was from another SO post that unfortunately I could not find anymore. Feel free to link that post in if you find/know it. The random id is used to identify the items in the dataframe and the uiComponents list. As you might notice, it may not work correctly one lucky day.

library(shiny)

ui <- fluidPage(
  headerPanel("Multiple Dates",  windowTitle = "Dates"),
  fluidRow(
    column(width = 2,
                 dateInput("date", "Date", value = "2019-05-31"),
                 tags$b("Selected"),
                 uiOutput("container")
    ),
    column(width = 10,
              verbatimTextOutput("text")
    )
  )
)


server <- function(input, output, session) {

  container <- reactiveValues(uiComponents = list())

  # empty data frame
  dates <- reactiveValues(df = data.frame(matrix(ncol=2,nrow=0, dimnames=list(NULL, c("id", "date")))))

  ###### Monitor changes in date-picker and add new dates to uiComponents
  observeEvent(input$date, {
    isolate({
      rnd <- as.integer(runif(1,1e5,1e6-1))
      dates$df <- rbind(dates$df, data.frame(id = rnd, date = input$date))
      dates$df <- dates$df[order(dates$df$date), ] # sort by date
      container$uiComponents <- NULL  # delete list and re-write it from df
      for (i in 1:NROW(dates$df)) {
        container$uiComponents <- append(
          container$uiComponents,
          list(
            list(
              "link" = actionLink(paste0("link", dates$df$id[i]), label = as.character(dates$df$date[i])),
              "br" = br()
            )
          )
        )
      }
    })
  }, ignoreInit = TRUE)

  ###### Monitor and locate click events from list
  observe({
    if(length(container$uiComponents) == 0) return()
    # links <- lapply(container$uiComponents, `[[`, "link")
    readLinkID <- sapply(container$uiComponents, function(x) {
      x$link$attribs$id
    })
    readLinkVals <- sapply(readLinkID, function(x) input[[x]])
    if(any(sapply(readLinkVals, is.null))) return()
    if(all(readLinkVals == 0)) return()
    isolate({
      container$uiComponents[[which(readLinkVals > 0)]] <- NULL
      dates$df <- dates$df[-which(readLinkVals > 0), ]
    })
  })

  output$container <- renderUI({
    container$uiComponents
  })

  output$text <- renderPrint({
    print(dates$df)
    str(container$uiComponents)
  })
}

shinyApp(ui = ui, server = server)

Answer 3

I rewrite the dateInput function.

And also you can have a look at : enter link

  mydateInput <- function(inputId, label, value = NULL, min = NULL, max = NULL,
                        format = "yyyy-mm-dd", startview = "month", weekstart = 0, language = "en", minviewmode="months",
                        width = NULL) {

  # If value is a date object, convert it to a string with yyyy-mm-dd format
  # Same for min and max
  if (inherits(value, "Date"))  value <- format(value, "%Y-%m-%d")
  if (inherits(min,   "Date"))  min   <- format(min,   "%Y-%m-%d")
  if (inherits(max,   "Date"))  max   <- format(max,   "%Y-%m-%d")

  htmltools::attachDependencies(
    tags$div(
             class = "shiny-date-input form-group shiny-input-container",
             style = if (!is.null(width)) paste0("width: ", validateCssUnit(width), ";"),

             controlLabel(inputId, label),
             tags$input(id = inputId, type = "text",
                        # datepicker class necessary for dropdown to display correctly
                        class = "form-control datepicker",
                        `data-date-language` = language,
                        `data-date-weekstart` = weekstart,
                        `data-date-format` = format,
                        `data-date-start-view` = startview,
                        `data-date-min-view-mode` = minviewmode,
                        `data-min-date` = min,
                        `data-max-date` = max,
                        `data-initial-date` = value,
                        `data-date-multidate` = 'true'

             )
    ),
    datePickerDependency
  )
}

`%AND%` <- function(x, y) {
  if (!is.null(x) && !is.na(x))
    if (!is.null(y) && !is.na(y))
      return(y)
  return(NULL)
}

controlLabel <- function(controlName, label) {
  label %AND% tags$label(class = "control-label", `for` = controlName, label)
}

datePickerDependency <- htmltools::htmlDependency(
  "bootstrap-datepicker", "1.6.4", c(href = "shared/datepicker"),
  script = "js/bootstrap-datepicker.min.js",
  stylesheet = "css/bootstrap-datepicker3.min.css",
  # Need to enable noConflict mode. See #1346.
  head = "<script>
  (function() {
  var datepicker = $.fn.datepicker.noConflict();
  $.fn.bsDatepicker = datepicker;
  })();
  </script>")


  [1]: https://stackoverflow.com/questions/31152960/display-only-months-in-daterangeinput-or-dateinput-for-a-shiny-app-r-programmin/32171132