Customize colors for boxplot with highcharter - r

I have boxplots on highcharter and I would like to customize both the
Fill color
Border color
Here is my code
df = data.frame(cbind(categ = rep(c('a','b','c','d')),value = rnorm(1000)))
hcboxplot(var = df$categ, x = as.numeric(df$value)) %>%
hc_chart(type = "column") %>%
hc_colors(c("#203d7d","#a0a0ed","#203d7e","#a0a0ad"))
The hc_colors works only if I put var2 instead of var but then the box plot are shrunken...

API for styling fillColor: https://api.highcharts.com/highcharts/series.boxplot.fillColor
And for "Border color": https://api.highcharts.com/highcharts/series.boxplot.color
Pure JavaScript example of how to style and define points: https://jsfiddle.net/BlackLabel/6tud3fgx
And R code:
library(highcharter)
df = data.frame(cbind(categ = rep(c('a','b','c','d', 'e')),value = rnorm(1000)))
hcboxplot(var = df$categ, x = as.numeric(df$value)) %>%
hc_chart(type = "column", events = list(
load = JS("function() {
var chart = this;
chart.series[0].points[2].update({
color: 'red'
})
chart.series[0].points[4].update({
x: 4,
low: 600,
q1: 700,
median: 800,
q3: 900,
high: 1000,
color: 'orange'
})
}")
)) %>%
hc_plotOptions(boxplot = list(
fillColor = '#F0F0E0',
lineWidth = 2,
medianColor = '#0C5DA5',
medianWidth = 3,
stemColor = '#A63400',
stemDashStyle = 'dot',
stemWidth = 1,
whiskerColor = '#3D9200',
whiskerLength = '20%',
whiskerWidth = 3,
color = 'black'
)) %>%
hc_colors(c("#203d7d","#a0a0ed","#203d7e","#a0a0ad"))

