How do you create a bar and line plot with R dygraphs? - r

I would like to create a bar and line chart using dygraphs, which seems like it should be possible based on the "Bar & Line Chart" dygraphs example here, and the dyBarChart() custom plotter provided in the dygraphs package.
Using the custom wrapper, I can create a barplot, so I think that code is working:
library(dygraphs)
dyBarChart <- function(dygraph) {
dyPlotter(
dygraph = dygraph,
name = "BarChart",
path = system.file("examples/plotters/barchart.js",package = "dygraphs")
)
}
lungDeaths <- cbind(ldeaths, mdeaths)
dygraph(lungDeaths) %>%
dyBarChart()
I assumed that I could then use dySeries() to customize the series I wanted to show up with a line/bar, but neither of the following work. They do not error out, but nothing is created. I'm also not sure if the "linePlotter" is the correct plotter name, but either way, I need a little help.
# doesn't work
dygraph(lungDeaths) %>%
dyBarChart() %>%
dySeries("ldeaths", plotter = "linePlotter")
# also doesn't work:
dygraph(lungDeaths) %>%
dySeries("ldeaths", plotter = "dyBarChart") %>%
dySeries("mdeaths", color = "blue")
Thanks.

Sometimes you get lucky… I‘ve worked on the same thing a couple of weeks ago and I‘ve found that the documentation is not quite clear on how to do it. But you were pretty close yourself.
How to do it – step by step:
You have to set the plotter for each dyseries
The plotter argument in the dyseries command does not take functions names. But it needs to be a javascript function as plain text
Stacking the bars is easier. Multibars need a way to pass an argument to the javascript function, which you cannot do directly in the package. So I had to do a workaround (At least I found no better way to do it in R).
BTW, setting the dyPlotter command did not work because it sets the plotter globally for all dySeries in the plot. At least that‘s what I figure it does.
So without further ado, here‘s my code. I have added some more test data just to show all the functions.
Test data:
library(xts)
library(dygraphs)
test<-xts(matrix(rnorm(100*4), ncol=4, nrow=100), order.by=seq.POSIXt(as.POSIXct("2017-01-01 00:00", tz="UTC"),by=3600, length.out = 100))
colnames(test)<-c("Series_A","Series_B", "Series_C", "Series_D")
Functions:
dy_position<-function(data_final, plot_title, y2_names=NULL, y1_label, y2_label, y1_step=F, y2_step=F, stacked=T){
data_final<-reorder_xts(data_final, y2_names) #reorder necessary so that all y2 are at the right end of the xts. Needed for the multibar plot
dyg <- dygraphs::dygraph(data_final, main=plot_title)
dyg <- dygraphs::dyAxis(dyg, "x", rangePad=20)
dyg <- dygraphs::dyAxis(dyg, "y", label = y1_label,
axisLabelWidth = 90)
y1_names<-colnames(data_final)[!(colnames(data_final) %in%y2_names)]
if (length(y1_names)==1){
stacked<-T #in this case only stacking works
}
if (stacked){
dyg <- dygraphs::dyOptions(dyg,stepPlot=y1_step,stackedGraph = T)
for(i in seq_along(y1_names)) {
dyg <- dygraphs::dySeries(dyg, y1_names[i], axis = "y", strokeWidth = 1.5, stepPlot = y1_step, plotter=" function barChartPlotter(e) {
var ctx = e.drawingContext;
var points = e.points;
var y_bottom = e.dygraph.toDomYCoord(0);
ctx.fillStyle = e.color;
// Find the minimum separation between x-values.
// This determines the bar width.
var min_sep = Infinity;
for (var i = 1; i < points.length; i++) {
var sep = points[i].canvasx - points[i - 1].canvasx;
if (sep < min_sep) min_sep = sep;
}
var bar_width = Math.floor(2.0 / 3 * min_sep);
// Do the actual plotting.
for (var i = 0; i < points.length; i++) {
var p = points[i];
var center_x = p.canvasx;
ctx.fillRect(center_x - bar_width / 2, p.canvasy,
bar_width, y_bottom - p.canvasy);
ctx.strokeRect(center_x - bar_width / 2, p.canvasy,
bar_width, y_bottom - p.canvasy);
}
}")
}
} else {
dyg <- dygraphs::dyOptions(dyg,stepPlot=y1_step)
for(i in seq_along(y1_names)) {
#plotter in function
dyg <- dygraphs::dySeries(dyg, y1_names[i], axis = "y", strokeWidth = 1.5, stepPlot = y1_step, plotter =multibar_combi_plotter(length(y2_names)))
}
}
# put stuff on y2 axis
dyg <- dygraphs::dyAxis(dyg, "y2", label = y2_label, independentTicks = T)
for(i in seq_along(y2_names)) {
dyg <- dygraphs::dySeries(dyg, y2_names[i], axis = "y2", strokeWidth = 1.5, stepPlot = y2_step)
}
return(dyg)
}
#we need to take into account all values and then leave out the ones we do not like
multibar_combi_plotter<-function(num_values){
#plotter function
plotter_text<-"function multiColumnBarPlotter(e) {
// We need to handle all the series simultaneously.
if (e.seriesIndex !== 0) return;
var g = e.dygraph;
var ctx = e.drawingContext;
var sets = e.allSeriesPoints;
var y_bottom = e.dygraph.toDomYCoord(0);
// Find the minimum separation between x-values.
// This determines the bar width.
var min_sep = Infinity;
for (var j = 0; j < sets.length-%s; j++) {
var points = sets[j];
for (var i = 1; i < points.length; i++) {
var sep = points[i].canvasx - points[i - 1].canvasx;
if (sep < min_sep) min_sep = sep;
}
}
var bar_width = Math.floor(2.0 / 3 * min_sep);
var fillColors = [];
var strokeColors = g.getColors();
for (var i = 0; i < strokeColors.length; i++) {
fillColors.push(strokeColors[i]);
}
for (var j = 0; j < sets.length-%s; j++) {
ctx.fillStyle = fillColors[j];
ctx.strokeStyle = strokeColors[j];
for (var i = 0; i < sets[j].length; i++) {
var p = sets[j][i];
var center_x = p.canvasx;
var x_left = center_x - (bar_width / 2) * (1 - j/(sets.length-%s-1));
ctx.fillRect(x_left, p.canvasy,
bar_width/sets.length, y_bottom - p.canvasy);
ctx.strokeRect(x_left, p.canvasy,
bar_width/sets.length, y_bottom - p.canvasy);
}
}
}"
custom_plotter <- sprintf(plotter_text, num_values, num_values, num_values)
return(custom_plotter)
}
reorder_xts<-function(xts_series,line_names){
bar_names<-colnames(xts_series)[!(colnames(xts_series)%in%line_names)]
xts_series<-xts_series[,c(bar_names,line_names)]
return(xts_series)
}
Some Explanation:
dy_position does all the plotting. It uses individual plotters per series axis.
reorder_xts is needed to make sure that all lines plots are at the right end of the xts. This is needed for the multibar plot. Because the java script is looping over all series (sets) to determine the width of the bars and we need to make sure we are not looping over the series which are line plots. Otherwise we have additional bars.
multibar_combi_plotter does exactly that. It takes a numeric parameter lines_names and modifies the javascript string so that it loops over all plots except for the line_names (i.e. last series in the right part of the xts). Notice several little %s in the string for the sprintfcommand! Afterwards it returns the plotter as character for the dySeries argument.
All the javascript code is taken directly from the examples in the dygraphs folder.
Here are some examples...
Examples:
dy_position(test,plot_title = "Test1", y2_names = c("Series_C","Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=F)
dy_position(test,plot_title = "Test1", y2_names = c("Series_C","Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=T)
dy_position(test,plot_title = "Test1", y2_names = c("Series_B","Series_C","Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=T)
dy_position(test,plot_title = "Test1", y2_names = c("Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=F)
dy_position(test,plot_title = "Test1", y2_names = c("Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=T)
dy_position(test,plot_title = "Test1", y2_names = NULL ,y1_label = "Axis1", y2_label = "Axis2", stacked=F)
dy_position(test,plot_title = "Test1", y2_names = NULL ,y1_label = "Axis1", y2_label = "Axis2", stacked=T)

I am not sure this is exactly what you want. What I propose, comes close to the combination of a bar plot and a line plot, without the need to create a separate function.
You can set the type of plot per series, with dySeries. You can choose between lineplot (default), stepPlot, and stemPlot. In addition you may set to see the points with drawPoints and pointSize, you may also opt to fill the graph or not with fillGraph. For other options type ?dySeries
The code looks as follows:
library(dygraphs)
lungDeaths <- cbind(ldeaths, mdeaths)
dygraph(lungDeaths, main = "Main Title") %>%
dySeries("ldeaths", drawPoints = FALSE) %>%
dySeries("mdeaths", stepPlot = TRUE, fillGraph = TRUE)
Yielding this plot:
Please, let me know whether this is what you want.

After a bit of research I think that this would be simplest. At least that's the way it seems for me.
You would need to download the "barseries.js" file available at http://dygraphs.com/tests/plotters.html
Then the code would look like so
library(dygraphs)
dyBarSeries <- function(dygraph, name, ...) {
file <- "plotters/barseries.js" #you need to link to the downloaded file
plotter_ <- paste0(readLines(file, skipNul = T), collapse = "\n")
dots <- list(...)
do.call('dySeries', c(list(dygraph = dygraph, name = name, plotter =
plotter_), dots))
}
lungDeaths <- cbind(ldeaths, mdeaths)
dygraph(lungDeaths) %>%
dyBarSeries("ldeaths") %>%
dySeries("mdeaths")
Yielding this result
enter image description here

Related

How to modify pre-existing function in local environment in R

I am trying to modify an existing function by copy and pasting it to an R script, and assigning it to a new function object in my local environment. However the new function cannot find functions that are called to within the original function. How can I fix this without looking up and finding each function individually? I am guessing that the original function is somehow linked to the package or its dependencies and 'knows where to look' for the missing function, but I cannot figure out how to do this with my new copy-and-pasted function.
library("camtrapR")
Print the function name
activityDensity
The output here is the code for this function. I have omitted it here because it is long (and I have pasted it below), but I copy and paste the output of the function code exactly (see below where I assign this exact code to a new function), except for the last two lines of output, which I think are important:
<bytecode: 0x000000002a2d1e20>
<environment: namespace:camtrapR>
So now I assign the copy and pasted code from the output above to a new function with New <-
New <- function (recordTable, species, allSpecies = FALSE, speciesCol = "Species",
recordDateTimeCol = "DateTimeOriginal", recordDateTimeFormat = "%Y-%m-%d %H:%M:%S",
plotR = TRUE, writePNG = FALSE, plotDirectory, createDir = FALSE,
pngMaxPix = 1000, add.rug = TRUE, ...)
{
wd0 <- getwd()
mar0 <- par()$mar
on.exit(setwd(wd0))
on.exit(par(mar = mar0), add = TRUE)
recordTable <- dataFrameTibbleCheck(df = recordTable)
timeZone <- "UTC"
checkForSpacesInColumnNames(speciesCol = speciesCol, recordDateTimeCol = recordDateTimeCol)
if (!is.data.frame(recordTable))
stop("recordTable must be a data frame", call. = FALSE)
if (!speciesCol %in% colnames(recordTable))
stop(paste("speciesCol = \"", speciesCol, "\" is not a column name in recordTable",
sep = ""), call. = FALSE)
if (!recordDateTimeCol %in% colnames(recordTable))
stop(paste("recordDateTimeCol = \"", recordDateTimeCol,
"\" is not a column name in recordTable", sep = ""),
call. = FALSE)
stopifnot(is.logical(c(allSpecies, writePNG, plotR, createDir)))
if (allSpecies == FALSE) {
stopifnot(species %in% recordTable[, speciesCol])
stopifnot(hasArg(species))
}
recordTable$DateTime2 <- parseDateTimeObject(inputColumn = recordTable[,
recordDateTimeCol], dateTimeFormat = recordDateTimeFormat,
timeZone = timeZone)
recordTable$Time2 <- format(recordTable$DateTime2, format = "%H:%M:%S",
usetz = FALSE)
recordTable$Time.rad <- (as.numeric(as.POSIXct(strptime(recordTable$Time2,
format = "%H:%M:%S", tz = timeZone))) - as.numeric(as.POSIXct(strptime("0",
format = "%S", tz = timeZone))))/3600 * (pi/12)
if (isTRUE(writePNG)) {
if (hasArg(plotDirectory)) {
if (isTRUE(createDir)) {
dir.create(plotDirectory, recursive = TRUE, showWarnings = FALSE)
setwd(plotDirectory)
}
else {
stopifnot(file.exists(plotDirectory))
setwd(plotDirectory)
}
}
else {
stop("writePNG is TRUE. Please set plotDirectory",
call. = FALSE)
}
}
pngWidth <- pngMaxPix
pngHeight <- round(pngMaxPix * 0.8)
if (allSpecies == FALSE) {
subset_species <- subset(recordTable, recordTable[, speciesCol] ==
species)
if (nrow(subset_species) == 1)
stop(paste(species, "had only 1 record. Cannot estimate density."),
call. = FALSE)
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
species, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = paste("Activity of",
species), rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(species), ": ", try_error_tmp[1],
" - SKIPPED", sep = ""), call. = FALSE)
}
else {
subset_species_list <- list()
for (i in 1:length(unique(recordTable[, speciesCol]))) {
spec.tmp <- unique(recordTable[, speciesCol])[i]
subset_species <- subset(recordTable, recordTable[,
speciesCol] == spec.tmp)
plot_main_title <- paste("Activity of", spec.tmp)
if (nrow(subset_species) == 1) {
warning(paste(toupper(spec.tmp), ": It had only 1 record. Cannot estimate density. - SKIPPED",
sep = ""), call. = FALSE)
next
}
else {
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
spec.tmp, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = plot_main_title,
rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(spec.tmp), ": ",
try_error_tmp[1], " - SKIPPED",
sep = ""), call. = FALSE)
}
subset_species_list[[i]] <- subset_species$Time.rad
names(subset_species_list)[i] <- spec.tmp
}
}
if (allSpecies == FALSE) {
return(invisible(subset_species$Time.rad))
}
else {
return(invisible(subset_species_list))
}
}
Yet, when I try to run this new function (arguments omitted here for clarity), it can't find a function embedded within.
How can I somehow assign this function to look within the original package camtrapR for any dependencies, etc.? and why does the code output from the function not already do this?
New()
Error in dataFrameTibbleCheck(df = recordTable) :
could not find function "dataFrameTibbleCheck"
This answer here: https://stackoverflow.com/a/49277036/9096420 allows one to manually edit and save a function's code for each R session, but it is non-reproducible (not code) that can be shared or re-used.
If New is the new function copied from camtrapR then use
environment(New) <- asNamespace("camtrapR")
to ensure that the function calls in its body are looked up in the correct places.

Customize colors for boxplot with highcharter

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.

Highlight/find data points in plotly scatter from the browser

I generated a scatterplot in HTML format using plotly and a generic dataframe. I am aware that it is possible to highlight (with a different color for example) certain data points before generating the plot HTML. However, I wonder if it is possible to add an element to the HTML file that would enable a user to find/highlight a certain data point based on its text label after the plot has been produced.
The code I used to produce the dataframe and scatter:
tab <- data.frame(sample.id = pca$sample.id,
EV1 = pca$eigenvect[, 1],
EV2 = pca$eigenvect[, 2],
stringsAsFactors=F)
p <- plot_ly(tab, x=tab$EV1, y=tab$EV2, text=tab$sample.id)
p <- layout(p, title="PCA", xaxis=list(title="PC 1"),
yaxis=list(title="PC 2"))
htmlwidgets::saveWidget(as.widget(p), paste(output_name, ".html", sep=""))
As far as I know there is not builtin functionality in Plotly but you just need a few lines of Javascript code to get the functionality.
Plotly stores the data in a application/json object in the HTML file. You can get the data via
var data = JSON.parse(document.querySelectorAll("script[type='application/json']")[0].innerHTML);
The text elements are stored in
data.x.data[i].text[j]
where i is the trace number and j is point number.
Now we need a text field and a button, we can use htmltools for that purpose
p <- htmlwidgets::appendContent(p, htmltools::tags$input(id='inputText', value='Merc', ''), htmltools::tags$button(id='buttonSearch', 'Search'))
Let's add a eventlister to the button which triggers a hover event of the first point of the first trace.
p <- htmlwidgets::appendContent(p, htmltools::tags$script(HTML(
'document.getElementById("buttonSearch").addEventListener("click", function()
{
var myDiv = document.getElementsByClassName("js-plotly-plot")[0]
Plotly.Fx.hover(myDiv, [{curveNumber: 0, pointNumber: 0}]);
}
)
')))
And the whole code which searches for through all text labels and triggers a hover event when the entered text is found in the label.
library(plotly)
library(htmlwidgets)
library(htmltools)
pcaCars <- princomp(mtcars, cor = TRUE)
carsHC <- hclust(dist(pcaCars$scores), method = "ward.D2")
carsDf <- data.frame(pcaCars$scores, "cluster" = factor(carsClusters))
carsClusters <- cutree(carsHC, k = 3)
carsDf <- transform(carsDf, cluster_name = paste("Cluster", carsClusters))
p <- plot_ly(carsDf, x = ~Comp.1 , y = ~Comp.2, text = rownames(carsDf),
mode = "markers", color = ~cluster_name, marker = list(size = 11), type = 'scatter', mode = 'markers')
p <- htmlwidgets::appendContent(p, htmltools::tags$input(id='inputText', value='Merc', ''), htmltools::tags$button(id='buttonSearch', 'Search'))
p <- htmlwidgets::appendContent(p, htmltools::tags$script(HTML(
'document.getElementById("buttonSearch").addEventListener("click", function()
{
var i = 0;
var j = 0;
var found = [];
var myDiv = document.getElementsByClassName("js-plotly-plot")[0]
var data = JSON.parse(document.querySelectorAll("script[type=\'application/json\']")[0].innerHTML);
for (i = 0 ;i < data.x.data.length; i += 1) {
for (j = 0; j < data.x.data[i].text.length; j += 1) {
if (data.x.data[i].text[j].indexOf(document.getElementById("inputText").value) !== -1) {
found.push({curveNumber: i, pointNumber: j});
}
}
}
Plotly.Fx.hover(myDiv, found);
}
);')))
htmlwidgets::saveWidget(p, paste('pca', ".html", sep=""))
p
The PCA implementation was modified from here.

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

Error in lattice::latticeParseFormula(x, data = data) : model must be a formula object

I tried to use rChart's rNVD3 package's discrete bar plot instead of the same old ggplot2. But it's requiring some formula argument as a first argument. I've not used lattice package and I don't know how to create one.
Here's my data frame:
df <- data.frame(
Pupil = factor(c("Richy","Shyam","Nithin"), levels=c("Richy","Shyam","Nithin")),
Scores = c(75,93,62)
)
Code I used to render the plot:
require(rNVD3)
bar1 <- nvd3Plot(x = "Pupil", y = "Scores", data = df, type = "discreteBarChart", width = 600)
bar1$printChart("chart1")
This is what the error is:
Error in lattice::latticeParseFormula(x, data = data) :
model must be a formula object
When I tried to rectify the error:
bar1<-nvd3Plot(Scores ~ Pupil, data = df, type = "discreteBarChart", width = 600)
bar1$printChart("chart1")
It just showed the .js code but not the barchart.
<div id='chart1' class='nvd3Plot'></div>
<script type='text/javascript'>
drawchart1()
function drawchart1(){
var opts = {"id":"chart1","yAxis":[],"x":"Pupil","y":"Scores","type":"discreteBarChart","width":600,"height":400},
data = [{"Pupil":"Richy","Scores":75},{"Pupil":"Shyam","Scores":93},{"Pupil":"Nithin","Scores":62}]
var data = d3.nest()
.key(function(d){
return opts.group === undefined ? 'main' : d[opts.group]
})
.entries(data)
nv.addGraph(function() {
var chart = nv.models[opts.type]()
.x(function(d) { return d[opts.x] })
.y(function(d) { return d[opts.y] })
.width(opts.width)
.height(opts.height)
d3.select("#" + opts.id)
.append('svg')
.datum(data)
.transition().duration(500)
.call(chart);
nv.utils.windowResize(chart.update);
return chart;
});
};
</script>
rCharts can be a little confusing sometimes due to its use of reference classes. You are very close. First install rCharts. Then, instead of nvd3Plot, use nPlot as shown below. Also, you might be interested in htmlwidgets.
library(rCharts)
df <- data.frame(
Pupil = factor(c("Richy","Shyam","Nithin"), levels=c("Richy","Shyam","Nithin")),
Scores = c(75,93,62)
)
# without formula interface
nPlot(
x = "Pupil", y = "Scores", data = df,
type = "discreteBarChart", width = 600
)
# with formula interface
nPlot(Scores~Pupil, data = df, type = "discreteBarChart", width = 600)

Resources