I'm trying to develop a basic R shiny app but facing issues with the processing speed. The procedure is as follows, I need to read csv file of about 500K rows -> split the file into smaller segments -> calculate new features for each segment and display the result. Below are my UI.R and Server.R
UI.R
library(shiny)
library(shinyBS)
library(shinycssloaders)
library(DT)
shinyUI(fluidPage(
mainPanel(
#UI for choosing the file to input
fileInput("file1", label = (" Choose Drivecycle Data "),multiple = F),
#UI for showing the number of Rows in original dataset
fluidRow(
column(8, h4(helpText("Number of rows input dataset"))),
column(3,verbatimTextOutput("totrows", placeholder = TRUE))),
#UI for showing the number of segments the data set had been split into
fluidRow(
column(8, h4(helpText("Number of segmentations"))),
column(3,verbatimTextOutput("totseg", placeholder = TRUE))),
fluidRow(
column(8, downloadButton("subtablednld", label = 'Downloadcsv'))
),
tabsetPanel(
#UI to show the original data set in First tab
tabPanel("Table",icon = icon("table"),withSpinner(DT::dataTableOutput('table'),
type = getOption("spinner.type", default = 8) )),
#UI to show the features of the segments of the orginal dataset in Second Tab
tabPanel("Feature Table",icon = icon("table"),withSpinner(DT::dataTableOutput('table1'),
type = getOption("spinner.type", default = 8) )),
),style = 'width:1000px;height"3000px'
)
)
)
Server.R
library(shiny)
library(earth)
library(tidyr)
options(shiny.maxRequestSize=300*1024^2) #increase the max upload file size
to 30 MB
options(shiny.trace=TRUE)
# Define server logic required to draw a histogram
shinyServer(function(input, output) {
#Function to input data set using UI
dataframe <- reactive( {
### Create a data frame reading data file to be used by other functions..
inFile <- input$file1
data1 <- read.csv(inFile$datapath, header = TRUE)
})
#Display the input dataset
observeEvent(input$file1,output$table <- renderDataTable({dataframe()}))
#Show the number of rows in the input dataset
observeEvent(input$file1,output$totrows<- renderText({nrow(dataframe())}))
#Split the data set
Splitfile <- function(){
split(dataframe(), (seq(nrow(dataframe()))-1) %/% 200)
}
#Show the number of segments the data has been split into
observeEvent(input$file1,output$totseg <-renderText({length(Splitfile())}))
#Acceleration calculation function
Acceleration <- function(){
c <- lapply(1:length(Splitfile()), function(i)
{
acceleration <- c(0,diff(Splitfile()[[i]]$Vehicle.Speed)/2)
})
Splitfile <- mapply(cbind, Splitfile(), "acceleration" = c, SIMPLIFY = F)
Splitfile
}
#Calculating Features
CaclFeatures <- function(){
FileFeatures <- lapply(1:length(Acceleration()), function(i){
Velocity_mean <-round(mean(Acceleration()[[i]]$Vehicle.Speed),digits = 3)
Variance_Velocity <-round(var(Acceleration()[[i]]$Vehicle.Speed)*
((length(Acceleration(
[[i]]$Vehicle.Speed)-1)/length(Acceleration()
[[i]]$Vehicle.Speed))
,digits = 3)
c(Velocity_mean,
Variance_Velocity)
})
FileFeatures<- as.data.frame(do.call(rbind, FileFeatures))
names(FileFeatures)[names(FileFeatures) == 'V1'] <- "Velocity_Mean"
names(FileFeatures)[names(FileFeatures) == 'V2'] <- "Variance_Velocity"
}
#Display the table containing all features of all the segments
output$table1 <- renderDataTable({
CaclFeatures()},options = list(scrollX = TRUE))
#Print to csv
output$subtablednld <- downloadHandler(
filename = function(){
paste("dataset-", ".csv", sep = "")
},
content = function(file){
write.csv(CaclFeatures(), file ,row.names = FALSE)
}
)
})
The app works fine if I read csv file of about 2k rows but does not work if I read data set more than 2k, It will neither give any error nor crash. The spinner keeps rotating but fails to show the result. Also, the same logic when used in regular R script work fine with large data set of more than 500k, rather I'm calculating 22 new features.
Currently, I am using a system of 8gb RAM i5 Processor. Is there a way to enhance the computing speed, when checked within my task manager Rstudio uses only around 47% - 52% of memory, I have no other process running other than R studio
EDIT: Sample data can be created by using the code below,
drive <- as.data.frame(sample(1:50, 500000, replace = T))
Your whole calculation seems to be dependent on some structural properties from your input data.frame, so I can't produce a working example in a reasonable time, with only minor changes to your code.
BUT, your code evaluation is aweful performance wise.
Take Acceleration for example. WITHIN your lapply, you call Splitfile(), which is a regular function. Assume that the number of splits is about 2500, you call this function 2500 times. And the operation split(dataframe(), (seq(nrow(dataframe()))-1) %/% 200) takes about 2 seconds on my computer, so you're waiting 5000 seconds, while the result of Splitfiles() is always the same. And then, inside CalcFeatures, you call Acceleration() again four times inside each lapply loop. That makes for an approximate waiting time of 5 000 * 2 500 * 4 = 50 000 000 seconds or 578 days.
You might have been confused with the concept of reactive where the function call would just return the current value and reevaluation is implicit.
So you either:
Call expensive functions once at the beginning of your function.
Start Acceleration with files <- Splitfiles() and use files from there on.
Start CalcFeatures with acc <- Acceleration() and use acc from there on.
Turn your functions into reactives.
Splitfiles <- reactive({ ... dataframe() ... })
Acceleration <- reactive({ ... Splitfiles() ... })
CalcFeature <- reactive({ ... Acceleration() ... })
A mixture of both concepts is not better. Stick to either one.
Related
I want to build a module in shiny that renders a tabBox with the number of tabPanel as a function of the data. The simulated data (see script below) has the tank or pond variable (column) ("viveiro" in Portuguese) whose quantity can be a variable. So the number of panels is a function of this variable. But the biggest problem is when inside each tabPanel I render a simple table (with renderTable()) that corresponds to a subset of each "viveiro" (tank/pond). I use the lapply() function both to build the renderUI and to assign the reactive expression to the outputs (see the applicable example below). nCiclo() is a reactive that represent the number of "viveiro" (tank/pond as you prefer) that can correspond to a sequence of 1:6 for example. It works well on the first lapply() in renderUI() for output$tab_box, but it doesn't work when I use it on the second lapply() for the output[[paste0('outCiclo',j)]] outputs in renderTable below.
Question:
How do I put this last lapply() function as a function of the number of "viveiro" (tank/pond) in the simulation data? I tried to replace the fix sequence 1:6 for reactive nCiclo() but does not work.
library(shiny)
library(shinydashboard)
library(openxlsx)
rm(list = ls())
#--------------------------------------------------
# Simulated data for the app
(n = 2*sample(3:8,1)) # tank/pond (portuguese viveiro) number (quantity) / random variable in the data
bio <- data.frame(
semana = rep(1:5,n),
peso = rnorm(5*n,85,15),
viveiro = rep(1:2,each=(5*n)/2),
ciclo = rep(1:n,each=5)
)
# An excel file will be saved to your Working Directory
# Use the file to import into the app
write.xlsx(bio,'bio.xlsx')
#--------------------------------------------------
####### Module #######
# UI Module
dashMenuUI <- function(id){
ns <- NS(id)
uiOutput(ns("tab_box"))
}
# Server Module
dashMenuServer <- function(id,df){
moduleServer(id,function(input,output,session){
ns <- session$ns
nCiclo <- reactive(unique(df()$ciclo)) # nCycle is simply 1:6 sequence.
output$tab_box <- renderUI({
do.call(tabBox, c(id='tabCiclo',
lapply(nCiclo(), function(i) {
tabPanel(
paste('ciclo', i),
tableOutput(outputId = ns(paste0('outCiclo',i)) )
)
}))
)
})
# The problem is here. I want to put the lapply function as a function of the pond/tank (portuguese viveiro) number (simulated data).
# but the nCycle() reactive doesn't work in place of 1:6
lapply(1:6, function(j) {
output[[paste0('outCiclo',j)]] <- renderTable({
subset(df(), ciclo==j)
})
})
})
}
#------------------------------------------------------
ui <- dashboardPage(
dashboardHeader(title = "Teste Módulo TabBox Dinâmico"),
dashboardSidebar(
sidebarMenu(
menuItem('Ciclo e viveiro',tabName = 'box_din')
)
),
dashboardBody(
tabItems(
tabItem(tabName='box_din',
fileInput(inputId = "upload",label = "Carregue seu arquivo", accept = c(".xlsx")),
dashMenuUI('tabRender')
)
)
)
)
server <- function(input, output, session) {
dados <- reactive({
req(input$upload)
file <- input$upload
ext <- tools::file_ext(file$datapath)
req(file)
validate(need(ext == "xlsx", "Por gentileza insira um arquivo de Excel (extensão .xlsx)"))
df <- read.xlsx(file$datapath,sheet = 1)
df
})
# Ciclo output
dashMenuServer('tabRender',dados)
}
shinyApp(ui, server)
When running the first session of the script note that you get an excel file (.xlsx) in your Working Directory, it is the simulated data to import into the app. The problem is that the 1:6 sequence is fixed and doesn't vary depending on the data (the cycles above 6 are not rendered in the panels), when I replace 1:6 with nCiclo() (try to test for yourself) (it is found in the server module) doesn't work.
I'm not sure if I made myself clear or if the English are understandable, but I thank you for taking the time to read the problem and help in my learning.
Calling nCicle() must be done in a reactive environment, which #Mikael's solution creates using observeEvent() (see comments). Another way is simply to move the lapply(nCiclo(), ...)) up into the output$tab_box <- renderUI() function:
output$tab_box <- renderUI({
lapply(nCiclo(), function(j) {
output[[paste0('outCiclo',j)]] <- renderTable({
subset(df(), ciclo==j)
})
})
do.call(tabBox, c(id='tabCiclo',
lapply(nCiclo(), function(i) {
tabPanel(
paste('ciclo', i),
tableOutput(outputId = ns(paste0('outCiclo', i)) )
)}
))
)
})
Good example of creating dynamic content in a Shiny app.
I am currently working on a shiny app that runs a series of calculations on a dataset on the fly when someone presses "Calculate". The dataset is very large and a lot of calculations are made via a lapply, which allows the user to track the progress with a progress bar.
This means the generation of the output data frame can be quite slow even when there are potentially results already sitting there just waiting to be displayed. The problem I'm having is that the data is potentially quite time sensitive when something is found and therefore if the calculations take, say, 15 minutes to run, there may have been something to display on the first calculation that is 15 minutes out of date.
Is there a way that after each iteration of the lapply (or feel free to suggest another method) the app can look to see whether there is data there and immediately show it, essentially refreshing the output table after each iteration? Essentially updating the reactive value during the observe rather than after.
I've put below a short example app that may help visualise the problem I'm having:
library(shiny)
testDF <- data.frame(number = c(1:10),
letter = letters[1:10])
ui <- fluidPage(
# UI Input
numericInput(inputId = "attemptDivide", label = "Number to divide by",
value = 1, min = 1, max = 10),
actionButton(inputId = "calculate", label = "Calculate"),
# UI Output
dataTableOutput("dividedTable")
)
# Define server logic
server <- function(input, output) {
# Create a bucket for results
results <- reactiveVal()
# Observe when "Calculate" is pushed and we should work out whether the
# number is perfectly divisible by the input given
observeEvent(input$calculate, {
divisibleDF <- lapply(testDF$number, function(x) {
# Set to sleep for 1 second to simulate for the the lapply being
# bigger and taking more time than this example
Sys.sleep(1)
# Find the row we're interested in
interest <- subset(testDF, number == x)
# Find whether the number is perfectly divisible by the one given
divisible <- (x / input$attemptDivide) %% 1 == 0
# If divisible is TRUE we keep, else we return an empty data frame
if (divisible) {
return(interest)
} else {
return(data.frame(number = integer(), letter = character()))
}
}) %>%
do.call(rbind, .)
# Save the results to bucket
results(divisibleDF)
})
# Create the table
output$dividedTable <- renderDataTable({
results()
})
}
# Run the app
shinyApp(ui = ui, server = server)
Thanks in advance for any help.
The app is asking the user to input predictor & dependent variables. For that I am using renderUI & uiOutput functions in server.R & ui.R files respectively. I am storing these inputs in predvar & depvar variables. Then i am using these variables in my reactive part of the code. This is where i think the problem of connection is between reactive code & user input variables. I have tried using caret::creatdatapartition instead of just createdatapartition.
server.R code
model <- reactive ({
prop = input$prop
predictor = input$predvar
dependent = input$depvar
if(length(predictor)==0){return("Select atleast one predictor")}
if(input$ex==TRUE){data <- datasets::iris}
else{file1 <- input$file
data = read.table(file = file1$datapath,sep =",",header = TRUE)
data = as.data.frame(data)}
set.seed(69)
inTrain <- createDataPartition(y=data$dependent,p=prop,list = FALSE) ## this line throws error
train <- data[inTrain,]
train <- train %>% select(predictor,dependent)
train(dependent~.,data=data,method = "rpart")
})
output$model <- renderPrint({
model()
)}
output$dependent <- renderUI({
if(input$ex==TRUE){
data = datasets::iris
dependents <- select_if(data,is.factor)
selectInput("depvar","Select the dependent variable",choices = colnames(dependents))
}
else{
file1 <- input$file
data = read.table(file = file1$datapath,sep =",",header = TRUE)
dependents <- select_if(data,is.factor)
selectInput("depvar","Select the dependent variable",choices = colnames(dependents))
}
})
output$predictor <- renderUI({
if(input$ex==TRUE){
data = datasets::iris
dependents <- select_if(data,is.numeric)
checkboxGroupInput("predvar","Select the predictor variables",choices = colnames(dependents))
}
else{
file1 <- input$file
data = read.table(file = file1$datapath,sep =",",header = TRUE)
dependents <- select_if(data,is.numeric)
checkboxGroupInput("predvar","Select the predictor variables",choices = colnames(dependents))
}
})
concerning ui.R code
checkboxInput("ex","Uncheck for using your own file",value = TRUE),
fileInput("file", "Upload the *.csv file with headers"),
uiOutput("dependent"),
uiOutput("predictor"),
sliderInput("prop",
"Enter the training data ratio",
min = .5,
max = 1,
value = .6,step = .05)
)
Shiny app output image link
You haven't given us a simple self contained example, so we can't give you a tested answer. But I think I can see at least two problems with your server code.
First, the model reactive looks like it will run then the server function is first called, before your predvar and depvar inputs have been populated. That's going to case a problem, but it's easy to fix: just put req(input$depvar, input$predvar at the start of the reactive. That will make sure the rest of the code in the reactive runs only once you've got values for both these inputs.
Second, the line you identified,
inTrain <- createDataPartition(y=data$dependent,p=prop,list = FALSE)
Says "create a data partition and assign the parameter y the contents of the column named 'dependent' in the data.frame data. What you want to say is "... using the contents of the column whose name is given by the value of my local variable dependent...".
So try
inTrain <- createDataPartition(y=data[[dependent]],p=prop,list = FALSE)
instead.
You may have other issues as well, but they're the two I spotted from what you've posted so far.
Based on our discussion below, here is a MWE:
library(shiny)
library(dplyr)
library(datasets)
ui <- shinyUI(
fluidPage(
titlePanel("Classification tree model on iris dataset."),
sidebarLayout(
sidebarPanel(
uiOutput("dependent"),
uiOutput("predictor"),
sliderInput("prop", "Enter the training data ratio", min = .5, max = 1, value = .6,step = .05) ),
mainPanel(
verbatimTextOutput("model")
)
)
)
)
server <- function(input, output) {
output$dependent <- renderUI({
data = datasets::iris
dependents <- select_if(data,is.factor)
selectInput("dependent","Select the dependent variable",choices = colnames(dependents))
})
output$predictor <- renderUI({
data = datasets::iris
predictors <- select_if(data,is.numeric)
checkboxGroupInput("predvar","Select the predictor variables", choices = colnames(predictors))
})
}
shinyApp(ui, server)
You had selectInput("depvar", ... rather than selectInput("dependent", ... in your output$dependent. That's all that was wrong.
A couple of points to note:
Your simple self-contained example (SSE)wasn't bad, but everything to do with model was irrelevant as far as I could see, so could be removed. There are also far easier ways of preenting the code to us than in multiple comments! ;)
In your SSE, I don't think there's a need for uiOutput and renderUI. You could present your checkBoxGroup and selectInput directly in the fluidPage and then use updateSelectInput() and updateCheckBoxGroupInput in an observe or observeEevent (the latter depending on data) reactive. That removes one level of indirection and might make things simpler whoever maintains your code. [NB: if you do this, you will need to change server <- function(input, output) {...} to server <- function(input, output, session) {...}.
Next time, rather than saying "I tried, and it didn't work" (I'm paraphrasing: I can't see your comments whilst writing an answer), say "I tried, but I got the following error [Give the error text] at line number nnn".
Good luck!
In my tiny Shiny app I am asking the user: how many time periods do you want to cut your time series into? For example, the user selects 3.
I want to use this input to take a fixed vector of dates and make it possible for the user the select from it the desired last date of Time Period 1 (in select box 1), and Time Period 2 (in select box 2). (The last date for time period 3 will be the very last date, so I don't need to ask).
I am not sure how to do it. I understand that because I don't know the desired number of time periods in advance, I have to create a list. But how do I then collect the input from those select boxes?
Thanks a lot!
library(shiny)
### UI #######################################################################
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
# Sidebar:
sidebarLayout(
sidebarPanel(
# Slider input for the number of time periods:
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints")
),
# Show just the number of periods so far.
mainPanel(
textOutput("nr_of_periods")
)
)
))
### SERVER ##################################################################
server = shinyServer(function(input, output, session) {
library(lubridate)
output$nr_of_periods <- renderPrint(input$num_periodsnr)
# Define our dates vector:
dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')
# STUCK HERE:
# output$period_cutpoints<-renderUI({
# list.out <- list()
# for (i in 1:input$num_periodsnr) {
# list.out[[i]] <- renderPrint(paste0("Sometext", i), ,
# )
# }
# return(list.out)
# })
})
# Run the application
shinyApp(ui = ui, server = server)
This is similar to a question I asked and subsequently worked out an answer to here. The big changes are (predictably) in the server.
Nothing needs to change in the UI, but as you'll see below I've included another textOutput so that you can see the dates you end up selecting, and I've also added an actionButton, which I'll explain later.
The server function has a couple additions, which I'll describe first and then put together at the end. You're right that you need to create a list of input objects inside the renderUI, which you can do through lapply. At this step, you're creating as many selectInputs as you'll have cutpoints, minus one because you say you don't need the last:
output$period_cutpoints<-renderUI({
req(input$num_periodsnr)
lapply(1:(input$num_periodsnr-1), function(i) {
selectInput(inputId=paste0("cutpoint",i),
label=paste0("Select cutpoint for Time Period ", i, ":"),
choices=dates)
})
})
Next, you'll need to access the values selected in each, which you can do in the same way, using a reactiveValues object you create first, and assign the new values to it. In my version of this problem, I couldn't figure out how to get the list to update without using an actionButton to trigger it. Simple reactive() or observe() doesn't do the trick, but I don't really know why.
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$num_periodsnr-1), function(i) {
seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
})
})
Full working app code then looks like this:
library(shiny)
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
sidebarLayout(
sidebarPanel(
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints"),
actionButton("submit", "Submit")
),
mainPanel(
textOutput("nr_of_periods"),
textOutput("cutpoints")
)
)
))
server = shinyServer(function(input, output, session) {
library(lubridate)
output$nr_of_periods <- renderPrint(input$num_periodsnr)
dates <- seq(ymd('2016-01-02'), ymd('2017-12-31'), by = '1 week')
output$period_cutpoints<-renderUI({
req(input$num_periodsnr)
lapply(1:(input$num_periodsnr-1), function(i) {
selectInput(inputId=paste0("cutpoint",i),
label=paste0("Select cutpoint for Time Period ", i, ":"),
choices=dates)
})
})
seldates <- reactiveValues(x=NULL)
observeEvent(input$submit, {
seldates$x <- list()
lapply(1:(input$num_periodsnr-1), function(i) {
seldates$x[[i]] <- input[[paste0("cutpoint", i)]]
})
})
output$cutpoints <- renderText({as.character(seldates$x)})
})
shinyApp(ui = ui, server = server)
you can make the boxes dynamically inside an lapply and send them as 1 output object to the ui
require("shiny")
require('shinyWidgets')
ui = shinyUI(fluidPage(
titlePanel("Defining time periods"),
# Sidebar:
sidebarLayout(
sidebarPanel(
# Slider input for the number of time periods:
numericInput("num_periodsnr", label = "Desired number of time periods?",
min = 1, max = 10, value = 2),
uiOutput("period_cutpoints")
),
# Show just the number of periods so far.
mainPanel(
textOutput("nr_of_periods")
)
)
))
# Define server logic ----
server <- function(session, input, output) {
output$period_cutpoints<- renderUI({
req(input$num_periodsnr > 0)
lapply(1:input$num_periodsnr, function(el) {
airDatepickerInput(inputId = paste('PeriodEnd', el, sep = ''), label = paste('Period End', el, sep = ' '), clearButton = TRUE, range = F, update_on = 'close')
})
})
}
# Run the app ----
shinyApp(ui = ui, server = server)
Since you did not provide a dataset to apply the inputs on, and I don't know what date ranges your data has, I did not add code to set min/max on the date pickers, and not sure what kind of code to provide for you to use the data. You would need to write something to put them in a list indeed
values <- reactiveValues(datesplits = list(),
previous_max = 0)
observeEvent(input$num_periodsnr, {
if(input$num_periodsnr > values$previous_max) {
lapply(values$previous_max:input$num_periodsnr, function(el) {
observeEvent(input[[paste(paste('PeriodEnd', el, sep = '')]], {
values$datesplits[el] <- input[[paste(paste('PeriodEnd', el, sep = '')]]
})
values$previous_max <- max(values$previous_max, input$num_periodsnr)
})
}
})
and then use the list of dates for whatever you need to do with them I think.
I use the trick with run lapenter code hereply from previous_max to input$num_periodsnr if(input$num_periodsnr > values$previous_max){} to avoid the problem you create when you repeatedly create observers for the same input element. Whereas ui elements are overwritten when created in a loop, observeEvents are made as copies, so every time your loop fires, you make another copy of observers 1:n. This results in all copies firing every time, until you have a million observers all firing, creating possible strange bugs, unwanted effects and loss of speed.
I created an R shiny application that has a dygraph based on a data table that is dynamically subsetted by a checkboxGroupInput. My problem is, when I attempt to load large amounts of data (millions of records), it loads very slowly and/or crashes.
After doing some more research, I stumbled upon a "lazy-load" technique from here. Based on my understanding, this technique essentially downsamples the data by only loading the number of data points equal to the width of the dygraph window. As the user zooms in, it will drill down and load more data within the dyRangeSelector max/min dates. I suspect this will solve my problem, because it will load significantly less data at any given dygraph interaction. However, all of the examples provided in this link were in Javascript, and I'm having trouble translating it to R.
I also attempted to treat the GraphDataProvider.js file as a dygraph plugin, but I was unable to get it to work properly.
A couple of quick notes on my implementation:
Each element of data_dict in the server is an xts object.
The do.call.cbind function call in the server is based off of this SO implementation, and it is very fast.
My current setup is essentially like this (I refactored it to make it generic):
Data Setup:
library(shiny)
library(shinydashboard)
library(dygraphs)
library(xts)
library(data.table)
start <- as.POSIXlt("2018-07-09 00:00:00","UTC")
end <- as.POSIXlt("2018-07-11 00:00:00","UTC")
x <- seq(start, end, by=0.5)
data <- data.frame(replicate(4,sample(0:1000,345601,rep=TRUE)))
data$timestamp <- x
data <- data[c("timestamp", "X1", "X2", "X3", "X4")]
data <- as.data.table(data)
filters <- c("X1","X2","X3","X4")
data_dict <- vector(mode="list", length=4)
names(data_dict) <- filters
data_dict[[1]] <- as.xts(data[,c('timestamp','X1')]); data_dict[[2]] <- as.xts(data[,c('timestamp','X2')])
data_dict[[3]] <- as.xts(data[,c('timestamp','X3')]); data_dict[[4]] <- as.xts(data[,c('timestamp','X4')])
# Needed to quickly cbind the xts objects
do.call.cbind <- function(lst){
while(length(lst) > 1) {
idxlst <- seq(from=1, to=length(lst), by=2)
lst <- lapply(idxlst, function(i) {
if(i==length(lst)) { return(lst[[i]]) }
return(cbind(lst[[i]], lst[[i+1]]))})}
lst[[1]]}
UI:
header <- dashboardHeader(title = "App")
body <- dashboardBody(
fluidRow(
column(width = 8,
box(
width = NULL,
solidHeader = TRUE,
dygraphOutput("graph")
)
),
column(width = 4,
box(
width = NULL,
checkboxGroupInput(
"data_selected",
"Filter",
choices = filters,
selected = filters[1]
),
radioButtons(
"data_format",
"Format",
choices=c("Rolling Averages","Raw"),
selected="Rolling Averages",
inline=TRUE
)
)
)
)
)
ui <- dashboardPage(
header,
dashboardSidebar(disable=TRUE),
body
)
Server:
server <- function(input, output) {
# Reactively subsets the dataset based on checkboxGroupInput filters
the_data <- reactive({
data <- do.call.cbind(data_dict[input$data_selected]) # Column bind multiple xts objects
})
output$graph <- renderDygraph({
graph <- dygraph(the_data()) %>%
dyRangeSelector(c("2018-07-10 00:00:00","2018-07-10 02:00:00")) %>%
dyOptions(useDataTimezone = TRUE,connectSeparatedPoints = TRUE)
if(input$data_format == "Rolling Averages") graph <- graph %>% dyRoller(rollPeriod = 100)
graph
})
}
Make App:
shinyApp(ui, server)
I would appreciate any help I can get on this, this has stumbled me for a while now. Thank you!