I made a couple functions to do some stuff with highcharts and boxplots. It will let you color each boxplot and fill it accordingly, and then inject new graphical parameters according to the Highcharts API, should you desire.
Check it out:
## Boxplots Data and names, note the data index (0,1,2) is the first number in the datum
series<- list(
list(
name="a",
data=list(c(0,1,2,3,4,5))
),
list(
name="b",
data=list(c(1,2,3,4,5,6))
),
list(
name="c",
data=list(c(2,3,4,5,6,7))
)
)
# Graphical attribute to be set: fillColor.
# Make the colors for the box fill and then also the box lines (make them match so it looks pretty)
cols<- viridisLite::viridis(n= length(series2), alpha = 0.5) # Keeping alpha in here! (for box fill)
cols2<- substr(cols, 0,7) # no alpha, pure hex truth, for box lines
gen_key_vector<-function(variable, num_times){
return(rep(variable, num_times))
}
kv<- gen_key_vector(variable = "fillColor", length(series))
# Make a function to put stuff in the 'series' list, requires seq_along to be used since x is the list/vector index tracker
add_variable_to_series_list<- function(x, series_list, key_vector, value_vector){
base::stopifnot(length(key_vector) == length(value_vector))
base::stopifnot(length(series_list) == length(key_vector))
series_list[[x]][length(series_list[[x]])+1]<- value_vector[x]
names(series_list[[x]])[length(series_list[[x]])]<- key_vector[x]
return(series_list[[x]])
}
## Put the extra stuff in the 'series' list
series2<- lapply(seq_along(series), function(x){ add_variable_to_series_list(x = x, series_list = series, key_vector = kv, value_vector = cols) })
hc<- highcharter::highchart() %>%
highcharter::hc_chart(type="boxplot", inverted=FALSE) %>%
highcharter::hc_title(text="This is a title") %>%
highcharter::hc_legend(enabled=FALSE) %>%
highcharter::hc_xAxis(type="category", categories=c("a", "b", "c"), title=list(text="Some x-axis title")) %>%
highcharter::hc_add_series_list(series2) %>%
hc_plotOptions(series = list(
marker = list(
symbol = "circle"
),
grouping=FALSE
)) %>%
highcharter::hc_colors(cols2) %>%
highcharter::hc_exporting(enabled=TRUE)
hc
This probably could be adjusted to work with a simple dataframe, but I think it will get you what you want for right now without having to do too much extra work. Also, maybe look into list_parse or list_parse2' fromhighcharter...it could probably help with building out theseries` object..I still need to look into that.
Edit:
I have expanded the example to make it work with a regular DF. As per some follow up questions, the colors are set using the viridis palette inside the make_highchart_boxplot_with_colored_factors function. If you want to allow your own palette and colors, you could expose those arguments and just include them as parameters inside the function call. The expanded example borrows how to add outliers from the highcharter library (albeit in a hacky way) and then builds everything else up from scratch. Hopefully this helps clarify my previous answer. Please note, I could probably also clean up the if condition to make it a little more brief, but I kept it verbose for illustrative purposes.
Double Edit: You can now specify a vector of colors for each level of the factor variable
library(highcharter)
library(magrittr)
library(viridisLite)
df = data.frame(cbind(categ = rep(c('a','b','c','d')),value = rnorm(1000)))
df$value<- base::as.numeric(df$value)
add_variable_to_series_list<- function(x, series_list, key_vector, value_vector){
base::stopifnot(length(key_vector) == length(value_vector))
base::stopifnot(length(series_list) == length(key_vector))
series_list[[x]][length(series_list[[x]])+1]<- value_vector[x]
names(series_list[[x]])[length(series_list[[x]])]<- key_vector[x]
return(series_list[[x]])
}
# From highcharter github pages:
hc_add_series_bwpout = function(hc, value, by, ...) {
z = lapply(levels(by), function(x) {
bpstats = boxplot.stats(value[by == x])$stats
outliers = c()
for (y in na.exclude(value[by == x])) {
if ((y < bpstats[1]) | (y > bpstats[5]))
outliers = c(outliers, list(which(levels(by)==x)-1, y))
}
outliers
})
hc %>%
hc_add_series(data = z, type="scatter", ...)
}
gen_key_vector<-function(variable, num_times){
return(rep(variable, num_times))
}
gen_boxplot_series_from_df<- function(value, by,...){
value<- base::as.numeric(value)
by<- base::as.factor(by)
box_names<- levels(by)
z=lapply(box_names, function(x) {
boxplot.stats(value[by==x])$stats
})
tmp<- lapply(seq_along(z), function(x){
var_name_list<- list(box_names[x])
#tmp0<- list(names(df)[x])
names(var_name_list)<- "name"
index<- x-1
tmp<- list(c(index, z[[x]]))
tmp<- list(tmp)
names(tmp)<- "data"
tmp_out<- c(var_name_list, tmp)
#tmp<- list(tmp)
return(tmp_out)
})
return(tmp)
}
# Usage:
#series<- gen_boxplot_series_from_df(value = df$total_value, by=df$asset_class)
## Boxplot function:
make_highchart_boxplot_with_colored_factors<- function(value, by, chart_title="Boxplots",
chart_x_axis_label="Values", show_outliers=FALSE,
boxcolors=NULL, box_line_colors=NULL){
by<- as.factor(by)
box_names_to_use<- levels(by)
series<- gen_boxplot_series_from_df(value = value, by=by)
if(is.null(boxcolors)){
cols<- viridisLite::viridis(n= length(series), alpha = 0.5) # Keeping alpha in here! (COLORS FOR BOXES ARE SET HERE)
} else {
cols<- boxcolors
}
if(is.null(box_line_colors)){
if(base::nchar(cols[[1]])==9){
cols2<- substr(cols, 0,7) # no alpha, pure hex truth, for box lines
} else {
cols2<- cols
}
} else {
cols2<- box_line_colors
}
# Injecting value 'fillColor' into series list
kv<- gen_key_vector(variable = "fillColor", length(series))
series2<- lapply(seq_along(series), function(x){ add_variable_to_series_list(x = x, series_list = series, key_vector = kv, value_vector = cols) })
if(show_outliers == TRUE){
hc<- highcharter::highchart() %>%
highcharter::hc_chart(type="boxplot", inverted=FALSE) %>%
highcharter::hc_title(text=chart_title) %>%
highcharter::hc_legend(enabled=FALSE) %>%
highcharter::hc_xAxis(type="category", categories=box_names_to_use, title=list(text=chart_x_axis_label)) %>%
highcharter::hc_add_series_list(series2) %>%
hc_add_series_bwpout(value = value, by=by, name="Outliers") %>%
hc_plotOptions(series = list(
marker = list(
symbol = "circle"
),
grouping=FALSE
)) %>%
highcharter::hc_colors(cols2) %>%
highcharter::hc_exporting(enabled=TRUE)
} else{
hc<- highcharter::highchart() %>%
highcharter::hc_chart(type="boxplot", inverted=FALSE) %>%
highcharter::hc_title(text=chart_title) %>%
highcharter::hc_legend(enabled=FALSE) %>%
highcharter::hc_xAxis(type="category", categories=box_names_to_use, title=list(text=chart_x_axis_label)) %>%
highcharter::hc_add_series_list(series2) %>%
hc_plotOptions(series = list(
marker = list(
symbol = "circle"
),
grouping=FALSE
)) %>%
highcharter::hc_colors(cols2) %>%
highcharter::hc_exporting(enabled=TRUE)
}
hc
}
# Usage:
tst_box<- make_highchart_boxplot_with_colored_factors(value = df$value, by=df$categ, chart_title = "Some Title", chart_x_axis_label = "Some X Axis", show_outliers = TRUE)
tst_box
# Custom Colors:
custom_colors_with_alpha_in_hex<- paste0(gplots::col2hex(sample(x=colors(), size = length(unique(df$categ)), replace = FALSE)), "80")
tst_box2<- make_highchart_boxplot_with_colored_factors(value = df$value, by=df$categ, chart_title = "Some Title",
chart_x_axis_label = "Some X Axis",
show_outliers = TRUE, boxcolors = custom_colors_with_alpha_in_hex)
tst_box2
tst_box3<- make_highchart_boxplot_with_colored_factors(value = df$value, by=df$categ, chart_title = "Some Title",
chart_x_axis_label = "Some X Axis",
show_outliers = TRUE, boxcolors = custom_colors_with_alpha_in_hex, box_line_colors = "black")
tst_box3
I hope this helps, please let me know if you have any more questions. I'm happy to try to help as best I can.
-nate

