Skip to content

Commit 1e7d35f

Browse files
burgergaburgerga
authored
Merge pull request #20 from nick-youngblut/master
Added civilian time and width option for timeInput (solves #12 and solves #19)
2 parents 3a0212f + 6fafe6a commit 1e7d35f

18 files changed

+484
-28
lines changed

‎DESCRIPTION

+13-4
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,17 @@ Package: shinyTime
22
Type: Package
33
Title: A Time Input Widget for Shiny
44
Version: 1.0.3.9000
5-
Authors@R: person("Gerhard", "Burger", email = "burger.ga@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-1062-5576"))
5+
Authors@R: c(
6+
person("Gerhard", "Burger",
7+
email = "burger.ga@gmail.com",
8+
role = c("aut", "cre"),
9+
comment = c(ORCID = "0000-0003-1062-5576")),
10+
person("Nick", "Youngblut",
11+
role = c("aut"),
12+
comment = c(ORCID = "0000-0002-7424-5276"))
13+
)
614
Description: Provides a time input widget for Shiny. This widget allows intuitive time input in the
7-
'[hh]:[mm]:[ss]' or '[hh]:[mm]' (24H) format by using a separate numeric input for each time
15+
'[hh]:[mm]:[ss]' or '[hh]:[mm]' (24H and 12H) format by using a separate numeric input for each time
816
component. The interface with R uses date-time objects. See the project page for more
917
information and examples.
1018
License: GPL-3 | file LICENSE
@@ -14,10 +22,11 @@ Imports:
1422
URL: https://burgerga.github.io/shinyTime/,
1523
https://github.com/burgerga/shinyTime
1624
BugReports: https://github.com/burgerga/shinyTime/issues
17-
RoxygenNote: 7.2.1
25+
RoxygenNote: 7.3.1
1826
Encoding: UTF-8
1927
Language: en-US
2028
Suggests:
2129
testthat (>= 2.1.0),
2230
spelling,
23-
hms
31+
hms,
32+
bslib

‎R/input-time.R

