Shiny Dashboard formatting issue - r

library(needs)
needs(
shiny,
ggplot2,
tidyverse,
shinydashboard,
DT
)
source("~/functions.R",local = T)
# Define UI for application that draws a histogram
header = dashboardHeader(
# tags$li(class = "dropdown",
# tags$style(".main-header {max-height: 80px}"),
# tags$style(".main-header .logo {height: 80px}")),
#title = tags$img(src='logo.png',height='100',width='200')
)
sidebar = dashboardSidebar(
menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F,
fileInput("file","Upload CSV files",multiple=TRUE,accept=("text/comma"))),
menuItem(text = 'Simulate',tabName = 'simulate',icon=icon('chart-line'),
helpText('Simulation Parameters'),
radioButtons('type',"Please choose the type of analysis:",choices = list("Gender" = 1,"US Minority Status" = 2),selected = 1),
sliderInput("numSims","Number of simulations:",min = 1, max = 10000,step = 1000,value = 10000),
sliderInput("numYears","Number of years to simulate:",min = 1,max = 5,value = 3,step = 1),
numericInput('turnover','Total Turnover', value = 10),
sliderInput('promoRate','Set Promo rate', value = 25, min = 1, max = 100, step = 5),
sliderInput('growthRate','Set growth rate',value = 0,min=0,max=100,step = 1),
helpText('0% Growth Rate assumes a flat, constant headcount'),
actionButton('go',label = "Update"),width = 4)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'data',
fluidRow(wellPanel(
fileInput(
inputId = 'file',
label = "File Upload:",
accept = c("csv", ".csv")))),
wellPanel(DT::dataTableOutput('table'))),
tabItem(
tabName = 'simulate',
fluidRow(
wellPanel(
DT:::dataTableOutput('simDataTable')
))
)
))
ui = shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server = server <- function(input, output) {
options(shiny.maxRequestSize = 30 * 1024 ^ 2)
dataset <- reactive({
req(input$file)
read.csv(input$file$datapath)
})
output$table = renderDataTable(dataset(), filter = 'top',options = list(scrollX = TRUE))
simulate = eventReactive(input$go,{
req(input$numSims,input$type)
x = dataset()
temp = dataSim(x,type=input$type,
numSims = input$numSims)
})
simulateAvg = reactive({
x = simulate()
y = x %>% group_by(Role) %>% summarise(mean(freq))
})
output$simDataTable = renderDataTable(simulateAvg())
}
shinyApp(ui,server)
I'm having some trouble with two issues.
1.) The formatting of the shiny dashboard is odd. The text on the side bar seems very compacted and not what other shiny dashboards look like. I'm not sure what the issue is.
2.) After upload, a table is suppose to appear on the dashboard body but it doesn't
3.) Once a table appears and I head to the simulate tab, will the dashboard body change accordingly and display the simulateAvgData set that I populated?
The dataSim function is from the source file on top. I don't receive any errors when I run anything so looking for guidance and inputs to whether or not this shiny dashboard work as intended. I'm newer to the dashboard packages from shiny.

You have a couple of issues here. You do not need a fileInput statement inside dashboardBody. Next, within dashboardSidebar, you can define fileInput at the top level of menuItem (option 1 in the code below), or a sub-level of the first menuItem (option 2 below). In either case, you need to have a menuItem with a tabName where you want to display the file that was read in. Once you read the input file, you need to select the appropriate tab to see the displayed data. Try this code
header <- dashboardHeader()
### option 1: fileInput at the first menuItem level
# sidebar <- dashboardSidebar(width=320,
# menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F),
# fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv"))
# )
### option 2 - fileInput as a subitem
sidebar <- dashboardSidebar(width=320,
menuItem("Full data",tabName="noData",icon=icon("table"),startExpanded = F, ## data not displayed for this tabName
menuItem("Full_data",tabName="Data", icon=icon("table")),
fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv")))
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'Data',
fluidRow(DTOutput('table')))
))
ui <- shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server <- function(input, output, session) {
data1 <- reactive({
req(input$file)
data <- read.csv(input$file$datapath,sep = ",", header = TRUE)
})
output$table <- renderDT(data1())
}
shinyApp(ui,server)

