Issue with inserting a dygraph in shiny app - r

I'm almost done building an app to explore data published in one of my papers, and thought that it would be nice to have something a little more interactive by adding a dygraph instead of a regular ggplot. Hence my problem... :)
Here is the code I have so far.
EDIT: Thanks to Waldi's comments below, I've slightly modified my code, and minimized it here to facilitate the process
library(shiny)
library(dygraphs)
library(xts)
library(tidyverse)
library(openxlsx)
Sys.setlocale("LC_TIME", "C")
data <- read.xlsx("https://www.bloomassociation.org/wp-content/uploads/2020/08/data.xlsx", sheet = 1) %>%
mutate(date = as.Date(date, origin = "1899-12-30"))
# Define UI for application that draws a histogram
ui <- fluidPage(# Define filters
fluidRow(
column(4,
selectInput("variableInput", label = h4("Show fisheries by:"),
unique(data$variable))),
column(4,
selectInput("unitInput", label = h4("Display data as:"),
unique(data$unit))),
column(4,
sliderInput("dateInput", label = h4("Select time range:"),
min = as.Date("2000-01-01"),
max = as.Date("2017-12-31"),
value = c(as.Date("2000-01-01"), as.Date("2017-12-31")),
timeFormat = "%b %Y")
),
# Display results
tabsetPanel(
tabPanel("Graphical view", withSpinner(dygraphOutput("distPlot"), type = getOption("spinner.type", default = 5), color = getOption("spinner.color", default = "#0A1D27"), size = getOption("spinner.size", default = 0.5))))
))
# Define server logic required to draw a histogram
server <- function(input, output) {
filtered_xts <- reactive({
data_ <- data %>%
filter(variable == input$variableInput,
unit == input$unitInput,
date >= input$dateInput[1],
date <= input$dateInput[2]
) %>%
select(-c(4:5)) %>%
mutate(quantity = round(quantity, 1)) %>%
spread(key = "category", value = "quantity") %>%
replace(is.na(.), 0)
# Debug the filtering // Solution provided by #Waldi; seems to fix most of my problem (see below)
print(data_)
data_ <- xts(data_, order.by = data_$date)
# Debug the xts conversion step
print(data_)
})
output$distPlot <- renderDygraph({
dygraph(filtered_xts()) %>%
dyOptions(fillGraph = TRUE, drawGrid = TRUE, stackedGraph = FALSE) #When stackedGraph = FALSE, everything works well, but I want it TRUE => it no longer works...
}
)
}
# Run the application
shinyApp(ui = ui, server = server)
As you can see, everything works fine when stackedGraph = FALSEin the dyOptions() but it looks like only (part of) the first time-series is included when TRUE... what am I missing?

Looks like filtered_xts() doesn't output any value.
Try:
filtered_xts <- reactive({
data_ <- data %>%
filter(variable == input$variableInput,
unit == input$unitInput,
date >= input$dateInput[1],
date <= input$dateInput[2]
) %>%
select(-c(4:5)) %>%
mutate(quantity = round(quantity, 1)) %>%
spread(key = "category", value = "quantity") %>%
replace(is.na(.), 0) %>% data.table::as.data.table()
})
Following our discussion in comments, the conversion to data.table is more efficient than conversion to xts to be able to fully use dygraphs options.

Related

Interactive heatmap in R using apexcharter fails at reactivity