Since there's no highcharter answer yet, I give you at least a base solution.
First, your definition of the data frame is somewhat flawed, rather do:
dat <- data.frame(categ=c('a','b','c','d'), value=rnorm(1000))
Now, using boxplot is quite straightforward. border option colors your borders. With option col you also could color the fills.
boxplot(value ~ categ, dat, border=c("#203d7d","#a0a0ed","#203d7e","#a0a0ad"), pars=list(outpch=16))
Gives
Note: See this nice solution for further customizations.

Related

r plotly update button with line plot does not work with add_markers

I have a problem with the joined plot of an updatable line and static markers in R plotly. The line plot is updated via a drop down menu button, which works well on its own. The additional dots in the add_markers function are also correct when the plot is first initialized.
But after the first update, the markers are cut off (to the left side of the plot where the line starts) and remaining markers are modified (y values are different to initial ones).
For the example here the button function is simplified, but the result shows the same strange behavior.
`
sample_df <- tibble::tibble(quarter_date = rep(c("2022-06-30","2022-09-30","2022-12-31"),3),
forecast_value = runif(9,min = 10,max = 16),
forecast_date = c(rep("2022-07-23",3),rep("2022-08-26",3),rep("2022-09-15",3)))
marks = tibble::tibble(dates = c("2022-05-21","2022-06-15","2022-07-02","2022-07-26","2022-08-27"),
values = c(11,13,12,15,14))
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id,df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>%
dplyr::filter(forecast_date == date_id) %>%
dplyr::pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
plotly::plot_ly(x = ~quarter_date) %>%
plotly::add_trace(data = sample_df %>%
dplyr::filter(forecast_date == max(forecast_date)),
#x = ~period_date,
y = ~forecast_value,
type = 'scatter',
mode = 'markers+lines',
name = 'forecasts') %>%
plotly::layout(
title = "Drop down menue",
yaxis = list(title = "y"),
updatemenus = list(
list(
y =1,
x = 0.9,
buttons = create_buttons(sample_df, unique(sample_df$forecast_date))
)
)) %>%
plotly::add_markers(data = marks,
x = ~dates,
y = ~values)
`
I have tried to set a wide xrange, used a second y2 axis and different approaches in the button calculation but nothing works as intended.
Does anyone have a clue why the add_markers is not working correctly after updating the line plot? Any ideas are highly appreciated!
Adding markers aren't the issue. The issue comes from the restyle. When you restyle the plot without designating that you only meant to change one trace, you changed all traces.
The solution is actually quite simple, you just need one more argument in your args call-- the trace number in a list: list(0) in this case. I've commented out your original args call, so you can see the change.
To make this repeatable, I added set.seed(46) before the creation of sample_df.
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id, df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>% filter(forecast_date == date_id) %>%
pull(forecast_value)), list(0)),
# args = list('y', list(df %>%
# filter(forecast_date == date_id) %>%
# pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
Now when you run your plot, you will see that your marker data remains visible.

