R Shiny ggvis does not react on dynamic input - r

I try to build a shiny dashboard with ggvis barcharts. The idea is to display barcharts with top 10 costs for a particular month in a year. The user may choose a year and a month. The choice of months is dependend on the chosen year, so if choosing 2016 only the months to date can be selected.
Somehow I can't pass the value of the dynamic input field to the barchart. Though it works as long as both input fields are static (exchanging input$month1 with input$monthtest in the first lines of the server script shows you how it is supposed to look like). I have tried about everything I can think of from isolating() the input month to using observe() instead of reactive().
The error returned is: Warning: Error in eval: incorrect length (0), expecting: 12; i.e. somehow the value in the dynamic field is not passed to the reactive environment
Many thanks in advance!
Here is a "minimal" working example close enough to what my actual dashboard looks like:
#Minimal example Shiny dynamic field
#ggvis Barchart depending on static and dynamic dropdown
library("zoo")
library("shiny")
library("ggvis")
library("magrittr")
library("dplyr")
library("lubridate")
#data-------------
#in the actual code months are in German
month.loc <- c("January","February","March","April","Mai", "June",
"July","August","September","October","November", "December")
#generate data
Databc1M<-data.frame("date"=seq(as.Date("2015-01-01"),
as.Date("2016-03-01"), by="months"), "cost1"=runif(15,min=0,max=100),
"cost2"=runif(15,min=0,max=100), "cost3"=runif(15,min=0,max=100),
"cost4"=runif(15,min=0,max=100),
"cost5"=runif(15,min=0,max=100), "cost6"=runif(15,min=0,max=100),
"cost7"=runif(15,min=0,max=100),
"cost8"=runif(15,min=0,max=100), "cost9"=runif(15,min=0,max=100),
"cost10"=runif(15,min=0,max=100))
#ui-------------
ui <- fluidPage(
ggvisOutput(plot_id = "Barcha_Abw"),
selectInput(inputId = "Year1", label = h3("Choose a year"),
choices = c(2015,2016), selected=2015
),
#Rendering plot works with static input field
selectInput(inputId = "monthtest", label = h3("Choose a month"),
choices = month.loc[1:3], selected=month.loc[1]
),
uiOutput("bc1month")
)
#server-------------
server <- function(input, output, session) {
output$bc1month <- renderUI({
#filter available months in a given year
outmonths<- Databc1M %>% dplyr::filter(format(Databc1M$date,"%Y")==
as.character(input$Year1)) %>%
.[[1]] %>% month() %>% month.loc[.]
#dynamic dropdown; latest month selected
selectInput(inputId = 'month1', label = h3("Choose a month
(dynamic drop down)"), choices = outmonths,
#choose latest month in dataset
selected= Databc1M[NROW(Databc1M),"date"] %>% month() %>%
month.loc[.])
})
#structure data and render barchart
TopAbw1 <- reactive({
Dataaux <- Databc1M %>%
dplyr::filter(format(Databc1M$date,"%Y")==input$Year1)
#!!!!!! not working: match(input$month1,...); input$monthtest works
Dataaux<-
dplyr::filter(Dataaux,month(Dataaux$date)==match(input$month1,
month.loc)) #input$month1
Dataaux <- gather(Dataaux,key="cost_id",value="Abweichung")
Dataaux <- Dataaux[-1,]
Dataaux <- Dataaux[order(Dataaux$Abweichung,decreasing=TRUE),] %>%
head(10)
Dataaux$cost_id <- factor(Dataaux$cost_id, levels = Dataaux$cost_id)
#render barchart
Dataaux %>%
ggvis(y=~abs(Abweichung),x=~cost_id) %>%
layer_text(text:=~round(abs(Abweichung),2)) %>%
layer_bars( stack =FALSE) %>%
add_axis("x", title = "", properties = axis_props(labels =
list(angle= 45, align = "left", fontSize = 12))) %>%
add_axis("y", title = "Mio. EUR")
})
TopAbw1 %>% bind_shiny("Barcha_Abw")
}
shinyApp(ui = ui, server = server)

I had a german version of the question. For the documentation purpose (and if anyone is curious about the answer:
#Minimal example Shiny dynamic field
#ggis Barchart soll nach Nutzereingabe in 2 Dropdowns neu gerendert werden
#Ein Dropdown ist dynamisch
library("zoo")
library("shiny")
library("ggvis")
library("magrittr")
library("dplyr")
library("lubridate")
#data-------------
month.loc <- c("Januar","Februar","März","April","Mai", "Juni",
"Juli","August","September","Oktober","November", "Dezember")
currdate <- as.Date("2015-01-01",format="%Y-%m-%d")
Databc1M<-data.frame("date"=seq(as.Date("2015-01-01"), as.Date("2016-03-01"), by="months"), "cost1"=runif(15,min=0,max=100),
"cost2"=runif(15,min=0,max=100), "cost3"=runif(15,min=0,max=100), "cost4"=runif(15,min=0,max=100),
"cost5"=runif(15,min=0,max=100), "cost6"=runif(15,min=0,max=100), "cost7"=runif(15,min=0,max=100),
"cost8"=runif(15,min=0,max=100), "cost9"=runif(15,min=0,max=100), "cost10"=runif(15,min=0,max=100))
#ui-------------
ui <- fluidPage(
ggvisOutput(plot_id = "Barcha_Abw"),
selectInput(inputId = "Year1", label = h3("Wählen Sie ein Jahr"),
choices = c(2015,2016), selected=2015
),
#Test mit fixem dropdown funktioniert der Plot
uiOutput("bc1month"),
plotOutput("TopAbw1")
)
#server-------------
server <- function(input, output, session) {
output$bc1month <- renderUI({
outmonths<- Databc1M %>% dplyr::filter(format(Databc1M$date,"%Y")== input$Year1) %>%
.[[1]] %>% month() %>% month.loc[.]
#input$Year1
selectInput(inputId = 'month1', label = h3("Wählen Sie einen Monat (dynamisch)"), choices = outmonths)
})
TopAbw1 <- reactive({
Dataaux <- Databc1M[which(year(Databc1M$date) %in% input$Year1),]
Dataaux <- Dataaux[which(months(Dataaux$date) %in% input$month1),]
Dataaux <- gather(Dataaux,key="cost_id",value="Abweichung")
Dataaux <- Dataaux[-1,]
Dataaux <- Dataaux[order(Dataaux$Abweichung,decreasing=TRUE),] %>%
head(10)
Dataaux$cost_id <- factor(Dataaux$cost_id, levels = Dataaux$cost_id)
Dataaux %>%
ggvis(y=~abs(Abweichung),x=~cost_id) #%>%
#layer_text(text:=~round(abs(Abweichung),2)) %>%
#layer_bars( stack =FALSE) %>%
#add_axis("x", title = "", properties = axis_props(labels = list(angle = 45, align = "left", fontSize = 12))) %>%
#add_axis("y", title = "Mio. EUR")
})
TopAbw1 %>% bind_shiny("Barcha_Abw")
}
shinyApp(ui = ui, server = server)

Related

Get the color code of a selected slice in HighCharter R

I'm trying to develop a part of a shiny app that makes an interactive visualization between a pie chart and a world map. So I want the users to click on the pie chart and then I can get the selected slice and the color code of the corresponding slice. I'm able to take the the slice that has been selected by the following code:
library(shiny)
library(highcharter)
ui <- fluidPage(
column(3,
highchartOutput("hcontainer",height = "300px")
),
column(3,
textOutput("clicked")
)
)
server <- function(input, output){
click_js <- JS("function(event) {Shiny.onInputChange('pieclick',event.point.name);}")
output$hcontainer <- renderHighchart({
highchart() %>%
hc_chart(type = "pie") %>%
hc_add_series(data = list(
list(y = 3, name = "cat 1"),
list(y = 4, name = "dog 11"),
list(y = 6, name = "cow 55"))) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
output$clicked <- renderText({
input$pieclick
})
}
shinyApp(ui, server)
But I can't see any way on how I can get the corresponding color of the selected slice ?
A possible solution for that is if I can get a vector of all the slice and a vector of all the corresponding color-codes then I can make a comparison between the value I got from the selection and the colors of each value. I also couldn't find a way to get all the values and color-codes used automatically in the pei chart generation.
Hey, the event.point has loads of other data, one of which is the event.point.color which we can take out. Do print out the object or event using console.log(event) so you can see what other things you can use from the event...
We can also ask for the hex color code from the point you're clicking within the same event. I couldn't find it how to use it seamlessly using purely JS, so going to do it on the R side...
Then we are going to convert the hex to human readable color using plotrix package. May need to remove digits of some colors like: grey27 and so on, so will just gsub and remove the digits
library(shiny)
library(plotrix)
library(highcharter)
ui <- fluidPage(
column(3,
highchartOutput("hcontainer",height = "300px")
),
column(3,
textOutput("clicked")
)
)
server <- function(input, output){
click_js <- JS("function(event) {Shiny.onInputChange('pieclick',[event.point.name,event.point.color]);}")
output$hcontainer <- renderHighchart({
highchart() %>%
hc_chart(type = "pie") %>%
hc_add_series(data = list(
list(y = 3, name = "cat 1"),
list(y = 4, name = "dog 11"),
list(y = 6, name = "cow 55"))) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
output$clicked <- renderText({
req(input$pieclick)
d <- input$pieclick
mycolor <- gsub("[[:digit:]]", "", color.id(d[2])[1])
paste0(d[1],"-",mycolor)
})
}
shinyApp(ui, server)

Loading online xml data to slider in R shiny dashboard

My friend and I built an R shiny dashboard using downloaded data. The code is as follows:
library(shiny)
library(shinydashboard)
library(dplyr)
library(tidyverse)
library(reshape)
library(scales)
ecd <- read.csv("ecd-figures.csv")
c(
"No of case" = "no_of_case",
"Minor Case" = "minor_case",
"All Non Fatal Case" = "all_non_fatal_case",
"Fatal Case" = "fatal_case"
) -> vec
ui <- fluidPage(sidebarLayout(
sidebarPanel
(
checkboxGroupInput("feature",
"Feature",
vec),
sliderInput(
"year",
"Year",
min = min(ecd$year),
max = max(ecd$year),
value = range(ecd$year),
sep = "",
step = 1
)
),
mainPanel(tabsetPanel(
tabPanel("Plot", plotOutput("correlation_plot")),
tabPanel("Table", tableOutput("ecd"))
))
))
server <- function(input, output) {
yearrange <- reactive({
ecd %>%
subset(year %in% input$year[1]:input$year[2]) %>%
select(c(year, input$feature))
})
output$correlation_plot <- renderPlot({
ecdsubset <- yearrange()
ecdsubset <- melt(ecdsubset, id = "year")
validate(need(input$feature, 'Check at least one item.'))
ggplot(ecdsubset, aes(x = year, y = value, color = variable)) + geom_line(size = 1) + scale_x_continuous(breaks =
seq(input$year[1], input$year[2], by = 1))
})
output$ecd <- renderTable({
yearrange()
})
}
shinyApp(ui, server)
The simple data file is here: https://drive.google.com/file/d/1pZQe89wxw14lirW2mRIgi9h29yPyc7Fs/view?usp=sharing
Then, I want to make everything online, i.e. calling api and not to download the csv file. It seems ok to read the contents rather simply, as follows:
library(xml2)
ecd_xml <-"https://www.labour.gov.hk/datagovhk/resource/ecd/ecd-figures.xml"
read_ecd <- read_xml(ecd_xml)
xml_find_all(read_ecd, ".//year")
{xml_nodeset (5)}
[1] <year>2015</year>
[2] <year>2016</year>
[3] <year>2017</year>
[4] <year>2018</year>
[5] <year>2019</year>
The problem is: how to parse every piece of information from the xml contents onto the dashboard?
Take the slidebar as an example. How to display the slidebar labels (i.e. 2015 and 2019) from parsing the <year> tag and selecting the max and min values?
And, can you recommend some reading materials for me to learn the whole process from xml to dashboard? Many many thanks in advance.
(P.S. I've tried to use xml package instead, since there are some standard arguments to find the max, min, and avg values of attributes. But I ran into another big error -
Error in function (type, msg, asError = TRUE) :
error:1407742E:SSL routines:SSL23_GET_SERVER_HELLO:tlsv1 alert protocol version
What should I do? My R version is 4.0.5 (2021-03-31).)
You can use xml2::as_list to create a tibble from the XML tree.
Moreover, you can use shiny::updateSliderInput to update UI slider ranges:
library(shiny)
library(shinydashboard)
library(dplyr)
library(tidyverse)
library(reshape)
library(scales)
library(xml2)
vec <- c(
"No of case" = "no_of_case",
"Minor Case" = "minor_case",
"All Non Fatal Case" = "all_non_fatal_case",
"Fatal Case" = "fatal_case"
)
ui <- fluidPage(sidebarLayout(
sidebarPanel(
checkboxGroupInput(
"feature",
"Feature",
vec
),
sliderInput(
"year",
"Year",
min = 2000,
max = 2001,
value = c(2000, 2001),
sep = "",
step = 1
)
),
mainPanel(tabsetPanel(
tabPanel("Plot", plotOutput("correlation_plot")),
tabPanel("Table", tableOutput("table"))
))
))
server <- function(input, output, session) {
xml <-
"https://www.labour.gov.hk/datagovhk/resource/ecd/ecd-figures.xml" %>%
read_xml()
table <-
xml %>%
xml_find_all(".//item") %>%
map(as_list) %>%
map(~ .x %>% as_tibble()) %>%
bind_rows() %>%
unnest(everything()) %>%
type_convert()
years <- table$year %>% unique()
updateSliderInput(
session = session,
inputId = "year",
min = min(years),
max = max(years),
value = c(min(years), max(years)) # current selected range
)
sub_table <- reactive({
table %>%
filter(year %in% input$year[1]:input$year[2]) %>%
select(c(year, input$feature))
})
output$correlation_plot <- renderPlot({
validate(need(input$feature, "Check at least one item."))
sub_table() %>%
pivot_longer(-year) %>%
ggplot(aes(x = year, y = value, color = name)) +
geom_line(size = 1) +
scale_x_continuous(
breaks = seq(input$year[1], input$year[2], by = 1)
)
})
output$table <- renderTable({
sub_table()
})
}
shinyApp(ui, server)

Slider with years for barplot

I am trying to get a slider within my barplot page to make the data interactive per year.
#library
library(dplyr)
library(shiny)
library(shinythemes)
library(ggplot2)
#Source
dataset <- read.csv("Wagegap.csv")
SFWage <- dataset %>%
group_by(gender,JobTitle, Year) %>%
summarise(averageBasePay = mean(BasePay, na.rm=TRUE)) %>%
select(gender, JobTitle, averageBasePay, Year)
clean <- SFWage %>% filter(gender != "")
#UI
ui <- fluidPage(
theme = shinytheme("united"),
navbarPage("San Fransisco Wages",
tabPanel("Barplot",
mainPanel(
plotOutput("barplot")
)) ,
tabPanel("Table",
mainPanel(
dataTableOutput("table")
))
)
)
#server
server <- function(input, output){
output$barplot <- renderPlot({
ggplot(clean, aes(x = JobTitle, y = averageBasePay ))+
geom_bar(stat="Identity", width = 0.3, fill="orange")+
labs(x= "Jobs", y = "Wage", title = "Wage per job")
})
output$table <- renderDataTable({
clean
})
}
#Run App
shinyApp(ui = ui, server = server)
I don't fully understand it yet how to put this input in.
I have tried sliding it into the navbarpage but I can't figure out how it works.
I also tried making year reactive but with no success.
It's not the year that has to be reactive; it's the whole data frame. Therefore, in your ui, you can do:
[...]
tabPanel("Barplot",
mainPanel(
sliderInput("year", label = "Which year should be displayed?", min = 1900, max = 2020, step = 5, value = 2000) # new
plotOutput("barplot")
)) ,
[...]
I put it there for convenience; the layout is yours. I tried do change as little as possible.
The server would then have:
server <- function(input, output){
# NEW ########################################
clean <- reactive({
SFWage <- dataset %>%
group_by(gender,JobTitle, Year) %>%
summarise(averageBasePay = mean(as.numeric(BasePay), na.rm=TRUE)) %>% # Notice the as.numeric()
select(gender, JobTitle, averageBasePay, Year)
SFWage %>% filter(gender != "" & Year == input$year)
})
# OLD ########################################
output$barplot <- renderPlot({
ggplot(clean(), aes(x = JobTitle, y = averageBasePay ))+ # Parenthesis
geom_bar(stat="Identity", width = 0.3, fill="orange")+
labs(x= "Jobs", y = "Wage", title = "Wage per job")
})
output$table <- renderDataTable({
clean() # Parenthesis
})
}
Don't forget to add the parenthesis, as I did here.
This should work, but I might have mistyped something or got it completely wrong. Since I don't have your data, I can't test it.
EDIT: Due to your comment, I added the as.numeric() term, as you can see above. However, if your data is not only not numeric but also with ,, you can do:
[...]
summarise(averageBasePay = mean(as.numeric(gsub(",", ".", BasePay)), na.rm=TRUE)) %>% # Notice the as.numeric() and the gsub()
[...]

Highcharter and Shiny with reactive dataset/mutated dataset within server function not working

When I try to produce a highcharter barplot within Shiny using a dataset that is grouped and summarized based on the selectInput values and these same values are referenced within hcaes() I get the error "object 'input' not found"
I have also tried hcaes_string() and then I get "object 'My.Variable' not found" but when I just put in My.Variable, it will produce the hchart so it can interact with the dataset being created within the server function. Obviously I'd like to switch between My.Variable and My.Variable2 with the dropdown. I've tried assigning the summarized dataset to a reactive object, but then I get the error "Objects of class/type reactiveExpr/reactive/function are not supported by hchart (yet)."
I've been at this for hours and this is my first question on StackOverflow. I rigged up a sample dataset so that the code is reproducible and I've updated R and RStudio to the latest versions.
library('highcharter')
library('plyr')
library('dplyr')
library('tidyr')
library('lubridate')
library('stringr')
library('tools')
library('shiny')
#demo <- read.csv("data/name-change-analysis.csv",stringsAsFactors = FALSE)
indiv <- rep(c('p1','p2','p3','p4','p5'),4)
Name.Change <- rep(c('yes','yes','no','yes','no'),4)
Overall.Category <- rep(c('against','support','support','neutral','against'),4)
Race <- rep(c('Black','White','White','Asian','White'),4)
Gender <- rep(c('Male','Male','Male','Female','Male'),4)
demo <- as.data.frame(cbind(indiv,Name.Change,Overall.Category,Race,Gender))
ui <-
navbarPage(
"Responses by demographics",
tabPanel(
"Manual labels",
fluidPage(
fluidRow(
column(
selectInput(
"category",
label = "Select a demographic category:",
choices = c("Race",
"Gender" = "gender")
),
width = 6
),
column(
selectInput(
"name_or_overall",
label = "Response Category",
choices = c(
"Name Change" = "Name.Change",
"Overall Category" = "Overall.Category"
),
width = "100%"
),
width = 6
)
),
highchartOutput("hcontainer")
)
),
collapsible = TRUE
)
server <- function(input, output, session) {
output$hcontainer <- renderHighchart({
demo %>%
group_by(input$category,input$name_or_overall) %>%
summarise(count = n()) %>%
hchart(type = "bar",
hcaes(y = "count",
x = as.name(input$category),
group = as.name(input$name_or_overall))) %>%
hc_plotOptions(bar = list(stacking = "percent")) %>%
hc_tooltip(shared = TRUE)
})
}
shinyApp(ui,server)
Try this
output$hcontainer <- renderHighchart({
df1 <- demo %>% mutate(var1=demo[[as.name(input$category)]], var2=demo[[as.name(input$name_or_overall)]])
df <- df1 %>% group_by(var1,var2) %>% summarise(count = n())
highchart() %>%
hc_add_series(df, type = "bar",
hcaes(y = "count",
x = "var1",
group = "var2")) %>%
hc_plotOptions(bar = list(stacking = "percent")) %>%
hc_tooltip(shared = FALSE)
})
You will get the following output:

Shiny + Leaflet reactive function not working

My data consists of columns like lon , lat, region, flat-type and year. I have used leaflet and shiny to create a map with cluster markers.
I included 2 selectInput boxes - one for year and one for the flat-type. Using the reactive function, it keeps giving me this error whenever I run the shiny app.
Error: Don't know how to get location data from object of class
reactiveExpr,reactive
Here's my code
library(shiny)
library(leaflet)
library(dplyr)
ui <- fluidPage(
titlePanel("Transactions for Resale Flats"),
h3("Model A Flats: 3-Room, 4-Room, 5-Room"),
sidebarLayout(position = 'right',
sidebarPanel(
selectInput("year","Year", choices = c("2007","2008",
"2009","2010","2011",
"2012","2013","2014",
"2015","2016","2017"), selected="2007"),
selectInput("type","Flat-Type",choices = c("3 ROOM",'4 ROOM',"5 ROOM"),selected = "3-Room"),
width = 2),
mainPanel(leafletOutput("mymap",height = 650,width=605)))
)
server <- function(input,output, session){
headlinedata<-reactive({
headlinedata%>%
filter(year %in% input$year & flat_type %in% input$type)
})
output$mymap <- renderLeaflet({
leaflet(data=headlinedata) %>%
addTiles() %>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(headlinedata$address,',',headlinedata$town))
})
observe(leafletProxy('mymap', data=headlinedata()))%>%
clearMarkers()%>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(headlinedata$address,',',headlinedata$town))
}
shinyApp(ui = ui, server = server)
Also this code
observe(leafletProxy('mymap', data=headlinedata()))%>%
clearMarkers()%>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(headlinedata$address,',',headlinedata$town))
Whenever I include this, the app will run for a second and then close immediately. This code is supposed to update the map markers whenever the input changes.
Thanks.
First, you need to refer to reactive variables as the variable name followed by (). In output$mymap, you refer to headlinedata, which is the data frame to be filtered, when it should be headlinedata(), which is the reactive variable that's already been filtered. To disambiguate the two, I changed the name of the reactive variable to df. Then, when that reactive variable is needed in code downstream, I refer to it as df().
Second, since df() is a reactive variable and we've set up the leaflet to depend upon it, whenever the reactive variable changes, the map will also change. This means we don't need the observe(leafletProxy ... code.
Here's a reproducible example you can copy and paste.
library(shiny)
library(leaflet)
library(dplyr)
set.seed(1)
headlinedata <- data.frame(year = rep(2007:2017, 10),
flat_type = sample(c("3 ROOM",'4 ROOM',"5 ROOM"),
110, replace=T),
lat = sample(1:50, 110, replace=T),
lng = sample(1:50, 110, replace=T),
address = "address",
town = "town")
ui <- fluidPage(
titlePanel("Transactions for Resale Flats"),
h3("Model A Flats: 3-Room, 4-Room, 5-Room"),
sidebarLayout(position = 'right',
sidebarPanel(
selectInput("year","Year", choices = c("2007","2008",
"2009","2010","2011",
"2012","2013","2014",
"2015","2016","2017"), selected="2007"),
selectInput("type","Flat-Type",choices = c("3 ROOM",'4 ROOM',"5 ROOM"),selected = "3-Room"),
width = 2),
mainPanel(leafletOutput("mymap",height = 650,width=605)))
)
server <- function(input,output, session){
df<-reactive({
headlinedata%>%
dplyr::filter(year %in% input$year & flat_type %in% input$type)
})
output$mymap <- renderLeaflet({
leaflet(data=df()) %>%
addTiles() %>%
addMarkers(clusterOptions = markerClusterOptions(),
label = paste(df()$address,',',df()$town))
})
}
shinyApp(ui = ui, server = server)

Resources