+80-12
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@
1515
#' @param seconds Show input for seconds. Defaults to TRUE.
1616
#' @param minute.steps Round time to multiples of \code{minute.steps} (should be a whole number).
1717
#' If not NULL sets \code{seconds} to \code{FALSE}.
18+
#' @param use.civilian Use civilian time (12-hour format) instead of 24-hour format.
1819
#'
1920
#' @returns Returns a \code{POSIXlt} object, which can be converted to
2021
#' a \code{POSIXct} object with \code{as.POSIXct} for more efficient storage.
@@ -46,15 +47,19 @@
4647
#' timeInput("time6", "Time:", seconds = FALSE),
4748
#'
4849
#' # Use multiples of 5 minutes
49-
#' timeInput("time7", "Time:", minute.steps = 5)
50+
#' timeInput("time7", "Time:", minute.steps = 5),
51+
#'
52+
#' # Use civilian (non-military time)
53+
#' timeInput("time8", "Time:", use.civilian = TRUE)
5054
#' )
5155
#'
5256
#' shinyApp(ui, server = function(input, output) { })
5357
#' }
5458
#'
5559
#' @importFrom htmltools tagList singleton tags
5660
#' @export
57-
timeInput <- function(inputId, label, value = NULL, seconds = TRUE, minute.steps = NULL) {
61+
timeInput <- function(inputId, label, value = NULL, seconds = TRUE,
62+
minute.steps = NULL, use.civilian = FALSE, width = NULL) {
5863
if(is.null(value)) value <- getDefaultTime()
5964
if(is.character(value)) value <- strptime(value, format = "%T")
6065
if(!is.null(minute.steps)) {
@@ -63,21 +68,75 @@ timeInput <- function(inputId, label, value = NULL, seconds = TRUE, minute.steps
6368
value <- roundTime(value, minute.steps)
6469
}
6570
value_list <- dateToTimeList(value)
66-
style <- "width: 8ch"
71+
72+
div_style <- htmltools::css(width = shiny::validateCssUnit(width))
73+
el_width <- "65px"
74+
el_style <- htmltools::css(`min-width` = shiny::validateCssUnit(el_width),
75+
flex = "1 1 auto")
76+
6777
input.class <- "form-control"
78+
# Set hour values
79+
if(use.civilian){
80+
min_hour <- "1"
81+
max_hour <- "12"
82+
value_hour <- as.numeric(value_list$hour)
83+
if(value_hour == 0){
84+
value_hour <- 12
85+
} else if(value_hour > 12){
86+
value_hour <- value_hour - 12
87+
}
88+
} else {
89+
min_hour <- "0"
90+
max_hour <- "23"
91+
value_hour = as.character(value_list$hour)
92+
}
93+
# Create UI input
6894
tagList(
6995
singleton(tags$head(
7096
tags$script(src = "shinyTime/input_binding_time.js")
7197
)),
72-
tags$div(id = inputId, class = "my-shiny-time-input form-group shiny input-container",
98+
tags$div(
99+
id = inputId,
100+
class = "my-shiny-time-input form-group shiny-input-container",
101+
style = div_style,
73102
shinyInputLabel(inputId, label, control = TRUE),
74-
tags$div(class = "input-group",
75-
tags$input(type="number", min="0", max="23", step="1", value = value_list$hour,
76-
style = style, class = paste(c(input.class, 'shinytime-hours'), collapse = " ")),
77-
tags$input(type="number", min="0", max="59", step=minute.steps, value = value_list$min,
78-
style = style, class = paste(c(input.class, 'shinytime-mins'), collapse = " ")),
79-
if(seconds) tags$input(type="number", min="0", max="59", step="1", value = value_list$sec,
80-
style = style, class = paste(c(input.class, 'shinytime-secs'), collapse = " ")) else NULL
103+
tags$div(
104+
class = "input-group",
105+
style = htmltools::css(display = "flex",
106+
`flex-direction` = "row",
107+
`flex-wrap` = "nowrap"),
108+
tags$input(
109+
type="number", min = min_hour, max = max_hour, step = "1",
110+
value = value_hour, style = el_style,
111+
class = paste(c(input.class, 'shinytime-hours'), collapse = " ")
112+
),
113+
tags$input(
114+
type="number", min = "0", max = "59", step = minute.steps,
115+
value = value_list$min, style = el_style,
116+
class = paste(c(input.class, 'shinytime-mins'), collapse = " ")
117+
),
118+
if(seconds){
119+
tags$input(
120+
type="number", min = "0", max = "59", step = "1",
121+
value = value_list$sec, style = el_style,
122+
class = paste(c(input.class, 'shinytime-secs'), collapse = " ")
123+
)
124+
} else NULL,
125+
if(use.civilian){
126+
tags$select(
127+
tags$option(
128+
value = "AM", "AM",
129+
selected = if(value_list$civilian == "AM") TRUE else NULL
130+
),
131+
tags$option(
132+
value = "PM", "PM",
133+
selected = if(value_list$civilian == "PM") TRUE else NULL
134+
),
135+
style = htmltools::css(`min-width` = shiny::validateCssUnit("70px"),
136+
flex = "1 1 auto"),
137+
class = paste(c(input.class, 'shinytime-civilian'), collapse = " ")
138+
)
139+
} else NULL
81140
)
82141
)
83142
)
@@ -113,7 +172,7 @@ timeInput <- function(inputId, label, value = NULL, seconds = TRUE, minute.steps
113172
#' @export
114173
updateTimeInput <- function(session, inputId, label = NULL, value = NULL) {
115174
value <- dateToTimeList(value)
116-
message <- dropNulls(list(label=label, value = value))
175+
message <- dropNulls(list(label = label, value = value))
117176
session$sendInputMessage(inputId, message)
118177
}
119178

@@ -127,3 +186,12 @@ updateTimeInput <- function(session, inputId, label = NULL, value = NULL) {
127186
shinyTimeExample <- function() {
128187
runApp(system.file('example', package='shinyTime', mustWork=T), display.mode='showcase')
129188
}
189+
190+
#' Show the shinyTime debug app
191+
#'
192+
#' App to test the input with a variety of options
193+
#'
194+
#' @importFrom shiny runApp
195+
shinyTimeDebug <- function() {
196+
runApp(system.file('debug', package='shinyTime', mustWork=T), display.mode='normal')
197+
}

‎R/utils.R

+32-2
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,11 @@
11
# Some utility functions
22

33
# Copied from shiny/R/input-utils.R
4+
#' Create a label tag for a given input
5+
#' @param inputId The input ID
6+
#' @param label The label text
7+
#' @param control Whether the label is for a control (e.g., a checkbox)
8+
#' @return A label tag
49
shinyInputLabel <- function(inputId, label = NULL, control = FALSE) {
510
classes <- c(
611
if (is.null(label)) "shiny-label-null",
@@ -15,34 +20,59 @@ shinyInputLabel <- function(inputId, label = NULL, control = FALSE) {
1520

1621
# Given a vector or list, drop all the NULL items in it
1722
# Copied from shiny/R/utils.R
23+
#' Drop NULL values from vector/lists
24+
#' @param x A vector or list
25+
#' @return A vector or list with all the NULL items removed
1826
dropNulls <- function(x) {
1927
x[!vapply(x, is.null, FUN.VALUE=logical(1))]
2028
}
2129

30+
#' Convert a time object to a list
31+
#' @param value A time object
32+
#' @return A list with the hour, minute and second components
2233
dateToTimeList <- function(value){
2334
if(is.null(value)) return(NULL)
2435
posixlt_value <- unclass(as.POSIXlt(value))
2536
time_list <- lapply(posixlt_value[c('hour', 'min', 'sec')], function(x) {
2637
sprintf("%02d", trunc(x))
2738
})
39+
time_list[["civilian"]] <- ifelse(posixlt_value$hour < 12, "AM", "PM")
2840
return(time_list)
2941
}
3042

43+
#' Convert a list to a time object
44+
#' @param value A list with the hour, minute and second components
45+
#' @return A time object
3146
timeListToDate <- function(value) {
3247
timeStringToDate(paste(c(value$hour, value$min, value$sec), collapse = ':'))
3348
}
3449

50+
#' Convert a string to a time object
51+
#' @param string A string with the time in the format "HH:MM:SS"
52+
#' @return A time object
3553
timeStringToDate <- function(string) {
3654
strptime(string, format = "%T")
3755
}
3856

57+
#' Get the default time
58+
#' @return A time object with the value "00:00:00"
3959
getDefaultTime <- function(){
4060
timeStringToDate("00:00:00")
4161
}
4262

43-
# From ?is.integer
44-
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol
63+
#' Round a time object to the nearest minute
64+
#' From ?is.integer
65+
#' @param x A time object
66+
#' @param tol The tolerance for rounding
67+
#' @return A time object rounded to the nearest minute
68+
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5){
69+
abs(x - round(x)) < tol
70+
}
4571

72+
#' Round a time object to the nearest minute
73+
#' @param time A time object
74+
#' @param minutes The number of minutes to round to
75+
#' @return A time object rounded to the nearest minute
4676
roundTime <- function(time, minutes) {
4777
stopifnot(any(class(time) %in% c("POSIXt", "hms")))
4878
stopifnot(is.wholenumber(minutes))

‎R/zzz.R

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

‎inst/debug/app.R

+85
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,85 @@
1+
library(shiny)
2+
library(bslib)
3+
library(shinyTime)
4+
5+
start_time <- "23:34:56"
6+
7+
getTimeInput <- local({
8+
nTimeInputs <- 0
9+
timeInputs <- c()
10+
function(label = NULL, value = strptime(start_time, "%T"), ...) {
11+
nTimeInputs <<- nTimeInputs + 1
12+
if(is.null(label)) label <- paste("genTimeInput", nTimeInputs)
13+
id <- paste0("gen_time_input", nTimeInputs)
14+
timeInputs <<- c(timeInputs, id)
15+
timeInput(id, label, value, ...)
16+
}
17+
})
18+
19+
getTimeInputs <- function(widths, ...) {
20+
purrr::map(widths, \(x) getTimeInput(width = paste0(x, "px"), ...))
21+
}
22+
23+
widths <- seq(100,500,50)
24+
25+
cards <- list(
26+
card(
27+
full_screen = TRUE,
28+
card_header("Width"),
29+
layout_column_wrap(
30+
width = 1/3,
31+
card(
32+
card_header("5-minute steps"),
33+
!!!getTimeInputs(widths = widths, minute.steps = 5)
34+
),
35+
card(
36+
card_header("24H"),
37+
!!!getTimeInputs(widths = widths)
38+
),
39+
card(
40+
card_header("12H"),
41+
!!!getTimeInputs(widths = widths, use.civilian = TRUE)
42+
)
43+
)
44+
),
45+
card(
46+
full_screen = TRUE,
47+
card_header("Alignment"),
48+
card(
49+
textInput("text_example", 'Example text input'),
50+
getTimeInput(label = "Enter time"),
51+
getTimeInput(label = "Enter time (5 minute steps)", minute.steps = 5),
52+
getTimeInput(label = "Enter time (civilian)", use.civilian = TRUE)
53+
)
54+
)
55+
)
56+
57+
sb <- sidebar(
58+
timeInput("source_time", "Desired time",
59+
value = strptime("00:00:00", "%T")),
60+
61+
actionButton("to_desired_time", "Apply desired time"),
62+
actionButton("to_current_time", "Set to current time")
63+
)
64+
65+
ui <- page_navbar(
66+
title = "shinyTimeDebug",
67+
sidebar = sb,
68+
nav_spacer(),
69+
nav_panel("Width", cards[[1]]),
70+
nav_panel("Alignment", cards[[2]])
71+
)
72+
73+
server <- function(input, output, session) {
74+
updateAllTimeInputs <- function(time, update_source = F) {
75+
timeInputIds <- get("timeInputs", envir = environment(getTimeInput))
76+
if(update_source) timeInputIds <- c("source_time",timeInputIds)
77+
purrr::map(timeInputIds, \(x) updateTimeInput(session, x, value = time))
78+
}
79+
80+
observeEvent(input$to_current_time, updateAllTimeInputs(Sys.time(), update_source = T))
81+
observeEvent(input$to_desired_time, updateAllTimeInputs(input$source_time))
82+
83+
}
84+
85+
shinyApp(ui, server)

‎inst/example/app.R

+25-3
Original file line numberDiff line numberDiff line change
@@ -9,31 +9,53 @@
99
library(shiny)
1010
library(shinyTime)
1111

12+
start_time <- "23:34:56"
13+
1214
ui <- fluidPage(
1315

1416
titlePanel("shinyTime Example App"),
1517

1618
sidebarLayout(
19+
1720
sidebarPanel(
18-
timeInput("time_input1", "Enter time", value = strptime("12:34:56", "%T")),
19-
timeInput("time_input2", "Enter time (5 minute steps)", value = strptime("12:34:56", "%T"), minute.steps = 5),
21+
width = 4,
22+
timeInput(
23+
"time_input1", "Enter time",
24+
value = strptime(start_time, "%T")
25+
),
26+
timeInput(
27+
"time_input2", "Enter time (5 minute steps)",
28+
value = strptime(start_time, "%T"),
29+
minute.steps = 5,
30+
width = "100px"
31+
),
32+
timeInput(
33+
"time_input3", "Enter time",
34+
value = strptime(start_time, "%T"),
35+
use.civilian = TRUE,
36+
width = "300px"
37+
),
2038
actionButton("to_current_time", "Current time")
2139
),
2240

2341
mainPanel(
42+
width = 8,
2443
textOutput("time_output1"),
25-
textOutput("time_output2")
44+
textOutput("time_output2"),
45+
textOutput("time_output3")
2646
)
2747
)
2848
)
2949

3050
server <- function(input, output, session) {
3151
output$time_output1 <- renderText(strftime(input$time_input1, "%T"))
3252
output$time_output2 <- renderText(strftime(input$time_input2, "%R"))
53+
output$time_output3 <- renderText(strftime(input$time_input3, "%r"))
3354

3455
observeEvent(input$to_current_time, {
3556
updateTimeInput(session, "time_input1", value = Sys.time())
3657
updateTimeInput(session, "time_input2", value = Sys.time())
58+
updateTimeInput(session, "time_input3", value = Sys.time())
3759
})
3860

3961
}

0 commit comments

Comments
 (0)