R gt: color a column by another column's value

I would like to create a gt table where I display numeric values from two columns together in a single cell, but color the cells based on just one of the column's values.
For example using the ToothGrowth example data I'd like to put the len and dose columns together in a single cell but color the cell backgrounds by the value of dose.
I tried to manually create a vector of colors to color the len_dose column but this does not work because it seems like it is reapplying the color vector to each different level of len_dose, not dose. I guess you could manually format the cells with tab_style() but that seems inefficient and does not give you the nice feature where the text color changes to maximize contrast with background. I don't know an efficient way to do this.
What I tried:
library(gt)
library(dplyr)
library(scales)
library(glue)
# Manually map dose to color
dose_colors <- col_numeric(palette = 'Reds', domain = range(ToothGrowth$dose))(ToothGrowth$dose)
ToothGrowth %>%
mutate(len_dose = glue('{len}: ({dose})')) %>%
gt(rowname_col = 'supp') %>%
cols_hide(c(len, dose)) %>%
data_color(len_dose, colors = dose_colors)
Output (not good because not colored by dose):
Not sure if you found a solution to this yet but here is what I did:
If you use tab_style() you don't need to try and create the vector of colors and can instead set the background color you want based on the dose column. If you want to color values differently based on dose, in addition to what I've colored here, then create another tab_style() for the desired value.
library(gt)
library(dplyr)
library(scales)
library(glue)
ToothGrowth %>%
mutate(len_dose = glue('{len}: ({dose})')) %>%
gt(rowname_col = 'supp') %>%
tab_style(
style = cell_fill(color = "palegreen"),
location = cells_body(
columns = len_dose,
rows = dose >= 1.0
)
) %>%
cols_hide(c(len, dose))
I faced the same issue and adjusted the gt::data_color function to accept separate source and target columns - with that, the following should work to produce your desired output.
# Distinguish SOURCE_columns and TARGET_columns
my_data_color <- function (data, SOURCE_columns, TARGET_columns, colors, alpha = NULL, apply_to = c("fill",
"text"), autocolor_text = TRUE)
{
stop_if_not_gt(data = data)
apply_to <- match.arg(apply_to)
colors <- rlang::enquo(colors)
data_tbl <- dt_data_get(data = data)
colors <- rlang::eval_tidy(colors, data_tbl)
resolved_source_columns <- resolve_cols_c(expr = {
{
SOURCE_columns
}
}, data = data)
resolved_target_columns <- resolve_cols_c(expr = {
{
TARGET_columns
}
}, data = data)
rows <- seq_len(nrow(data_tbl))
data_color_styles_tbl <- dplyr::tibble(locname = character(0),
grpname = character(0), colname = character(0), locnum = numeric(0),
rownum = integer(0), colnum = integer(0), styles = list())
for (i in seq_along(resolved_source_columns)) {
data_vals <- data_tbl[[resolved_source_columns[i]]][rows]
if (inherits(colors, "character")) {
if (is.numeric(data_vals)) {
color_fn <- scales::col_numeric(palette = colors,
domain = data_vals, alpha = TRUE)
}
else if (is.character(data_vals) || is.factor(data_vals)) {
if (length(colors) > 1) {
nlvl <- if (is.factor(data_vals)) {
nlevels(data_vals)
}
else {
nlevels(factor(data_vals))
}
if (length(colors) > nlvl) {
colors <- colors[seq_len(nlvl)]
}
}
color_fn <- scales::col_factor(palette = colors,
domain = data_vals, alpha = TRUE)
}
else {
cli::cli_abort("Don't know how to map colors to a column of class {class(data_vals)[1]}.")
}
}
else if (inherits(colors, "function")) {
color_fn <- colors
}
else {
cli::cli_abort("The `colors` arg must be either a character vector of colors or a function.")
}
color_fn <- rlang::eval_tidy(color_fn, data_tbl)
color_vals <- color_fn(data_vals)
color_vals <- html_color(colors = color_vals, alpha = alpha)
color_styles <- switch(apply_to, fill = lapply(color_vals,
FUN = function(x) cell_fill(color = x)), text = lapply(color_vals,
FUN = function(x) cell_text(color = x)))
data_color_styles_tbl <- dplyr::bind_rows(data_color_styles_tbl,
generate_data_color_styles_tbl(column = resolved_target_columns[i], rows = rows,
color_styles = color_styles))
if (apply_to == "fill" && autocolor_text) {
color_vals <- ideal_fgnd_color(bgnd_color = color_vals)
color_styles <- lapply(color_vals, FUN = function(x) cell_text(color = x))
data_color_styles_tbl <- dplyr::bind_rows(data_color_styles_tbl,
generate_data_color_styles_tbl(column = resolved_target_columns[i],
rows = rows, color_styles = color_styles))
}
}
dt_styles_set(data = data, styles = dplyr::bind_rows(dt_styles_get(data = data),
data_color_styles_tbl))
}
# Add function into gt namespace (so that internal gt functions can be called)
library(gt)
tmpfun <- get("data_color", envir = asNamespace("gt"))
environment(my_data_color) <- environment(tmpfun)
library(dplyr)
#>
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#>
#> filter, lag
#> The following objects are masked from 'package:base':
#>
#> intersect, setdiff, setequal, union
library(glue)
# Map dose to color
ToothGrowth %>%
mutate(len_dose = glue('{len}: ({dose})')) %>%
gt(rowname_col = 'supp') %>%
cols_hide(c(len, dose)) %>%
my_data_color(SOURCE_columns = "dose", TARGET_columns = "len_dose",
colors = scales::col_numeric(palette = c("red", "green"), domain = c(min(ToothGrowth$dose), max(ToothGrowth$dose))))
Created on 2022-11-03 with reprex v2.0.2

