Formatting selectInput() to show character dates to the user - r

I am currently building a shiny app and trying to get a set of dates to render as character strings to the end user, while still keeping their date format when invoked in the server side code.
There might be a simple solution here, but unsure how to get the dates to format in the selectInput dropdown. In my actual use case, using a date slider isn't ideal as the dates do not follow a common interval.
Reproducible example below:
# setup
require(lubridate)
test.dates <- as.Date(c('2014-06-01', '2014-07-01', '2014-08-01',
'2014-09-01', '2014-10-01', '2014-11-01',
'2014-12-01', '2015-01-01','2015-02-01',
'2015-03-01', '2015-04-01'))
test.names <- as.character(paste0(month(test.dates, label = T), ' ',
year(test.dates)))
test.df <- data.frame(date = test.dates)
row.names(test.df) <- test.names
# shiny
server <- function(input, output) {
output$table <- renderTable(test.df)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("test", label = "DATE FORMAT TEST:", choices =
test.df, selected = test.df[1,])
),
mainPanel(tableOutput('table'))
)
)
shinyApp(ui = ui, server = server)

I believe you will find it much easier to pass around character objects than date objects in Shiny. I would simply use the direct character values of your dates and whenever you need them to be date objects in your subsequent analysis explicitly convert to a date object. The following provides an example where both the dropdown and table have the character formatted dates.
require(lubridate)
myDates <- c('2014-06-01', '2014-07-01', '2014-08-01',
'2014-09-01', '2014-10-01', '2014-11-01',
'2014-12-01', '2015-01-01','2015-02-01',
'2015-03-01', '2015-04-01')
test.names <- as.character(paste0(lubridate::month(test.dates, label=TRUE), ' ',
year(test.dates)))
test.df <- data.frame(date = myDates)
row.names(test.df) <- test.names
# shiny
server <- function(input, output) {
output$table <- renderTable(test.df)
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("test", label = "DATE FORMAT TEST:", choices =
myDates, selected = myDates[1])
),
mainPanel(tableOutput('table'))
)
)
shinyApp(ui = ui, server = server)

Related

No "datesdisabled" in updateDateInput in R Shiny?

