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)
Related
Is there a way to imitate the daysofweekdisabled found in dateInput?
I want people to select only mondays.
Unfortunately, there is no built-in feature of function dateRangeInput. However, one can create a hook to evaluate if a given input is valid or not i.e. both start and end date is on a Monday:
library(shiny)
library(lubridate)
ui <- fluidPage(
dateRangeInput("daterange1", "Date range:",
start = "2001-01-01",
end = "2010-12-31"
),
textOutput("daterange1_valid")
)
server <- function(input, output, session) {
output$daterange1_valid <- renderText({
is_valid <- all(input$daterange1 %>% map_lgl(~ wday(.x, label = TRUE) == "Mon"))
ifelse(is_valid, "valid", "not valid. Start and end must be on a Monday!")
})
}
shinyApp(ui, server)
Another way is to just use two dateInput elements instead. This will allow you to also color days other than Monday grey in the picker.
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)
I'm building a Shiny application where I want to use the dyRangeSelector from dygraphs to provide the input period.
My problem is that I only want the reactive change to fire when the selector receives a "MouseUp"-event, ie., when the user is done with choosing the period. Right now events are dispatched as the selector is moved which results in a lagged app since the computations done for each period take a few seconds. Essentially, Shiny is too reactive for my taste here (I know this it the wrong way round - normally we want the apps to be super reactive).
Can I modify when the reactive request is dispatched?
Here's a small example that shows the problem.
library(quantmod)
library(shiny)
library(dygraphs)
library(magrittr)
# Create simple user interface
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
dygraphOutput("dygraph")
),
mainPanel(
plotOutput("complicatedPlot")
)
)
))
server <- shinyServer(function(input, output) {
## Read the data once.
dataInput <- reactive({
getSymbols("NASDAQ:GOOG", src = "google",
from = "2017-01-01",
auto.assign = FALSE)
})
## Extract the from and to from the selector
values <- reactiveValues()
observe({
if (!is.null(input$dygraph_date_window)) {
rangewindow <- strftime(input$dygraph_date_window[[1]], "%Y-%m-%d")
from <- rangewindow[1]
to <- rangewindow[2]
} else {
from <- "2017-02-01"
to <- Sys.Date()+1
}
values[["from"]] <- from
values[["to"]] <- to
})
## Render the range selector
output$dygraph <- renderDygraph({
dygraph(dataInput()[,4]) %>% dyRangeSelector() %>% dyOptions(retainDateWindow = TRUE)
})
## Render the "complicated" plot
output$complicatedPlot <- renderPlot({
plot(1,1)
text(1,1, values[["from"]])
Sys.sleep(1) ## Inserted to represent computing time
})
})
## run app
runApp(list(ui=ui, server=server))
There is a function in shiny called debounce which might pretty much suit your needs. If you rewrite the limits to a reactive expression (as opposed to observe), you can wrap it into debounce with a specification of time in milliseconds to wait before evaluation. Here is an example with 1000ms:
library(quantmod)
library(shiny)
library(dygraphs)
library(magrittr)
# Create simple user interface
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
dygraphOutput("dygraph")
),
mainPanel(
plotOutput("complicatedPlot")
)
)
))
server <- shinyServer(function(input, output) {
## Read the data once.
dataInput <- reactive({
getSymbols("NASDAQ:GOOG", src = "google",
from = "2017-01-01",
auto.assign = FALSE)
})
## Extract the from and to from the selector
values <- reactiveValues()
limits <- debounce(reactive({
if (!is.null(input$dygraph_date_window)) {
rangewindow <- strftime(input$dygraph_date_window[[1]], "%Y-%m-%d")
from <- rangewindow[1]
to <- rangewindow[2]
} else {
from <- "2017-02-01"
to <- Sys.Date()+1
}
list(from = from,
to = to)
}), 1000)
## Render the range selector
output$dygraph <- renderDygraph({
dygraph(dataInput()[,4]) %>% dyRangeSelector() %>% dyOptions(retainDateWindow = TRUE)
})
## Render the "complicated" plot
output$complicatedPlot <- renderPlot({
plot(1,1)
text(1,1, limits()[["from"]])
Sys.sleep(1) ## Inserted to represent computing time
})
})
## run app
runApp(list(ui=ui, server=server))
This basically means that the reactive expression must be returning the same value for at least 1s to be send to its dependencies. You can experiment with the best time.
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)
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()
})
})