How to plot Highcharter side by side in RStudio Viewer?

I wanted to see an exact output of a Highcharter plot side by side in RStudio Viewer if it possible, exactly showed in this reference: http://jkunst.com/highcharter/highcharts.html, So let me define it like this for a simple usage
highcharter_all_plot <- function(){
library(highcharter)
library(dplyr)
library(stringr)
library(purrr)
n <- 5
set.seed(123)
colors <- c("#d35400", "#2980b9", "#2ecc71", "#f1c40f", "#2c3e50", "#7f8c8d")
colors2 <- c("#000004", "#3B0F70", "#8C2981", "#DE4968", "#FE9F6D", "#FCFDBF")
df <- data.frame(x = seq_len(n) - 1) %>%
mutate(
y = 10 + x + 10 * sin(x),
y = round(y, 1),
z = (x*y) - median(x*y),
e = 10 * abs(rnorm(length(x))) + 2,
e = round(e, 1),
low = y - e,
high = y + e,
value = y,
name = sample(fruit[str_length(fruit) <= 5], size = n),
color = rep(colors, length.out = n),
segmentColor = rep(colors2, length.out = n)
)
print(head(df))
create_hc <- function(t) {
dont_rm_high_and_low <- c("arearange", "areasplinerange",
"columnrange", "errorbar")
is_polar <- str_detect(t, "polar")
t <- str_replace(t, "polar", "")
if(!t %in% dont_rm_high_and_low){
df <- df %>% dplyr::select(-e, -low, -high)
}
highchart() %>%
hc_title(text = paste(ifelse(is_polar, "polar ", ""), t),
style = list(fontSize = "15px")) %>%
hc_chart(type = t,
polar = is_polar) %>%
hc_xAxis(categories = df$name) %>%
hc_add_series(df, name = "Fruit Consumption", showInLegend = FALSE)
}
hcs <- c("line", "spline", "area", "areaspline",
"column", "bar", "waterfall" , "funnel", "pyramid",
"pie" , "treemap", "scatter", "bubble",
"arearange", "areasplinerange", "columnrange", "errorbar",
"polygon", "polarline", "polarcolumn", "polarcolumnrange",
"coloredarea", "coloredline") %>% map(create_hc)
return(hcs)
}
x <- highcharter_all_plot()
#Then plot can be accessed in by calling x[[1]], x[[2]], x[[3]]..
As far as my understanding of side by side plot, I only know of 2 these handy methods, which is:
1) Using par(mfrow)
par(mfrow=c(3,4)) -> (which only can by applied to base plot)
2) Using grid.arrange from gridExtra
library(gridExtra)
grid.arrange(x[[1]], x[[2]], x[[3]], x[[4]], nrow=2, ncol=2)
-> (Cannot work since x not a ggplot type)
So I wanted to know if there is a way that this can be applied? I am new using Highcharter
If you inspect the Highcharter website you provided, you will see that those charts are not sided by side using R, but they are just renderer in separate HTML containers and positioned by bootstrap (CSS). So, if you want to render your charts in an HTML environment, I suggest rendering every chart into a separate div.
But maybe Shiny is a tool you are looking for. Maybe this is a duplicate of Shiny rcharts multiple chart output
Maybe this will help you too: https://github.com/jbkunst/highcharter/issues/37