at the moment I try to create an interactive heatmap in R with apexcharter. This works fine at manual chart creation but fails on interactive use within shiny.
library(shiny)
library(tidyverse)
library(apexcharter)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Test Heatmap"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "heatmap_filter",
label = "heatmap filter",
choices = c(1999, 2008),
selected = 2008
)
),
mainPanel(
apexchartOutput("heatmap")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$heatmap <- renderApexchart({
df <- mpg %>% filter(year == input$heatmap_filter) %>% mutate_if(is.character, as.factor) %>% group_by(manufacturer, class) %>% summarise(cnt = n()) %>% tidyr::complete(class, fill = list(cnt = 0))
q20 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[2],0)
q40 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[3],0)
q60 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[4],0)
q80 <- round(as.numeric(quantile(df %>% filter(cnt>0) %>% pull(cnt), probs = seq(0,1,0.2), na.rm = TRUE))[5],0)
apex(
data = df,
type = "heatmap",
mapping = aes(x = manufacturer, y = class, fill = cnt)
) %>%
ax_dataLabels(enabled = TRUE) %>%
ax_plotOptions(
heatmap = heatmap_opts(
enableShades = FALSE,
colorScale = list(
ranges = list(
list(from = 0, to = q20, color = "#106e45"), #grün
list(from = q20, to = q40, color = "#90dbba"), #leichtes grün
list(from = q40, to = q60, color = "#fff33b"), #gelb
list(from = q60, to = q80, color = "#f3903f"), # orange
list(from = q80, to = 20, color = "#e93e3a") #rot
)
)
)
) %>%
ax_title(
text = paste("Test interactive heatmap",
input$heatmap_filter
), align = "center"
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
With the manual approach everthing works as expected. But when I change the input select only the values changes but not the heatmap quantil ranges and not the title input. Its seems like the input value is not pushing the changes to already calculated variables. I already tried to use an reactive df or reactive variables but so far nothing works.
I added a minimal example where you could change the year input and this should change the title and the color ranges.
Can you help me?
Thanks in advance.
Try setting auto_update to FALSE in the call to apex
apex(
data = df,
type = "heatmap",
auto_update = FALSE,
...

Why does `filter` crash with an input length error in my shiny app?

i am pretty new to programmring but i have to make a shiny app for a university course.
As you can see i webscraped a data table thats presents different bike geometries and i wanted to create a shiny app, where i can compare the geometries with each other. I am quite happy with my progress, but now i got the problem that it always shows me the error: "Error in : Problem with filter() input ..1.
x Input ..1 must be of size 19 or 1, not size 0.
i Input ..1 is !=.... 161: "
I want that its possible in the app to choose one bike and it automatically compares the bike and shows me the 10 most similar bikes.
#table
Canyon <- read_html("https://enduro-mtb.com/canyon-strive-cfr-9-0-ltd-test-2020/")
Rose <- read_html("https://enduro-mtb.com/rose-root-miller-2020-test/")
Ghost <- read_html("https://enduro-mtb.com/ghost-riot-enduro-2021-erster-test/")
Cube <- read_html("https://enduro-mtb.com/cube-stereo-170-sl-29-test-2020/")
Comparison <- tibble(
Geometry = Canyon %>%
html_nodes(".geometry strong") %>%
html_text()%>%
str_trim(),
CanyonStrive = Canyon %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
GhostRiot = Ghost %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
CubeStereo = Cube %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
RoseRootMiller = Rose %>%
html_nodes("td:nth-child(3)") %>%
html_text()%>%
str_trim(),
)
ComparisonTable <- Comparison %>%
mutate_all(~gsub("mm|°|-.*|/.*|\\.", "", .)) %>%
mutate_all(~gsub(",", ".", .)) %>%
mutate_all(type.convert, as.is=TRUE) %>%
gather("Bikes", "value", 2:ncol(Comparison)) %>%
spread(Geometry,value)
Art <- c("Enduro", "Enduro", "AllMountain", "Enduro")
ComparisonTableHallo <- ComparisonTable
ComparisonTableHallo$Art <- Art
# server
server <- function(input, output, session) {
selectedData1 <- reactive({
ComparisonTableHallo %>%
filter(ComparisonTableHallo$Bikes != gsub("[[:space:]]*$","",gsub("- .*",'',input$Bikes)))
})
selectedData2 <- reactive({
selectedData1() %>%
select(1:12) %>%
filter(selectedData1()$Art %in% input$Art)
})
selectedData3 <- reactive({
ComparisonTableHallo %>%
select(1:12) %>%
filter(ComparisonTableHallo$Bikes == gsub("[[:space:]]*$","",gsub("- .*",'',input$Bikes)))
})
selectedData4 <- reactive({
rbind(selectedData3(),selectedData2())
})
selectedData5 <- reactive({
selectedData4() %>%
select(3:11)
})
selectedData6 <- reactive({
as.numeric(knnx.index(selectedData5(), selectedData5()[1, , drop=FALSE], k=2))
})
selectedData7 <- reactive({
selectedData4()[selectedData6(),]
})
selectedData8 <- reactive({
selectedData7() %>%
select(3:11)
})
# Combine the selected variables into a new data frame
output$plot1 <- renderPlotly({
validate(
need(dim(selectedData2())[1]>=2, "Sorry, no ten similar bikes were found.
Please change the input filters."
)
)
plot_ly(
type = 'scatterpolar',
mode = "closest",
fill = 'toself'
) %>%
add_trace(
r = as.matrix(selectedData8()[1,]),
theta = c("Kettenstrebe", "Lenkwinkel","Oberrohr","Radstand","Reach","Sattelrohr","Sitzwinkel","Stack","Steuerrohr",
"Tretlagerabsenkung"),
showlegend = TRUE,
mode = "markers",
name = selectedData7()[1,1]
) %>%
add_trace(
r = as.matrix(selectedData8()[2,]),
theta = c("Kettenstrebe","Lenkwinkel","Oberrohr","Radstand","Reach","Sattelrohr","Sitzwinkel","Stack","Steuerrohr",
"Tretlagerabsenkung"),
showlegend = TRUE,
mode = "markers",
visible="legendonly",
name = selectedData7()[2,1]
) %>%
layout(
polar = list(
radialaxis = list(
visible = T,
range = c(0,100)
)
),
showlegend=TRUE
)
})
}
#shiny app
ui <- fluidPage(navbarPage("Bike Comparison",
tabPanel("Graphic",fluidPage(theme = shinytheme("flatly")),
tags$head(
tags$style(HTML(".shiny-output-error-validation{color: red;}"))),
pageWithSidebar(
headerPanel('Apply filters'),
sidebarPanel(width = 4,
selectInput('Bike', 'Choose a Bike:',paste(ComparisonTableHallo$Bikes)),
checkboxGroupInput(inputId = "Art",
label = 'Art:', choices = c("Enduro" = "Enduro", "AllMountain" = "AllMountain"
),
selected = c("Enduro" = "Enduro","AllMountain" = "AllMountain"),inline=TRUE),
submitButton("Update filters")
),
mainPanel(
column(8, plotlyOutput("plot1", width = 800, height=700),
p("To visualize the graph of the player, click the icon at side of names
in the graphic legend. It is worth noting that graphics will be overlapped.",
style = "font-size:25px")
)
)
)))
)
shinyApp(ui = ui, server = server)
On your UI, your input is named Bike, on your server, you are referring to input$Bikes. Either Bike needs to change to Bikes, or the opposite.
Edit: (elaboration) Your error is telling you that you have a problem with one your arguments to the function filter. Specifically, you're passing an object of length 0 to the function. You are trying to pass the Bike. An empty select input would pass "", so that isn't the problem. "" has length 1. However an input you never assigned would pass NULL. That has length 0.

Specify column width on the fist n variables where n is a variable dependent on an input selector

I have an app with a DT datatable. The table groups by some specified dimensions input by the user. Where the user specifies 1,2,3 or 4 grouping variables, I would like these variables to have a width of 100px.
The full code to reproduce is below. The specific code block in question is:
output$eg_table <- DT::renderDT({my_flights_react() },
filter = 'top', options = list(dom = 'tip',
autoWidth = T,
scrollX=T,
columnDefs = list(list(width = '100px',
targets = 1:length(input$group_dims)))
)
)
If I change 1:length(input$group_dims) to instead be 1:3 then the first 3 columns will indeed adjust to the specified length. It seems DT or Shiny cannot properly read in the length of the input input$group_dims.
How can I adjust the first n number of column widths where the number of columns is a variable dependent upon user input?
Full code to reproduce, note only the first column shows as 100px, even if I select all the fields in the selector:
library(tidyverse)
library(shiny)
library(nycflights13)
library(lubridate)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Example Shiny App"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput(inputId = "group_dims",
label = "group_dims",
choices = c("carrier", "origin", "dest", "tailnum"),
selected = c("carrier"),
multiple = T) # There can be only one
),
# DT table
mainPanel(
DT::dataTableOutput("eg_table")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# initial preprocessing
my_flights <- flights %>%
filter(month == 11 & day >= 14) %>% # just data for 2 weeks
mutate(date = ymd(paste(year, month, day, sep = "-"))) %>%
select(date, carrier, origin, dest, tailnum, distance) %>%
mutate(date = ordered(format(date, "%d-%b"), levels = format(sort(unique(date)), "%d-%b")))
# recative preprocessing
my_flights_react <- reactive({
dims <- input$group_dims
my_flights %>%
group_by_at(vars(date, dims)) %>%
summarise(distance = sum(distance)) %>%
pivot_wider(names_from = date, values_from = distance) %>%
replace(is.na(.), 0) %>%
ungroup() %>%
add_column(Total = rowSums(select(., -dims), na.rm = T), .after = length(dims)) %>%
arrange(desc(Total))
})
output$eg_table <- DT::renderDT({my_flights_react() },
filter = 'top', options = list(dom = 'tip',
autoWidth = T,
scrollX=T,
columnDefs = list(list(width = '100px',
targets = 1:length(input$group_dims)))
)
)
}
# Run the application
shinyApp(ui = ui, server = server)
Screen:
Your minimal example is working OK. The columns are wider than without the columnsDef bit. (Selecting tailgate throws an error, but that's besides the point.)

How to keep values after changing chained selectInputs in shiny in R?

I have a complicated shiny app (here is a simpler example) which looks like that:
The app gives user the possibility to change four parameters (selectInput). The lower parameter depends on the highter one (ex. month on year, type on year and month and so on). Everything works but the fact that when I change one parameter, the other one changes too. It is needed in some situations, but not always. It is needed when the level chosen earlier does not exist in new configuration but for example when I have the following situation it should not be changed. Ex. I chose type 'AGD' and size 'medium' for some year and month and I show the prise or something for this combination. Then I would like to compare it to the same size in type 'RTV' so I change type parameter. Everything works but the size changes to the 'big' while I wanted it still to be 'medium'. I can make another click but what for? It is very inconvenient then...
Do you know how to deal with a problem like that?
I managed to do it for two dependencies using observe and reactive values, but for four dependencies it does not work.
Here is my code:
library("shiny")
library("plotly")
library("dplyr")
data <- data.frame(year = rep(c(rep(2018, 6), rep(2019, 11)), each = 5),
month = rep(c(7:12, 1:11), each = 5),
type = rep(c("AGD", "AGD", "AGD", "RTV", "RTV"), 6 + 11),
value = sample(1:100, 85),
size = rep(c("big", "small", "medium", "big", "miedium"), 6 + 11))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("year"),
uiOutput("month"),
uiOutput("type"),
uiOutput("size")
),
mainPanel(
)
)
)
server <- function(input, output, session) {
output$year <- renderUI({
year <- data %>%
select(year) %>%
unique()
selectInput("year",
"YEAR",
year$year,
selected = max(year$year))
})
output$month <- renderUI({
month <- data %>%
filter(year == input$year) %>%
select(month) %>%
unique() %>%
arrange()
selectInput("month",
"MONTH",
month$month,
selected = max(month$month))
})
output$type <- renderUI({
type <- data %>%
filter(year == input$year,
month == input$month) %>%
select(type) %>%
unique() %>%
arrange()
selectInput("type",
"TYPE",
type$type,
selected = type$type[1])
})
output$size <- renderUI({
size <- data %>%
filter(year == input$year,
month == input$month,
type == input$type) %>%
select(size) %>%
unique() %>%
arrange()
selectInput("size",
"SIZE",
size$size,
selected = size$size[1])
})
}
shinyApp(ui = ui, server = server)
Issues With the Existing Code
There are a couple of issues with the code here and the solution allows us to introduce the concept of memory into the app. First and foremost there are two issues I would like to address right off the bat.
c("big", "small", "medium", "big", "medium") and not c("big", "small", "medium", "big", "miedium")
The uiOutput() and renderUI() combination results the server serving a new selectInput button, everytime the input is changed. Instead we can simply instantiate a static UI element and update it using updateSelectInput()
Solution
To solve this problem lets first fix 1) and 2) described above. Then we need to introduce the concept of memory. The server needs to know what was previously selected, so that we can set it as the default option when the selectInput is updated. We can store this as a regular list (a variable for year, month, type and size) or a reactive list using reactiveValues.
Its great that you have settled on a clear cut logic for the filtering options, there is a clear hierarchy from years-> months -> type -> size. However, everytime months was changed for example a new input was generated for type and size.
We would now like to introduce a simple logic where the input selection only modifies the memory selected_vals. Then a change in memory triggers the other inputs to be updated. This is best seen in the solution below.
Code Solution
library("shiny")
library("plotly")
library("dplyr")
data <- data.frame(year = rep(c(rep(2018, 6), rep(2019, 11)), each = 5),
month = rep(c(7:12, 1:11), each = 5),
type = rep(c("AGD", "AGD", "AGD", "RTV", "RTV"), 6 + 11),
value = sample(1:100, 85),
size = rep(c("big", "small", "medium", "big", "medium"), 6 + 11))
years = data %>% arrange(year) %>% .$year %>% unique(.)
month = data %>% arrange(month) %>% .$month %>% unique(.)
type = data %>% arrange(type)%>% .$type %>% unique(.)
size = data %>% arrange(size) %>%.$size %>% unique(.)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("year","Year",choices = years,selected = 2018),
selectInput("month","Month",choices = month,selected = 7),
selectInput("type","Type",choices = type,selected = "AGD"),
selectInput("size","Size",choices = size,selected = "big")
),
mainPanel(
)
)
)
server <- function(input, output, session) {
#------- Initialize the Memory ----------
selected_vals = reactiveValues(year = 2019,month = 7, type = "AGD", size = "big")
#------ Whenever any of the inputs are changed, it only modifies the memory----
observe({
req(input$year,input$month,input$type,input$size)
selected_vals$year <- input$year
selected_vals$month <- input$month
selected_vals$type <- input$type
selected_vals$size <- input$size
})
#------ Update all UI elements using the values stored in memory ------
observe({
year <- data %>%
select(year) %>%
unique()
updateSelectInput(session,"year",choices = year$year,selected = selected_vals$year)
})
observe({
month <- data %>%
filter(year == selected_vals$year) %>%
select(month) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$month %in% month$month) displayVal = selected_vals$month else displayVal = NULL
updateSelectInput(session,"month",choices = month$month,selected = displayVal)
})
observe({
type <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month) %>%
select(type) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$type %in% type$type) displayVal = selected_vals$type else displayVal = NULL
updateSelectInput(session,"type",choices = type$type,selected = displayVal)
})
observe({
size <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month,
type == selected_vals$type) %>%
select(size) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if(selected_vals$size %in% size$size) displayVal = selected_vals$size else displayVal = NULL
updateSelectInput(session,"size",choices = size$size,selected = displayVal)
})
}
shinyApp(ui = ui, server = server)
Edit
As mentioned in the comment below there is a bug in the code. This is caused by the fact that then displayVal = NULL shiny sets the default value to display as the first element in he array. However we forget to store this in memory, selected_vals. The code below fixes this.
library("shiny")
library("plotly")
library("dplyr")
data <- data.frame(year = rep(c(rep(2018, 6), rep(2019, 11)), each = 5),
month = rep(c(7:12, 1:11), each = 5),
type = rep(c("AGD", "AGD", "AGD", "RTV", "RTV"), 6 + 11),
value = sample(1:100, 85),
size = rep(c("big", "small", "medium", "big", "medium"), 6 + 11))
years = data %>% arrange(year) %>% .$year %>% unique(.)
month = data %>% arrange(month) %>% .$month %>% unique(.)
type = data %>% arrange(type)%>% .$type %>% unique(.)
size = data %>% arrange(size) %>%.$size %>% unique(.)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("year","Year",choices = years,selected = 2018),
selectInput("month","Month",choices = month,selected = 7),
selectInput("type","Type",choices = type,selected = "AGD"),
selectInput("size","Size",choices = size,selected = "big")
),
mainPanel(
)
)
)
server <- function(input, output, session) {
#------- Initialize the Memory ----------
selected_vals = reactiveValues(year = 2019,month = 7, type = "AGD", size = "big")
#------ Whenever any of the inputs are changed, it only modifies the memory----
observe({
req(input$year,input$month,input$type,input$size)
selected_vals$year <- input$year
selected_vals$month <- input$month
selected_vals$type <- input$type
selected_vals$size <- input$size
})
#------ Update all UI elements using the values stored in memory ------
observe({
year <- data %>%
select(year) %>%
unique()
updateSelectInput(session,"year",choices = year$year,selected = selected_vals$year)
})
observe({
month <- data %>%
filter(year == selected_vals$year) %>%
select(month) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$month %in% month$month){
displayVal = selected_vals$month
}else{
displayVal = NULL
selected_vals$month = month$month[1]
}
updateSelectInput(session,"month",choices = month$month,selected = displayVal)
})
observe({
type <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month) %>%
select(type) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if (selected_vals$type %in% type$type){
displayVal = selected_vals$type
}else{
displayVal = NULL
selected_vals$type = tpye$type[1]
}
updateSelectInput(session,"type",choices = type$type,selected = displayVal)
})
observe({
size <- data %>%
filter(year == selected_vals$year,
month == selected_vals$month,
type == selected_vals$type) %>%
select(size) %>%
unique() %>%
arrange()
#Check if the value is in memory, if not return NULL (it defaults to the first element)
if(selected_vals$size %in% size$size){
displayVal = selected_vals$size
} else{
displayVal = NULL
selected_vals$size = size$size[1]
}
updateSelectInput(session,"size",choices = size$size,selected = displayVal)
})
}
shinyApp(ui = ui, server = server)

