#' Scatter plot HTML widget
#'
#' Interactive scatter plots based on htmlwidgets and d3.js
#'
#' @param data default dataset to use for plot.
#' @param x numerical vector of x values, or variable name if data is not NULL
#' @param y numerical vector of y values, or variable name if data is not NULL
#' @param x_log if TRUE, set x scale as logarithmic
#' @param y_log if TRUE, set y scale as logarithmic
#' @param lab optional character vector of text labels, or variable name if
#' data is not NULL
#' @param point_size points size. Ignored if size_var is not NULL.
#' @param labels_size text labels size
#' @param labels_positions Either a data frame, as created by the
#' "Export labels positions" menu entry, giving each label x and y
#' position, or the value `"auto"` to use an automatic labeler.
#' @param point_opacity points opacity, as an integer (same opacity for all
#' points).
#' @param fixed force a 1:1 aspect ratio
#' @param col_var optional vector for points color mapping, or variable name
#' if data is not NULL
#' @param col_continuous specify if the color scale must be continuous. By
#' default, if \code{col_var} is numeric, not a factor, and has more than
#' 6 unique values, it is considered as continuous.
#' @param colors vector of custom points colors. Colors must be defined as an
#' hexadecimal string (eg "#FF0000"). If \code{colors} is a named list or
#' a named vector, then the colors will be associated with their name
#' within \code{col_var}. A string can be given to specify a d3-scale-chromatic
#' function name (for example, "interpolatePurples" or "schemeTableau10")
#' @param ellipses draw confidence ellipses for points or the different color
#' mapping groups
#' @param ellipses_level confidence level for ellipses (0.95 by default)
#' @param symbol_var optional vector for points symbol mapping, or variable
#' name if data is not NULL
#' @param symbols vector of custom points symbols. Symbols must be defined as
#' character strings with the following possible values : "circle", "cross",
#' "diamond", "square", "star", "triangle", and "wye". If \code{symbols} is a
#' named list or a named vector, then the symbols will be associated with their
#' name within \code{symbol_var}.
#' @param size_var optional vector for points size mapping, or variable name
#' if data is not NULL
#' @param size_range numeric vector of length 2, giving the minimum and
#' maximum point sizes when mapping with size_var
#' @param sizes named list or named vector of sizes. Each size
#' will be associated by their name within `size_var`.
#' @param col_lab color legend title. Set to NA to remove color legend entirely.
#' @param symbol_lab symbols legend title. Set to NA to remove symbol legend entirely.
#' @param size_lab size legend title. Set to NA to remove size legend entirely.
#' @param key_var optional vector of rows ids, or variable name if data is not
#' NULL. This is passed as a key to d3, and is only added in shiny apps
#' where displayed rows are filtered interactively.
#' @param type_var optional vector of points type : "point" for a dot
#' (default), "arrow" for an arrow starting from the origin.
#' @param opacity_var optional vector of points opacity (values between 0 and
#' 1)
#' @param opacities named list or named vector of opacities. Each opacity
#' will be associated by their name within `opacity_var`.
#' @param url_var optional vector of URLs to be opened when a point is clicked
#' @param unit_circle set tot TRUE to draw a unit circle
#' @param tooltips logical value to display tooltips when hovering points
#' @param tooltip_text optional character vector of tooltips text
#' @param tooltip_position the tooltip position relative to its point. Must a
#' combination of "top" or "bottom" with "left" or "right" (default is
#' "bottom right").
#' @param xlab x axis label
#' @param ylab y axis label.
#' @param axes_font_size font size for axes text (any CSS compatible value)
#' @param legend_font_size font size for legend text (any CSS compatible
#' value)
#' @param hover_size factor for changing size when hovering points
#' @param hover_opacity points opacity when hovering
#' @param xlim numeric vector of length 2, manual x axis limits
#' @param ylim numeric vector of length 2, manual y axis limits
#' @param menu wether to display the tools menu (gear icon)
#' @param lasso logical value to add
#' {https://github.com/skokenes/D3-Lasso-Plugin}{d3-lasso-plugin} feature
#' @param lasso_callback the body of a JavaScript callback function with the
#' argument \code{sel} to be applied to a lasso plugin selection
#' @param click_callback the body of a JavaScript callback function whose
#' inputs are html_id, and the index of the clicked element.
#' @param zoom_callback the body of a JavaScript callback function whose
#' inputs are the new xmin, xmax, ymin and ymax after a zoom action is
#' triggered.
#' @param init_callback the body of a JavaScript callback function applied
#' to the scatter object at init time.
#' @param zoom_on coordinates where to center zoom on plot draw or update.
#' @param zoom_on_level zoom level on plot draw or update. Ignored if `zoom_on` is NULL.
#' @param disable_wheel if TRUE, disable zooming with mousewheel.
#' @param lines a data frame with at least the \code{slope} and
#' \code{intercept} columns, and as many rows as lines to add to
#' scatterplot. Style can be added with \code{stroke}, \code{stroke_width}
#' and \code{stroke_dasharray} columns. To draw a vertical line, pass
#' \code{Inf} as \code{slope} value.
#' @param html_id manually specify an HTML id for the svg root node. A random
#' one is generated by default.
#' @param dom_id_reset_zoom HTML DOM id of the element to bind the
#' "reset zoom" control to.
#' @param dom_id_svg_export HTML DOM id of the element to bind the
#' "svg export" control to.
#' @param dom_id_lasso_toggle HTML DOM id of the element to bind the
#' "toggle lasso" control to.
#' @param transitions if TRUE, data updates are displayed with smooth
#' transitions, if FALSE the whole chart is redrawn. Only used within
#' shiny apps.
#' @param legend_width legend area width, in pixels. Set to 0 to disable
#' legend completely.
#' @param left_margin margin on the left of the plot, in pixels
#' @param caption caption to be displayed when clicking on the corresponding
#' icon. Either a character string, or a list with title, subtitle and
#' text elements.
#' @param width figure width, computed when displayed
#' @param height figure height, computed when displayed
#'
#' @description Generates an interactive scatter plot based on d3.js.
#' Interactive features include zooming, panning, text labels moving, tooltips,
#' fading effects in legend. Additional handlers are provided to change label
#' size, point opacity or export the figure as an SVG file via HTML form controls.
#'
#' @source
#' D3.js was created by Michael Bostock. See \url{https://d3js.org/}
#'
#' @examples
#' scatterD3(x = mtcars$wt, y = mtcars$mpg, data=NULL, lab = rownames(mtcars),
#' col_var = mtcars$cyl, symbol_var = mtcars$am,
#' xlab = "Weight", ylab = "Mpg", col_lab = "Cylinders",
#' symbol_lab = "Manual transmission", html_id = NULL)
#'
#' @importFrom ellipse ellipse
#' @importFrom stats cov
#' @importFrom htmlwidgets JS
#' @export
scatterD3 <- function(x, y, data = NULL, lab = NULL,
x_log = FALSE, y_log = FALSE,
point_size = 64, labels_size = 10,
labels_positions = NULL,
point_opacity = 1,
opacities = NULL,
hover_size = 1,
hover_opacity = NULL,
fixed = FALSE,
col_var = NULL,
col_continuous = NULL,
colors = NULL,
ellipses = FALSE,
ellipses_level = 0.95,
symbol_var = NULL,
symbols = NULL,
size_var = NULL,
size_range = c(10,300),
sizes = NULL,
col_lab = NULL,
symbol_lab = NULL,
size_lab = NULL,
key_var = NULL,
type_var = NULL,
opacity_var = NULL,
unit_circle = FALSE,
url_var = NULL,
tooltips = TRUE,
tooltip_text = NULL,
tooltip_position = "bottom right",
xlab = NULL, ylab = NULL,
html_id = NULL,
width = NULL, height = NULL,
legend_width = 150,
left_margin = 30,
xlim = NULL, ylim = NULL,
dom_id_reset_zoom = "scatterD3-reset-zoom",
dom_id_svg_export = "scatterD3-svg-export",
dom_id_lasso_toggle = "scatterD3-lasso-toggle",
transitions = FALSE,
menu = TRUE,
lasso = FALSE,
lasso_callback = NULL,
click_callback = NULL,
init_callback = NULL,
zoom_callback = NULL,
zoom_on = NULL,
zoom_on_level = NULL,
disable_wheel = FALSE,
lines = data.frame(slope = c(0, Inf),
intercept = c(0, 0),
stroke_dasharray = c(5,5)),
axes_font_size = "100%",
legend_font_size = "100%",
caption = NULL) {
## Variable names as default labels
if (is.null(xlab)) xlab <- deparse(substitute(x))
if (is.null(ylab)) ylab <- deparse(substitute(y))
if (is.null(col_lab)) col_lab <- deparse(substitute(col_var))
if (is.null(symbol_lab)) symbol_lab <- deparse(substitute(symbol_var))
if (is.null(size_lab)) size_lab <- deparse(substitute(size_var))
opacity_lab <- deparse(substitute(opacity_var))
if (is.null(html_id)) html_id <- paste0("scatterD3-", paste0(sample(LETTERS, 8, replace = TRUE), collapse = ""))
## NSE
if (!is.null(data)) {
null_or_name <- function(varname) {
if (varname != "NULL") return(data[, varname])
else return(NULL)
}
## Get variable names
x <- data[, deparse(substitute(x))]
y <- data[, deparse(substitute(y))]
lab <- deparse(substitute(lab))
col_var <- deparse(substitute(col_var))
size_var <- deparse(substitute(size_var))
symbol_var <- deparse(substitute(symbol_var))
opacity_var <- deparse(substitute(opacity_var))
url_var <- deparse(substitute(url_var))
key_var <- deparse(substitute(key_var))
type_var <- deparse(substitute(type_var))
## Get variable data if not "NULL"
lab <- null_or_name(lab)
col_var <- null_or_name(col_var)
size_var <- null_or_name(size_var)
symbol_var <- null_or_name(symbol_var)
opacity_var <- null_or_name(opacity_var)
url_var <- null_or_name(url_var)
key_var <- null_or_name(key_var)
type_var <- null_or_name(type_var)
}
x_categorical <- is.factor(x) || !is.numeric(x)
y_categorical <- is.factor(y) || !is.numeric(y)
x_levels <- levels(x)
y_levels <- levels(y)
## No negative values and no 0 lines if logarithmic scales
if (x_log) {
if (any(x <= 0))
stop("Logarithmic scale and negative values in x")
lines <- lines[!(lines$slope == 0 & lines$intercept == 0),]
}
if (y_log) {
if (any(y <= 0))
stop("Logarithmic scale and negative values in y")
lines <- lines[!(lines$slope == Inf & lines$intercept == 0),]
}
## colors can be named
## we'll need to convert named vector to a named list
## for the JSON conversion
if (!is.null(colors) && !is.null(names(colors))) {
colors <- as.list(colors)
if (!setequal(names(colors), unique(col_var))) warning("Set of colors and col_var values do not match")
}
## Idem for symbols
if (!is.null(symbols) && !is.null(names(symbols))) {
symbols <- as.list(symbols)
if (!setequal(names(symbols), unique(symbol_var))) warning("Set of symbols and symbol_var values do not match")
}
## Idem for sizes
if (!is.null(sizes) && !is.null(names(sizes))) {
sizes <- as.list(sizes)
if (!setequal(names(sizes), unique(size_var))) warning("Set of sizes and size_var values do not match")
}
## Idem for opacities
if (!is.null(opacities) && !is.null(names(opacities))) {
opacities <- as.list(opacities)
if (!setequal(names(opacities), unique(opacity_var))) warning("Set of opacities and opacity_var values do not match")
}
## Determine from the data if we have a continuous or ordinal color scale
if (is.null(col_continuous)) {
col_continuous <- FALSE
if (!is.factor(col_var) && is.numeric(col_var) && length(unique(col_var)) > 6) {
col_continuous <- TRUE
}
}
## If caption is a character string, convert it to a list
if (is.character(caption)) {
caption <- list(text = caption)
}
## Tooltip position
tooltip_position_x <- gsub("^.* ([a-z]+) *$", "\\1", tooltip_position)
tooltip_position_y <- gsub("^ *([a-z]+) .*$", "\\1", tooltip_position)
if (!(tooltip_position_x %in% c("left", "right")) ||
!(tooltip_position_y %in% c("top", "bottom"))) {
warning("tooltip_position must be a combination of 'top' or 'bottom' and 'left' or 'right'.")
tooltip_position_x <- "right"
tooltip_position_y <- "bottom"
}
## data element
data <- data.frame(x = x, y = y)
col_levels <- NULL
symbol_levels <- NULL
if (!is.null(lab)) data <- cbind(data, lab = lab)
if (!is.null(col_var) && !col_continuous) {
# Keep order of levels if factor
if (is.factor(col_var)) col_levels <- levels(col_var)
col_var <- as.character(col_var)
col_var[is.na(col_var)] <- "NA"
data <- cbind(data, col_var = col_var)
}
if (!is.null(col_var) && col_continuous) {
if (any(is.na(col_var))) warning("NA values in continuous col_var. Values set to min(0, col_var)")
col_var[is.na(col_var)] <- min(0, col_var, na.rm = TRUE)
data <- cbind(data, col_var = col_var)
}
if (!is.null(symbol_var)) {
# Keep order of levels if factor
if (is.factor(symbol_var)) symbol_levels <- levels(symbol_var)
symbol_var <- as.character(symbol_var)
symbol_var[is.na(symbol_var)] <- "NA"
data <- cbind(data, symbol_var = symbol_var)
}
if (!is.null(size_var)) {
if (any(is.na(size_var))) warning("NA values in size_var. Values set to min(0, size_var)")
size_var[is.na(size_var)] <- min(0, size_var, na.rm = TRUE)
data <- cbind(data, size_var = size_var)
}
if (!is.null(type_var)) data <- cbind(data, type_var = type_var)
if (!is.null(url_var)) {
url_var[is.na(url_var)] <- ""
data <- cbind(data, url_var = url_var)
if (!is.null(click_callback)) {
click_callback <- NULL
warning("Both url_var and click_callback defined, click_callback set to NULL")
}
}
if (!is.null(opacity_var)) data <- cbind(data, opacity_var = opacity_var)
if (!is.null(key_var)) {
data <- cbind(data, key_var = key_var)
} else {
data <- cbind(data, key_var = seq_along(x))
}
if (!is.null(tooltip_text)) data <- cbind(data, tooltip_text = tooltip_text)
## Compute confidence ellipses point positions with ellipse::ellipse.default()
compute_ellipse <- function(x, y, level = ellipses_level, npoints = 50) {
cx <- mean(x)
cy <- mean(y)
data.frame(ellipse::ellipse(stats::cov(cbind(x,y)), centre = c(cx, cy), level = level, npoints = npoints))
}
## Compute ellipses points data
ellipses_data <- list()
if (ellipses && !col_continuous && !x_categorical && !y_categorical) {
## Only one ellipse
if (is.null(col_var)) {
ell <- compute_ellipse(x, y)
ellipses_data <- append(ellipses_data, list(list(level = "_scatterD3_all", data = ell)))
} else {
## One ellipse per col_var level
for (l in unique(col_var)) {
sel <- col_var == l & !is.na(col_var)
if (sum(sel) > 2) {
tmpx <- x[sel]
tmpy <- y[sel]
ell <- compute_ellipse(tmpx, tmpy)
ellipses_data <- append(ellipses_data, list(list(level = l, data = ell)))
}
}
}
} else {
## Force no ellipses if continuous color or categorical variable
ellipses <- FALSE
}
## List of hashes for each data variable, to track which data elements changed
## to apply updates and transitions in shiny app.
hashes <- list()
if (transitions) {
for (var in c("x", "y", "lab", "key_var", "col_var", "symbol_var", "size_var", "ellipses_data", "opacity_var", "lines", "labels_positions")) {
hashes[[var]] <- digest::digest(get(var), algo = "sha256")
}
}
## Disable automatic labels position if too many labels
n_lab <- sum(lab != "")
if (n_lab > 500 && !is.null(labels_positions) && labels_positions == "auto") {
warning(gettext("More than 500 labels, automatic labels positioning has been disabled"))
labels_positions <- NULL
}
## create a list that contains the settings
settings <- list(
x_log = x_log,
y_log = y_log,
labels_size = labels_size,
labels_positions = labels_positions,
point_size = point_size,
point_opacity = point_opacity,
opacities = opacities,
hover_size = hover_size,
hover_opacity = hover_opacity,
xlab = xlab,
ylab = ylab,
has_labels = !is.null(lab),
col_lab = col_lab,
col_continuous = col_continuous,
col_levels = col_levels,
colors = colors,
ellipses = ellipses,
ellipses_data = ellipses_data,
symbol_lab = symbol_lab,
symbol_levels = symbol_levels,
symbols = symbols,
size_range = size_range,
size_lab = size_lab,
sizes = sizes,
opacity_lab = opacity_lab,
opacities = opacities,
unit_circle = unit_circle,
has_color_var = !is.null(col_var),
has_symbol_var = !is.null(symbol_var),
has_size_var = !is.null(size_var),
has_opacity_var = !is.null(opacity_var),
has_url_var = !is.null(url_var),
has_legend = (!is.na(col_lab) && !is.null(col_var)) ||
(!is.na(symbol_lab) && !is.null(symbol_var)) ||
(!is.na(size_lab) && !is.null(size_var)),
has_tooltips = tooltips,
tooltip_text = tooltip_text,
tooltip_position_x = tooltip_position_x,
tooltip_position_y = tooltip_position_y,
has_custom_tooltips = !is.null(tooltip_text),
click_callback = htmlwidgets::JS(click_callback),
init_callback = htmlwidgets::JS(init_callback),
zoom_callback = htmlwidgets::JS(zoom_callback),
zoom_on = zoom_on,
zoom_on_level = zoom_on_level,
disable_wheel = disable_wheel,
fixed = fixed,
legend_width = legend_width,
left_margin = left_margin,
html_id = html_id,
xlim = xlim,
ylim = ylim,
x_categorical = x_categorical,
y_categorical = y_categorical,
x_levels = x_levels,
y_levels = y_levels,
menu = menu,
lasso = lasso,
lasso_callback = htmlwidgets::JS(lasso_callback),
dom_id_reset_zoom = dom_id_reset_zoom,
dom_id_svg_export = dom_id_svg_export,
dom_id_lasso_toggle = dom_id_lasso_toggle,
transitions = transitions,
axes_font_size = axes_font_size,
legend_font_size = legend_font_size,
caption = caption,
lines = lines,
hashes = hashes
)
## pass the data and settings using 'x'
x <- list(
data = data,
settings = settings
)
## create widget
htmlwidgets::createWidget(
name = 'scatterD3',
x,
width = width,
height = height,
package = 'scatterD3',
sizingPolicy = htmlwidgets::sizingPolicy(
browser.fill = TRUE,
browser.defaultWidth = "100%",
browser.defaultHeight = "85vh",
viewer.fill = TRUE,
viewer.defaultWidth = "100%",
viewer.defaultHeight = "85vh"
)
)
}
#' @rdname scatterD3-shiny
#' @export
scatterD3Output <- function(outputId, width = '100%', height = '600px'){
htmlwidgets::shinyWidgetOutput(outputId, 'scatterD3', width, height, package = 'scatterD3')
}
#' @rdname scatterD3-shiny
#' @export
renderScatterD3 <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) { expr <- substitute(expr) } # force quoted
htmlwidgets::shinyRenderWidget(expr, scatterD3Output, env, quoted = TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.