Related

Shiny: dynamic checkboxGroupInput

I'm building a Shiny app and I would like to add a dynamic "checkboxGroup" which depends on some other input. More precisely, the user can upload N files, the app makes some calculations, then the output is a table with N columns (one for each file uploaded). At this point I would like the user to be able to select only certain columns, i.e. the ones he/she would like to consider, then the table should update according to the user's choice.
I had a look at some shiny apps on the web, and the closest solution is probably something like
https://shiny.rstudio.com/gallery/datatables-demo.html
but unfortunately in that example we have
checkboxGroupInput("show_vars", "Columns in diamonds to show:",
names(diamonds), selected = names(diamonds))
where diamonds is "known", whereas in my case I don't know how many files the user will upload and so how many columns my table will have.
Any ideas?
Cheers
EDITED:
Here there is the portion of code I'm reffering to. It works, the user can upload N excel files with same number of rows. The app returns a tab with N columns (the second column of each file uploaded).
Ideally, now I would like to add N check boxes (all selected initially), and the user can uncheck the columns he/she doesn't want to consider. Say he/she uncheck 2 columns, then the tab changes into a tab with N-2 columns.
Thanks again
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(data.table)
library(dplyr)
library(xlsx)
sidebar <- dashboardSidebar(
width = 350,
sidebarMenu(
tags$style(HTML(".sidebar-menu li a { color: #f4f8e8; }")),
menuItem("Computations",tabName = "tab1", icon = icon("file-text-o"))
))
body <- dashboardBody(
tags$style(".content-wrapper {background-color: #c3f9fa;}"),
style = "color: black;",
tabItems(
tabItem(
tabName = "tab1",
h2("upload files"),
tags$style(HTML(" .progress-bar { background-color: #1dbcbf; }")),
fileInput("csvs",
label="Upload CSVs here",
multiple = TRUE),
textInput(inputId="num_files",
label="number of files uploaded",
value = "",
width = NULL,
placeholder = NULL),
actionButton(inputId = "display_tab", label = "Display Tab after computations"),
box(title = "tab after computations:",tableOutput("all_cols"),width = 100),
checkboxGroupInput(inputId="show_vars", "Columns to keep:", choices = "selectedData", selected = "selectedData")
)))
dbHeader <- dashboardHeader(title = 'Exercise')
ui <- dashboardPage(
skin = "black",
dbHeader,
sidebar,
body
)
server <- function(input, output) {
options(shiny.maxRequestSize=260*1024^2)
computations <- function(num_files, db){
num_files <- as.numeric(num_files)
N <- nrow(db)/num_files #number of rows for 1 file (they all have same size)
tab_to_be_displayed <- db[1:N,2]
for(j in (1:(num_files - 1))){
left <- j*N+1
right <- (j+1)*N
tab_to_be_displayed <- cbind(tab_to_be_displayed, db[left:right,2])
}
return(tab_to_be_displayed)
}
mycsvs<-reactive({
rbindlist(lapply(input$csvs$datapath, fread),
use.names = TRUE, fill = TRUE)
})
selectedData <- reactive({
names(computations(input$num_files, mycsvs()))
})
observeEvent(input$display_tab,{
numero <- input$num_files
comp_tab <- computations(numero, mycsvs())
output$all_cols <- renderTable(comp_tab, align = 'c', rownames = TRUE, colnames = TRUE, digits = 3)
})
}
shinyApp(ui = ui, server = server)
I simplified the code a bit to demonstrate how the group checkboxes could work.
In simplifying, I kept the data as a list from the csv files. Then for computations extracted the second column from all data frames in the list, then used select to show columns based on the checkboxes.
The checkbox items are based on the names of the second columns of the data, with a default of all selected.
Instead of entering the number of files that were read, it is now computed based on the length of the list of data.
Let me know if this is closer to what you need.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(data.table)
library(dplyr)
library(xlsx)
sidebar <- dashboardSidebar(
width = 350,
sidebarMenu(
tags$style(HTML(".sidebar-menu li a { color: #f4f8e8; }")),
menuItem("Computations",tabName = "tab1", icon = icon("file-text-o"))
))
body <- dashboardBody(
tags$style(".content-wrapper {background-color: #c3f9fa;}"),
style = "color: black;",
tabItems(
tabItem(
tabName = "tab1",
h2("upload files"),
tags$style(HTML(" .progress-bar { background-color: #1dbcbf; }")),
fileInput("csvs",
label="Upload CSVs here",
multiple = TRUE),
textOutput("numfiles"),
box(title = "tab after computations:",tableOutput("all_cols"),width = 100),
uiOutput("checkboxes")
)))
dbHeader <- dashboardHeader(title = 'Exercise')
ui <- dashboardPage(
skin = "black",
dbHeader,
sidebar,
body
)
server <- function(input, output) {
options(shiny.maxRequestSize=260*1024^2)
db <- reactiveVal(list())
computations <- function(){
req(input$checkboxes)
do.call(cbind, lapply(db(), "[", , 2)) %>%
select_if(names(.) %in% input$checkboxes)
}
observeEvent(input$csvs, {
db(lapply(input$csvs$datapath, fread))
})
output$numfiles <- renderText(paste("Number of files: ", length(db())))
output$checkboxes <- renderUI({
choice_list <- unlist(lapply(db(), function(x) colnames(x)[2]))
checkboxGroupInput("checkboxes", "Columns to keep:", choices = choice_list, selected = choice_list)
})
output$all_cols <- renderTable(computations(), align = 'c', rownames = TRUE, colnames = TRUE, digits = 3)
}
shinyApp(ui = ui, server = server)
It sounds like you need your checkboxGroupInput to be reactive. That requires a combination of renderUI on your server script, and uiOutput on your ui script.