R Shiny - How to use the "melt" function (reshape2 package) to create a stacked barplot

thanks to your answers, I managed to make a barplot that reacts according to the time unit (Week, Month, Year) and agregates data by time unit (the link is here) :
R Shiny - How to create a barplot that reacts according to the time unit (Week, Month, Year) and agregates data by time unit
Then, I wish to make a stacked barplot with two variables. For it, I generate the follow data frame with two variables (i.e. in my example: Imported_cases and Autochthonous_cases) and I apply the “melt” function. The UI is here :
library(shiny)
library(dplyr)
library(lubridate)
library(ggplot2)
library(scales)
library(reshape2)
Disease <- data.frame(
Date = seq(as.Date("2015/1/1"), as.Date("2017/1/1"), "days"),
Imported_cases = rep(1),Autochtonous_cases=rep(2))
Disease <- Disease %>% mutate(
Week = format(Date, "%Y-%m-%U"),
Month = format(Date, "%Y-%m"), Year = format(Date, "%Y"))
Disease<- melt(Disease, id = c("Date","Week","Month","Year"),
measured = c("Imported_cases", "Autochtonous_cases"))
print(head(Disease))
ui <- fluidPage(
dateRangeInput("daterange", "Choice the date",
start = min(Disease$Date),
end = max(Disease$Date),
min = min(Disease$Date),
max = max(Disease$Date),
separator = " - ", format = "dd/mm/yy",
startview = 'Month', language = 'fr', weekstart = 1),
selectInput(inputId = 'Time_unit',
label = 'Time_unit',
choices = c('Week', 'Month', 'Year'),
selected = 'Month'),
plotOutput("Disease"))
When I run my server, R Shiny displays : Error object 'variable' not found. You find bellow the server code :
server <- function(input, output) {
dateRangeInput <- reactive({
dataset <- subset(
Disease, Date >= input$daterange[1] & Date <= input$daterange[2])
dataset
})
selectInput = reactive({
dataset <- dateRangeInput() %>% group_by_(input$Time_unit) %>%
summarise(Sum = sum(value))
dataset
})
output$Disease <-renderPlot({
ggplot(data=selectInput(),
aes_string(x = input$Time_unit, y = "Sum",
fill = "variable")) +
geom_bar(stat = "identity")
})
}
shinyApp (ui = ui, server = server)
I don't know if the problem is the code of selectInput or the code of output$Disease. I don't understand why Shiny doesn't find "variable" (cf. print(head(Disease)). Thank you for your help (I hope to be clear).
Hier is code which is going to work and create the stacked bar plot:
library(shiny)
library(dplyr)
library(lubridate)
library(ggplot2)
library(scales)
library(reshape2)
Disease<-data.frame(Date=seq(as.Date("2015/1/1"), as.Date("2017/1/1"), "days"),Cases=rep(1),Autochtonous_cases=rep(2))
Disease <- Disease %>% mutate(Week = format(Date, "%Y-%m-%U"),Month = format(Date, "%Y-%m"), Year = format(Date, "%Y"))
Disease<-melt(Disease,id=c("Date","Week","Month","Year")) # just id
ui <- fluidPage(
dateRangeInput("daterange", "Choice the date",
start = min(Disease$Date),
end = max(Disease$Date),
min = min(Disease$Date),
max = max(Disease$Date),
separator = " - ", format = "dd/mm/yy",
startview = 'Month', language = 'fr', weekstart = 1),
selectInput(inputId = 'Time_unit',
label='Time_unit',
choices=c('Week','Month','Year'),
selected='Month'),
plotOutput("Disease"))
server <- function(input, output) {
dateRangeInput<-reactive({
dataset <- subset(Disease, Date >= input$daterange[1] & Date <= input$daterange[2])
dataset
})
selectInput= reactive({
dataset <- dateRangeInput() %>% group_by_(input$Time_unit,"variable") %>% summarise(Sum = sum(value)) #I have added here grouping as variable
print(head(dataset))
dataset
})
output$Disease <-renderPlot({
ggplot(data=selectInput(), aes_string(x=input$Time_unit,y="Sum", fill = "variable")) + geom_bar(stat="identity") +
labs(title="Disease", y ="Number of cases") +
theme_classic() +
theme(plot.title = element_text(hjust = 0.5))
})
}
shinyApp (ui = ui, server = server)
I guess this is what You are looking for. You had small mistakes in melt function, setting up only id variables is fair enough, second thing is to consider the created variable column in group_by_ (as You wanna get the count of cases and autochtonous cases), and last is using variable as an fill argument in ggplot.

Resources