Merge pull request #20 from nick-youngblut/master

Added civilian time and width option for timeInput (solves #12 and solves #19)

DESCRIPTION

@@ -2,9 +2,17 @@ Package: shinyTime
 Type: Package
 Title: A Time Input Widget for Shiny
 Version: 1.0.3.9000
-Authors@R: person("Gerhard", "Burger", email = "[email protected]", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-1062-5576"))
+Authors@R: c(
+    person("Gerhard", "Burger", 
+           email = "[email protected]", 
+           role = c("aut", "cre"), 
+           comment = c(ORCID = "0000-0003-1062-5576")),
+    person("Nick", "Youngblut", 
+           role = c("aut"), 
+           comment = c(ORCID = "0000-0002-7424-5276"))
+    )
 Description: Provides a time input widget for Shiny. This widget allows intuitive time input in the
-    '[hh]:[mm]:[ss]' or '[hh]:[mm]' (24H) format by using a separate numeric input for each time
+    '[hh]:[mm]:[ss]' or '[hh]:[mm]' (24H and 12H) format by using a separate numeric input for each time
     component. The interface with R uses date-time objects. See the project page for more
     information and examples.
 License: GPL-3 | file LICENSE
@@ -14,10 +22,11 @@ Imports:
 URL: https://burgerga.github.io/shinyTime/,
     https://github.com/burgerga/shinyTime
 BugReports: https://github.com/burgerga/shinyTime/issues
-RoxygenNote: 7.2.1
+RoxygenNote: 7.3.1
 Encoding: UTF-8
 Language: en-US
 Suggests:
     testthat (>= 2.1.0),
     spelling,
-    hms
+    hms,
+    bslib

R/input-time.R

@@ -15,6 +15,7 @@
 #' @param seconds Show input for seconds. Defaults to TRUE.
 #' @param minute.steps Round time to multiples of \code{minute.steps} (should be a whole number).
 #' If not NULL sets \code{seconds} to \code{FALSE}.
+#' @param use.civilian Use civilian time (12-hour format) instead of 24-hour format.
 #'
 #' @returns Returns a \code{POSIXlt} object, which can be converted to
 #' a \code{POSIXct} object with \code{as.POSIXct} for more efficient storage.
@@ -46,15 +47,19 @@
 #'   timeInput("time6", "Time:", seconds = FALSE),
 #'
 #'   # Use multiples of 5 minutes
-#'   timeInput("time7", "Time:", minute.steps = 5)
+#'   timeInput("time7", "Time:", minute.steps = 5),
+#'
+#'   # Use civilian (non-military time)
+#'   timeInput("time8", "Time:", use.civilian = TRUE)
 #' )
 #'
 #' shinyApp(ui, server = function(input, output) { })
 #' }
 #'
 #' @importFrom htmltools tagList singleton tags
 #' @export
-timeInput <- function(inputId, label, value = NULL, seconds = TRUE, minute.steps = NULL) {
+timeInput <- function(inputId, label, value = NULL, seconds = TRUE,
+                      minute.steps = NULL, use.civilian = FALSE, width = NULL) {
   if(is.null(value)) value <- getDefaultTime()
   if(is.character(value)) value <- strptime(value, format = "%T")
   if(!is.null(minute.steps)) {
@@ -63,21 +68,75 @@ timeInput <- function(inputId, label, value = NULL, seconds = TRUE, minute.steps
     value <- roundTime(value, minute.steps)
   }
   value_list <- dateToTimeList(value)
-  style <- "width: 8ch"
+
+  div_style <- htmltools::css(width = shiny::validateCssUnit(width))
+  el_width <- "65px"
+  el_style <- htmltools::css(`min-width` = shiny::validateCssUnit(el_width),
+                             flex = "1 1 auto")
+
   input.class <- "form-control"
+  # Set hour values
+  if(use.civilian){
+    min_hour <- "1"
+    max_hour <- "12"
+    value_hour <- as.numeric(value_list$hour)
+    if(value_hour == 0){
+      value_hour <- 12
+    } else if(value_hour > 12){
+      value_hour <- value_hour - 12
+    }
+  } else {
+    min_hour <- "0"
+    max_hour <- "23"
+    value_hour = as.character(value_list$hour)
+  }
+  # Create UI input
   tagList(
     singleton(tags$head(
       tags$script(src = "shinyTime/input_binding_time.js")
     )),
-    tags$div(id = inputId, class = "my-shiny-time-input form-group shiny input-container",
+    tags$div(
+      id = inputId,
+      class = "my-shiny-time-input form-group shiny-input-container",
+      style = div_style,
       shinyInputLabel(inputId, label, control = TRUE),
-      tags$div(class = "input-group",
-        tags$input(type="number", min="0", max="23", step="1", value = value_list$hour,
-                   style = style, class = paste(c(input.class, 'shinytime-hours'), collapse = " ")),
-        tags$input(type="number", min="0", max="59", step=minute.steps, value = value_list$min,
-                   style = style, class = paste(c(input.class, 'shinytime-mins'), collapse = " ")),
-        if(seconds) tags$input(type="number", min="0", max="59", step="1", value = value_list$sec,
-                   style = style, class = paste(c(input.class, 'shinytime-secs'), collapse =  " ")) else NULL
+      tags$div(
+        class = "input-group",
+        style = htmltools::css(display = "flex",
+                               `flex-direction` = "row",
+                               `flex-wrap` = "nowrap"),
+        tags$input(
+          type="number", min = min_hour, max = max_hour, step = "1",
+          value = value_hour, style = el_style,
+          class = paste(c(input.class, 'shinytime-hours'), collapse = " ")
+        ),
+        tags$input(
+          type="number", min = "0", max = "59", step = minute.steps,
+          value = value_list$min, style = el_style,
+          class = paste(c(input.class, 'shinytime-mins'), collapse = " ")
+        ),
+        if(seconds){
+          tags$input(
+            type="number", min = "0", max = "59", step = "1",
+            value = value_list$sec, style = el_style,
+            class = paste(c(input.class, 'shinytime-secs'), collapse =  " ")
+          )
+        } else NULL,
+        if(use.civilian){
+          tags$select(
+            tags$option(
+              value = "AM", "AM",
+              selected = if(value_list$civilian == "AM") TRUE else NULL
+            ),
+            tags$option(
+              value = "PM", "PM",
+              selected = if(value_list$civilian == "PM") TRUE else NULL
+            ),
+            style = htmltools::css(`min-width` = shiny::validateCssUnit("70px"),
+                                   flex = "1 1 auto"),
+            class = paste(c(input.class, 'shinytime-civilian'), collapse =  " ")
+          )
+        } else NULL
       )
     )
   )
@@ -113,7 +172,7 @@ timeInput <- function(inputId, label, value = NULL, seconds = TRUE, minute.steps
 #' @export
 updateTimeInput <- function(session, inputId, label = NULL, value = NULL) {
   value <- dateToTimeList(value)
-  message <- dropNulls(list(label=label, value = value))
+  message <- dropNulls(list(label = label, value = value))
   session$sendInputMessage(inputId, message)
 }
 
@@ -127,3 +186,12 @@ updateTimeInput <- function(session, inputId, label = NULL, value = NULL) {
 shinyTimeExample <- function() {
   runApp(system.file('example', package='shinyTime', mustWork=T), display.mode='showcase')
 }
+
+#' Show the shinyTime debug app
+#'
+#' App to test the input with a variety of options
+#'
+#' @importFrom shiny runApp
+shinyTimeDebug <- function() {
+  runApp(system.file('debug', package='shinyTime', mustWork=T), display.mode='normal')
+}

R/utils.R

@@ -1,6 +1,11 @@
 # Some utility functions
 
 # Copied from shiny/R/input-utils.R
+#' Create a label tag for a given input
+#' @param inputId The input ID
+#' @param label The label text
+#' @param control Whether the label is for a control (e.g., a checkbox)
+#' @return A label tag
 shinyInputLabel <- function(inputId, label = NULL, control = FALSE) {
   classes <- c(
     if (is.null(label)) "shiny-label-null",
@@ -15,34 +20,59 @@ shinyInputLabel <- function(inputId, label = NULL, control = FALSE) {
 
 # Given a vector or list, drop all the NULL items in it
 # Copied from shiny/R/utils.R
+#' Drop NULL values from vector/lists
+#' @param x A vector or list
+#' @return A vector or list with all the NULL items removed
 dropNulls <- function(x) {
   x[!vapply(x, is.null, FUN.VALUE=logical(1))]
 }
 
+#' Convert a time object to a list
+#' @param value A time object
+#' @return A list with the hour, minute and second components
 dateToTimeList <- function(value){
   if(is.null(value)) return(NULL)
   posixlt_value <- unclass(as.POSIXlt(value))
   time_list <- lapply(posixlt_value[c('hour', 'min', 'sec')], function(x) {
     sprintf("%02d", trunc(x))
   })
+  time_list[["civilian"]] <- ifelse(posixlt_value$hour < 12, "AM", "PM")
   return(time_list)
 }
 
+#' Convert a list to a time object
+#' @param value A list with the hour, minute and second components
+#' @return A time object
 timeListToDate <- function(value) {
   timeStringToDate(paste(c(value$hour, value$min, value$sec), collapse = ':'))
 }
 
+#' Convert a string to a time object
+#' @param string A string with the time in the format "HH:MM:SS"
+#' @return A time object
 timeStringToDate <- function(string) {
   strptime(string, format = "%T")
 }
 
+#' Get the default time
+#' @return A time object with the value "00:00:00"
 getDefaultTime <- function(){
   timeStringToDate("00:00:00")
 }
 
-# From ?is.integer
-is.wholenumber <- function(x, tol = .Machine$double.eps^0.5)  abs(x - round(x)) < tol
+#' Round a time object to the nearest minute
+#' From ?is.integer
+#' @param x A time object
+#' @param tol The tolerance for rounding
+#' @return A time object rounded to the nearest minute
+is.wholenumber <- function(x, tol = .Machine$double.eps^0.5){
+  abs(x - round(x)) < tol
+}
 
+#' Round a time object to the nearest minute
+#' @param time A time object
+#' @param minutes The number of minutes to round to
+#' @return A time object rounded to the nearest minute
 roundTime <- function(time, minutes) {
   stopifnot(any(class(time) %in% c("POSIXt", "hms")))
   stopifnot(is.wholenumber(minutes))

R/zzz.R

@@ -10,6 +10,8 @@
 .onLoad <- function(libname, pkgname) {
   # Add directory for static resources
   addResourcePath('shinyTime', system.file('www', package='shinyTime', mustWork = TRUE))
+  # Make shinyTime work with running devtools::load_all(".") multiple times
+  removeInputHandler('my.shiny.timeInput')
   # Do some processing on the data we get from javascript before we pass it on to R
   registerInputHandler('my.shiny.timeInput', function(data, ...) {
     # Replace NULL by 0

inst/debug/app.R

@@ -0,0 +1,85 @@
+library(shiny)
+library(bslib)
+library(shinyTime)
+
+start_time <- "23:34:56"
+
+getTimeInput <- local({
+  nTimeInputs <- 0
+  timeInputs <- c()
+  function(label = NULL, value = strptime(start_time, "%T"), ...) {
+    nTimeInputs <<- nTimeInputs + 1
+    if(is.null(label)) label <- paste("genTimeInput", nTimeInputs)
+    id <- paste0("gen_time_input", nTimeInputs)
+    timeInputs <<- c(timeInputs, id)
+    timeInput(id, label, value, ...)
+  }
+})
+
+getTimeInputs <- function(widths, ...) {
+  purrr::map(widths, \(x) getTimeInput(width = paste0(x, "px"), ...))
+}
+
+widths <- seq(100,500,50)
+
+cards <- list(
+  card(
+    full_screen = TRUE,
+    card_header("Width"),
+    layout_column_wrap(
+      width = 1/3,
+      card(
+        card_header("5-minute steps"),
+        !!!getTimeInputs(widths = widths, minute.steps = 5)
+      ),
+      card(
+        card_header("24H"),
+        !!!getTimeInputs(widths = widths)
+      ),
+      card(
+        card_header("12H"),
+        !!!getTimeInputs(widths = widths, use.civilian = TRUE)
+      )
+    )
+  ),
+  card(
+    full_screen = TRUE,
+    card_header("Alignment"),
+    card(
+        textInput("text_example", 'Example text input'),
+        getTimeInput(label = "Enter time"),
+        getTimeInput(label = "Enter time (5 minute steps)", minute.steps = 5),
+        getTimeInput(label = "Enter time (civilian)", use.civilian = TRUE)
+    )
+  )
+)
+
+sb <- sidebar(
+  timeInput("source_time", "Desired time",
+            value = strptime("00:00:00", "%T")),
+
+  actionButton("to_desired_time", "Apply desired time"),
+  actionButton("to_current_time", "Set to current time")
+)
+
+ui <- page_navbar(
+  title = "shinyTimeDebug",
+  sidebar = sb,
+  nav_spacer(),
+  nav_panel("Width", cards[[1]]),
+  nav_panel("Alignment", cards[[2]])
+)
+
+server <- function(input, output, session) {
+  updateAllTimeInputs <- function(time, update_source = F) {
+    timeInputIds <- get("timeInputs", envir = environment(getTimeInput))
+    if(update_source) timeInputIds <- c("source_time",timeInputIds)
+    purrr::map(timeInputIds, \(x) updateTimeInput(session, x, value = time))
+  }
+
+  observeEvent(input$to_current_time, updateAllTimeInputs(Sys.time(), update_source = T))
+  observeEvent(input$to_desired_time, updateAllTimeInputs(input$source_time))
+
+}
+
+shinyApp(ui, server)

inst/example/app.R

@@ -9,31 +9,53 @@
 library(shiny)
 library(shinyTime)
 
+start_time <- "23:34:56"
+
 ui <- fluidPage(
 
    titlePanel("shinyTime Example App"),
 
    sidebarLayout(
+
       sidebarPanel(
-        timeInput("time_input1", "Enter time", value = strptime("12:34:56", "%T")),
-        timeInput("time_input2", "Enter time (5 minute steps)", value = strptime("12:34:56", "%T"), minute.steps = 5),
+        width = 4,
+        timeInput(
+          "time_input1", "Enter time",
+          value = strptime(start_time, "%T")
+        ),
+        timeInput(
+          "time_input2", "Enter time (5 minute steps)",
+          value = strptime(start_time, "%T"),
+          minute.steps = 5,
+          width = "100px"
+        ),
+        timeInput(
+          "time_input3", "Enter time",
+          value = strptime(start_time, "%T"),
+          use.civilian = TRUE,
+          width = "300px"
+        ),
         actionButton("to_current_time", "Current time")
       ),
 
       mainPanel(
+        width = 8,
         textOutput("time_output1"),
-        textOutput("time_output2")
+        textOutput("time_output2"),
+        textOutput("time_output3")
       )
    )
 )
 
 server <- function(input, output, session) {
   output$time_output1 <- renderText(strftime(input$time_input1, "%T"))
   output$time_output2 <- renderText(strftime(input$time_input2, "%R"))
+  output$time_output3 <- renderText(strftime(input$time_input3, "%r"))
 
   observeEvent(input$to_current_time, {
     updateTimeInput(session, "time_input1", value = Sys.time())
     updateTimeInput(session, "time_input2", value = Sys.time())
+    updateTimeInput(session, "time_input3", value = Sys.time())
   })
 
 }