How to make dynamic tabpanels according to number of files uploaded and render a complicated Table within the tab

I am working on an app where the user can upload either one file or multiple files of individual-level data to get analyzed.
So far if the user uploads multiple files the app combines all the files in one dataset and analyzes all of them combined. I have different outputs 2 tables and a graph.
What I am struggling to do is when the user uploads multiple files I want to keep the compiled result but I want to add dynamic tabs to each box according to the number of files uploaded to present the table/graph for that file alone.
I added a checkbox so the user checks it if they are uploading multiple files. The idea was to write an observeEvent code to insert tabs according to the number of files being uploaded, that code got complicated because I had to put the renderTable chunk within it, and it is not working.
So my question is, is there a better way of doing what I am trying to do? and If my idea makes sense what is wrong with my code and why isn't it working? Thank you
Here is a sample of the code;
library(shiny)
library(dplyr)
library(shinydashboard)
library(tidyr)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(title = "Treatment and Care Cascade",
titleWidth = 300),
#Sidebar contents (tabs)
dashboardSidebar(
sidebarMenu(
menuItem("HIV Cascade", tabName = "hiv")
)),
#Main panel for displaying outputs
dashboardBody(
tabItems(
#First tab content
tabItem(tabName = "hiv",
h2("HIV Treatment and Care Cascade"),
fluidRow(
#Input: Select a file for hcv data
box(fluidRow(
box(fileInput("dt_hiv","Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,tesxt/plain",".csv")),width = 12,solidHeader = TRUE, height = 75),
#Input: Checkbox if file has header
box(checkboxInput("multiplehiv", "Uploading multiple files",TRUE),width = 3,solidHeader = TRUE, height = 50)), width = 12, height = 255),
#Outputs
tabBox(id = "hivcasbox", tabPanel(id = "tab1", title ="HIV Cascade",tableOutput("hivcascade"))),
box(tableOutput("hivCascadeduration"), title = "HIV Cascade - duration", solidHeader = TRUE)
))
)))
server <- function(input, output){
#Combining the datasets together
dthiv <- reactive({req(input$dt_hiv)
rbindlist(lapply(input$dt_hiv$datapath, fread, header = input$hivheader, quote = input$hivquote, sep = input$hivsep),
use.names = TRUE, fill = TRUE)
})
#The analysis chunk
cascade_hiv <- reactive({dthiv() %>% summarize("Diagnosed" = sum(hiv_posresult,na.rm = T),
"Linkage to care" = sum(linkagetocare_hiv,na.rm = T))})
cascade_hiv1 <- reactive({as.data.frame(t(cascade_hiv()))})
Percentage <- reactive({(round((cascade_hiv1()$V1*100/cascade_hiv1()$V1[1]),1))})
cascade_hiv3 <- reactive({cbind(cascade_hiv1(),Percentage())})
cascade_hiv4 <- reactive({cascade_hiv3() %>% rename(Total = V1, Percentage = "Percentage()")})
output$hivcascade <- renderTable({
cascade_hiv5 <- as.data.frame(cascade_hiv4())
rownames(cascade_hiv5) <- c("Diagnosed","Linkage to care")
cascade_hiv5},include.rownames = TRUE)
observeEvent(input$multiplehiv, {
for (i in 1:length(input$dt_hiv$datapath)) {
insertTab(inputId = "hivcasbox",
tabPanel(paste("Region",i), renderTable({
dthiv_r <- input$dt_hiv$datapath[i] %>% summarize("Diagnosed" = sum(hiv_posresult,na.rm = T),
"Linkage to care" = sum(linkagetocare_hiv,na.rm = T))
cascade_hiv1_r <- as.data.frame(t(dthiv_r))
Percentage_r <- round((cascade_hiv1_r$V1*100/cascade_hiv1_r$V1[1]),1)
cascade_hiv3_r <- cbind(cascade_hiv1_r,Percentage_r)
cascade_hiv4_r <- cascade_hiv3_r %>% rename(Total = V1, Percentage = "Percentage_r")
cascade_hiv5_r <- as.data.frame(cascade_hiv4_r)
rownames(cascade_hiv5_r) <- c("Diagnosed","Linkage to care")
cascade_hiv5_r},include.rownames = FALSE)),
target = "tab1")
}
})
}
shinyApp(ui, server)
Created on 2019-08-01 by the reprex package (v0.3.0)
the app runs but when I check the multiple files box, no tabs get inserted
I couldn't get the above code to work but I found another one that works using "str and eval(parse(text = str))",
however, it is not the most elegant or concise code, so I would appreciate it if someone has a better way of doing it. Thank you!
ibrary(shiny)
library(dplyr)
library(shinydashboard)
library(tidyr)
library(shinyjs)
library(data.table)
ui <- dashboardPage(
dashboardHeader(title = "Treatment and Care Cascade",
titleWidth = 300),
dashboardSidebar(
sidebarMenu(
menuItem("HIV Cascade", tabName = "hiv")
)),
dashboardBody(
tabItems(
#First tab content
tabItem(tabName = "hiv",
h2("HIV Treatment and Care Cascade"),
fluidRow(
#Input: Select a file for hcv data
box(fluidRow(
box(fileInput("dt_hiv","Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,tesxt/plain", ".csv")),width = 12,solidHeader = TRUE, height = 75),
#actionButton("multiplehiv", "Add 'Dynamic' tab"),
#Input: Checkbox if file has header
box(checkboxInput("multiplehiv", "Uploading multiple files",FALSE),
width = 3,solidHeader = TRUE, height = 50)
), width = 12, height = 255),
#Outputs
uiOutput("tabs")
))
)))
server <- function(input, output){
dthiv <- reactive({req(input$dt_hiv)
rbindlist(lapply(input$dt_hiv$datapath, fread),
use.names = TRUE, fill = TRUE)
})
cascade_hiv <- reactive({dthiv() %>% summarize("Diagnosed" = sum(hiv_posresult,na.rm = T),
"Linkage to care" = sum(linkagetocare_hiv,na.rm = T))})
cascade_hiv1 <- reactive({as.data.frame(t(cascade_hiv()))})
Percentage <- reactive({(round((cascade_hiv1()$V1*100/cascade_hiv1()$V1[1]),1))})
cascade_hiv3 <- reactive({cbind(cascade_hiv1(),Percentage())})
cascade_hiv4 <- reactive({cascade_hiv3() %>% rename(Total = V1, Percentage = "Percentage()")})
n_files <- reactive({length(input$dt_hiv$datapath)})
output$tabs <- renderUI({
if (input$multiplehiv == 1) {
str <- "tabBox(id = 'hivcasbox',
tabPanel(id = 'taball', title = 'HIV Cascade' ,tableOutput('hivcascade')),"
for (i in 1:n_files()) {str <- paste0(str, "tabPanel(id = paste('tab', ",i,") , title = paste('Data', ",i,") , tableOutput('hivcascader_",i,"')),")}
str <- gsub(",$",")",str)
eval(parse(text = str))
}
else {
tabBox(id = "hivcasbox",
tabPanel(id = "tab1", title = "HIV Cascade",tableOutput("hivcascade")))
}
})
output$hivcascade <- renderTable({
cascade_hiv5 <- as.data.frame(cascade_hiv4())
rownames(cascade_hiv5) <- c("Diagnosed","Linkage to care")
cascade_hiv5},include.rownames = TRUE)
dt_files <- reactive({lapply(input$dt_hiv$datapath[1:n_files()],read.csv)})
observe({
for (i in 1:n_files())
{str1 <- paste0("dthiv_r_",i,"<- reactive({dt_files()[[",i,"]] %>% summarize('Diagnosed' = sum(hiv_posresult,na.rm = T),
'Linkage to care' = sum(linkagetocare_hiv,na.rm = T))})
cascade_hiv1_r_",i,"<- reactive({as.data.frame(t(dthiv_r_",i,"()))})
Percentage_r_",i,"<- reactive({round((cascade_hiv1_r_",i,"()$V1*100/cascade_hiv1_r_",i,"()$V1[1]),1)})
cascade_hiv3_r_",i," <- reactive({cbind(cascade_hiv1_r_",i,"(),Percentage_r_",i,"())})
cascade_hiv4_r_",i,"<- reactive({cascade_hiv3_r_",i,"() %>% rename(Total = V1, Percentage = 'Percentage_r_",i,"()')})")
eval(parse(text = str1))}
for (i in 1:n_files()) {
str2 <- paste0("output$hivcascader_",i," <- renderTable({
cascade_hiv5_r_",i," <- as.data.frame(cascade_hiv4_r_",i,"())
rownames(cascade_hiv5_r_",i,") <- c('Diagnosed','Linkage to care')
cascade_hiv5_r_",i,"},include.rownames = TRUE)")
eval(parse(text = str2))}
})
}
shinyApp(ui, server)

