Nothing
# DatetimeFilterState ------
#' @rdname DatetimeFilterState
#' @docType class
#'
#' @title `FilterState` object for date time data
#'
#' @description Manages choosing a range of date-times.
#'
#' @examples
#' # use non-exported function from teal.slice
#' include_css_files <- getFromNamespace("include_css_files", "teal.slice")
#' include_js_files <- getFromNamespace("include_js_files", "teal.slice")
#' DatetimeFilterState <- getFromNamespace("DatetimeFilterState", "teal.slice")
#'
#' library(shiny)
#'
#' filter_state <- DatetimeFilterState$new(
#' x = c(Sys.time() + seq(0, by = 3600, length.out = 10), NA),
#' slice = teal_slice(varname = "x", dataname = "data"),
#' extract_type = character(0)
#' )
#' isolate(filter_state$get_call())
#' filter_state$set_state(
#' teal_slice(
#' dataname = "data",
#' varname = "x",
#' selected = c(Sys.time() + 3L, Sys.time() + 8L),
#' keep_na = TRUE
#' )
#' )
#' isolate(filter_state$get_call())
#'
#' # working filter in an app
#' library(shinyjs)
#'
#' datetimes <- as.POSIXct(c("2012-01-01 12:00:00", "2020-01-01 12:00:00"))
#' data_datetime <- c(seq(from = datetimes[1], to = datetimes[2], length.out = 100), NA)
#' fs <- DatetimeFilterState$new(
#' x = data_datetime,
#' slice = teal_slice(
#' varname = "x", dataname = "data", selected = data_datetime[c(47, 98)], keep_na = TRUE
#' )
#' )
#'
#' ui <- fluidPage(
#' useShinyjs(),
#' include_css_files(pattern = "filter-panel"),
#' include_js_files(pattern = "count-bar-labels"),
#' column(4, tags$div(
#' tags$h4("DatetimeFilterState"),
#' fs$ui("fs")
#' )),
#' column(4, tags$div(
#' id = "outputs", # div id is needed for toggling the element
#' tags$h4("Condition (i.e. call)"), # display the condition call generated by this FilterState
#' textOutput("condition_datetime"), tags$br(),
#' tags$h4("Unformatted state"), # display raw filter state
#' textOutput("unformatted_datetime"), tags$br(),
#' tags$h4("Formatted state"), # display human readable filter state
#' textOutput("formatted_datetime"), tags$br()
#' )),
#' column(4, tags$div(
#' tags$h4("Programmatic filter control"),
#' actionButton("button1_datetime", "set drop NA", width = "100%"), tags$br(),
#' actionButton("button2_datetime", "set keep NA", width = "100%"), tags$br(),
#' actionButton("button3_datetime", "set a range", width = "100%"), tags$br(),
#' actionButton("button4_datetime", "set full range", width = "100%"), tags$br(),
#' actionButton("button0_datetime", "set initial state", width = "100%"), tags$br()
#' ))
#' )
#'
#' server <- function(input, output, session) {
#' fs$server("fs")
#' output$condition_datetime <- renderPrint(fs$get_call())
#' output$formatted_datetime <- renderText(fs$format())
#' output$unformatted_datetime <- renderPrint(fs$get_state())
#' # modify filter state programmatically
#' observeEvent(
#' input$button1_datetime,
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = FALSE))
#' )
#' observeEvent(
#' input$button2_datetime,
#' fs$set_state(teal_slice(dataname = "data", varname = "x", keep_na = TRUE))
#' )
#' observeEvent(
#' input$button3_datetime,
#' fs$set_state(
#' teal_slice(dataname = "data", varname = "x", selected = data_datetime[c(34, 56)])
#' )
#' )
#' observeEvent(
#' input$button4_datetime,
#' fs$set_state(
#' teal_slice(dataname = "data", varname = "x", selected = datetimes)
#' )
#' )
#' observeEvent(
#' input$button0_datetime,
#' fs$set_state(
#' teal_slice(
#' dataname = "data", varname = "x", selected = data_datetime[c(47, 98)], keep_na = TRUE
#' )
#' )
#' )
#' }
#'
#' if (interactive()) {
#' shinyApp(ui, server)
#' }
#'
#' @keywords internal
#'
DatetimeFilterState <- R6::R6Class( # nolint
"DatetimeFilterState",
inherit = FilterState,
# public methods ----
public = list(
#' @description
#' Initialize a `FilterState` object. This class
#' has an extra field, `private$timezone`, which is set to `Sys.timezone()` by
#' default. However, in case when using this module in `teal` app, one needs
#' timezone of the app user. App user timezone is taken from `session$userData$timezone`
#' and is set only if object is initialized in `shiny`.
#'
#' @param x (`POSIXct` or `POSIXlt`)
#' variable to be filtered.
#' @param x_reactive (`reactive`)
#' returning vector of the same type as `x`. Is used to update
#' counts following the change in values of the filtered dataset.
#' If it is set to `reactive(NULL)` then counts based on filtered
#' dataset are not shown.
#' @param slice (`teal_slice`)
#' specification of this filter state.
#' `teal_slice` is stored in the object and `set_state` directly manipulates values within `teal_slice`.
#' `get_state` returns `teal_slice` object which can be reused in other places.
#' Note that `teal_slice` is a `reactiveValues`, which means it has reference semantics, i.e.
#' changes made to an object are automatically reflected in all places that refer to the same `teal_slice`.
#' @param extract_type (`character`)
#' specifying whether condition calls should be prefixed by `dataname`. Possible values:
#' - `character(0)` (default) `varname` in the condition call will not be prefixed
#' - `"list"` `varname` in the condition call will be returned as `<dataname>$<varname>`
#' - `"matrix"` `varname` in the condition call will be returned as `<dataname>[, <varname>]`
#'
#' @return Object of class `DatetimeFilterState`, invisibly.
#'
initialize = function(x,
x_reactive = reactive(NULL),
extract_type = character(0),
slice) {
isolate({
checkmate::assert_multi_class(x, c("POSIXct", "POSIXlt"))
checkmate::assert_class(x_reactive, "reactive")
super$initialize(
x = x,
x_reactive = x_reactive,
slice = slice,
extract_type = extract_type
)
checkmate::assert_multi_class(slice$choices, c("POSIXct", "POSIXlt"), null.ok = TRUE)
private$set_choices(slice$choices)
if (is.null(slice$selected)) slice$selected <- slice$choices
private$set_selected(slice$selected)
})
invisible(self)
},
#' @description
#' Returns reproducible condition call for current selection.
#' For this class returned call looks like
#' `<varname> >= as.POSIXct(<min>) & <varname> <= <max>)` with optional `is.na(<varname>)`.
#' @param dataname name of data set; defaults to `private$get_dataname()`
#' @return `call`
#'
get_call = function(dataname) {
if (isFALSE(private$is_any_filtered())) {
return(NULL)
}
if (missing(dataname)) dataname <- private$get_dataname()
varname <- private$get_varname_prefixed(dataname)
choices <- private$get_selected()
tzone <- Find(function(x) x != "", attr(as.POSIXlt(choices), "tzone"))
class <- class(choices)[1L]
date_fun <- as.name(
switch(class,
"POSIXct" = "as.POSIXct",
"POSIXlt" = "as.POSIXlt"
)
)
choices <- as.character(choices + c(0, 1))
filter_call <-
call(
"&",
call(
">=",
varname,
as.call(list(date_fun, choices[1L], tz = tzone))
),
call(
"<",
varname,
as.call(list(date_fun, choices[2L], tz = tzone))
)
)
private$add_keep_na_call(filter_call, varname)
}
),
# private members ----
private = list(
# private methods ----
set_choices = function(choices) {
if (is.null(choices)) {
choices <- as.POSIXct(trunc(range(private$x, na.rm = TRUE), units = "secs"))
} else {
choices <- as.POSIXct(choices, units = "secs")
choices_adjusted <- c(
max(choices[1L], min(as.POSIXct(private$x), na.rm = TRUE)),
min(choices[2L], max(as.POSIXct(private$x), na.rm = TRUE))
)
if (any(choices != choices_adjusted)) {
warning(sprintf(
"Choices adjusted (some values outside of variable range). Varname: %s, dataname: %s.",
private$get_varname(), private$get_dataname()
))
choices <- choices_adjusted
}
if (choices[1L] >= choices[2L]) {
warning(sprintf(
"Invalid choices: lower is higher / equal to upper, or not in range of variable values.
Setting defaults. Varname: %s, dataname: %s.",
private$get_varname(), private$get_dataname()
))
choices <- range(private$x, na.rm = TRUE)
}
}
private$set_is_choice_limited(private$x, choices)
private$x <- private$x[
(
as.POSIXct(trunc(private$x, units = "secs")) >= choices[1L] &
as.POSIXct(trunc(private$x, units = "secs")) <= choices[2L]
) | is.na(private$x)
]
private$teal_slice$choices <- choices
invisible(NULL)
},
# @description
# Check whether the initial choices filter out some values of x and set the flag in case.
set_is_choice_limited = function(xl, choices = NULL) {
private$is_choice_limited <- (any(xl < choices[1L], na.rm = TRUE) | any(xl > choices[2L], na.rm = TRUE))
invisible(NULL)
},
cast_and_validate = function(values) {
tryCatch(
expr = {
values <- as.POSIXct(values, origin = "1970-01-01 00:00:00")
if (anyNA(values)) stop()
values
},
error = function(e) stop("Vector of set values must contain values coercible to POSIX.")
)
},
check_length = function(values) {
if (length(values) != 2) stop("Vector of set values must have length two.")
if (values[1] > values[2]) {
warning(
sprintf(
"Start date '%s' is set after the end date '%s', the values will be replaced by a default datetime range.",
values[1], values[2]
)
)
values <- isolate(private$get_choices())
}
values
},
remove_out_of_bounds_values = function(values) {
choices <- private$get_choices()
if (values[1] < choices[1L] || values[1] > choices[2L]) {
warning(
sprintf(
"Value: %s is outside of the range for the column '%s' in dataset '%s', setting minimum possible value.",
values[1], private$get_varname(), toString(private$get_dataname())
)
)
values[1] <- choices[1L]
}
if (values[2] > choices[2L] | values[2] < choices[1L]) {
warning(
sprintf(
"Value: '%s' is outside of the range for the column '%s' in dataset '%s', setting maximum possible value.",
values[2], private$get_varname(), toString(private$get_dataname())
)
)
values[2] <- choices[2L]
}
values
},
# shiny modules ----
# @description
# UI Module for `DatetimeFilterState`.
# This UI element contains two date-time selections for `min` and `max`
# of the range and a checkbox whether to keep the `NA` values.
# @param id (`character(1)`) `shiny` module instance id.
ui_inputs = function(id) {
ns <- NS(id)
isolate({
ui_input_1 <- shinyWidgets::airDatepickerInput(
inputId = ns("selection_start"),
value = private$get_selected()[1],
startView = private$get_selected()[1],
timepicker = TRUE,
minDate = private$get_choices()[1L],
maxDate = private$get_choices()[2L],
update_on = "close",
addon = "none",
position = "bottom right"
)
ui_input_2 <- shinyWidgets::airDatepickerInput(
inputId = ns("selection_end"),
value = private$get_selected()[2],
startView = private$get_selected()[2],
timepicker = TRUE,
minDate = private$get_choices()[1L],
maxDate = private$get_choices()[2L],
update_on = "close",
addon = "none",
position = "bottom right"
)
ui_reset_1 <- actionButton(
class = "date_reset_button",
inputId = ns("start_date_reset"),
label = NULL,
icon = icon("fas fa-undo")
)
ui_reset_2 <- actionButton(
class = "date_reset_button",
inputId = ns("end_date_reset"),
label = NULL,
icon = icon("fas fa-undo")
)
ui_input_1$children[[2]]$attribs <- c(ui_input_1$children[[2]]$attribs, list(class = "input-sm"))
ui_input_2$children[[2]]$attribs <- c(ui_input_2$children[[2]]$attribs, list(class = "input-sm"))
tags$div(
tags$div(
class = "flex",
ui_reset_1,
tags$div(
class = "flex w-80 filter_datelike_input",
tags$div(class = "w-45 text-center", ui_input_1),
tags$span(
class = "input-group-addon w-10",
tags$span(class = "input-group-text w-100 justify-content-center", "to"),
title = "Times are displayed in the local timezone and are converted to UTC in the analysis"
),
tags$div(class = "w-45 text-center", ui_input_2)
),
ui_reset_2
),
private$keep_na_ui(ns("keep_na"))
)
})
},
# @description
# Server module
# @param id (`character(1)`) `shiny` module instance id.
# @return `NULL`.
server_inputs = function(id) {
moduleServer(
id = id,
function(input, output, session) {
logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
# this observer is needed in the situation when teal_slice$selected has been
# changed directly by the api - then it's needed to rerender UI element
# to show relevant values
private$observers$selection_api <- observeEvent(
ignoreNULL = TRUE, # dates needs to be selected
ignoreInit = TRUE, # on init selected == default, so no need to trigger
eventExpr = private$get_selected(),
handlerExpr = {
start_date <- input$selection_start
end_date <- input$selection_end
if (!all(private$get_selected() == c(start_date, end_date))) {
logger::log_trace("DatetimeFilterState$server@1 state changed, id: { private$get_id() }")
if (private$get_selected()[1] != start_date) {
shinyWidgets::updateAirDateInput(
session = session,
inputId = "selection_start",
value = private$get_selected()[1]
)
}
if (private$get_selected()[2] != end_date) {
shinyWidgets::updateAirDateInput(
session = session,
inputId = "selection_end",
value = private$get_selected()[2]
)
}
}
}
)
private$observers$selection_start <- observeEvent(
ignoreNULL = TRUE, # dates needs to be selected
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
eventExpr = input$selection_start,
handlerExpr = {
logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
start_date <- input$selection_start
end_date <- private$get_selected()[[2]]
tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))
attr(start_date, "tzone") <- tzone
if (start_date > end_date) {
showNotification(
"Start date must not be greater than the end date. Ignoring selection.",
type = "warning"
)
shinyWidgets::updateAirDateInput(
session = session,
inputId = "selection_start",
value = private$get_selected()[1] # sets back to latest selected value
)
return(NULL)
}
private$set_selected(c(start_date, end_date))
}
)
private$observers$selection_end <- observeEvent(
ignoreNULL = TRUE, # dates needs to be selected
ignoreInit = TRUE, # ignoreInit: should not matter because we set the UI with the desired initial state
eventExpr = input$selection_end,
handlerExpr = {
start_date <- private$get_selected()[1]
end_date <- input$selection_end
tzone <- Find(function(x) x != "", attr(as.POSIXlt(private$get_choices()), "tzone"))
attr(end_date, "tzone") <- tzone
if (start_date > end_date) {
showNotification(
"End date must not be lower than the start date. Ignoring selection.",
type = "warning"
)
shinyWidgets::updateAirDateInput(
session = session,
inputId = "selection_end",
value = private$get_selected()[2] # sets back to latest selected value
)
return(NULL)
}
private$set_selected(c(start_date, end_date))
logger::log_trace("DatetimeFilterState$server@2 selection changed, id: { private$get_id() }")
}
)
private$keep_na_srv("keep_na")
private$observers$reset1 <- observeEvent(
ignoreInit = TRUE, # reset button shouldn't be trigger on init
ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
input$start_date_reset,
{
shinyWidgets::updateAirDateInput(
session = session,
inputId = "selection_start",
value = private$get_choices()[1L]
)
logger::log_trace("DatetimeFilterState$server@2 reset start date, id: { private$get_id() }")
}
)
private$observers$reset2 <- observeEvent(
ignoreInit = TRUE, # reset button shouldn't be trigger on init
ignoreNULL = TRUE, # it's impossible and wrong to set default to NULL
input$end_date_reset,
{
shinyWidgets::updateAirDateInput(
session = session,
inputId = "selection_end",
value = private$get_choices()[2L]
)
logger::log_trace("DatetimeFilterState$server@3 reset end date, id: { private$get_id() }")
}
)
logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
NULL
}
)
},
server_inputs_fixed = function(id) {
moduleServer(
id = id,
function(input, output, session) {
logger::log_trace("DatetimeFilterState$server initializing, id: { private$get_id() }")
output$selection <- renderUI({
vals <- format(private$get_selected(), usetz = TRUE, nsmall = 3)
tags$div(
tags$div(icon("clock"), vals[1]),
tags$div(span(" - "), icon("clock"), vals[2])
)
})
logger::log_trace("DatetimeFilterState$server initialized, id: { private$get_id() }")
NULL
}
)
},
# @description
# UI module to display filter summary
# renders text describing selected date range and
# if NA are included also
content_summary = function(id) {
selected <- format(private$get_selected(), "%Y-%m-%d %H:%M:%S")
min <- selected[1]
max <- selected[2]
tagList(
tags$span(
class = "filter-card-summary-value",
HTML(min, "–", max)
),
tags$span(
class = "filter-card-summary-controls",
if (private$na_count > 0) {
tags$span("NA", if (isTRUE(private$get_keep_na())) icon("check") else icon("xmark"))
}
)
)
}
)
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.