Using multiple reactive values - r

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()
})
})

Related

I have some problem with a reactive table in Shiny R

I'm trying to create a dashboard using shiny in R, but I'm facing some little problems
I have:
db is my data.frame with:
db$domain:chr,
db$date:chr,
db$value:num.
So I've created:
db_4 <- reactive({ subset(db,db$domain %in% input$domain &
db$date<=input$daterange[2] & db$date>=input$daterange[1]})
the inputs are:
input$domain: selectinput with multiple choices,
input$date: daterangeinput.
I'm trying to create a table that gives me the sum of the db$value, aggregated by db$date. I've tried something like:
output$table2 <- rendertable ({aggregate(db_4()["value"], by=list(db_4()["date"]), sum) })
but I get always an empty table.
Can anybody help me in solving this little issue?
Thx a lot
I would highly recommend you to read this article about debugging.
In Shiny you can use the browser() function within both reactive and render functions. It should help you locate the problem (i.e.: data has the expected structure)
It seems the problem is with the aggregate function: db_4()["date"] returns a data.frame, where you need a vector.
Solution:
library(shiny)
db <- data.frame(
domain = letters[1:3],
date = seq(
from = as.Date("2019-01-01"),
to = as.Date("2019-06-01"),
by = "1 months"
),
value = runif(12)
)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("domain", "Domain", choices = unique(db$domain)),
dateRangeInput("daterange", "Date",
min = min(db$date), max = max(db$date),
start = min(db$date), end = max(db$date))
),
mainPanel(
tableOutput("table2")
)
)
)
server <- function(input, output, session) {
db_4 <- reactive( {
subset(db,
db$domain %in% input$domain &
db$date<=input$daterange[2] &
db$date>=input$daterange[1]
)
})
output$table2 <- renderTable( {
req(db_4()) # Don't render table when db_4() is NULL
# Uncomment next line to check if everything goes as expected
#browser()
aggregate(
data.frame(value = db_4()$value),
by=list(date = as.factor(db_4()$date)),
sum
)
})
}
shinyApp(ui, server)
Also I would highly recommend sharing the code of your minimal example including some dummy data, so that it can be copy-pasted in an instant. It would increase the chances of someone answering.

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)

Change reactive time for dygraph's dyRangeSelector in Shiny

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.

Dynamic select input not working with loaded data

Using R shiny, I am developing a simple app that allows user to input data from a Rdata file. I want the app to load the data, show the names of numeric variables in a select input field, and after the user selected one of variables do some analysis. But I can not get it working. In the code provided I obtain two outputs: summary, which works fine, and the MEAN of the selected variable which I can not get work.
server.R
library(shiny)
library(shinydashboard)
library(data.table)
library(DT)
shinyServer(function(input, output) {
#### DATA LOAD
df <- reactive({
df <- input$datafile
if (is.null(df)) {
# User has not uploaded a file yet
return(NULL)
}
objectsLoaded <- load(input$datafile$name)
# the above returns a char vector with names of objects loaded
df <- eval(parse(text=objectsLoaded[1]))
# the above finds the first object and returns it
df<-data.table(df)
})
#### SELECTS
num <- reactive({
num <- sapply(df(),is.numeric)
num <- names(num)
})
output$var_num <- renderUI({
vector.num <- as.vector(num())
selectInput("var_num", "Select Variables :", as.list(vector.num), multiple = FALSE)
})
#### OUTPUTS
### SUMMARY
output$summary_num <-renderDataTable({
x<-t(sapply(df(), summary))
x<-as.data.frame(x)
x<-setDT(x, keep.rownames = TRUE)[]
colnames(x) <- c("Variable","Mínimo","1er Quartil", "Mediana", "Media", "3er Quartil","Máximo")
datatable(x)
})
### MEAN OF SELECTED VAR
output$test <-renderPrint ({
if(is.null(df()))
return()
dat<- df()
dat <- dat[,num(), drop = FALSE]
mean(dat[,input$var_num])
})
})
UI.R
dashboardPage(
dashboardHeader(title = "TITLE", titleWidth = 500),
dashboardSidebar(disable = TRUE), #---> fin SIDEBAR
dashboardBody(
fluidRow(
box(width=12, status = "primary",
tabsetPanel(
tabPanel("Test",
fileInput("datafile", label = h3("File input")),
uiOutput("var_num"),
br(),hr(),br(),
fluidRow(column(width=4, uiOutput("var_caracter"),textOutput("test"))),
br(),hr(),br(),
fluidRow(column(width=8, "Variables Numericas", dataTableOutput("summary_num")))
)
) # fin tabsetPanel
) # fin box
)# fin fluidRow
)# fin dashboardBody
)# fin dashboardPage
When I run the app everything goes fine (select input, summary, etc) except the calculation and printing of the MEAN of the selected variable. I guess for some reason the subsetted dataframe is empty, but I do not know why...
Any help will be great! Thanks in advance.
I get it working.
The solution was to define the dataset I used as.data.frame:
### MEAN OF SELECTED VAR
output$test <-renderPrint ({
if(is.null(df()))
return()
dat<- as.data.frame(df()) ## THIS IS THE CORRECTION
dat <- dat[,num(), drop = FALSE]
mean(dat[,input$var_num])
})
I do not really understand why... The reactive file df() was defined as data.table and dat shoul inherit that, but for some reason it was necesary an explicit definition as dataframe.

Formatting selectInput() to show character dates to the user

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)

Resources