I built an app in R Shiny which uses time series data that excludes many dates. Within the app a user can select a new dataset, so the dates available will change. I'm using updateDateInput to update the dateInput selector. However, updateDateInput does not seem to allow the datesdisabled function?
Here is a reprex:
library(shiny)
# Sample 3 dates and disable the rest
my_dates <- sample(seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day"), 3)
date_choices <- seq.Date(from = min(my_dates), to = max(my_dates), by = 1)
dates_disabled <- date_choices[!(date_choices %in% my_dates)]
ui <- fluidPage(
dateInput("date", "Select Date",
min = min(date_choices),
max = max(date_choices),
value = max(date_choices),
datesdisabled = dates_disabled),
actionButton("click", "Click Me")
)
server <- function(input, output, session) {
observeEvent(input$click, {
my_dates <- sample(seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day"), 3)
date_choices <- seq.Date(from = min(my_dates), to = max(my_dates), by = 1)
dates_disabled <- date_choices[!(date_choices %in% my_dates)]
updateDateInput(
session,
"date",
min = min(date_choices),
max = max(date_choices),
value = max(date_choices),
datesdisabled = dates_disabled)
})
}
shinyApp(ui, server)
When the button is clicked and the updateDateInput runs, I get this error:
Warning: Error in updateDateInput: unused argument (datesdisabled =
dates_disabled)
I guess there is the option of changing the date to a character and using selectInput? But then I don't get the nice calendar!
You are right, the datesdisabled argument is not available in the update function. You can change the disabled dates by moving the UI declaration into the server and feed it to the client with renderUI().
The sample does not declare the date input in the UI but a uiOutput("date"). The server can dynamically create the dateInput using the datesdisabled argument. This way you can change the disabled dates.
The example will pick only 3 enabled dates after every button click.
# Reprex: The actual implementation of this uses data from a file:
# 1. Reads data file before ui and server are established
# 2. Does a bunch of calculations
# 3. Identifies dates that exist in data file
# 4. The data file is getting updated in the background from another application.
# 5. Allows user to click the button to update the data file. Reprex shows code
# that is used to update the date selector based on new data read. Dates are
# random in reprex, but would come from data file in actual code.
# Sample 3 dates and disable the rest - actual code reads data file here
# and parses out dates that exist in records
my_dates <- seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day")
date_choices <- sample(my_dates, 31-3)
ui <- fluidPage(
uiOutput("date"), textOutput("disabled"),
actionButton("click", "Click Me")
)
server <- function(input, output, session) {
dates_disabled <- reactiveVal(NULL)
# Init 'dates_disabled()' once before Shiny flushes the reactive system with callback,
# using date_choices that exist in original data set
onFlush(fun = function () {dates_disabled(date_choices)}, once = TRUE)
# dateInput widget
output$date <- renderUI({
maxDate <- as.Date(max(setdiff(my_dates, dates_disabled())),
origin = "1970-01-01")
dateInput(input = "date",
label = "Select Date",
min = min(my_dates),
max = max(my_dates),
value = maxDate,
datesdisabled = dates_disabled())
})
# This output makes it easier to test if it works by showing the enabled dates
output$disabled <- renderPrint({
req(dates_disabled()) # only run this when 'dates_disabled' is initialized properly
Enabled <- as.Date(setdiff(seq(as.Date('2021-01-01'), as.Date('2021-01-31'), by = "day"),
dates_disabled()),
origin = '1970-01-01')
paste("Enabled:", paste(Enabled[order(Enabled)], collapse = ", "))
})
# Set new datesdisabled on button click
# Actual code would read updated data file and parse new dates
observeEvent(input$click, {
SelectedDates <- sample(my_dates, 31-3)
dates_disabled( SelectedDates )
})
}
shinyApp(ui, server)

merging selected date and time as date-time variables in shiny

I have the following code that should ask for a date and a time and then merge them together to get a date-time variable, if possible POSIXct.
library(shiny)
library(shinyTime)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
dateInput(inputId='dateRange1',
label = 'Enter initial date: yyyy-mm-dd'),
timeInput("time_input1", "Enter time of the initial day", value = strptime("00:00:00", "%T"))
),
mainPanel(
textOutput("time_output1")
)))
################
server <- function(input, output) {
vals <- reactiveValues()
observe({
vals$initial_date <-paste(as.character(input$dateRange1),strftime(input$time_input1, "%T") , collapse = " - ")
})
output$time_output1 <- renderText(vals$initial_date)
}
shinyApp(ui, server)
I would like the class of vals$initial_date to be "POSIXct" "POSIXt", but I do not manage. I need to make operations with the dates and times. I have tried many things, among other ones I have used:
vals$initial_date<- strptime(vals$initial_date, "%d-%m-%Y %H:%M:%S")
and
vals$initial_date<- as.POSIXct(vals$initial_date, "%d-%m-%Y %H:%M:%S")
inside the 'observe', but it did not work.
Can someone please tell me where my problem is?
thanks!
The time input already has the date component, we can get rid of it if you like. Note that I have added the inherits test to see if the object in the reactiveValues() is of type POSIXct. Also I added some renderText conditional so it displays full datetime oppose to just date when rendering 00:00:00
library(shiny)
library(shinyTime)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
dateInput(inputId='dateRange1',label = 'Enter initial date: yyyy-mm-dd ', value = Sys.Date()),
timeInput("time_input1", "Enter time of the initial day", value = strptime("00:00:00", "%T"))
),
mainPanel(
textOutput("time_output1")
)))
################
server <- function(input, output) {
vals <- reactiveValues()
observe({
testdatetime <- paste(input$dateRange1,strftime(input$time_input1, format="%H:%M:%S"))
testdatetime <- as.POSIXct(testdatetime, format="%Y-%m-%d %H:%M:%S",tz= "UTC")
vals$initial_date <- testdatetime
# Check if the Time is a POSIXct object
test <- inherits(testdatetime, "POSIXct")
print(test)
})
output$time_output1 <- renderText({
value <- as.character(vals$initial_date)
if(nchar(value) == nchar(as.character(Sys.Date()))){
value <- paste(value,"00:00:00 ")
}
value
})
}
shinyApp(ui, server)

using server outputs as input parameters in Shiny