User specified fill

I am using ggvis and have the following code with a selectInput on the UI side allowing the user to select which variable dictates fill and shape (inputId is fill and shape respectively). I want the plot to have the ability to have a constant fill or shape should the user choose. The else section of this code works exactly how I want, but when I select the option in the if statement the app crashes with the following error:
Error in eval: could not find function ":="
I know I have the syntax correct because if I suppress the legends and the if/else statement and specify the fill as constant (fill := "black") it works how I want it to.
Any help would be appreciated.
vis <- reactive({
fillvar <- prop("fill", as.symbol(input$fill))
shapevar <- prop("shape", as.symbol(input$shape))
filteredData() %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size.hover := 200,
fillOpacity:= 0.5, fillOpacity.hover := 1,
# Allows for points to be consistent if the user desires
if (input$fill == "All Points Black") {
fill := "black"}
else {
fill = fillvar}
,
if (input$shape == "All Points Circles") {
shape := "circle"}
else {
shape = shapevar}
,
key := ~ID
) %>%
# Adds legends to the Plot in designated locations
add_legend("fill", title = as.character(fillvar)) %>%
add_legend("shape", title = as.character(shapevar), properties = legend_props(legend = list(y=300))) %>%
# Adds the previously defined tool_tip my_tooltip
add_tooltip(my_tooltip, "hover") %>%
# Specifies the size of the plot
set_options(width = 800, height = 400, duration = 0)
})
#Actually plots the data
vis %>% bind_shiny("plot1")
As I mentioned in a comment, you can create a variable for prop using an if statement. This allows you to bypass the issue of := by using either a constant or a variable directly in prop.
You get legends automatically. To control the placement when you have two legends (which will lead to an overlap), you can name your ggvis graph. This allows you to refer to add elements to the graphic in order to move the second legend down only when it is added based on logic and your shapevar and fillvar values.
Here's the code just for the reactive function.
vis <- reactive({
fillvar = "black"
if(input$fill != "All Points Black") {
fillvar = as.name(input$fill)
}
shapevar = "circle"
if(input$shape != "All Points Circles") {
shapevar = as.name(input$shape)
}
p1 = filteredData() %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size.hover := 200,
fillOpacity:= 0.5, fillOpacity.hover := 1,
prop("fill", fillvar),
prop("shape", shapevar),
key := ~ID
) %>%
# Adds the previously defined tool_tip my_tooltip
add_tooltip(my_tooltip, "hover") %>%
# Specifies the size of the plot
set_options(width = 800, height = 400, duration = 0)
# Control addition of second legend using if() on p1 object
if(fillvar != "black" & shapevar != "circle") {
p1 %>% add_legend("shape", properties = legend_props(legend = list(y=300)))
}
else {
p1
}
})
The code now is functional with input from #aosmith as I want it to be if the legend is suppressed. However, when I do this, the legend for fill and shape overlap as this post addresses.
legends on ggvis graph are overlaping when using tooltip
The fix for that is to add in a legend which makes the plot disappear if the constant data visualization option is selected. I will post a new question to try and get this issue resolved.
UPDATE: The answer below solves the original issue, but #aosmith's answer fixed a second issue that arose after correcting the first issue as well.
My code with the corrected original issue, but containing an overlapping legend (corrected with #aosmith's answer) is below.
vis <- reactive({
# Allows for points to be consistent if the user desires
if (input$fill == "All Points Black") {
fillvar = "black"}
else {
fillvar <- as.symbol(input$fill)}
if (input$shape == "All Points Circles") {
shapevar = "circle"}
else {
shapevar <- as.symbol(input$shape)}
#Plot Data with Visualization Customization
xvar <- prop("x", as.symbol(input$x))
yvar <- prop("y", as.symbol(input$y))
filteredData() %>%
ggvis(x = xvar, y = yvar) %>%
layer_points(size.hover := 200,
fillOpacity:= 0.5, fillOpacity.hover := 1,
prop("fill", fillvar),
prop("shape", shapevar),
key := ~Shot_ID
) %>%
# Adds the previously defined tool_tip my_tooltip
add_tooltip(my_tooltip, "hover") %>%
# Specifies the size of the plot
set_options(width = 800, height = 450, duration = 0)
})
#Actually plots the data
vis %>% bind_shiny("plot1")

rcdimple facet function subplot labels

I am using rcdimple to create a set of faceted barplots based on a categorical column. The plots are coming out as expected but I cannot figure out how to apply a label to each subplot.
In the example below I have commented out some of the options I have tried:
fake.data <- read.table(sep=',', header=T, text="
category,variable,value,count
A Category,SITE.ACTIVITIES,1,51
A Category,SITE.ACTIVITIES,2,116
A Category,SITE.ACTIVITIES,3,46
A Category,PROXIMITY.TO.RECEPTORS,1,17
A Category,PROXIMITY.TO.RECEPTORS,2,111
A Category,PROXIMITY.TO.RECEPTORS,3,93
All Others,SITE.ACTIVITIES,1,60
All Others,SITE.ACTIVITIES,2,37
All Others,SITE.ACTIVITIES,3,54
All Others,PROXIMITY.TO.RECEPTORS,1,80
All Others,PROXIMITY.TO.RECEPTORS,2,167
All Others,PROXIMITY.TO.RECEPTORS,3,120
")
plt <- fake.data %>%
dimple(x ="value", y = "count",
#title = c('A Category','All Others'),
groups = 'category', type = "bar",
width = 900, height = 220) %>%
facet('variable',
#title = c('A Category','All Others'),
removeAxes = T) %>%
default_colors(c('blue','grey')) %>%
xAxis(type = "addCategoryAxis",
#facet.title = c('A Category','All Others'),
orderRule = "value") %>%
yAxis(overrideMax=300, ticks=4) %>%
add_legend() %>%
add_title(text = c('A Category','All Others'))
After seeing figure 2.14 in this blog post I have added the following:
plt$x$options$tasks <- list(htmlwidgets::JS('
function(){
//this.widgetDimple should hold our chart
var chart1 = this.widgetDimple[0];
var chart2 = this.widgetDimple[1];
chart1.svg.append("text")
.attr("x", chart1.axes[0]._scale(3) )
.attr("y", chart1.axes[1]._scale(300) )
.attr("text-anchor", "middle")
.text("A Category")
chart2.svg.append("text")
.attr("x", chart2.axes[0]._scale(3) )
.attr("y", chart2.axes[1]._scale(300) )
.attr("dy", "0.6em")
.attr("text-anchor", "middle")
.text("All Others")
}
'))
plt
I think I am on the right path but think there is probably a cleaner way to do this (sorry my javascript is not great).
The easiest solution seems to be to add text via svg.append("text") as outlined above. The rcdimple facet function creates an array of chart objects one for each subplot. In turn each subplot contains the information needed for each label accessible via OBJECT.data[0].variable.
The solution presented below will work for any number of facet chart objects. The numbers 1 and 350 relate to the x and y position of the labels related to the x and y axis values. These would need to be modified for different datasets
plt <- fake.data %>%
dimple(x ="value", y = "count",
groups = 'category', type = "bar",
width = 900, height = 220) %>%
facet('variable',removeAxes = T) %>%
default_colors(c('blue','grey')) %>%
xAxis(type = "addCategoryAxis",orderRule = "value") %>%
yAxis(overrideMax=300, ticks=4) %>%
add_legend() %>%
add_title(text = 'Plot Title')
plt$x$options$tasks <- list(htmlwidgets::JS(sprintf('
function(){
var n = this.widgetDimple.length
var variables = {};
var subs = [];
for (var i = 1; i <= n; ++i) subs.push("c"+i)
for( var i = 0; i < n; i++) {
var v = subs[i];
variables[v] = this.widgetDimple[i]
variables[v].svg.append("text")
.attr("x", variables[v].axes[0]._scale(%s) )
.attr("y", variables[v].axes[1]._scale(%s) )
.attr("text-anchor", "left")
.text(variables[v].data[0].variable)
};
}
', 1, 350)))
plt
There may be a more elegant solution, my JS is not great. Thanks to authors of the rcdimple package and the examples given here

Resources