Unable to render Gauge from Flexdashboard library in Shiny app

I am trying to create a Shiny app which
a) prompts user to upload a file which contains numeric data,
b) reads the file and assigns the data points to different variables,
c) calculates new variables from the captured variables
d) display a 'Gauge' using the calculated variables
The code successfully executes but the Gauge chart is not rendered properly. There is no error or warning message either. Instead, I am getting the following message:
"Input to asJSON(keep_vec_names=TRUE) is a named vector. In a future version of jsonlite, this option will not be supported, and named vectors will be translated into arrays instead of objects. If you want JSON object output, please use a named list instead. See ?toJSON."
And instead of the gauge output I am getting that tiny spec in the middle, as seen in the attached image.
The entire code is fairly long, hence providing just the relevant snippets of code.
Would really appreciate if you can help fix this.
library(shiny)
library(flexdashboard)
ui <- fluidPage(
tabPanel("Sensitivity Analysis",
sidebarLayout(
sidebarPanel(
uiOutput("Sensitivity_Analysis")
),
mainPanel(
gaugeOutput("sensitivity", width = "600px", height = "600px")
)
)
),
server <- function (input, output)
{
output$input_financials=renderUI({
fluidRow(fileInput("file1", "Choose CSV File",multiple = FALSE,accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton("process","Process"))})
data_input=reactiveValues()
observeEvent(input$process,{
file_input <- input$file1
if (is.null(file_input)) {
return(NULL)}
## File is read and all the inputs are assigned to variables
....
## Output for Gauge begins
output$sensitivity <- flexdashboard::renderGauge({
gauge_limit <- data_input$wc_value
data_input$cash_rel_dpo <- ## Formula for cash_del_dpo
data_input$cash_rel_dro <- ## Formula for cash_del_dro
data_input$cash_rel_dio <- ## Formula for cash_del_dio
data_input$wc_predicted_value <- (data_input$wc_predicted_value - data_input$cash_rel_dpo - data_input$cash_rel_dro - data_input$cash_rel_dio)
gauge(data_input$wc_predicted_value, min = 0, max = gauge_limit,
gaugeSectors(success = c(0, 10000),
warning = c(10001, 50000),
danger = c(50001, 1000000000))
)
})
shinyApp(ui = ui, server = server)
Screenshot of the output generated upon executing the code
There's a similar gauge in package billboarder, try this example:
library(shiny)
library(billboarder)
ui <- fluidPage(
tabPanel(
title = "Sensitivity Analysis",
sidebarLayout(
sidebarPanel(
fileInput("file1", "Choose CSV File",
multiple = FALSE,
accept = c("text/csv","text/comma-separated-values,text/plain",".csv")),
actionButton(inputId = "process", label = "Process (click here to refresh the gauge)")
),
mainPanel(
billboarderOutput("sensitivity", width = "400px", height = "400px")
)
)
)
)
server <- function (input, output) {
data_input <- reactiveValues(x = 0)
observeEvent(input$process, {
data_input$x <- sample.int(1e5, size = 1)
}, ignoreInit = TRUE)
## Output for Gauge begins
output$sensitivity <- renderBillboarder({
billboarder() %>%
bb_gaugechart(
value = data_input$x,
name = "Predicted value",
steps = c(1e4, 5e4, 1e5),
steps_color = rev(c("#FF0000","#F6C600", "#60B044"))
) %>%
bb_gauge(
min = 0, max = 1e5,
units = "",
label = list(
format = htmlwidgets::JS("function(value, ratio) {return d3.format(',')(value);}") # format value with thousand separator
),
width = 80
)
})
}
shinyApp(ui = ui, server = server)

Display R Shiny Plot After Inputting File

I would like to display a chart (for a Shiny app), based on data inputted by a user through a file. With the current setup, there is an error message claiming the data is not found, so the plot (from the rCharts package) does not get displayed.
Code attached below:
ui.R
library(rCharts)
library(shinydashboard)
library(shiny)
dashboardPage(
skin = "black",
header <- dashboardHeader(
titleWidth = 475
),
sidebar <- dashboardSidebar(
sidebarMenu(
)
),
body <- dashboardBody(
tabItems(
tabItem("setup",
box(width = 4,title = tags$b('Input Dataset'), solidHeader = T, status = 'primary', collapsible = T,
helpText("Default max. file size is 5 MB. Please upload both files for analysis in csv format."),
fileInput("file1","Upload the first file"),
fileInput("file2","Upload the second file")
),
box(height = 500, width = 12,title = tags$b('Visualize Data'), solidHeader = T, status = 'primary',
showOutput("myPlot", "Highcharts")
)
)
)
)
)
server.R
library(shiny)
library(rCharts)
# Define server logic required to draw a histogram
shinyServer(function(input, output) {
observe({
file1 = input$file1
file2 = input$file2
if (is.null(file1) || is.null(file2)) {
return(NULL)
}
data1 = read.csv(file1$datapath)
data2 = read.csv(file2$datapath)
})
output$myPlot<-renderChart2({
# Prepare data
data1[,2] <- (data1[,2])/sum(data1[,2])
# Create chart
a <- rCharts:::Highcharts$new()
a$chart(type = "column")
a$xAxis(categories = rownames(x))
a$yAxis(title = list(text = "Normalized Intensity"))
a$data(data1)
a$set(width = 600, height = 500)
return(a)
})
})
Try adding something like this. Make sure you check for nrow and return and empty Highcharts$new() object as renderChart2 expects one.
library(shiny)
library(rCharts)
# Define server logic required to draw a histogram
shinyServer(function(input, output) {
data1 <- reactive({read.csv(file1$datapath)})
data2 <- reactive({read.csv(file2$datapath)})
output$myPlot<-renderChart2({
data1 <- data1()
# Prepare data
if(nrow(data1==0)){return(Highcharts$new())}
data1[,2] <- (data1[,2])/sum(data1[,2])
# Create chart
a <- rCharts:::Highcharts$new()
a$chart(type = "column")
a$xAxis(categories = rownames(x))
a$yAxis(title = list(text = "Normalized Intensity"))
a$data(data1)
a$set(width = 600, height = 500)
return(a)
})
})

create empty dygraph in Rshiny

I'm using Dygraphs package for visualizing actual and the time series predicted values in R shiny. Here is the sample code that I used to generate the Dygraph. In some cases where the data points are less Holt Winters(gamma =T) does not give any prediction and I need to show an empty Dygraph with the title "Insufficient Data"). I'm not able to do this. Appreciate any help on this
library(dygraphs)
plotDyg <- fluidPage(
fluidRow(
box(selectizeInput("c1", "Enter a key",
choices = reactive({sort(unique(df$key))})(),
multiple = FALSE),width=3),
box(dygraphOutput("tsDy"), width = 10, height = 500))
)
ui <- dashboardPage(
dashboardHeader(title = "XYZ"),
dashboardSidebar(
sidebarMenu(
menuItem("abc", tabName = "sidebar2", icon = icon("bar-chart") ,
menuSubItem("def",icon = icon("folder-open"), tabName = "subMenu1")
)
)
),
dashboardBody(
tabItems(
tabItem(tabName = "subMenu1",
fluidRow(
tabBox(
title = "ghi", id = "tabset2",height = "1500px",width = 100,
tabPanel("abcdef", plotDyg)
)
)
)
)
)
)
server <- function(input, output) {
output$tsDy <- renderDygraph({
if(!is.null(input$c1)){
df.0 <- reactive({df[df$key == input$c1,]})()
tspred <- reactive({
df.0 <- convert_to_ts(df.0) # converts column "fin_var" to a monthly time series and returns the entire dataframe
act <- df.0$fin_var
hw <- tryCatch(HoltWinters(df.0$fin_var), error=function(e)NA)
if(length(hw) > 1){
p <- predict(hw, n.ahead = 12, prediction.interval = TRUE, level = 0.95)
all1 <- cbind(act, p)
}else{all1 <- matrix()}
})
if(!is.na(tspred())){
dygraph(tspred(), main = "TS Predictions") %>%
dySeries("act", label = "Actual") %>%
dySeries(c("p.lwr", "p.fit", "p.upr"), label = "Predicted") %>%
dyOptions(drawGrid = F) %>%
dyRangeSelector()
}else{dygraph(matrix(0), main = "Insufficient Data")} # I could just do 'return()' but I want to show an empty Dygraph with the title
}else{return()}
})
}
I too am unable to render Dygraphs with an empty time series. To render a message to the user I used the validate/need functions in Shiny
In your case I would replace
if(!is.na(tspred())){
With
validate(need(!is.na(tspred())), "Insufficient Data"))
This will avoid the "error: argument is of length zero" message within Dygraphs and print an appropriate message to the end user.

Resources