Below you will find some code for a very simple shiny dashboard.
It includes a global list called choice, which has three elements: date.1, date.2 and date.3 (each one is a different date sequence).
The UI includes just three inputs:
One select input which allows the user to select one of our global choices.
One start date input
One end date input.
The server function starts with a reactive expression which creates a vector of our choices selection. Then there are two text outputs which pull the min and max date values of our selection.
What i'm trying to do is use the start.date and end.date outputs to populate the value parameters of the date inputs in the ui, so depending on which choice you select the starting points of the date inputs will change.
library(shiny)
start.date1 <- as.Date("2017-01-01","%Y-%m-%d")
end.date1 <- as.Date("2017-01-31","%Y-%m-%d")
start.date2 <- as.Date("2017-02-01","%Y-%m-%d")
end.date2 <- as.Date("2017-02-28","%Y-%m-%d")
start.date3 <- as.Date("2017-03-01","%Y-%m-%d")
end.date3 <- as.Date("2017-03-31","%Y-%m-%d")
choice <- list()
choice$date.1 <- as.character(seq(start.date1,end.date1,by="week"))
choice$date.2 <- as.character(seq(start.date2,end.date2,by="week"))
choice$date.3 <- as.character(seq(start.date3,end.date3,by="week"))
ui <- fluidPage(
selectInput("select.scenario","select.scenario", choices = names(choice)),
dateInput("start.date","start.date",value = textOutput("start.date")),
dateInput("end.date","end.date",value = textOutput("end.date"))
)
server <- function(input, output) {
dates <- eventReactive(input$select.scenario,{
df <- choice[[as.character(input$select.scenario)]]
})
output$start.date <- renderText({
df <- dates()
start.date <- min(as.Date((df)))
start.date
})
output$end.date <- renderText({
df <- dates()
end.date <- max(as.Date((df)))
end.date
})
}
shinyApp(ui = ui, server = server)
You can't output into the ui definition. Either use uiOutput, or set the values/ranges using the update functions:
library(shiny)
start.date1 <- as.Date("2017-01-01","%Y-%m-%d")
end.date1 <- as.Date("2017-01-31","%Y-%m-%d")
start.date2 <- as.Date("2017-02-01","%Y-%m-%d")
end.date2 <- as.Date("2017-02-28","%Y-%m-%d")
start.date3 <- as.Date("2017-03-01","%Y-%m-%d")
end.date3 <- as.Date("2017-03-31","%Y-%m-%d")
choice <- list()
choice$date.1 <- as.character(seq(start.date1,end.date1,by="week"))
choice$date.2 <- as.character(seq(start.date2,end.date2,by="week"))
choice$date.3 <- as.character(seq(start.date3,end.date3,by="week"))
ui <- fluidPage(
selectInput("select.scenario","select.scenario", choices = names(choice)),
dateInput("start.date","start.date"),
dateInput("end.date","end.date")
)
server <- function(session, input, output) {
dates <- eventReactive(input$select.scenario,{
df <- choice[[as.character(input$select.scenario)]]
})
observeEvent(input$select.scenario, {
updateDateInput(session, "start.date", value=min(as.Date(dates())))
updateDateInput(session, "end.date", value=max(as.Date(dates())))
})
}
shinyApp(ui = ui, server = server)

Display only one value in selectInput in R Shiny app

I am trying to dynamically populate the values of the selectInput from the data file uploaded by the user. The selectInput must contain only numeric columns.
Here is my code snippet for server.R
...
idx <- sapply(data.file, is.numeric)
numeric_columns <- data.file[, idx]
factor_columns <- data.file[, !idx]
updateSelectInput(session, "bar_x", "Select1", choices = names(numeric_columns))
updateSelectInput(session, "bar_y", "Select2", choices = names(factor_columns))
...
Corresponding ui.r
...
selectInput("bar_x", "Select1", choices = NULL),
selectInput("bar_y", "Select2", choices = NULL)
...
The code works fine as long as there are more than one values in any dropdown. However, it fails as soon as it encounters only one value to be displayed in the selectInput.
How can I handle this specific condition, given that the data is uploaded and it cannot be controlled if there is just one column as numeric?
It appears that in 2019, this issue still exists. The issue that I have seen is that when there is only one option in the dropdown, the name of the column is displayed instead of the one option.
This appears to only be a graphical problem, as querying the value for the selectInput element returns the correct underlying data.
I was unable to figure out why this problem exists, but an easy way around this bug is to simply change the name of the column so that it looks like the first element in the list.
library(shiny)
ui <- fluidPage(
selectInput("siExample",
label = "Example Choices",
choices = list("Loading...")),
)
server <- function(input, output, session) {
# load some choices into a single column data frame
sampleSet <- data.frame(Example = c("test value"))
# rename the set if there is only one value
if (length(sampleSet$Example) == 1) {
# This should only be done on a copy of your original data,
# you don't want to accidentally mutate your original data set
names(sampleSet) <- c(sampleSet$Example[1])
}
# populate the dropdown with the sampleSet
updateSelectInput(session,
"siExample",
choices = sampleSet)
}
shinyApp(ui = ui, server = server)
Info: Code was adapted by OP to make error reproducible.
To solve your issue use val2 <- val[,idx, drop = FALSE]
You dropped the column names by subsetting the data.frame().
To avoid this use drop = FALSE; see Keep column name when select one column from a data frame/matrix in R.
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
# drj's changes START block 1
#selectInput('states', 'Select states', choices = c(1,2,4))
selectInput('states', 'Select states', choices = NULL)
# drj's changes END block 1
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
observe({
#drj's changes START block 2
#val <- c(1,2,3)
#names(val) <- c("a","b","c")
#updateSelectInput(session, 'states', 'Select states', choices = names(val[1]))
val <- as.data.frame(cbind(c("_1","_2","_3"), c(4, 4, 6)))
names(val) <- c("a","b")
val$b <- as.numeric(val$b)
idx <- sapply(val, is.numeric)
val2 <- val[,idx, drop = FALSE]
updateSelectInput(session, 'states', 'Select states', choices = names(val2))
#drj's changes END block 2
})
}
# Run the application
shinyApp(ui = ui, server = server)

