I make a leaflet map with a responsive heatmap using addHeatmap. Unfortunately, this kind of tool it is not enough useful because two main problems: 1) The heatmap is redrawed with each new level of zoom and 2) you can not make the heatmap and the points in a separated group each one.
It is possible a similar solution with addWebGLHeatmap?
There is the code for the addHeatmap solution, following this question
library(crosstalk)
library(leaflet)
library(leaflet.extras)
library(dplyr)
# Wrap data frame in SharedData
sd <- SharedData$new(quakes[sample(nrow(quakes), 10),])
bscols(widths=c(3,9),
# Create a filter input
filter_slider("mag", "Magnitude", sd, column=~mag, step=0.1),
leaflet(sd) %>%
addTiles() %>%
addMarkers() %>%
addHeatmap(layerId="heatmap") %>%
removeHeatmap("heatmap") %>%
htmlwidgets::onRender("
function(el,x){
var myMap = this;
var coord_state;
var coords;
function get_markers(){
coord_state = [];
myMap.eachLayer(function(layer){
if (typeof layer.options.lat != 'undefined'){
coord_state.push([layer.options.lat, layer.options.lng, 0.5]);
}
})
return(coord_state)
}
function update_layer(){
coords = get_markers()
heat1.setLatLngs(coords);
heat1.redraw();
}
var heat1 = L.heatLayer(get_markers(), {radius: 25}).addTo(myMap);
myMap.on('layerremove', update_layer);
myMap.on('layeradd', update_layer);
}
"))
This method is kind of a hack, but still should be able to work with addWebGLHeatmap. It adds two sets of identical markers and hides one which controls the heatmap. This allows for the layer control. A working example can be found here:
https://rpubs.com/Jumble/leaflet_webgl_heatmap
Below is the code that produced this. This code solves the main two problems although it struggles if you wan't to plot over 1000 points.
Rather than using crosstalk it might be better to use a combination of something like leafgl, shiny and addWebGLHeatmap if you are wanting to plot thousands of points.
n <- 200
data <- data.frame(id = seq(1, n*2), lat = rnorm(n, 0, 15), long = rnorm(n, 0, 15), group=c(rep("Heatmap",n), rep("Markers", n)), mag=rep(as.integer(runif(n, 0, 20)),2))
sd <- SharedData$new(data)
bscols(widths=c(3,9),
filter_slider("mag", "Magnitude", sd, column=~mag, step=0.1),
leaflet(sd, options=leafletOptions(preferCanvas = TRUE)) %>%
addTiles() %>%
leaflet::setView(lat=0, lng=0, zoom=4) %>%
addMarkers(group=~group) %>%
leaflet.extras::addWebGLHeatmap(layerId = "heatmapwebgl") %>%
leaflet.extras::removeWebGLHeatmap("heatmapwebgl") %>%
addLayersControl(overlayGroups = c("Heatmap", "Markers"), options=layersControlOptions(collapsed=FALSE)) %>%
htmlwidgets::onRender("
function(el,x){
var myMap = this;
var coord_state;
// hide heatmap markers
setTimeout(function(){
myMap.eachLayer(function(layer){
if (layer.options.group=='Heatmap'){
layer.setOpacity(0);
layer.getElement().style.pointerEvents = 'none';
}
})
}, 100)
function get_markers(){
coord_state = [];
myMap.eachLayer(function(layer){
if (layer.options.group=='Heatmap'){
coord_state.push([layer.options.lat, layer.options.lng, 0.5]);
layer.getElement().style.pointerEvents = 'none';
}
})
return(coord_state)
}
function redraw_heatmap(){
heatmap.setData(get_markers());
}
var heatmap = L.webGLHeatmap({size: 1000000,units: 'm',alphaRange: 1});
heatmap.setData(get_markers());
myMap.addLayer(heatmap);
myMap.on('layerremove', redraw_heatmap);
myMap.on('layeradd', redraw_heatmap);
}
"))
Below for Circle Markers
n <- 200
data <- data.frame(id = seq(1, n*2), lat = rnorm(n, 0, 15), long = rnorm(n, 0, 15), group=c(rep("Heatmap",n), rep("Markers", n)), mag=rep(as.integer(runif(n, 0, 20)),2))
sd <- SharedData$new(data)
bscols(widths=c(3,9),
filter_slider("mag", "Magnitude", sd, column=~mag, step=0.1),
leaflet(sd) %>%
addTiles() %>%
leaflet::setView(lat=0, lng=0, zoom=4) %>%
addCircleMarkers(group=~group, opacity=~ifelse(group=="Heatmap", 0, 0.5), fillOpacity=~ifelse(group=="Heatmap", 0, 0.2)) %>%
leaflet.extras::addWebGLHeatmap(layerId = "heatmapwebgl") %>%
leaflet.extras::removeWebGLHeatmap("heatmapwebgl") %>%
addLayersControl(overlayGroups = c("Heatmap", "Markers"), options=layersControlOptions(collapsed=FALSE)) %>%
htmlwidgets::onRender("
function(el,x){
var myMap = this;
var coord_state;
function get_markers(){
coord_state = [];
myMap.eachLayer(function(layer){
if (layer.options.group=='Heatmap'){
coord_state.push([layer.options.lat, layer.options.lng, 0.5]);
layer.getElement().style.pointerEvents = 'none';
}
})
return(coord_state)
}
function redraw_heatmap(){
heatmap.setData(get_markers());
}
var heatmap = L.webGLHeatmap({size: 1000000,units: 'm',alphaRange: 1});
heatmap.setData(get_markers());
myMap.addLayer(heatmap);
myMap.on('layerremove', redraw_heatmap);
myMap.on('layeradd', redraw_heatmap);
}
"))
Related
I'm trying to implement the plugin extension , groupedLayerControl, for leaflet maps. You can see below the code I'm working with (currently not working). I'm trying to put the overlayers in different group categories. I'm new to javascript so I really can't identify what I'm doing wrong. The code does not give me the groups' layers in the map. Can someone help me out?
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
Value1 = c(12,43,54,34,23,77,44,22)
Value2 = c(6,5,2,7,5,6,4,3)
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2)
Lon = c(5, -3, -2, -1, 4, 3, -5, 0)
leaflet() %>%
addProviderTiles(providers$CartoDB.Positron, group = "Alpha") %>%
registerPlugin(groupedLayerControlPlugin) %>%
onRender("function(el, x) {
var baseLayers = {
'Alpha': this.layerManager.getLayerGroup('Alpha'),
};
var groupedOverlays = {
'Group 1': {
'Value1': this.layerManager.getLayerGroup('Value1'),
},
'Group 2': {
'Value2': this.layerManager.getLayerGroup('Value2'),
}
};
var Options = {
groupCheckboxes: true
};
console.log(L.control.groupedLayers);
L.control.groupedLayers(baseLayers, groupedOverlays, Options).addTo(this);
}") %>%
addCircles(lat=Lat, lng=Lon,
radius = Value1*1000, group = "Value1") %>%
addCircles(lat=Lat, lng=Lon,
radius = Value2*10000, group = "Value1")
This is an old question , but thought I'd add a complete working example using your data. You only had one issue in the provided example, which was that you needed at least one group = "Value2" argument for one of the leaflet::addCircles(). Both of the addCircles() in your example show group = "Value1").
In the below code, I've also added an additional base layer to demonstrate base layer grouping in addition to the groupedlayercontrol of overlays.
library(dplyr)
library(leaflet)
library(htmlwidgets)
Value1 = c(12,43,54,34,23,77,44,22)
Value2 = c(6,5,2,7,5,6,4,3)
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2)
Lon = c(5, -3, -2, -1, 4, 3, -5, 0)
urlf <- 'https://raw.githubusercontent.com/ismyrnow/leaflet-groupedlayercontrol/gh-pages/dist/%s'
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.js'), 'C:/Temp/L.Control.groupedlayer.js', mode="wb")
download.file(sprintf(urlf,'leaflet.groupedlayercontrol.min.css'), 'C:/Temp/L.Control.groupedlayer.css', mode="wb")
groupedLayerControlPlugin <- htmltools::htmlDependency(
name = 'ctrlGrouped',
version = "1.0.0",
src = c(file = normalizePath('C:/Temp')),
script = "L.Control.groupedlayer.js",
stylesheet = "L.Control.groupedlayer.css"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
leaflet() %>%
addProviderTiles("Stamen.Watercolor", group = "Beta") %>%
addProviderTiles(providers$CartoDB.Positron, group = "Alpha") %>%
registerPlugin(groupedLayerControlPlugin) %>%
onRender("function(el, x) {
var groups = {
Value1: this.layerManager.getLayerGroup('Value1'),
Value2: this.layerManager.getLayerGroup('Value2')
};
var baseLayers = {
'Alpha': this.layerManager.getLayerGroup('Alpha'),
'Beta': this.layerManager.getLayerGroup('Beta')
};
var groupedOverlays = {
'all value groups': {
'Value 1' : groups.Value1,
'Value 2' : groups.Value2}
};
var Options = {
groupCheckboxes: true
};
console.log(L.control.groupedLayers);
L.control.groupedLayers(baseLayers, groupedOverlays, Options).addTo(this);
}") %>% addCircles(lat=Lat, lng=Lon,
radius = Value1*1000, group = "Value1") %>%
addCircles(lat=Lat, lng=Lon,
radius = Value2*10000, group = "Value2")
I'm developing an R shiny app and ideally I would need to do precisely what is done here:
More specifically, I have dataframe with stocks open, close, high, low data and I would need to replicate what's displayed in the attached image in column "Range".
I understand I should attach some code, but the truth here, I can't find anything close to what I'm asking online.
A sample dataframe would be:
df = data.frame(STOCK=c("IBM","MSFT","FB"), OPEN=c(100,90, 80), CLOSE=c(102, 85, 82), LOW=c(99,81,78), HIGH=c(105, 91, 88))
Then, I have no idea of what to do from here. Any suggestions? Thanks
You can use custom-rendering follow this guide
https://glin.github.io/reactable/articles/examples.html#custom-rendering-1
library(dplyr)
library(sparkline)
data <- chickwts %>%
group_by(feed) %>%
summarise(weight = list(weight)) %>%
mutate(boxplot = NA, sparkline = NA)
reactable(data, columns = list(
weight = colDef(cell = function(values) {
sparkline(values, type = "bar", chartRangeMin = 0, chartRangeMax = max(chickwts$weight))
}),
boxplot = colDef(cell = function(value, index) {
sparkline(data$weight[[index]], type = "box")
}),
sparkline = colDef(cell = function(value, index) {
sparkline(data$weight[[index]])
})
))
I am trying to make an interactive stock performance plot from R. It is to compare the relative performance of several stocks. Each stock's performance line should start at 0%.
For static plots I would use dplyr group_by and mutate to calculate performance (see my code).
With ggplot2 and plotly/ggplotly, rangeslider() allows to interactively select the x-axis range. Now I'd like performance to be starting at 0 from any start range selected.
How can I either move the dplyr calculation into the plotting or have a feedback loop to recalculate as the range is changed?
Ideally it should be usable in static RMarkdown HTML. Alternatively I'd also switch to Shiny.
I tried several options for rangeslider. Also I tried with ggplot stat_function but could not achieve the desired result. Also I found dygraphs which has dyRangeSelector. But also here I face the same problem.
This is my code:
library(plotly)
library(tidyquant)
stocks <- tq_get(c("AAPL", "MSFT"), from = "2019-01-01")
range_from <- as.Date("2019-02-01")
stocks_range <- stocks %>%
filter(date >= range_from) %>%
group_by(symbol) %>%
mutate(performance = adjusted/first(adjusted)-1)
p <- stocks_range %>%
ggplot(aes(x = date, y = performance, color = symbol)) +
geom_line()
ggplotly(p, dynamicTicks = T) %>%
rangeslider(borderwidth = 1) %>%
layout(hovermode = "x", yaxis = list(tickformat = "%"))
If you do not want to use shiny, you can either use the dyRebase option in dygraphs, or you have to insert custom javascript code in plotly. In both examples, I rebase to one, not zero.
Option 1: with dygraphs
library(dygraphs)
library(tidyquant)
library(timetk)
library(tidyr)
stocks <- tq_get(c("AAPL", "MSFT"), from = "2019-01-01")
stocks %>%
dplyr::select(symbol, date, adjusted) %>%
tidyr::spread(key = symbol, value = adjusted) %>%
timetk::tk_xts() %>%
dygraph() %>%
dyRebase(value = 1) %>%
dyRangeSelector()
Note that `dyRebase(value = 0) does not work.
Option 2: with plotly using event handlers. I try to avoid ggplotly, hence my plot_ly solution. Here the time selection is just by zooming, but I think it can be done by a range selector as well. The javascript code in onRenderRebaseTxt rebases every trace to the first visible data point (taking care of possible missing values). It is only called with the relayout event, hence the first rebasing must be done before the plot.
library(tidyquant)
library(plotly)
library(htmlwidgets)
library(dplyr)
stocks <- tq_get(c("AAPL", "MSFT"), from = "2019-01-01")
pltly <-
stocks %>%
dplyr::group_by(symbol) %>%
dplyr::mutate(adjusted = adjusted / adjusted[1L]) %>%
plotly::plot_ly(x = ~date, y = ~adjusted, color = ~symbol,
type = "scatter", mode = "lines") %>%
plotly::layout(dragmode = "zoom",
datarevision = 0)
onRenderRebaseTxt <- "
function(el, x) {
el.on('plotly_relayout', function(rlyt) {
var nrTrcs = el.data.length;
// array of x index to rebase to; defaults to zero when all x are shown, needs to be one per trace
baseX = Array.from({length: nrTrcs}, (v, i) => 0);
// if x zoomed, increase baseX until first x point larger than x-range start
if (el.layout.xaxis.autorange == false) {
for (var trc = 0; trc < nrTrcs; trc++) {
while (el.data[[trc]].x[baseX[trc]] < el.layout.xaxis.range[0]) {baseX[trc]++;}
}
}
// rebase each trace
for (var trc = 0; trc < nrTrcs; trc++) {
el.data[trc].y = el.data[[trc]].y.map(x => x / el.data[[trc]].y[baseX[trc]]);
}
el.layout.yaxis.autorange = true; // to show all traces if y was zoomed as well
el.layout.datarevision++; // needs to change for react method to show data changes
Plotly.react(el, el.data, el.layout);
});
}
"
htmlwidgets::onRender(pltly, onRenderRebaseTxt)
I found a solution with plotly_relayout which reads out the visible x-axis range. This is used to recompute the performance. It works as a Shiny app. Here's my code:
library(shiny)
library(plotly)
library(tidyquant)
library(lubridate)
stocks <- tq_get(c("AAPL", "MSFT"), from = "2019-01-01")
ui <- fluidPage(
titlePanel("Rangesliding performance"),
mainPanel(
plotlyOutput("plot")
)
)
server <- function(input, output) {
d <- reactive({ e <- event_data("plotly_relayout")
if (is.null(e)) {
e$xaxis.range <- c(min(stocks$date), max(stocks$date))
}
e })
stocks_range_dyn <- reactive({
s <- stocks %>%
group_by(symbol) %>%
mutate(performance = adjusted/first(adjusted)-1)
if (!is.null(d())) {
s <- s %>%
mutate(performance = adjusted/nth(adjusted, which.min(abs(date - date(d()$xaxis.range[[1]]))))-1)
}
s
})
output$plot <- renderPlotly({
plot_ly(stocks_range_dyn(), x = ~date, y = ~performance, color = ~symbol) %>%
add_lines() %>%
rangeslider(start = d()$xaxis.range[[1]], end = d()$xaxis.range[[2]], borderwidth = 1)
})
}
shinyApp(ui = ui, server = server)
Definign the start/end of the rangeslider only works with plot_ly, not with a ggplot object converted by ggplotly. I am unsure if this is a bug, therefore opened an issue on Github.
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.
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