Calendar range support

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: shiny.semantic
 Title: Semantic UI Support for Shiny
-Version: 0.5.0
+Version: 0.5.0.9000
 Authors@R: c(person("Filip", "Stachura", email = "[email protected]", role = "aut"),
   person("Dominik", "Krzeminski", role = "aut"),
   person("Krystian", "Igras", role = "aut"),
@@ -52,6 +52,7 @@ Suggests:
     rmarkdown,
     testthat,
     tibble,
+    stringr,
     withr
 VignetteBuilder:
     knitr

NAMESPACE

@@ -8,6 +8,8 @@ export(actionButton)
 export(action_button)
 export(button)
 export(calendar)
+export(calendar_range_double)
+export(calendar_range_single)
 export(card)
 export(cards)
 export(check_proper_color)
@@ -97,6 +99,7 @@ export(updateSelectInput)
 export(updateSliderInput)
 export(update_action_button)
 export(update_calendar)
+export(update_calendar_range)
 export(update_dropdown_input)
 export(update_multiple_checkbox)
 export(update_multiple_radio)

R/calendar.R

@@ -50,6 +50,26 @@
 #'   type = "month"
 #' )
 #' }
+#'
+#'
+#' \dontrun{
+#' # Calendar range
+#'   calendar(
+#'     input_id = "start_date",
+#'     type = "date",
+#'     value = "2020-02-20",
+#'     min = "2020-01-01",
+#'     max = "2020-03-01",
+#'   )
+#'
+#'   calendar(
+#'     input_id = "end_date",
+#'     type = "date",
+#'     value = "2020-02-23",
+#'     min = "2020-01-01",
+#'     max = "2020-03-01",
+#'   )
+#' }
 #' @rdname calendar
 #' @export
 calendar <- function(input_id, value = NULL, placeholder = NULL, type = "date", min = NA, max = NA) {
@@ -72,6 +92,30 @@ calendar <- function(input_id, value = NULL, placeholder = NULL, type = "date",
   cal_widget
 }
 
+#' Defines calendar ranges
+#'
+#'
+#' @param input_id Input name. Reactive value is available under \code{input[[input_id]]}.
+#' @param value Initial value of the numeric input.
+#' @param placeholder Text visible in the input when nothing is inputted.
+#' @param type Select from \code{'year'}, \code{'month'}, \code{'date'} and \code{'time'}
+#' @param min Minimum allowed value.
+#' @param max Maximum allowed value.
+#' @param start_calendar_id id of the calendar that defines the range start.
+#' @param end_calendar_id id of the calendar that defines the range end.
+#'
+#' @rdname calendar_range_single
+#'
+#' @export
+calendar_range_single <- function(input_id, value = NULL, placeholder = NULL, type = "date", min = NA, max = NA,
+                                  start_calendar_id = NULL, end_calendar_id = NULL) {
+  cal_widget <- calendar(input_id, value, placeholder, type, min, max)
+  if (!is.null(start_calendar_id)) cal_widget$attribs[["data-start-calendar-id"]] <- start_calendar_id
+  if (!is.null(end_calendar_id)) cal_widget$attribs[["data-end-calendar-id"]] <- end_calendar_id
+
+  cal_widget
+}
+
 #' Update UI calendar
 #'
 #' This function updates the date on a calendar

R/calendar_range.R

@@ -0,0 +1,119 @@
+#' Create Semantic UI Calendar Range
+#'
+#' This is a wrapper for creating calendar ranges using Semantic UI calendars.
+#' It creates a form composed of two calendars. The selected range values are
+#' available under \code{input[[input_id]]}.
+#'
+#' @details The Semantic UI calendar range automatically pops up the end range
+#' calendar when changing the start date. Therefore events are only sent on
+#' changes done in the end date calendar.
+#'
+#' @param input_id Input name. Reactive value is available under \code{input[[input_id]]}.
+#' @param start_value Initial value of the calendar defining the start of the range.
+#' @param end_value Initial value of the calendar defining the end of the range.
+#' @param start_placeholder Text visible in the start calendar input when nothing is inputted.
+#' @param end_placeholder Text visible in the end calendar input when nothing is inputted.
+#' @param type Select from \code{'year'}, \code{'month'}, \code{'date'} and \code{'time'}.
+#' @param min Minimum allowed value in both calendars.
+#' @param max Maximum allowed value in both calendars.
+#'
+#' @rdname calendar_range_double
+#' @export
+#'
+calendar_range_double <- function(input_id, type = "date", start_value = NULL, end_value = NULL,
+                           start_placeholder = NULL, end_placeholder = NULL, min = NA, max = NA) {
+  if (!is.null(start_value)) start_value <- format(as.Date(start_value), "%Y/%m/%d")
+  if (!is.null(end_value)) end_value <- format(as.Date(end_value), "%Y/%m/%d")
+  if (!is.na(min)) min <- format(as.Date(min), "%Y/%m/%d")
+  if (!is.na(max)) max <- format(as.Date(max), "%Y/%m/%d")
+
+  start_cal_widget <- create_cal_widget(
+    type = type,
+    value = start_value,
+    placeholder = start_placeholder,
+    min = min,
+    max = max
+  )
+
+  end_cal_widget <- create_cal_widget(
+    type = type,
+    value = end_value,
+    placeholder = end_placeholder,
+    min = min,
+    max = max
+  )
+
+  cal_range_widget <- div(
+    id = input_id,
+    class = "ui form semantic-input-date-range",
+    div(
+      class = "two fields",
+      div(
+        class = "field",
+        start_cal_widget
+      ),
+      div(
+        class = "field",
+        end_cal_widget
+      )
+    )
+  )
+
+  cal_range_widget
+}
+
+create_cal_widget <- function(type="date", value, placeholder, min, max) {
+  cal_widget <- div(
+    class = "ui calendar ss-input-date-range-item",
+    `data-type` = type,
+    `data-date` = value,
+    div(
+      class = "ui input left icon",
+      tags$i(class = "calendar icon"),
+      tags$input(type = "text", placeholder)
+    )
+  )
+
+  if (!is.na(min)) {
+    cal_widget$attribs[["data-min-date"]] <- min
+  }
+
+  if (!is.na(max)) {
+    cal_widget$attribs[["data-max-date"]] <- max
+  }
+
+  cal_widget
+}
+
+#'
+#' Update UI calendar range
+#'
+#' This function updates the dates on a calendar range.
+#'
+#' @param session The \code{session} object passed to function given to
+#'   \code{shinyServer}.
+#' @param input_id ID of the calendar range that will be updated
+#' @param start_value New start value of the calendar defining the start of the range.
+#' @param end_value New end value of the calendar defining the end of the range.
+#' @param min New minimum allowed value in both calendars.
+#' @param max New maximum allowed value in both calendars.
+#'
+#' @return None. This function is called for its side effects.
+#'
+#' @rdname calendar_range
+#' @export
+update_calendar_range <- function(session, input_id, start_value = NULL, end_value = NULL, min = NULL, max = NULL) {
+  if (!is.null(start_value)) value <- format(as.Date(start_value), "%Y/%m/%d")
+  if (!is.null(end_value)) value <- format(as.Date(end_value), "%Y/%m/%d")
+  if (!is.null(min)) min <- format(as.Date(min), "%Y/%m/%d")
+  if (!is.null(max)) max <- format(as.Date(max), "%Y/%m/%d")
+
+  message <- list(
+    start_value = start_value,
+    end_value = end_value,
+    min = min,
+    max = max
+  )
+
+  session$sendInputMessage(input_id, message = message)
+}

R/semanticPage.R

@@ -157,6 +157,7 @@ semanticPage <- function(..., title = "", theme = NULL, suppress_bootstrap = TRU
       shiny::tags$script(src = "shiny.semantic/shiny-semantic-button.js"),
       shiny::tags$script(src = "shiny.semantic/shiny-semantic-slider.js"),
       shiny::tags$script(src = "shiny.semantic/shiny-semantic-calendar.js"),
+      shiny::tags$script(src = "shiny.semantic/shiny-semantic-calendar-range.js"),
       shiny::tags$script(src = "shiny.semantic/shiny-semantic-fileinput.js"),
       shiny::tags$script(src = "shiny.semantic/shiny-semantic-numericinput.js"),
       shiny::tags$script(src = "shiny.semantic/shiny-semantic-rating.js"),

examples/calendar_range/app.R

@@ -0,0 +1,44 @@
+library(shiny)
+library(shiny.semantic)
+
+ui <- semanticPage(
+        title = "Calendar range example",
+        calendar_range_double(
+          input_id = "calendar_range",
+          start_value = "2020-02-20",
+          end_value = "2020-03-20",
+          min = "2020-01-01",
+          max = "2020-12-01",
+          start_placeholder = "Select range start",
+          end_placeholder = "Select range end"
+        ),
+        div(
+          class = "two fields",
+          div(class = "field", textOutput("start_date_value")),
+          div(class = "field", textOutput("end_date_value"))
+        ),
+        action_button(input_id = "calendar_range_update", label = "Update calendar range")
+      )
+
+server <- function(input, output, session) {
+  output$start_date_value <- renderText({
+    as.character(input$calendar_range[1])
+  })
+
+  output$end_date_value <- renderText({
+    as.character(input$calendar_range[2])
+  })
+
+  observeEvent(input$calendar_range_update, {
+    update_calendar_range(
+      session = session,
+      input_id = "calendar_range",
+      start_value = "2021-01-01",
+      end_value = "2021-02-02",
+      min = "2020-11-20",
+      max = "2021-12-20"
+    )
+  })
+}
+
+shinyApp(ui = ui, server = server)

inst/www/shiny-semantic-calendar-range.js

@@ -0,0 +1,103 @@
+var semanticDateRangeBinding = new Shiny.InputBinding();
+
+function updateSingleCalendar(calendarElement, value) {
+  if (value !== null) {
+    calendarElement.calendar('set date', value)
+  }
+}
+
+function retrieveRangeCalendars(el) {
+  const calendars = $(el).find('.ss-input-date-range-item')
+
+  return {
+    start: calendars.eq(0),
+    end: calendars.eq(1)
+  }
+}
+
+function updateCalendarInterval(calendarElement, intervalType, value) {
+  calendarElement.calendar(`set ${intervalType}Date`, value)
+  calendarElement.attr(`data-${intervalType}-date`, value);
+}
+
+$.extend(semanticDateRangeBinding, {
+
+  // This initialize input element. It extracts data-value attribute and use that as value.
+  initialize: function(el) {
+    const calendarRange = retrieveRangeCalendars(el);
+
+    calendarRange.start.calendar({
+      type: calendarRange.start.data('type'),
+      endCalendar: calendarRange.end
+    });
+
+    calendarRange.end.calendar({
+      type: calendarRange.end.data('type'),
+      onChange: function(date, text, mode) {
+        calendarRange.end.trigger('change.semanticDateRangeBinding');
+      },
+      startCalendar: calendarRange.start
+    })
+  },
+
+  // This returns a jQuery object with the DOM element.
+  find: function(scope) {
+    return $(scope).find('.semantic-input-date-range');
+  },
+
+  // Return the date in an unambiguous format, yyyy-mm-dd (as opposed to a
+  // format like mm/dd/yyyy)
+  getValue: function(el) {
+    const calendarRange = retrieveRangeCalendars(el);
+    return [
+      formatDate(calendarRange.start.calendar('get date')),
+      formatDate(calendarRange.end.calendar('get date'))
+    ];
+  },
+
+  setValue: function(el, value) {
+    const calendarRange = retrieveRangeCalendars(el);
+
+    updateSingleCalendar(calendarRange.start, value.start);
+    updateSingleCalendar(calendarRange.end, value.end);
+  },
+
+  subscribe: function(el, callback) {
+    $(el).on('change.semanticDateRangeBinding', function(event) {
+      callback(true);
+    });
+  },
+
+  unsubscribe: function(el) {
+    $(el).off('.semanticDateRangeBinding');
+  },
+
+  getRatePolicy: function() {
+    return {
+      policy: 'debounce',
+      delay: 250
+    };
+  },
+
+  receiveMessage: function(el, data) {
+    const calendarRange = retrieveRangeCalendars(el);
+    if (data.hasOwnProperty('min')) {
+      updateCalendarInterval(calendarRange.start, 'min', data.min)
+      updateCalendarInterval(calendarRange.end, 'min', data.min)
+    }
+
+    if (data.hasOwnProperty('max')) {
+      updateCalendarInterval(calendarRange.start, 'max', data.max)
+      updateCalendarInterval(calendarRange.end, 'max', data.max)
+    }
+
+    this.setValue(el, {start: data.start_value, end: data.end_value})
+    const values = this.getValue(el);
+    calendarRange.start.attr('data-date', values[0]);
+    calendarRange.end.attr('data-date', values[1]);
+
+    $(el).trigger("change.semanticDateRangeBinding")
+  }
+});
+
+Shiny.inputBindings.register(semanticDateRangeBinding, 'shiny.semanticDateRange');

inst/www/shiny-semantic-calendar.js

@@ -23,10 +23,20 @@ $.extend(semanticDateBinding, {
 
   // This initialize input element. It extracts data-value attribute and use that as value.
   initialize: function(el) {
+    const startCalendarId = $(el).data('startCalendarId') ?
+      `#${$(el).data('startCalendarId')}` :
+      null;
+
+    const endCalendarId = $(el).data('endCalendarId') ?
+      `#${$(el).data('endCalendarId')}` :
+      null;
+
     $(el).calendar({
       onChange: function(date, text, mode) {
         $(el).trigger('change');
-      }
+      },
+      startCalendar: startCalendarId,
+      endCalendar: endCalendarId
     });
   },