Using multiple reactive values

I am trying to create a shiny R application where the user inputs 2 dates: the start date and the end date(assuming that the user will choose either of the dates for a particular week).By choosing the dates the user will be able to see how much he will be selling each item from a list of items next week within those days. I have been provided with data on what percent of total sales happen each day within a week. Using that and using data on sales of each item from past week I have tried to create the app. However I think I am making some error while using the reactive expression. Any help will be greatly appreciated. I have provided the code below.
ui.R
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
dateInput('Start_Date',label = "starting on:",value = Sys.Date())
dateInput('End_Date',label = "Ending on:",value = Sys.Date())
),
mainPanel(
tableoutput("mytable")
)
)
))
server.R
library(shiny)
library(stats)
shinyServer(function(input, output) {
Days<-c("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday")
Percent_sales_by_day<-c(.10,.14,.14,.14,.14,.17,.17)
Data_days<-data.frame(Days,Percent)
items_sold<-c("A","B","C","D")
sales_last_week<-c("100","200","300","800")
Data_sales<-data.frame(items_sold,sales_last_week)
Day_vector<-reactive({
weekdays(seq(as.Date(input$Start_Date),as.Date(input$End_Date),by = "days"))
})
Daily_split_vector<-reactive({
library(dplyr)
Data_days%>%
filter(Days %in% Day_vector())
Data_days$Percent_sales_by_day
})
Daily_split_value<-reactive({
sum(Daily_split_vector())
})
Forecast<-reactive({
Data_sales%>%
mutate(sales_last_week=sales_last_week* Daily_split_value())
})
output$mytable<-renderTable({
Forecast()
})
})
I'm not 100% clear on your underlying objective, but regardless the code below runs for me. I tried to comment all of the changes I made - they were mostly just minor syntactic errors - but let me know if you would like me to clarify anything.
ui.R:
library(shiny)
##
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
dateInput(
'Start_Date',
label = "starting on:",
value = Sys.Date()
), ## added comma
dateInput(
'End_Date',
label = "Ending on:",
value = Sys.Date())
),
mainPanel(
tableOutput("mytable") ## 'tableOutput' not 'tableoutput'
)
)
))
server.R:
library(shiny)
library(dplyr)
options(stringsAsFactors=F) ## try to avoid factors unless you
## specifically need them
##
shinyServer(function(input, output) {
Days <- c(
"Sunday","Monday","Tuesday","Wednesday",
"Thursday","Friday","Saturday")
Percent_sales_by_day <- c(
.10,.14,.14,.14,.14,.17,.17)
Data_days <- data.frame(
Days,
Percent_sales_by_day) ## changed from 'Percent'
items_sold <- c("A","B","C","D")
sales_last_week <- c(
100,200,300,800) ## changed from character (???) to numeric type
Data_sales <- data.frame(
items_sold,
sales_last_week)
Day_vector <- reactive({
weekdays(
seq.Date(
as.Date(input$Start_Date),
as.Date(input$End_Date),
by = "day"))
})
Daily_split_vector <- reactive({
Data_days %>%
filter(Days %in% Day_vector()) %>% ## added pipe
## Data_days$Percent_sales_by_day ## changed this line
select(Percent_sales_by_day) ## to this line
})
Daily_split_value <- reactive({
sum(Daily_split_vector())
})
Forecast <- reactive({
Data_sales%>%
mutate(
sales_last_week=sales_last_week* Daily_split_value())
})
output$mytable <- renderTable({
Forecast()
})
})

Resources