I'm producing a set of charts using highcharter. I have items, which each have variants, and units sold by variant. I'm looking for a method by which I can choose which variants are pre-selected to appear on the chart.
Below is an example of the chart I produced:
library(tidyverse)
library(highcharter)
library(viridis)
df <- tibble(item_name = c('beer','beer','soft drink','soft_drink'),
units = c(15,50,25,10),
variant_name = c('blonde','white','coke','lemonade'))
cols = as.vector(scales::viridis_pal(option = "turbo", direction = 1)(length(unique(df$variant_name))))
df %>%
group_by(item_name) %>%
arrange(desc(units)) %>%
ungroup() %>%
hchart(
"column", hcaes(x = item_name, y = units, group = variant_name),
stacking = "normal"
) %>%
hc_colors(c(cols))
I would like to be able to pre-select, let's say 'blonde' and 'coke'. Other variants would have to be selected by clicking on the variant name in the chart:
I haven't been able to find a way to do that so far, the documentation for highcharts only points to doing so when you have multiple series.
You could write your own JS function to load the elements. Where you can specify the chart.series.load, check this link for extra info. Here is a reproducible example:
library(tidyverse)
library(highcharter)
library(viridis)
df <- tibble(item_name = c('beer','beer','soft drink','soft_drink'),
units = c(15,50,25,10),
variant_name = c('blonde','white','coke','lemonade'))
cols = as.vector(scales::viridis_pal(option = "turbo", direction = 1)(length(unique(df$variant_name))))
df %>%
group_by(item_name) %>%
arrange(desc(units)) %>%
ungroup() %>%
hchart(
"column", hcaes(x = item_name, y = units, group = variant_name),
stacking = "normal"
) %>%
hc_chart(events = list(load = JS("function() {
var chart = this;
chart.series[1].setVisible(true)
chart.series[2].setVisible(false)
chart.series[3].setVisible(false)
chart.series[4].setVisible(false)
}"))) %>%
hc_colors(c(cols))
Output:
I am using highcharter library and referred to below link to create an interactive tooltip chart in a bubble chart
https://jkunst.com/blog/posts/2019-02-04-using-tooltips-in-unexpected-ways/
Plot image:
Using gapminder data as shown in link I was able to reproduce the same but when I use my other data then the tool tip chart doesn't appear.
Code for my other data:
libs
library(tidyverse)
library(highcharter)
data
grouped_cases_df <- read.csv("https://raw.githubusercontent.com/johnsnow09/covid19-df_stack-code/main/grouped_cases.csv")
tt_base <- grouped_cases_df %>%
arrange(desc(Date)) %>%
distinct(Country.Region, .keep_all = TRUE)
tt_base
tt_inner <- grouped_cases_df %>%
select(Country.Region, Date, Daily_cases) %>%
nest(-Country.Region) %>%
mutate(
data = map(data, mutate_mapping, hcaes(x = Date, y = Daily_cases), drop = TRUE),
data = map(data, list_parse)
) %>%
rename(tt_nestdata = data)
tt_inner
tt_daily <- left_join(tt_base, tt_inner, by = "Country.Region")
tt_daily
hchart(
tt_daily,
"point",
hcaes(x = Active, y = Confirmed, name = Country.Region,
size = Daily_cases, group = continent, name = Country.Region)
) %>%
hc_yAxis(type = "logarithmic") %>%
hc_tooltip(
useHTML = TRUE,
headerFormat = "<b>{point.key}</b>",
pointFormatter = tooltip_chart(accesor = "tt_nestdata")
) %>%
hc_title(text = "Active Vs Confirmed Cases as of latest Date") %>%
hc_subtitle(text = "Size of bubble based on Deaths <br> (ttchart: population growth)")
Issue: Getting blank tooltip chart for every country.
I also tried by changing Country.Region to as.factor() but didn't help. I am not sure whats wrong with this.
It's needed make two changes:
The tooltip data needs to be ready to highcharter. So you need to transform the Date column from text to date then to a numeric value which highcharts can interpret as date:
mutate(Date = highcharter::datetime_to_timestamp(lubridate::ymd(Date)))
Then, in the hc_opts argument in the tooltip_chart function you need to specify the x Axis treat the values as date.
pointFormatter = tooltip_chart(accesor = "tt_nestdata", hc_opts = list(xAxis = list(type = "datetime")))
Then:
I have a dataset that I want to visualize overall and disaggregated by a few different variables. I created a flexdashboard with a toy shiny app to select the type of disaggregation, and working code to plot the correct subset.
My approach is repetitive, which is a hint to me that I'm missing out on a better way to do this. The piece that's tripping me up is the need to count by date and expand the matrix. I'm not sure how get group counts by week in one pipe. I do it in several steps and combine.
Thoughts?
(ps. I asked this question on RStudio Community, but I think it's probably more of a "SO question". I don't have permissions to delete it from RSC, so apologies for the cross-post.)
---
title: "test"
output:
flexdashboard::flex_dashboard:
theme: bootstrap
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(tibbletime)
library(dygraphs)
library(magrittr)
library(xts)
```
```{r global, include=FALSE}
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"),
as.Date("2018-06-30"),
"days"),
sex = sample(c("male", "female"), 181, replace=TRUE),
lang = sample(c("english", "spanish"), 181, replace=TRUE),
age = sample(20:35, 181, replace=TRUE))
dat <- sample_n(dat, 80)
```
Sidebar {.sidebar}
=====================================
```{r}
radioButtons("diss", label = "Disaggregation",
choices = list("All" = 1, "By Sex" = 2, "By Language" = 3),
selected = 1)
```
Page 1
=====================================
```{r}
# all
all <- reactive(
dat %>%
mutate(new = 1) %>%
arrange(date) %>%
# time series analysis
as_tbl_time(index = date) %>% # convert to tibble time object
select(date, new) %>%
collapse_by('1 week', side="start", clean=TRUE) %>%
group_by(date) %>%
mutate(total = sum(new, na.rm=TRUE)) %>%
distinct(date, .keep_all = TRUE) %>%
ungroup() %>%
# expand matrix to include weeks without data
complete(date = seq(date[1],
date[length(date)],
by = "1 week"),
fill = list(total = 0))
)
# males only
males <- reactive(
dat %>%
filter(sex=="male") %>%
mutate(new = 1) %>%
arrange(date) %>%
# time series analysis
as_tbl_time(index = date) %>%
select(date, new) %>%
collapse_by('1 week', side="start", clean=TRUE) %>%
group_by(date) %>%
mutate(total_m = sum(new, na.rm=TRUE)) %>%
distinct(date, .keep_all = TRUE) %>%
ungroup() %>%
# expand matrix to include weeks without data
complete(date = seq(date[1],
date[length(date)],
by = "1 week"),
fill = list(total_m = 0))
)
# females only
females <- reactive(
dat %>%
filter(sex=="female") %>%
mutate(new = 1) %>%
arrange(date) %>%
# time series analysis
as_tbl_time(index = date) %>%
select(date, new) %>%
collapse_by('1 week', side="start", clean=TRUE) %>%
group_by(date) %>%
mutate(total_f = sum(new, na.rm=TRUE)) %>%
distinct(date, .keep_all = TRUE) %>%
ungroup() %>%
# expand matrix to include weeks without data
complete(date = seq(date[1],
date[length(date)],
by = "1 week"),
fill = list(total_f = 0))
)
# english only
english <- reactive(
dat %>%
filter(lang=="english") %>%
mutate(new = 1) %>%
arrange(date) %>%
# time series analysis
as_tbl_time(index = date) %>%
select(date, new) %>%
collapse_by('1 week', side="start", clean=TRUE) %>%
group_by(date) %>%
mutate(total_e = sum(new, na.rm=TRUE)) %>%
distinct(date, .keep_all = TRUE) %>%
ungroup() %>%
# expand matrix to include weeks without data
complete(date = seq(date[1],
date[length(date)],
by = "1 week"),
fill = list(total_e = 0))
)
# spanish only
spanish <- reactive(
dat %>%
filter(lang=="spanish") %>%
mutate(new = 1) %>%
arrange(date) %>%
# time series analysis
as_tbl_time(index = date) %>%
select(date, new) %>%
collapse_by('1 week', side="start", clean=TRUE) %>%
group_by(date) %>%
mutate(total_s = sum(new, na.rm=TRUE)) %>%
distinct(date, .keep_all = TRUE) %>%
ungroup() %>%
# expand matrix to include weeks without data
complete(date = seq(date[1],
date[length(date)],
by = "1 week"),
fill = list(total_s = 0))
)
# combine
totals <- reactive({
all <- all()
females <- females()
males <- males()
english <- english()
spanish <- spanish()
all %>%
select(date, total) %>%
full_join(select(females, date, total_f), by = "date") %>%
full_join(select(males, date, total_m), by = "date") %>%
full_join(select(english, date, total_e), by = "date") %>%
full_join(select(spanish, date, total_s), by = "date")
})
# convert to xts
totals_ <- reactive({
totals <- totals()
xts(totals, order.by = totals$date)
})
# plot
renderDygraph({
totals_ <- totals_()
if (input$diss == 1) {
dygraph(totals_[, "total"],
main= "All") %>%
dySeries("total", label = "All") %>%
dyRangeSelector() %>%
dyOptions(useDataTimezone = FALSE,
stepPlot = TRUE,
drawGrid = FALSE,
fillGraph = TRUE)
} else if (input$diss == 2) {
dygraph(totals_[, c("total_f", "total_m")],
main = "By sex") %>%
dyRangeSelector() %>%
dySeries("total_f", label = "Female") %>%
dySeries("total_m", label = "Male") %>%
dyOptions(useDataTimezone = FALSE,
stepPlot = TRUE,
drawGrid = FALSE,
fillGraph = TRUE)
} else {
dygraph(totals_[, c("total_e", "total_s")],
main = "By language") %>%
dyRangeSelector() %>%
dySeries("total_e", label = "English") %>%
dySeries("total_s", label = "Spanish") %>%
dyOptions(useDataTimezone = FALSE,
stepPlot = TRUE,
drawGrid = FALSE,
fillGraph = TRUE)
}
})
```
Update:
#Jon Spring suggested writing a function to reduce some repetition (applied below), which is a nice improvement. The basic approach is the same, however. Segment, calculate, combine, plot. Is there a way to do this without breaking apart and putting back together?
---
title: "test"
output:
flexdashboard::flex_dashboard:
theme: bootstrap
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(tibbletime)
library(dygraphs)
library(magrittr)
library(xts)
```
```{r global, include=FALSE}
# generate data
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"),
as.Date("2018-06-30"),
"days"),
sex = sample(c("male", "female"), 181, replace=TRUE),
lang = sample(c("english", "spanish"), 181, replace=TRUE),
age = sample(20:35, 181, replace=TRUE))
dat <- sample_n(dat, 80)
# Jon Spring's function
prep_dat <- function(filtered_dat, col_name = "total") {
filtered_dat %>%
mutate(new = 1) %>%
arrange(date) %>%
# time series analysis
tibbletime::as_tbl_time(index = date) %>% # convert to tibble time object
select(date, new) %>%
tibbletime::collapse_by("1 week", side = "start", clean = TRUE) %>%
group_by(date) %>%
mutate(total = sum(new, na.rm = TRUE)) %>%
distinct(date, .keep_all = TRUE) %>%
ungroup() %>%
# expand matrix to include weeks without data
complete(
date = seq(date[1], date[length(date)], by = "1 week"),
fill = list(total = 0)
)
}
```
Sidebar {.sidebar}
=====================================
```{r}
radioButtons("diss", label = "Disaggregation",
choices = list("All" = 1, "By Sex" = 2, "By Language" = 3),
selected = 1)
```
Page 1
=====================================
```{r}
# all
all <- reactive(
prep_dat(dat)
)
# males only
males <- reactive(
prep_dat(
dat %>%
filter(sex == "male")
) %>%
rename("total_m" = "total")
)
# females only
females <- reactive(
prep_dat(
dat %>%
filter(sex == "female")
) %>%
rename("total_f" = "total")
)
# english only
english <- reactive(
prep_dat(
dat %>%
filter(lang == "english")
) %>%
rename("total_e" = "total")
)
# spanish only
spanish <- reactive(
prep_dat(
dat %>%
filter(lang == "spanish")
) %>%
rename("total_s" = "total")
)
# combine
totals <- reactive({
all <- all()
females <- females()
males <- males()
english <- english()
spanish <- spanish()
all %>%
select(date, total) %>%
full_join(select(females, date, total_f), by = "date") %>%
full_join(select(males, date, total_m), by = "date") %>%
full_join(select(english, date, total_e), by = "date") %>%
full_join(select(spanish, date, total_s), by = "date")
})
# convert to xts
totals_ <- reactive({
totals <- totals()
xts(totals, order.by = totals$date)
})
# plot
renderDygraph({
totals_ <- totals_()
if (input$diss == 1) {
dygraph(totals_[, "total"],
main= "All") %>%
dySeries("total", label = "All") %>%
dyRangeSelector() %>%
dyOptions(useDataTimezone = FALSE,
stepPlot = TRUE,
drawGrid = FALSE,
fillGraph = TRUE)
} else if (input$diss == 2) {
dygraph(totals_[, c("total_f", "total_m")],
main = "By sex") %>%
dyRangeSelector() %>%
dySeries("total_f", label = "Female") %>%
dySeries("total_m", label = "Male") %>%
dyOptions(useDataTimezone = FALSE,
stepPlot = TRUE,
drawGrid = FALSE,
fillGraph = TRUE)
} else {
dygraph(totals_[, c("total_e", "total_s")],
main = "By language") %>%
dyRangeSelector() %>%
dySeries("total_e", label = "English") %>%
dySeries("total_s", label = "Spanish") %>%
dyOptions(useDataTimezone = FALSE,
stepPlot = TRUE,
drawGrid = FALSE,
fillGraph = TRUE)
}
})
```
Thanks for explaining more about your goals. I think the approach #simon-s-a suggests will simplify things. If we can run the grouping dynamically, and structure it so that we don't need to know the possible components in those groups beforehand, it will be a lot easier to maintain.
Here's a minimum viable product that rebuilds the plotting function to include the grouping logic inside it.
Once grouped by date and whatever our grouping variable is, it counts how many rows each group has, then spreads those so each group gets a column.
Then I use padr::pad to pad out any missing time rows in between, and replace all the NA's with zeros.
Finally, that data frame is converted to an xts object and fed into dygraph, which seems to handle the multiple columns automatically.
Here:
---
title: "test"
output:
flexdashboard::flex_dashboard:
theme: bootstrap
runtime: shiny
---
```{r setup, include=FALSE}
library(flexdashboard)
library(tidyverse)
library(tibbletime)
library(dygraphs)
library(magrittr)
library(xts)
```
```{r global, include=FALSE}
# generate data
set.seed(1)
dat <- data.frame(date = seq(as.Date("2018-01-01"),
as.Date("2018-06-30"),
"days"),
sex = sample(c("male", "female"), 181, replace=TRUE),
lang = sample(c("english", "spanish"), 181, replace=TRUE),
age = sample(20:35, 181, replace=TRUE))
dat <- dplyr::sample_n(dat, 80)
```
Sidebar {.sidebar}
=====================================
```{r}
radioButtons("diss", label = "Disaggregation",
choices = list("All" = "Total",
"By Sex" = "sex",
"By Language" = "lang"),
selected = "Total")
```
Page 1
=====================================
```{r plot}
renderDygraph({
grp_col <- rlang::sym(input$diss) # This converts the input selection to a symbol
dat %>%
mutate(Total = 1) %>% # This is a hack to let us "group" by Total -- all one group
# Here's where we unquote the symbol so that dplyr can use it
# to refer to a column. In this case I make a dummy column
# that's a copy of whatever column we want to group
mutate(my_group = !!grp_col) %>%
# Now we make a group for every existing combination of week
# (using lubridate::floor_date) and level of our grouping column,
# count how many rows in each group, and spread that to wide format.
group_by(date = lubridate::floor_date(date, "1 week"), my_group) %>%
count() %>% spread(my_group, n) %>% ungroup() %>%
# padr:pad() fills in any missing weeks in the sequence with new rows
# Then we replace all the NA's with zeroes.
padr::pad() %>% replace(is.na(.), 0) %>%
# Finally we can convert to xts and feed the wide table into digraph.
xts::xts(order.by = .$date) %>%
dygraph() %>%
dyRangeSelector() %>%
dyOptions(
useDataTimezone = FALSE, stepPlot = TRUE,
drawGrid = FALSE, fillGraph = TRUE
)
})
```
This is a good place to make a function, to shorten your code and make it less prone to error.
http://r4ds.had.co.nz/functions.html
A complicating bit is that programming with dplyr often requires wading into a framework called tidyeval, which is very powerful but can be intimidating.
https://dplyr.tidyverse.org/articles/programming.html
(Here's an alternative approach that sidesteps tidyeval: https://cran.r-project.org/web/packages/seplyr/vignettes/using_seplyr.html)
In your scenario, it's possible to avoid these challenges entirely by doing a bit of manipulation before and after your function. It's not as elegant, but works.
BTW, I can't guarantee it'll work since you didn't share a verifiable reprex (e.g. including a sample of data with the same form as yours), but it worked with the fake data I made up. (See bottom.) Sorry, I missed the chunk where your sample data was provided.
prep_dat <- function(filtered_dat, col_name = "total") {
filtered_dat %>%
mutate(new = 1) %>%
arrange(date) %>%
# time series analysis
tibbletime::as_tbl_time(index = date) %>% # convert to tibble time object
select(date, new) %>%
tibbletime::collapse_by("1 week", side = "start", clean = TRUE) %>%
group_by(date) %>%
mutate(total = sum(new, na.rm = TRUE)) %>%
distinct(date, .keep_all = TRUE) %>%
ungroup() %>%
# expand matrix to include weeks without data
complete(
date = seq(date[1], date[length(date)], by = "1 week"),
fill = list(total = 0)
)
}
Then you could call it with your filtered data and the name of the total column. This fragment should be able to replace the ~20 lines you're currently using:
males <- prep_dat(dat_fake %>%
filter(sex == "male")) %>%
rename("total_m" = "total")
Fake data that I tested on:
dat_fake <- tibble(
date = as.Date("2018-01-01") + runif(500, 0, 100),
new = runif(500, 0, 100),
sex = sample(c("male", "female"),
500, replace = TRUE),
lang = sample(c("english", "french", "spanish", "portuguese", "tagalog"),
500, replace = TRUE)
)
I think you can make some gains by changing the order of your preparation. Right now the flow of your app is approximately:
Data => prepare all combinations => select desired visualization => make plot
Consider instead:
Data => select desired visualization => prepare required combination => make plot
This would make use of Shiny's reactivity to (re)prepare the data required for the requested plot in response to changes in the user's selection.
By way of code snippets (Sorry, I don't have sufficient familiarity with flexdashboard and tibbletime to ensure this code runs, but I hope it is enough to highlight the approach):
Your control selects the column you want to focus on (note we use "All" = "'1'" so this evaluates to a constant in the group-by, else it has to be handled separately):
radioButtons("diss", label = "Disaggregation",
choices = list("All" = "'1'",
"By Sex" = "sex",
"By Language" = "lang",
"By other" = "column_name_of_'other'"),
selected = 1)
And then use this in your group by to prepare only the data required for the present visualization (you'll need to adjust the function suggested by #Jon_Spring in response to this earlier group-by):
preped_dat = reactive({
dat %>%
group_by_(input$diss) %>%
# etc
})
Before plotting (you'll need to adjust the plotting function in response to the possible change in data format):
renderDygraph({
totals = preped_data()
dygraph(totals) %>%
dySeries("total", label = ) %>%
dyRangeSelector()
})
With regard to group_by you can use group_by_ if all your arguments are text strings, or group_by(!! sym(input$diss), other_column_name) if you want to mix the text string input from your control with other column names.
One possible disadvantage of this change in approach is reduced responsiveness during interactivity if your data set is large. The present approach does all the computation up front and then minimal computation each selection - this may be preferable if you have a large amount of processing. My suggested approach will have minimal up front processing and moderate computation each selection.
R Code:
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
options(stringsAsFactors = FALSE)
rm(list = ls())
if (!require("pacman")) install.packages("pacman")
pacman::p_load("dplyr","tidyr","highcharter")
raw_data <- read.csv("results.csv")
DT <- data.table(raw_data)
cols <- c('Person','ABC_Capability','ABC_Sub.capability','Leadership.Facet','Facet.Score')
DT <- DT[, cols, with = FALSE]
names(DT) <- c('Person','Capability','Sub_Capability','SVL','Facet_Score')
DT <- dcast(DT, Capability + Sub_Capability + SVL ~ Person,
value.var = c('Facet_Score'))
DT1 <- DT %>%
group_by(name = Sub_Capability) %>%
do(categories = .$SVL) %>%
list_parse()
highchart() %>%
hc_chart(type = "bar") %>%
hc_title(text = "Some Title") %>%
hc_add_series(name="A", data = DT$Joan) %>%
hc_add_series(name="B", data = DT$Shane) %>%
hc_add_series(name="C", data = DT$Simon) %>%
hc_xAxis(categories = DT1)
Output:
I tried using a smaller dataset and realized every time there is a single value in a group. The label gets truncated. For example: Develops people > Empowering
Any help would be appreciated.
Like Kamil Kulig mentioned, you can try making the categories an array instead of vector and it worked for me. Using the sample code you provided, it would be:
DT1 <- DT %>%
group_by(name = Sub_Capability) %>%
# store SVL as array
do(categories = array(.$SVL)) %>%
list_parse()
New Update:
The vector needs to be converted to an array using the array() function even if you are not using grouped categories but simply wanted to rename the tick labels i.e.
highcharter::hchart(mtcars[1, ],
"column", name = "MPG",
highcharter::hcaes(x = 0, y = mpg),
showInLegend = F) %>%
# x axis format
highcharter::hc_xAxis(title = list(text ="Car Name"),
# relabel x axis tick to the name of the cars
categories = array(rownames(mtcars)[1]))
then the axis tick label will display the name of the car.
If you use simply categories = rownames(mtcars)[1]) instead of converting it into an array the x axis label won't display properly:
Here the tick label is just M instead of Mazada RX4.