#' Scatter
#'
#' Scatter plot
#' @inherit LabeledScatter
#' @inherit Column
#' @param x A numeric vector for the x-axis coordinates (which may be named); or a matrix or datarame; or a list of matrices where each matrix share the same row and column names.
#' @param scatter.labels.as.hovertext Logical; if TRUE, labels are shown has hovers; otherwise, as a labeled scatterplot.
#' @param scatter.sizes.as.diameter Whether to show the points with diameter (instead of area, which is the default) proportional to the sizes variable.
#' @param line.thickness Thickness, in pixels, of the series line
#' @param line.colors Character; a vector containing one or more named
#' @param marker.symbols Character; a vector describing the symbol used for each data series.
#' See \url{https://plotly-r.com/working-with-symbols.html} for a list of symbol names.
#' Note there is no corresponding parameter for LabeledScatter.
#' @param marker.size Size in pixels of marker. This is overriden
#' if \code{scatter.sizes} is provided, but used for the legend
#' if \code{scatter.colors.as.categorical}.
#' @param data.label.position Character; where to place the source data value in relation
#' to the marker icon. Can be "top left", "top center", "top right", "middle left", "middle center",
#' "middle right", "bottom left", "bottom center", "bottom right".
#' @param scatter.max.groups Maximum number of different color categories in data. The is
#' equivalent to the number of enteries in the legend. Increasing this too high may cause
#' performance issues.
#' @param marker.border.width Width in pixels of border/line around markers; 0 is no line.
#' @param marker.border.colors Character; a vector containing one or more colors specified as hex codes.
#' @param marker.border.opacity Opacity of border/line around markers as an alpha value (0 to 1).
#' @param swap.x.and.y Swap the x and y axis around on the chart.
#' @param small.mult.index Used by Small Multiples to add prefixes to warnings.
#' @param y.tick.on.label Logical; Set to FALSE to move grid lines between categories.
#' @param x.tick.on.label Logical; Set to FALSE to move grid lines between categories.
#' @param sz.min Parameter to control scaling of scatter.sizes, used by SmallMultiples
#' @param sz.max Parameter to control scaling of scatter.sizes, used by SmallMultiples
#' @param sz.scale Parameter to control scaling of scatter.sizes. Marker size (in pixels) of
#' the points with the largest value of \code{scatter.size}. This defaults to 100/6 of \code{marker.size}.
#' @param col.min Parameter to control scaling of scatter.colors, used by SmallMultiples
#' @param col.max Parameter to control scaling of scatter.colors, used by SmallMultiples
#' @importFrom grDevices rgb col2rgb
#' @importFrom flipChartBasics ChartColors
#' @importFrom flipTime AsDateTime
#' @importFrom flipTransformations AsNumeric ParseText
#' @importFrom plotly plot_ly config toRGB add_trace add_text layout hide_colorbar
#' @importFrom stats loess loess.control lm predict
#' @export
Scatter <- function(x = NULL,
y = NULL,
scatter.x.column = 1,
scatter.y.column = 2,
scatter.labels = NULL,
scatter.labels.name = NULL,
scatter.sizes = NULL,
scatter.sizes.name = NULL,
scatter.sizes.column = 3,
scatter.sizes.as.diameter = FALSE,
scatter.colors = NULL,
scatter.colors.name = NULL,
scatter.colors.column = 4,
scatter.colors.as.categorical = TRUE,
scatter.labels.as.hovertext = TRUE,
scatter.max.labels = 50,
scatter.max.groups = 50,
annotation.list = NULL,
colors = ChartColors(12),
trend.lines = FALSE,
logos = NULL,
logo.size = 0.5,
fit.type = "None",
fit.window.size = 3,
fit.ignore.last = FALSE,
fit.line.type = "dot",
fit.line.width = 1,
fit.line.name = "Fitted",
fit.line.colors = colors,
fit.line.opacity = 1,
fit.CI.show = FALSE,
fit.CI.colors = fit.line.colors,
fit.CI.opacity = 0.4,
legend.show = TRUE,
legend.orientation = "Vertical",
legend.wrap = TRUE,
legend.wrap.nchar = 30,
tooltip.show = TRUE,
modebar.show = FALSE,
zoom.enable = TRUE,
axis.drag.enable = FALSE,
global.font.family = "Arial",
global.font.color = rgb(44, 44, 44, maxColorValue = 255),
title = "",
title.font.family = global.font.family,
title.font.color = global.font.color,
title.font.size = 16,
title.align = "center",
subtitle = "",
subtitle.font.family = global.font.family,
subtitle.font.color = global.font.color,
subtitle.font.size = 12,
subtitle.align = "center",
footer = "",
footer.font.family = global.font.family,
footer.font.color = global.font.color,
footer.font.size = 8,
footer.align = "center",
footer.wrap = TRUE,
footer.wrap.nchar = 100,
data.label.show = FALSE,
data.label.font.family = global.font.family,
data.label.font.color = global.font.color,
data.label.font.autocolor = FALSE,
data.label.font.size = 10,
data.label.position = "top middle",
opacity = NULL,
background.fill.color = "transparent",
background.fill.opacity = 1,
charting.area.fill.color = background.fill.color,
charting.area.fill.opacity = 0,
legend.fill.color = background.fill.color,
legend.fill.opacity = 0,
legend.border.color = rgb(44, 44, 44, maxColorValue = 255),
legend.border.line.width = 0,
legend.font.color = global.font.color,
legend.font.family = global.font.family,
legend.font.size = 10,
legend.position.y = 1,
legend.position.x = 1.02,
legend.ascending = NA,
margin.autoexpand = TRUE,
margin.top = NULL,
margin.bottom = NULL,
margin.left = NULL,
margin.right = NULL,
margin.inner.pad = NULL,
grid.show = TRUE,
y.title = "",
y.title.font.color = global.font.color,
y.title.font.family = global.font.family,
y.title.font.size = 12,
y.line.width = 0,
y.line.color = rgb(0, 0, 0, maxColorValue = 255),
y.tick.mark.length = 0,
y.tick.mark.color = "transparent",
y.bounds.minimum = NULL,
y.bounds.maximum = NULL,
y.tick.distance = NULL,
y.tick.maxnum = NULL,
y.zero = FALSE,
y.zero.line.width = 0,
y.zero.line.color = rgb(225, 225, 225, maxColorValue = 255),
y.data.reversed = FALSE,
y.grid.width = 1 * grid.show,
y.grid.color = rgb(225, 225, 225, maxColorValue = 255),
y.tick.show = TRUE,
y.tick.on.label = TRUE,
y.tick.suffix = "",
y.tick.prefix = "",
y.tick.format = "",
y.hovertext.format = "",
y.tick.angle = NULL,
y.tick.font.color = global.font.color,
y.tick.font.family = global.font.family,
y.tick.font.size = 10,
x.title = "",
x.title.font.color = global.font.color,
x.title.font.family = global.font.family,
x.title.font.size = 12,
x.line.width = 0,
x.line.color = rgb(0, 0, 0, maxColorValue = 255),
x.tick.mark.length = 3,
x.tick.mark.color = "transparent",
x.bounds.minimum = NULL,
x.bounds.maximum = NULL,
x.tick.distance = NULL,
x.tick.maxnum = 11,
x.zero = FALSE,
x.zero.line.width = 0,
x.zero.line.color = rgb(225, 225, 225, maxColorValue = 255),
x.data.reversed = FALSE,
x.grid.width = 1 * grid.show,
x.grid.color = rgb(225, 225, 225, maxColorValue = 255),
x.tick.show = TRUE,
x.tick.on.label = TRUE,
x.tick.suffix = "",
x.tick.prefix = "",
x.tick.format = "",
x.hovertext.format = "",
x.tick.angle = NULL,
x.tick.font.color = global.font.color,
x.tick.font.family = global.font.family,
x.tick.font.size = 10,
x.tick.label.wrap = TRUE,
x.tick.label.wrap.nchar = 21,
hovertext.font.family = global.font.family,
hovertext.font.size = 11,
hovertext.align = "left",
hovertext.template = NULL,
line.thickness = 0,
line.colors = colors,
marker.border.width = 1,
marker.border.colors = colors,
marker.border.opacity = NULL,
marker.size = 6,
marker.symbols = "circle",
swap.x.and.y = FALSE,
small.mult.index = NULL,
legend.bubbles.show = TRUE,
label.auto.placement = TRUE,
sz.min = NULL,
sz.max = NULL,
sz.scale = NULL,
col.min = NULL,
col.max = NULL)
{
tmp.stat <- attr(x, "statistic")
if ((is.array(x) || is.numeric(x)) && isTRUE(grepl("%", tmp.stat)))
{
x <- x/100
attr(x, "statistic") <- NULL
}
# Use labeled scatterplots if multiple tables are provided
if ((is.list(x) && !is.data.frame(x)) || !scatter.labels.as.hovertext)
{
if (is.list(x) || !is.null(rownames(x))|| (length(dim(x)) < 2 && !is.null(names(x))))
{
cl <- as.list(match.call())
cl <- cl[-1]
cl$scatter.labels.as.hovertext <- NULL
return(do.call(LabeledScatter, cl))
}
else if (!scatter.labels.as.hovertext)
warning("Labels not provided.")
}
annot.data <- x
# Adjust some of the the default default tick formats
if (!is.null(tmp.stat) && grepl("%)?$", tmp.stat))
{
if (nchar(x.tick.format) == 0 || grepl("[0-9]$", x.tick.format))
x.tick.format = paste0(x.tick.format, "%")
}
if (!any(nzchar(x.hovertext.format)))
x.hovertext.format <- x.tick.format
if (!any(nzchar(y.hovertext.format)))
y.hovertext.format <- y.tick.format
warning.prefix <- if (!is.null(small.mult.index)) paste0("Chart ", small.mult.index, ": ") else ""
# Grouping font attributes to simplify passing to plotly
title.font = list(family = title.font.family, size = title.font.size, color = title.font.color)
subtitle.font = list(family = subtitle.font.family, size = subtitle.font.size, color = subtitle.font.color)
x.title.font = list(family = x.title.font.family, size = x.title.font.size, color = x.title.font.color)
y.title.font = list(family = y.title.font.family, size = y.title.font.size, color = y.title.font.color)
ytick.font = list(family = y.tick.font.family, size = y.tick.font.size, color = y.tick.font.color)
xtick.font = list(family = x.tick.font.family, size = x.tick.font.size, color = x.tick.font.color)
footer.font = list(family = footer.font.family, size = footer.font.size, color = footer.font.color)
legend.font = list(family = if (!is.null(legend.font.family)) legend.font.family else global.font.family,
color = if (!is.null(legend.font.color)) legend.font.color else global.font.family,
size = if (!is.null(legend.font.size)) legend.font.size else data.label.font.size)
# Try to store name of variables
scatter.mult.yvals <- isTRUE(attr(x, "scatter.mult.yvals"))
if (!is.null(scatter.sizes) && is.null(scatter.sizes.name))
scatter.sizes.name <- deparse(substitute(scatter.sizes))
if (!is.null(scatter.labels) && is.null(scatter.labels.name))
scatter.labels.name <- deparse(substitute(scatter.labels))
if (!is.null(scatter.colors) && is.null(scatter.colors.name))
scatter.colors.name <- deparse(substitute(scatter.colors))
if (is.matrix(x) || is.data.frame(x))
{
.isValidColumnIndex <- function(n) {return (!is.null(n) && !is.na(n) && n > 0 && n <= ncol(x))}
if (is.null(scatter.labels) && !is.null(rownames(x)))
scatter.labels <- rownames(x)
if (is.null(y) && .isValidColumnIndex(scatter.y.column))
{
if (!any(nzchar(y.title)) && !is.null(colnames(x)) && !scatter.mult.yvals)
y.title <- colnames(x)[scatter.y.column]
y <- x[,scatter.y.column]
}
if (is.null(scatter.sizes) && .isValidColumnIndex(scatter.sizes.column))
{
if (is.null(scatter.sizes.name) && !is.null(colnames(x)))
scatter.sizes.name <- colnames(x)[scatter.sizes.column]
scatter.sizes.name <- trimws(scatter.sizes.name)
scatter.sizes <- x[,scatter.sizes.column]
}
if (is.null(scatter.colors) && .isValidColumnIndex(scatter.colors.column))
{
if (is.null(scatter.colors.name) || nchar(scatter.colors.name) == 0)
scatter.colors.name <- colnames(x)[scatter.colors.column]
scatter.colors.name <- trimws(scatter.colors.name)
scatter.colors <- x[,scatter.colors.column]
}
if (!any(nzchar(x.title)) && (!is.null(colnames(x))) &&
.isValidColumnIndex(scatter.x.column) && !scatter.mult.yvals)
x.title <- colnames(x)[scatter.x.column]
if (!.isValidColumnIndex(scatter.x.column))
x <- NULL
else
x <- x[,scatter.x.column]
}
if (is.null(scatter.labels) && !is.null(names(x)))
scatter.labels <- names(x)
# Specify marker size defaults. This ensures existing charts are not changed
if (!is.null(scatter.sizes))
{
if (is.null(sz.scale))
sz.scale <- 50/6 * marker.size
# Marker size used in legend
# This is fixed to match behaviour of LabeledScatter
# (It also useful to keep it small because space in the legend is limited)
marker.size <- 12
}
# Warning if non-default selected but corresponding data is missing
if (is.null(small.mult.index) && is.null(scatter.sizes) && scatter.sizes.as.diameter)
warning("'Sizes' variable not provided.")
if (is.null(small.mult.index) && is.null(scatter.colors) && !scatter.colors.as.categorical)
warning("'Colors' variable not provided.")
qualitative.palettes <- c("Default colors", "Primary colors",
"Light colors", "Strong colors", "Colorblind safe colors")
if (!scatter.colors.as.categorical && !is.null(attr(colors, "palette.type"))
&& attr(colors, "palette.type") %in% qualitative.palettes)
warning("For a numeric 'colors' variable, a qualitative palette should not be used. The colorscale is created by interpolating the colors.")
# Basic data checking
if (is.null(x) && is.null(y))
stop("At least one of x or y must be supplied.")
if (is.null(x))
x <- rep(0, length(y))
n <- length(x)
if (is.null(y))
y <- rep(0, n)
if (swap.x.and.y)
{
tmp <- x
x <- y
y <- tmp
tmp <- x.title
x.title <- y.title
y.title <- tmp
}
if (any(duplicated(cbind(x, y))))
warning(warning.prefix, "Chart contains overlapping points in the same position.")
# Remove NAs
not.na <- !is.na(x) & !is.na(y)
if (!all(not.na))
warning(warning.prefix, "Data points with missing values have been omitted.")
n <- length(x)
if (!is.null(scatter.sizes))
{
if (length(scatter.sizes) != n)
stop("'scatter.sizes' should be a numeric vector with the same number of observations as 'x'.")
if (any(!is.finite(suppressWarnings(AsNumeric(scatter.sizes, binary = FALSE)))))
{
warning(warning.prefix, "Some points omitted due to missing values in 'scatter.sizes'.")
not.na <- not.na & is.finite(suppressWarnings(AsNumeric(scatter.sizes, binary = FALSE)))
}
}
if (!is.null(scatter.colors))
{
if (length(scatter.colors) != n)
stop("'scatter.colors' should be a vector with the same number of observations as 'x'.")
if (any(is.na(scatter.colors)))
{
warning(warning.prefix, "Some points omitted due to missing values in 'scatter.colors'")
not.na <- not.na & !is.na(scatter.colors)
}
groups <- scatter.colors # keep group names with NA
} else
{
scatter.colors.as.categorical <- FALSE
groups <- rep("Series 1", n)
}
if (all(!not.na))
stop("No non-NA points to plot.")
if (any(not.na))
{
if (!is.null(scatter.labels))
scatter.labels <- scatter.labels[which(not.na)]
if (!is.null(x))
x <- x[which(not.na)]
if (!is.null(y))
y <-y[which(not.na)]
if (!is.null(scatter.sizes))
scatter.sizes <- scatter.sizes[which(not.na)]
if (!is.null(scatter.colors))
scatter.colors <- scatter.colors[which(not.na)]
}
n <- sum(not.na)
if (!is.null(scatter.sizes))
{
sz.tmp <- abs(AsNumeric(scatter.sizes, binary = FALSE))
if (is.null(sz.min))
sz.min <- min(sz.tmp, na.rm = TRUE)
if (is.null(sz.max))
sz.max <- max(sz.tmp, na.rm = TRUE)
if (!scatter.sizes.as.diameter)
{
sz.tmp <- sqrt(sz.tmp)
sz.min <- sqrt(sz.min)
sz.max <- sqrt(sz.max)
}
if (any(class(scatter.sizes) %in% c("Date", "POSIXct", "POSIXt")))
scatter.sizes.scaled <- (sz.tmp - sz.min)/(sz.max - sz.min) * sz.scale
else
scatter.sizes.scaled <- sz.tmp/sz.max * sz.scale
if (is.null(opacity))
opacity <- 0.4
}
if (is.null(opacity))
opacity <- if (fit.type == "None") 1 else 0.4
if (is.null(marker.border.opacity))
marker.border.opacity <- opacity
if (data.label.font.autocolor)
data.label.font.color <- colors
scatter.colors.as.numeric <- 0
colorbar <- NULL
if (scatter.colors.as.categorical && length(unique(scatter.colors)) > scatter.max.groups)
{
warning("The colors variable has been treated as a numeric scale because there ",
"are more than ", scatter.max.groups, " categories and would be slow to render")
scatter.colors.as.categorical <- FALSE
}
if (!is.null(scatter.colors) && !scatter.colors.as.categorical)
{
# make colorscalebar
colors <- StripAlphaChannel(colors, "Alpha values in selected colors were not used in the numeric color scale. Adjust 'opacity' for transparent points instead")
col.fun <- colorRamp(unique(colors)) # undo recycling in PrepareColors
cc.orig <- rgb(col.fun((0:5)/5), maxColorValue = 255) # hex values of opaque colors
cc.rgb <- col2rgb(cc.orig)
bg.rgb <- c(255, 255, 255)
conv.alpha <- function(xx, alpha) { # fake alpha transparency
yy <- (xx * alpha) + (bg.rgb * (1 - alpha))
return(rgb(yy[1], yy[2], yy[3], maxColorValue = 255))}
bg.rgb <- col2rgb(conv.alpha(col2rgb(background.fill.color), background.fill.opacity))
cc.alpha <- apply(cc.rgb, 2, conv.alpha, alpha = opacity)
cc.vals <- seq(from = 0, to = 1, length = length(cc.orig))
col.scale <- mapply(function(a,b)c(a,b), a = cc.vals, b = toRGB(cc.alpha), SIMPLIFY = FALSE)
# getting labels for all types
if (is.character(scatter.colors))
scatter.colors <- as.factor(scatter.colors)
scatter.colors.as.numeric <- 1
groups <- rep(NA, n)
groups[not.na] <- 1
col.tmp <- AsNumeric(scatter.colors, binary = FALSE)
if (is.null(col.min))
col.min <- min(col.tmp, na.rm = TRUE)
if (is.null(col.max))
col.max <- max(col.tmp, na.rm = TRUE)
scatter.colors.scaled <- (col.tmp - col.min)/(col.max - col.min)
scatter.colors.labels <- col.tmp
if (any(class(scatter.colors) == "factor") ||
any(class(scatter.colors) %in% c("Date", "POSIXct", "POSIXt")))
scatter.colors.labels <- scatter.colors.scaled
colors <- rgb(col.fun(scatter.colors.scaled), maxColorValue=255)
if (any(class(scatter.colors) %in% c("Date", "POSIXct", "POSIXt")))
{
col.min <- 0
col.max <- 1
tmp.seq <- seq(0, 1, length=5)
colorbar <- list(tickmode="array", tickvals=tmp.seq,
ticktext=c(min(scatter.colors) + diff(range(scatter.colors)) * tmp.seq),
outlinewidth=0, tickfont=legend.font)
}
else if (any(class(scatter.colors) == "factor"))
{
col.min <- 0
col.max <- 1
tmp.seq <- seq(from = 0, to = 1, length = nlevels(scatter.colors))
colorbar <- list(tickmode="array", tickvals = tmp.seq,
ticktext=levels(scatter.colors), outlinewidth=0, tickfont=legend.font)
}
else
colorbar <- list(outlinewidth = 0, tickfont=legend.font)
}
if (is.factor(groups))
g.list <- levels(groups) # fix legend order
else if (any(class(groups) %in% c("Date", "POSIXct", "POSIXt", "integer", "numeric")))
g.list <- sort(unique(groups[!is.na(groups)]))
else
g.list <- unique(groups[!is.na(groups)])
num.groups <- length(g.list)
groups <- groups[not.na]
num.series <- if (scatter.colors.as.numeric) 1 else num.groups
colors <- vectorize(colors, num.groups)
if (is.null(fit.line.colors))
fit.line.colors <- colors
if (is.null(fit.CI.colors))
fit.CI.colors <- fit.line.colors
if (is.null(line.colors))
line.colors <- colors
if (is.null(marker.border.colors))
marker.border.colors <- colors
line.colors <- vectorize(line.colors, num.groups)
marker.border.colors <- vectorize(marker.border.colors, num.groups)
marker.symbols <- vectorize(marker.symbols, num.groups)
data.label.font.color <- vectorize(data.label.font.color, num.groups)
data.label.font = lapply(data.label.font.color,
function(cc) list(family = data.label.font.family, size = data.label.font.size, color = cc))
# hovertext
.isEmptyName <- function(x) !any(nzchar(trimws(x)))
source.text <- paste0(scatter.labels, " (", formatByD3(x, x.hovertext.format, x.tick.prefix, x.tick.suffix), ", ",
formatByD3(y, y.hovertext.format, y.tick.prefix, y.tick.suffix), ")")
source.text <- trimws(source.text)
if (!.isEmptyName(scatter.colors.name) && !scatter.mult.yvals)
{
colors.str <- if (is.numeric(scatter.colors)) FormatAsReal(scatter.colors, decimals = decimalsFromD3(x.hovertext.format)) else as.character(scatter.colors)
source.text <- paste0(source.text, "<br>", scatter.colors.name, ": ", colors.str)
}
if (!.isEmptyName(scatter.sizes.name) && !scatter.mult.yvals)
{
sizes.str <- if (is.numeric(scatter.sizes)) FormatAsReal(scatter.sizes, decimals = decimalsFromD3(x.hovertext.format)) else as.character(scatter.sizes)
source.text <- paste0(source.text, "<br>", scatter.sizes.name, ": ", sizes.str)
}
# other constants
colorbar.show <- setShowLegend(legend.show) # colorbar is always shown even for 1 data series
legend.show <- setShowLegend(legend.show, num.series + scatter.colors.as.numeric)
series.mode <- if (is.null(line.thickness) || line.thickness == 0) "markers"
else "markers+lines"
if (data.label.show)
series.mode <- paste0(series.mode, "+text")
type <- "Scatterplot"
legend <- setLegend("Scatterplot", legend.font, legend.ascending,
legend.fill.color, legend.fill.opacity,
legend.border.color, legend.border.line.width,
legend.position.x, legend.position.y,
orientation = legend.orientation)
legend$itemsizing <- if (!is.null(scatter.sizes)) "constant" else "trace"
if (length(footer) == 0 || nchar(footer) == 0)
{
footer <- ""
if (!.isEmptyName(scatter.labels.name))
footer <- sprintf("%sPoints labeled by '%s'; ",
footer, scatter.labels.name[1])
if (!.isEmptyName(scatter.colors.name) && !scatter.mult.yvals)
footer <- sprintf("%sPoints colored according to '%s'; ",
footer, scatter.colors.name[1])
if (!.isEmptyName(scatter.sizes.name) && !scatter.mult.yvals)
footer <- sprintf("%s%s of points are proportional to absolute value of '%s'; ",
footer,
if (scatter.sizes.as.diameter) "Diameter" else "Area",
scatter.sizes.name[1])
}
footer <- autoFormatLongLabels(footer, footer.wrap, footer.wrap.nchar, truncate=FALSE)
# Format axis labels
#if (is.null(y.tick.decimals))
# y.tick.decimals <- decimalsToDisplay(as.numeric(y))
x.range <- setValRange(x.bounds.minimum, x.bounds.maximum, x)
y.range <- setValRange(y.bounds.minimum, y.bounds.maximum, y)
xtick <- setTicks(x.range$min, x.range$max, x.tick.distance, x.data.reversed)
ytick <- setTicks(y.range$min, y.range$max, y.tick.distance, y.data.reversed)
xlab.tmp <- if (!is.numeric(x)) as.character(x)
else FormatAsReal(x, decimals=2) #x.tick.decimals)
ylab.tmp <- if (!is.numeric(y)) as.character(y)
else FormatAsReal(y, decimals=2) #y.tick.decimals)
# Avoid points being trimmed off if they are too close to zero
if (x.zero && is.numeric(x))
{
x.abs.max <- max(abs(range(x, na.rm=T)), na.rm=T)
if (!is.finite(x.abs.max) || x.abs.max == 0 || any(abs(range(x, na.rm=T))/x.abs.max < 1e-2))
x.zero <- FALSE
}
if (y.zero && is.numeric(y))
{
y.abs.max <- max(abs(range(y, na.rm=T)), na.rm=T)
if (!is.finite(y.abs.max) || y.abs.max == 0 || any(abs(range(y, na.rm=T))/y.abs.max < 1e-2))
y.zero <- FALSE
}
axisFormat <- formatLabels(list(x=xlab.tmp, y=ylab.tmp), type,
x.tick.label.wrap, x.tick.label.wrap.nchar,
x.tick.format, y.tick.format)
yaxis <- setAxis(y.title, "left", axisFormat, y.title.font,
y.line.color, y.line.width, y.grid.width * grid.show, y.grid.color,
ytick, ytick.font, y.tick.angle, y.tick.mark.length,
y.tick.distance, y.tick.format, y.tick.prefix, y.tick.suffix,
y.tick.show, y.zero, y.zero.line.width, y.zero.line.color,
y.hovertext.format, num.maxticks = y.tick.maxnum,
tickcolor = y.tick.mark.color, zoom.enable = zoom.enable)
xaxis <- setAxis(x.title, "bottom", axisFormat, x.title.font,
x.line.color, x.line.width, x.grid.width * grid.show, x.grid.color,
xtick, xtick.font, x.tick.angle, x.tick.mark.length,
x.tick.distance, x.tick.format, x.tick.prefix, x.tick.suffix, x.tick.show,
x.zero, x.zero.line.width, x.zero.line.color,
x.hovertext.format, axisFormat$labels, num.maxticks = x.tick.maxnum,
tickcolor = x.tick.mark.color, zoom.enable = zoom.enable)
if (!y.tick.on.label)
yaxis$tickson <- "boundaries"
if (!x.tick.on.label)
xaxis$tickson <- "boundaries"
if (xaxis$type == "date")
x <- AsDateTime(as.character(x), on.parse.failure = "silent")
if (yaxis$type == "date")
y <- AsDateTime(as.character(y), on.parse.failure = "silent")
if (is.factor(x))
levels(x) <- autoFormatLongLabels(levels(x), x.tick.label.wrap, x.tick.label.wrap.nchar)
if (is.character(x))
x <- autoFormatLongLabels(x, x.tick.label.wrap, x.tick.label.wrap.nchar)
# Work out margin spacing
margins <- list(t = 20, b = 20, r = 60, l = 80, pad = 0)
margins <- setMarginsForAxis(margins, axisFormat, xaxis)
margins <- setMarginsForAxis(margins, ylab.tmp, yaxis)
margins <- setMarginsForText(margins, title, subtitle, footer, title.font.size,
subtitle.font.size, footer.font.size)
legend.text <- autoFormatLongLabels(g.list, legend.wrap, legend.wrap.nchar, remove.empty = FALSE)
margins <- setMarginsForLegend(margins, legend.show, legend, legend.text)
margins <- setCustomMargins(margins, margin.top, margin.bottom, margin.left,
margin.right, margin.inner.pad)
margins$autoexpand <- margin.autoexpand
## START PLOTTING
p <- plot_ly(data.frame(x = x,y = y))
# add invisible trace to force correct order
tmp.x <- if (is.factor(x)) levels(x)
else unique(x)
tmp.y <- if (is.factor(y)) levels(y)
else unique(y)
if (length(tmp.x) >= length(tmp.y))
tmp.y <- rep(tmp.y, length = length(tmp.x))
else
tmp.x <- rep(tmp.x, length = length(tmp.y))
p <- add_trace(p, x = tmp.x, y = tmp.y, type = "scatter",
mode = "lines", hoverinfo = "skip", showlegend = F, opacity = 0)
chart.labels <- list(SeriesLabels = list())
for (ggi in 1:num.groups)
{
ind <- which(groups == g.list[ggi])
if (length(ind) == 0)
next
tmp.size <- if (!is.null(scatter.sizes)) scatter.sizes.scaled[ind]
else rep(marker.size, length(ind))
# Initialise marker/line settings
# There are some problems with the border opacity when using marker.opacity
# instead of marker.colors.alpha but the second setting needs hovertext
# font colors to be fixed
line.obj <- if (is.null(line.thickness) || line.thickness == 0) NULL
else list(width = line.thickness, color = line.colors[ggi])
if (ggi == 1 && scatter.colors.as.numeric)
marker.obj <- list(size = tmp.size, sizemode = "diameter", symbol = marker.symbols,
color = colors, opacity = opacity,
#color = toRGB(colors, alpha = opacity), opacity = 1.0,
line = list(width = marker.border.width,
color = toRGB(marker.border.colors, alpha = marker.border.opacity)),
colorscale = col.scale, cmin = col.min, cmax = col.max,
showscale = colorbar.show, colorbar = colorbar)
else
marker.obj <- list(size = tmp.size, sizemode = "diameter", symbol = marker.symbols[ggi],
#color = toRGB(colors[ggi], alpha = opacity), opacity = 1.0,
color = colors[ggi], opacity = opacity,
line = list(width = marker.border.width,
color = toRGB(marker.border.colors[ggi], alpha = marker.border.opacity)))
# Add attribute for PPT exporting
# Note that even without data labels, overlay annotations can still be present
chart.labels$SeriesLabels[[ggi]] <- list(Font = setFontForPPT(data.label.font[[ggi]]), ShowValue = FALSE)
pt.segs <- lapply(ind,
function(ii)
{
pt <- list(Index = ii-1)
if (data.label.show)
pt$Segments <- list(list(Field="Value"))
else
pt$Segments <- list()
return(pt)
}
)
# Traces for annotation need to occur before main trace to avoid hiding hover info
annot.text <- rep("", length(ind))
for (j in seq_along(annotation.list))
{
if (!checkAnnotType(annotation.list[[j]]$type, "Scatter"))
next
a.tmp <- annotation.list[[j]]
tmp.dat <- getAnnotScatterData(annot.data, a.tmp$data, ind)
a.tmp$threshold <- ParseText(a.tmp$threshold, tmp.dat)
ind.sel <- if (is.null(a.tmp$threstype) || is.null(a.tmp$threshold)) 1:length(tmp.dat)
else if (is.factor(tmp.dat) && !is.ordered(tmp.dat)) selectFactor(a.tmp$threshold, 1:length(tmp.dat), a.tmp$data, ggi)
else if (a.tmp$threstype == "above threshold") which(tmp.dat > a.tmp$threshold)
else if (a.tmp$threstype == "below threshold") which(tmp.dat < a.tmp$threshold)
else which(is.na(tmp.dat))
if (length(ind.sel) > 0)
{
if (a.tmp$type == "Marker border")
p <- add_trace(p, x = x[ind[ind.sel]], y = y[ind[ind.sel]], showlegend = FALSE, cliponaxis = FALSE,
type = "scatter", mode = "markers", hoverinfo = "skip",
marker = list(size = tmp.size[ind.sel], sizemode = "diameter", color = "transparent",
line = list(width = a.tmp$width, color = a.tmp$color)),
legendgroup = if (num.series > 1) ggi else 1, symbols = marker.symbols)
else
annot.text[ind.sel] <- addAnnotToDataLabel(annot.text[ind.sel], a.tmp, tmp.dat[ind.sel])
pt.segs <- getPointSegmentsForPPT(pt.segs, ind.sel, a.tmp, tmp.dat[ind.sel])
}
}
# Clean up PPT chart labels
pt.segs <- tidyPointSegments(pt.segs, length(ind), index.map = ind)
if (isTRUE(attr(pt.segs, "SeriesShowValue")))
{
chart.labels$SeriesLabels[[ggi]]$ShowValue <- TRUE
attr(pt.segs, "SeriesShowValue") <- NULL
}
if (length(pt.segs) > 0)
chart.labels$SeriesLabels[[ggi]]$CustomPoints <- pt.segs
if (any(nzchar(annot.text) > 0))
p <- add_trace(p, x = x[ind], y = y[ind], showlegend = FALSE, cliponaxis = FALSE,
type = "scatter", mode = "markers+text", hoverinfo = "skip",
marker = list(size = pmax(1.0, tmp.size - 7), sizemode = "diameter", color = "transparent",
line = list(width = 0)), legendgroup = if (num.series > 1) ggi else 1,
text = annot.text, textposition = "middle right", symbols = marker.symbols)
# Customise hovertext format if hovertext.template is set; otherwise use default source.text
hover.tmp <- NULL
if (!is.null(hovertext.template))
{
hovertext.template <- vectorize(hovertext.template, length(x))
hover.tmp <- evalHoverTemplate(hovertext.template[ind], x[ind],
x.hovertext.format, x.tick.prefix, x.tick.suffix, y[ind],
y.hovertext.format, y.tick.prefix, y.tick.suffix)
}
# Main trace
p <- add_trace(p, x = x[ind], y = y[ind],
name = legend.text[ggi],
showlegend = (legend.show && !scatter.colors.as.numeric),
legendgroup = if (num.series > 1) ggi else 1,
textposition = data.label.position, cliponaxis = FALSE,
textfont = if (data.label.show) data.label.font[[ggi]] else NULL,
marker = marker.obj, line = line.obj, text = source.text[ind],
hoverinfo = if (num.series == 1) "text" else "name+text",
hovertemplate = hover.tmp,
hoverlabel = list(font = list(color = autoFontColor(colors[ggi]),
size = hovertext.font.size, family = hovertext.font.family)),
type = "scatter", mode = series.mode, symbols = marker.symbols)
if (fit.type != "None" && num.series > 1)
{
tmp.fit <- fitSeries(x[ind], y[ind], fit.type, fit.ignore.last, xaxis$type,
fit.CI.show, fit.window.size, warning.prefix)
tmp.fname <- sprintf("%s: %s", fit.line.name, g.list[ggi])
p <- add_trace(p, x = tmp.fit$x, y = tmp.fit$y, type = 'scatter', mode = "lines",
name = tmp.fname, legendgroup = ggi, showlegend = FALSE,
hoverlabel = list(font = list(color = autoFontColor(fit.line.colors[ggi]),
size = hovertext.font.size, family = hovertext.font.family)),
line = list(dash = fit.line.type, width = fit.line.width, shape = 'spline',
color = fit.line.colors[ggi]), opacity = fit.line.opacity)
if (fit.CI.show && !is.null(tmp.fit$lb))
{
p <- add_trace(p, x = tmp.fit$x, y = tmp.fit$lb, type = 'scatter',
mode = 'lines', name = "Lower bound of 95%CI",
showlegend = FALSE, legendgroup = ggi,
hoverlabel = list(font = list(color = autoFontColor(fit.CI.colors[ggi]),
size = hovertext.font.size, family = hovertext.font.family)),
line=list(color=fit.CI.colors[ggi], width=0, shape='spline'))
p <- add_trace(p, x = tmp.fit$x, y = tmp.fit$ub, type = 'scatter',
mode = 'lines', name = "Upper bound of 95% CI",
fill = "tonexty", fillcolor = toRGB(fit.CI.colors[ggi], alpha = fit.CI.opacity),
hoverlabel = list(font = list(color = autoFontColor(fit.CI.colors[ggi]),
size = hovertext.font.size, family = hovertext.font.family)),
showlegend = FALSE, legendgroup = ggi,
line = list(color=fit.CI.colors[ggi], width=0, shape='spline'))
}
}
}
if (fit.type != "None" && num.series == 1)
{
tmp.fit <- fitSeries(x, y, fit.type, fit.ignore.last, xaxis$type, fit.CI.show,
fit.window.size, warning.prefix)
p <- add_trace(p, x = tmp.fit$x, y = tmp.fit$y, type = 'scatter', mode = 'lines',
name = fit.line.name, showlegend = FALSE,
hoverlabel = list(font = list(color = autoFontColor(fit.line.colors[1]),
size = hovertext.font.size, family = hovertext.font.family)),
line = list(dash = fit.line.type, width = fit.line.width,
shape = 'spline', color = fit.line.colors[1]), opacity = fit.line.opacity)
if (fit.CI.show && !is.null(tmp.fit$lb))
{
p <- add_trace(p, x = tmp.fit$x, y = tmp.fit$lb, type = 'scatter',
mode = 'lines', name = "Lower bound of 95%CI", showlegend = FALSE,
hoverlabel = list(font = list(color = autoFontColor(fit.CI.colors[ggi]),
size = hovertext.font.size, family = hovertext.font.family)),
line=list(color=fit.CI.colors[1], width=0, shape='spline'))
p <- add_trace(p, x = tmp.fit$x, y = tmp.fit$ub, type = 'scatter',
mode = 'lines', name = "Upper bound of 95% CI", showlegend = FALSE,
hoverlabel = list(font = list(color = autoFontColor(fit.CI.colors[ggi]),
size = hovertext.font.size, family = hovertext.font.family)),
fill = "tonexty", fillcolor = toRGB(fit.CI.colors[1], alpha = fit.CI.opacity),
line = list(color=fit.CI.colors[1], width=0, shape='spline'))
}
}
if (is.null(chart.labels[["SeriesLabels"]]))
chart.labels <- NULL
else
{
serieslabels.num.changes <- vapply(chart.labels$SeriesLabels,
function(s) isTRUE(s$ShowValue) + length(s$CustomPoints),
integer(1L))
if (all(serieslabels.num.changes == 0))
chart.labels <- NULL
}
# Chart title is added in flipChart but axis names from the variable names
# need to be assigned here
if (any(nzchar(x.title)) || any(nzchar(y.title)))
{
if (is.null(chart.labels))
chart.labels <- list()
if (any(nzchar(x.title)))
chart.labels$PrimaryAxisTitle <- x.title
if (any(nzchar(y.title)))
chart.labels$ValueAxisTitle <- y.title
}
annot <- list(setSubtitle(subtitle, subtitle.font, margins, subtitle.align),
setTitle(title, title.font, margins, title.align),
if (is.null(small.mult.index)) setFooter(footer, footer.font, margins, footer.align) else NULL)
annot <- Filter(Negate(is.null), annot)
p <- config(p, displayModeBar = modebar.show, showAxisDragHandles = axis.drag.enable)
p$sizingPolicy$browser$padding <- 0
p <- layout(p,
margin = margins,
showlegend = legend.show,
legend = legend,
yaxis = yaxis,
xaxis = xaxis,
margin = margins,
plot_bgcolor = toRGB(charting.area.fill.color, alpha = charting.area.fill.opacity),
paper_bgcolor = toRGB(background.fill.color, alpha = background.fill.opacity),
annotations = annot,
shapes = zerolines(x.zero, x.zero.line.width, x.zero.line.color,
y.zero, y.zero.line.width, y.zero.line.color),
hovermode = if (tooltip.show) "closest" else FALSE,
hoverlabel = list(namelength = -1, bordercolor = "transparent", align = hovertext.align,
font = list(size = hovertext.font.size, family = hovertext.font.family))
)
attr(p, "can-run-in-root-dom") <- TRUE
result <- list(htmlwidget = p)
class(result) <- "StandardChart"
attr(result, "ChartType") <- if (!is.null(scatter.sizes)) "Bubble"
else "X Y Scatter"
attr(result, "ChartLabels") <- chart.labels
result
}
getAnnotScatterData <- function(data, name, ind)
{
if (!name %in% colnames(data))
stop("Annotation data does not contain '", name, "'. ",
"Allowable names are: '", paste(colnames(data), collapse = "', '"), "'. ")
return(data[ind, name])
}
selectFactor <- function(threshold, index, var.name, i)
{
if (nchar(trimws(threshold)) > 0 && i == 1)
warning("Inequalities are not applicable to '", var.name,
"' because it is an unordered categorical variable. Ignoring threshold '", threshold, "'.")
return(index)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.