#' ErrorIfNotEnoughData
#'
#' Returns an error if there is not enough data for charting.
#' @param x The data to be plotted.
#' @param require.tidy The data is assumed to be a numeric vector, matrix, array, or data frame.
#' @param require.notAllMissing The data is required to contain at least one non-NA value.
#' @export
ErrorIfNotEnoughData <- function(x, require.tidy = TRUE, require.notAllMissing = FALSE)
{
.stop <- function()
{ stop("There is not enough data to create a plot.") }
.possiblyTidy <- function(x)
{is.numeric(x) || is.matrix(x) || is.data.frame(x) || is.array(x)}
.noData <- function(x)
{NROW(x) == 0 || NCOL(x) == 0}
if (!require.tidy && is.list(x))
x <- x[[1]]
if (require.tidy && !.possiblyTidy(x))
stop("The data is not in an appropriate format.")
if (.noData(x))
.stop()
if (require.notAllMissing && all(is.na(x)))
.stop()
}
# hovertemplate is preferrable to hoverinfo because it allows better control
# of formatting. Specifically, we can re-order the x/y and control separators
# and newlines. But the format is slightly more complex
setHoverTemplate <- function(i, axis, chart.matrix, template = NULL, is.bar = FALSE)
{
# if no template is defined, set default base on axis type
if (all(!nzchar(template)))
{
if (axis$type == "category")
template <- if (is.bar) "%{y}: %{x}" else "%{x}: %{y}"
else
template <- "(%{x}, %{y})"
}
if (length(template) > 1)
template <- matrix(template, nrow(chart.matrix), ncol(chart.matrix))[,i]
# Set label shown in secondary box with series name if defined
label <- if (ncol(chart.matrix) == 1 && colnames(chart.matrix)[1] %in% c("Series.1", "Series 1")) ""
else colnames(chart.matrix)[i]
template <- paste0(template, "<extra>", label, "</extra>")
ind.na <- which(!is.finite(chart.matrix[,i]))
if (length(ind.na) > 0)
{
template <- rep(template, length = nrow(chart.matrix))
val.pattern <- if (is.bar) "%{x}" else "%{y}"
na.template <- gsub(val.pattern, "", template[ind.na], fixed = TRUE)
template[ind.na] <- na.template
}
return(template)
}
# Used by barcharts and radar chart to because x and y coords do not
# match values in data
evalHoverTemplate <- function(template, x, x.hovertext.format, x.tick.prefix, x.tick.suffix,
y, y.hovertext.format, y.tick.prefix, y.tick.suffix)
{
x.match <- regexpr("%{x}", template, fixed = TRUE)
y.match <- regexpr("%{y}", template, fixed = TRUE)
if (all(x.match == -1) && all(y.match == -1))
return(template)
x.txt <- formatByD3(x, x.hovertext.format, x.tick.prefix, x.tick.suffix)
y.txt <- formatByD3(y, y.hovertext.format, y.tick.prefix, y.tick.suffix)
template <- gsub("%", "%%", template, fixed = TRUE) # comment out other '%' signs
if (all(y.match == -1))
{
template <- gsub("{x}", "s", template, fixed = TRUE)
template <- gsub("%%s", "%s", template, fixed = TRUE)
return(sprintf(template, x.txt))
} else if (all(x.match == -1))
{
template <- gsub("{y}", "s", template, fixed = TRUE)
template <- gsub("%%s", "%s", template, fixed = TRUE)
return(sprintf(template, y.txt))
} else
{
template <- gsub("{y}", "s", template, fixed = TRUE)
template <- gsub("{x}", "s", template, fixed = TRUE)
template <- gsub("%%s", "%s", template, fixed = TRUE)
if (all(y.match < x.match))
return(sprintf(template, y.txt, x.txt))
else
return(sprintf(template, x.txt, y.txt))
}
}
#' Checks input data and converts it into a matrix for charting
#'
#' Converts input data into a matrix with 2 dimensions
#' and row and columns names which can be used for charting.
#' @param x Input in the form of vector, matrix, array, time-series object
#' or a Q table. If input is a Q table, then only the first statistic is returned
#' @param assign.col.names Whether to assign column names. This defaults to true,
#' It is set to false (for example in \code{Heat}) because the columns do not
#' make up separate series.
#' @return Numeric matrix with the first statistic in \code{x}.
#' @importFrom flipU CopyAttributes
#' @noRd
checkMatrixNames <- function(x, assign.col.names = TRUE)
{
# Check for special case where x is a time-series object
tInfo <- attr(x, "tsp", exact = TRUE)
if (length(tInfo) == 3)
{
t.seq <- seq(from = tInfo[1], to = tInfo[2], by = 1/tInfo[3])
x <- as.matrix(x)
rownames(x) <- t.seq
return(x)
}
# If x is a 1-d slice from a multi-stat crosstab
# Then label matrix as Q-table so that secondary statistics are not plotted
# But can still be used for annotations
# We assume its a 1-d slice if at least 2 colnames match something in the list of cell statistics
is.slice <- FALSE
q.cell.statnames <- c("Average", "Standard Deviation", "Minimum", "5th Percentile", "25th Percentile",
"Median", "75th Percentile", "95th Percentile", "Maximum", "Mode",
"Trimmed Average", "Interquartile Range", "Sum", "% Share", "Column Sample Size",
"%", "% Excluding NaN", "Row %", "Column %", "Cumulative %", "Expected %", "Residual %",
"Sample Size", "Missing Count", "Effective Sample Size", "Count",
"Weighted Column Sample Size", "Weighted Sample Size", "Weighted Count", "t-Statistic",
"d.f.", "z-Statistic", "Standard Error", "p", "Corrected p", "Index",
"Multiple Comparison Adjustment", "Not Duplicate", "Column Names",
"Columns Compared", "Column Comparisons")
if (inherits(x, "matrix") && !is.null(colnames(x)) && is.null(attr(x, "name")) && is.null(attr(x, "questions")) &&
ncol(x) > 1 && all(colnames(x) %in% q.cell.statnames))
{
attr(x, "name") <- " "
attr(x, "questions") <- " "
is.slice <- TRUE
}
# Convert into a matrix format and extract primary statistic
old.names <- c(dimnames(x), NA, NA) # ensure there are at least 2 elements
new.x <- if (length(dim(x)) == 3) matrix(x[,,1], nrow(x), ncol(x), dimnames = old.names[1:2]) # explicitly specify dimensions
else as.matrix(suppressWarnings(AsTidyTabularData(x))) # handles 1d data + statistic properly
# Try to convert character matrix to numeric
# This may occur in Q-tables with a character statistic (e.g. 'Column Comparisons')
old.dim <- dim(new.x)
old.names <- dimnames(new.x)
if (is.character(new.x))
{
new.x <- as.numeric(new.x)
dim(new.x) <- old.dim
dimnames(new.x) <- old.names
}
# Convert percentage data to decimal form
if (isPercentData(x) && !is.slice)
{
new.x <- new.x/100
attr(new.x, "statistic") <- NULL
}
# Assign row/column names if missing
if (is.null(rownames(new.x)))
rownames(new.x) <- 1:NROW(new.x)
if (is.null(colnames(new.x)) && assign.col.names)
colnames(new.x) <- sprintf("Series %d", 1:NCOL(new.x))
if (any(duplicated(rownames(new.x))))
stop("Row names of the input table must be unique.")
attr(new.x, "sorted.rows") <- attr(x, "sorted.rows")
return(new.x)
}
checkTableList <- function(y, trend.lines)
{
num.tables <- length(y)
y.names <- rep("", num.tables)
used.names <- c()
for (i in 1:num.tables)
{
if (is.null(attr(y[[i]], "name", exact = TRUE)))
{
attr(y[[i]], "name") <- as.character(i)
used.names <- c(used.names, i)
}
y.names[i] <- attr(y[[i]], "name", exact = TRUE)[1]
}
if (!trend.lines && length(used.names) > 0)
warning(sprintf("Tables have been automatically assigned names '%s'. You can name tables using R code: 'attr(table.name, \"name\") <- \"Description\"'", paste(used.names, collapse="', '")))
if (any(duplicated(y.names)) & !trend.lines)
warning(sprintf("Tables have duplicate names: '%s'. Points from duplicated tables cannot be distinguised.", paste(y.names[duplicated(y.names)], collapse = "', '")))
# Check tables match - order of rows will match first table
r.names <- rownames(y[[1]])
c.names <- colnames(y[[1]])
if (!is.null(r.names) && any(duplicated(r.names)) && length(y) > 1)
stop("Row names of tables must be unique or NULL for multiple tables to be plotted but are duplicated.")
if (num.tables > 1) {
for (i in 2:num.tables)
{
if (!setequal(r.names, rownames(y[[i]])))
stop(sprintf("Tables should have identical row names but table '%s' differs from table '%s'.",
y.names[i], y.names[1]))
if (!setequal(c.names, colnames(y[[i]])))
stop(sprintf("Tables should have identical column names but table '%s' differs from table '%s'.",
y.names[i], y.names[1]))
if (!is.null(r.names))
y[[i]] <- y[[i]][r.names, , drop = FALSE]
if (!is.null(c.names))
y[[i]] <- y[[i]][, c.names, drop = FALSE]
}
}
return(y)
}
#' Returns range of axis or vector in format readable for plotly
#'
#' @param axis If \code{axis} object is provided and \code{range} is
#' specified in it (i.e. not \code{auto.range}), then this range will
#' be returned
#' @param axisFormat This is the output of \code{formatLabels}. This object
#' contains information if the axis is a date.
#' @param x If \code{axis$range} is not provided, and \code{axisFormat} does
#' not contain dates, then range is determined
#' from the range of the data \code{x}. Offsets are added so that
#' bar and column charts are not truncated
#' @importFrom flipTime AsDateTime
#' @noRd
getRange <- function(x, axis, axisFormat)
{
tozero <- FALSE
range <- NULL
if (!is.null(axis) && !any(is.na(axis$range)))
{
# in setAxis, date ranges must be a character, but when we copy an
# axis to add data labels, we need it as a numeric
if (axis$type == "date" && is.character(axis$range))
range <- as.numeric(AsDateTime(axis$range)) * 1000
else
range <- axis$range
if (is.null(axis$range) && axis$rangemode == "tozero")
tozero <- TRUE
}
# Use axis type if numeric or categorical specified
# For date axis, we do some more checking
if (is.null(range) && !is.null(axis) && !is.null(axis$type))
{
if (axis$type == "numeric")
range <- calcRangeNumeric(x)
else if (axis$type == "category")
range <- calcRangeCategorical(x)
if (isTRUE(axis$rangemode == "tozero"))
range <- c(min(0, range[1]), max(0, range[2]))
if (isTRUE(axis$autorange == "reversed"))
range <- rev(range)
}
# Unspecified axis type or with a date range
if (is.null(range))
{
# In most cases axisFormat$ymd is specified if axis is a date
if (!is.null(axisFormat) && length(axisFormat$ymd) >= 2)
{
tmp.dates <- sort(unique(as.numeric(axisFormat$ymd))) * 1000
diff <- min(diff(tmp.dates), na.rm = TRUE)
range <- range(tmp.dates) + c(-0.5, 0.5) * diff
}
else if (is.numeric(x))
{
range <- calcRangeNumeric(x)
if (tozero)
range <- c(min(0, range[1]), max(0, range[2]))
}
else if (all(!is.na(suppressWarnings(AsDateTime(x, on.parse.failure = "silent")))) &&
!(!is.null(axis) && axis$type == "numeric"))
{
tmp.dates <- sort(unique(as.numeric(AsDateTime(x)))) * 1000
diff <- min(diff(tmp.dates), na.rm = TRUE)
range <- range(tmp.dates) + c(-0.5, 0.5) * diff
}
else if (all(!is.na(suppressWarnings(as.numeric(x)))))
{
range <- calcRangeNumeric(x)
if (tozero)
range <- c(min(0, range[1]), max(0, range[2]))
}
else
range <- calcRangeCategorical(x)
if (!is.null(axis) && axis$autorange == "reversed")
range <- rev(range)
}
range
}
calcRangeNumeric <- function(x, offset = 0.5)
{
tmp <- as.numeric(unique(x))
diff <- if (length(x) == 1) 1
else abs(min(diff(sort(tmp)), na.rm = TRUE))
return(range(tmp) + c(-offset, offset) * diff)
}
calcRangeCategorical <- function(x)
{
tmp <- unique(x)
return(c(-0.5, length(tmp)-0.5))
}
isReversed <- function(axis)
{
if (is.null(axis$range))
return(axis$autorange == "reversed")
return(xor(axis$range[1] > axis$range[2], axis$autorange == "reversed"))
}
#' Construct line of best fit
#'
#' @param x Independent (predictor) data for fitting (this is actually
#' the y-axis in bar charts). May be vector of numeric, dates or factor.
#' @param y Dependent (predicted data). This must be a numeric vector.
#' @param fit.type May be \code{Smooth}, which creates a loess smooth, or
#' any other value will use a \code{Linear} regression to create the line
#' of best fit
#' @param axis.type The axis type of the dependent axis. This is used
#' to provide extra information about how to display the \code{x} variable.
#' @param ignore.last Whether to ignore the last observation in \code{x}
#' and \code{y}.
#' @param warning.prefix Used by small multiples for nice warning messages.
#' @importFrom stats supsmu filter
#' @importFrom mgcv gam
#' @noRd
fitSeries <- function(x, y, fit.type, ignore.last, axis.type, CI.show = FALSE,
fit.window.size = 3, warning.prefix = "")
{
if (!is.numeric(y))
{
warning("Line of best fit cannot handle non-numeric y-values.")
return(list(x = NULL, y = NULL))
}
tmp.is.factor <- axis.type != "numeric"
if (tolower(axis.type) == "category" && !is.factor(x))
x0 <- (1:length(x)) - 1
else if (tmp.is.factor)
x0 <- suppressWarnings(AsNumeric(x, binary = FALSE))
else
x0 <- as.numeric(x)
tmp.dat <- data.frame(xorig = x, x = x0, y = y)
if (ignore.last)
tmp.dat <- tmp.dat[-which.max(tmp.dat$x),]
if (nrow(tmp.dat) < 2)
{
warning(warning.prefix, "Not enough data to constuct line of best fit.")
return(list(x = NULL, y = NULL))
}
ord <- order(tmp.dat$x)
tmp.dat <- tmp.dat[ord,]
if (grepl("(friedman|super|supsmu|moving average)", fit.type, perl = TRUE, ignore.case = TRUE))
{
if (CI.show)
warning("Confidence intervals cannot be computed for trend lines of this type.")
if (!grepl("moving average", fit.type, perl = TRUE, ignore.case = TRUE))
{
ind.na <- which(!is.finite(tmp.dat$x) | !is.finite(tmp.dat$y))
if (length(ind.na) > 0)
tmp.dat <- tmp.dat[-ind.na,]
}
indU <- which(!duplicated(tmp.dat$x))
if (length(indU) < nrow(tmp.dat))
warning(warning.prefix, "Multiple points at the same x-coordinate ignored for estimating line of best fit.\n")
if (grepl("moving average", fit.type, perl = TRUE, ignore.case = TRUE))
{
if (!is.finite(fit.window.size) && fit.window.size <= 0)
stop("Moving average must have a positive window size")
if (length(indU) <= fit.window.size)
{
warning("Trend line could not be shown. The length of the data series ",
"must be larger than the window size (", fit.window.size, ")")
return(list(x = NULL, y = NULL))
}
tmp.gaps <- unique(diff(tmp.dat$x[indU]))
if (any(tmp.gaps > min(tmp.gaps) * 1.2)) # allow some variation for dates
warning("Moving averages do not account for the different intervals between values.")
if (grepl("center|centre", fit.type, perl = TRUE, ignore.case = TRUE))
tmp.avg <- rev(filter(tmp.dat$y[rev(indU)], rep(1/fit.window.size, fit.window.size), sides = 2))
else
tmp.avg <- filter(tmp.dat$y[indU], rep(1/fit.window.size, fit.window.size), sides = 1)
return(list(x = tmp.dat$xorig[indU], y = as.numeric(tmp.avg)))
}
else
{
tmp.fit <- suppressWarnings(try(supsmu(tmp.dat$x[indU], tmp.dat$y[indU]), silent = TRUE))
if (!inherits(tmp.fit, "try-error"))
return(list(x = tmp.dat$xorig[indU], y = tmp.fit$y))
}
}
else if (grepl("(smooth|loess)", fit.type, ignore.case = TRUE) && nrow(tmp.dat) > 7)
tmp.fit <- suppressWarnings(try(loess(y~x, data = tmp.dat), silent = TRUE))
else if (grepl("(cubic|spline|gam)", fit.type, ignore.case = TRUE))
tmp.fit <- suppressWarnings(try(gam(y~s(x, bs = "cr"), data = tmp.dat), silent = TRUE))
else
tmp.fit <- suppressWarnings(try(lm(y~x, data=tmp.dat), silent = TRUE))
if (inherits(tmp.fit, "try-error"))
{
warning(warning.prefix, "Could not fit trend line using ", fit.type, ".")
return(list(x = NULL, y = NULL))
}
x.fit <- if (tmp.is.factor) tmp.dat$x
else seq(from = min(x0, na.rm = TRUE), to = max(x0, na.rm = TRUE), length = 100)
if (!tmp.is.factor && max(x.fit) < max(tmp.dat$x))
x.fit <- c(x.fit, max(tmp.dat$x))
y.fit <- if (inherits(tmp.fit, "gam")) suppressWarnings(try(predict(tmp.fit, data.frame(x = x.fit), se = CI.show, type = "response")))
else suppressWarnings(try(predict(tmp.fit, data.frame(x = x.fit), se = CI.show)))
if (inherits(y.fit, "try-error"))
{
warning("Could not fit trend line to data. Check that you expect to map a single x-value to a single y-value.")
y.fit <- NULL
lb <- NULL
ub <- NULL
}
if (tmp.is.factor)
x.fit <- tmp.dat$xorig
if (CI.show)
{
lb <- as.numeric(y.fit$fit - (1.96 * y.fit$se))
ub <- as.numeric(y.fit$fit + (1.96 * y.fit$se))
return(list(x = x.fit, y = y.fit$fit, lb = lb, ub = ub))
}
return(list(x = x.fit, y = y.fit))
}
# This function deals with both logical or string inputs
setShowLegend <- function(legend.show, num.series = 2)
{
auto.show <- num.series > 1
# Default response is to only show legend if it there is more than 1 series
if (isTRUE(legend.show) || is.na(legend.show) || grepl("Auto", legend.show))
return(auto.show)
if (isTRUE(legend.show == FALSE))
return(FALSE)
# If legend.show is not boolean, check for string inputs
# Note that legend is shown even if there is only 1 series
# For legacy reasons, the boolean inputs do not give the same result.
if (grepl(legend.show, "Show"))
return(TRUE)
if (grepl(legend.show, "Hide"))
return(FALSE)
# If legend.show is unknown, then return default
return(auto.show)
}
setLegend <- function(type, font, ascending, fill.color, fill.opacity, border.color, border.line.width,
x.pos = NULL, y.pos = NULL, reversed = FALSE, orientation = 'Vertical', y2.show = FALSE)
{
if (tolower(substr(orientation, 1, 1)) == "h")
orientation <- "h"
else
orientation <- "v"
if (y2.show)
{
if (is.null(x.pos))
x.pos <- if (orientation == "v") 1.15 else 0.5
if (is.null(y.pos))
y.pos <- if (orientation == "v") 1.0 else -0.3
} else
{
if (is.null(x.pos))
x.pos <- if (orientation == "v") 1.02 else 0.5
if (is.null(y.pos))
y.pos <- if (orientation == "v") 1.0 else -0.2
}
if (is.na(ascending))
ascending <- !(grepl("Stacked", type) && !reversed) || grepl("Stacked Bar", type)
order <- if (!ascending) "reversed" else "normal"
return(list(bgcolor = toRGB(fill.color, alpha=fill.opacity),
bordercolor = border.color,
borderwidth = border.line.width,
orientation = orientation,
font = font,
xanchor = if (x.pos == 0.5) "center" else "left",
yanchor = if (y.pos > 1.0) "bottom" else "auto",
y = max(-2, min(3, y.pos)),
x = max(-2, min(3, x.pos)),
traceorder = order))
}
#' @importFrom flipTime AsDateTime
getAxisType <- function(labels, format)
{
d3.type <- d3FormatType(format)
if (d3.type == "category")
return("category")
if (d3.type == "date")
{
if (inherits(labels, "Date") || inherits(labels, "POSIXt") || inherits(labels, "POSIXct"))
return("date")
ymd <- try(suppressWarnings(AsDateTime(as.character(labels), on.parse.failure = "silent")), silent = TRUE)
if (!inherits(ymd, "try-error") && !any(is.na(ymd)))
return("date")
}
if (d3.type == "numeric")
{
if (!any(is.na(suppressWarnings(as.numeric(gsub(",", "", labels))))))
return("numeric")
}
# Try to find default format based only on labels
if (!any(is.na(suppressWarnings(as.numeric(gsub(",", "", labels))))))
return("numeric")
ymd <- try(suppressWarnings(AsDateTime(labels, on.parse.failure = "silent")), silent = TRUE)
if (!inherits(ymd, "try-error") && all(!is.na(ymd)) && length(ymd) > 1)
return("date")
else
return("category")
}
# This is only used in labeledscatter
convertAxis <- function(values, axis.type)
{
if (axis.type == "date")
return(AsDateTime(values, on.parse.failure = "silent"))
if (axis.type == "category")
{
# Do not use flipTransformations::Factor because we don't want to aggregate by QDate
if (inherits(values, "factor"))
return(values)
return(factor(values, levels = unique(as.character(values))))
}
if (axis.type == "numeric")
return(as.numeric(values))
# not sure what type this is?
return(as.vector(values))
}
d3FormatType <- function(format)
{
if (is.null(format) || is.na(format) || format == "")
return("")
if (format == "Category")
return("category")
if (grepl("%[aAbBcdefHIJmMLpQsSuUVwWxXyYz]", format))
return("date")
else
return("numeric")
}
#' @importFrom flipTime AsDateTime
#' @importFrom verbs Sum
#' @noRd
formatLabels <- function(dat, type, label.wrap, label.wrap.nchar, x.format, y.format)
{
is.bar <- grepl("Bar", type, fixed=T)
if (is.matrix(dat))
{
x.labels <- rownames(dat)
y.labels <- NULL
x.axis.type <- "numeric"
y.axis.type <- "numeric"
if (!is.bar)
x.axis.type <- getAxisType(x.labels, x.format)
else
y.axis.type <- getAxisType(x.labels, x.format)
}
else
{
x.labels <- unique(dat[[1]])
y.labels <- unique(dat[[2]])
x.axis.type <- getAxisType(x.labels, x.format)
y.axis.type <- getAxisType(y.labels, y.format)
}
categorical.axis.type <- if (is.bar) y.axis.type else x.axis.type
if (isTRUE(attr(dat, "sorted.rows")) && categorical.axis.type != "category")
warning("Sorting has been applied to the rows of the input table but the positioning of ",
"elements in a numeric or date axis is not affected by the order in the table. ",
"To use the order of the table rows, set the axis number type to 'Category' in ",
"Chart > CATEGORIES AXIS > Axis number type")
# labels are only processed for independent x-axis (or y-axis in bar charts)
# the other axis is always numeric
labels <- x.labels
axis.type <- if (is.bar) y.axis.type else x.axis.type
if (axis.type == "date")
{
ymd <- AsDateTime(labels, on.parse.failure = "silent")
n.dup <- Sum(duplicated(ymd), remove.missing = FALSE)
if (n.dup > 0)
warning("Date axis has ", n.dup, " duplicated values. There may have been an error parsing dates.")
labels <- ymd
}
else
{
ymd <- NULL
if (is.character(labels))
labels <- autoFormatLongLabels(labels, label.wrap, label.wrap.nchar)
}
return(list(ymd = ymd, labels = labels, labels.on.x = !is.bar,
x.axis.type = x.axis.type, y.axis.type = y.axis.type))
}
getDateAxisRange <- function(label.dates, new.range = NULL)
{
if (length(new.range) == 2)
return(as.character(new.range))
tmp.dates <- as.numeric(label.dates)
diff <- min(abs(diff(sort(unique(tmp.dates)))), na.rm = TRUE)
# Always return date-ranges as characters since there
# seems to be more problems with using milliseconds since plotly v4.8.0
range <- as.character(range(label.dates) + c(-1,1) * ceiling(0.5 * diff))
return(as.character(range))
}
# This function is used to override the default plotly settings for
# a date/time axis. The return value is used to set the 'dtick' parameter.
# It can be one of:
# - time between ticks in units of milliseconds
# - intervals in months, e.g. 'M3' for 3 months, allows for different number of days per month
# - NULL, i.e revert back to plotly defaults
# Where date intervals are reasonably regular we prefer to use plotly defaults
# because it will do try to simplify labels depending on the timescale
# e.g. only show years at the beginning of each year instead of each month
# or hide day of month.
setDateTickDistance <- function(date.labels, num.maxticks)
{
# For a reasonably long series of dates, plotly does reasonably well
# But for a short series, plotly will place ticks on every Sunday,
# which usually does not align with the data points
n <- length(date.labels)
if (n < 2 || n > 10)
return(NULL)
tmp.dist <- as.numeric(difftime(date.labels[n], date.labels[1], units = "secs"))/(n-1)
# We check if the date labels are on the first or each month
# or the first day of each year, because these are likely
# internally generated. They occur when the user does not give
# a fully specified date, e.g. "Jan 2017", or "2019".
use.auto.ticks <- TRUE
if (tmp.dist <= 86400) # time scale is less than a day
use.auto.ticks <- FALSE
else if (tmp.dist <= 0.9 * 31536000) { # on the scale of a year
# Check for monthly intervals which accounts for different number of days per month
seconds.in.day <- 86400
nmonth <- round(tmp.dist/(seconds.in.day * 30))
if (!is.null(num.maxticks) && n > num.maxticks)
nmonth <- (floor(n/num.maxticks) + 1) * nmonth
day.of.month <- as.numeric(format(date.labels, "%d"))
# use auto generated ticks to default to not showing the day of month
if (all(day.of.month == 1))
return (NULL)
if (length(unique(day.of.month)) == 1)
return(paste0("M", nmonth))
# Check for monthly intervals which are fixed relative to the end of the month
offset <- 31 - as.numeric(min(day.of.month))
if (inherits(date.labels, "Date") &&
length(unique(format(date.labels + offset, "%d"))) == 1)
return(paste0("M", nmonth))
if (inherits(date.labels, "POSIXct") &&
length(unique(format(date.labels + (offset * seconds.in.day), "%d"))) == 1)
return(paste0("M", nmonth))
use.auto.ticks <- FALSE
} else # use auto generated tick to default to not showing month or day
use.auto.ticks <- all(as.numeric(format(date.labels, "%j")) == 1)
# If axis range is considerable larger than the intervals between ticks
# use plotly defaults
if (difftime(max(date.labels), min(date.labels), units = "secs") >
(n+1) * tmp.dist)
use.auto.ticks <- TRUE
# Override plotly defaults by specifying tickdistance
if (!use.auto.ticks)
{
if (!is.null(num.maxticks) && n > num.maxticks)
{
tmp.mult <- floor(n/num.maxticks) + 1
tmp.dist <- tmp.dist * tmp.mult
}
tickdistance <- tmp.dist * 1000 # in units of milliseconds
return(tickdistance)
}
return(NULL)
}
setAxis <- function(title, side, axisLabels, titlefont,
linecolor, linewidth, gridwidth, gridcolor,
ticks, tickfont, tickangle, ticklen, tickdistance,
tickformatmanual, tickprefix, ticksuffix, tickshow,
show.zero, zero.line.width, zero.line.color,
hovertext.format.manual, labels = NULL, num.series = 1,
with.bars = FALSE, tickcolor = "transparent", num.maxticks = NULL,
zoom.enable = TRUE)
{
axis.type <- if (side %in% c("bottom", "top")) axisLabels$x.axis.type else axisLabels$y.axis.type
has.line <- !is.null(linewidth) && linewidth > 0
if (!tickshow)
tickfont$size <- 0
if (!is.null(labels) && any(!is.na(labels)) && any(nzchar(labels) > 0) &&
is.null(tickangle) && side %in% c("bottom", "top"))
{
lab.nchar <- max(c(0, nchar(unlist(strsplit(split = "<br>", as.character(labels))))), na.rm = TRUE)
tickangle <- if ((!axis.type %in% c("numeric", "linear", "date")) && lab.nchar > 2 &&
length(labels) * num.series * lab.nchar > 50) 90
else 0
}
autorange <- ticks$autorange
range <- ticks$range
day.len <- 60 * 60 * 24 * 1000
tickmode <- ticks$mode
tick0 <- NULL
tickformat <- checkD3Format(tickformatmanual, axis.type)
hoverformat <- checkD3Format(hovertext.format.manual, axis.type, "Hovertext")
# Categorical axis of a bar chart
if ((!axisLabels$labels.on.x) && side %in% c("left","right"))
{
autorange <- FALSE
if (axis.type == "date")
{
is.autorange <- is.null(ticks$range)
range <- rev(getDateAxisRange(axisLabels$ymd, range))
# Check whether or not to override tick positions
if (with.bars && is.autorange)
{
tmp.dist <- setDateTickDistance(axisLabels$ymd, num.maxticks)
if (!is.null(tmp.dist))
{
tickmode <- "linear"
tick0 <- axisLabels$ymd[1]
tickdistance <- tmp.dist
}
}
}
else if (axis.type == "numeric")
{
# Create a fake axis to specify axis type
if (is.null(range))
range <- calcRangeNumeric(axisLabels$labels)
range <- rev(range)
if (show.zero)
{
range[2] <- min(range[2], 0)
range[1] <- max(range[1], 0)
}
}
else
range <- c(length(axisLabels$labels) - 0.5, -0.5)
if (ticks$autorange != "reversed")
range <- rev(range)
}
else if (axis.type == "date" && length(axisLabels$ymd) >= 2)
{
is.autorange <- is.null(ticks$range)
autorange <- FALSE
rev <- length(range) == 2 && range[2] < range[1]
range <- getDateAxisRange(axisLabels$ymd, range)
if (ticks$autorange == "reversed" || rev)
range <- rev(range)
# Check whether or not to override tick positions
if (is.autorange && length(axisLabels$labels) <= 10)
{
tmp.dist <- setDateTickDistance(axisLabels$ymd, num.maxticks)
if (!is.null(tmp.dist))
{
tickmode <- "linear"
tick0 <- axisLabels$ymd[1]
tickdistance <- tmp.dist
}
}
}
else if (axis.type == "category" && !is.null(axisLabels$ymd))
{
if (!is.null(range))
{
rev <- range[1] > range[2]
range <- calcRangeCategorical(as.character(axisLabels$ymd))
if (rev)
range <- rev(range)
}
}
rangemode <- "normal"
if (axis.type == "numeric" && show.zero)
rangemode <- "tozero"
if (zero.line.width == 0)
{
if (gridwidth == 0)
zero.line.color <- "transparent"
else
zero.line.color <- gridcolor # if no zero line, draw a normal grid line at zero
} else
zero.line.color <- "transparent" # hide plotly zero line so we can draw one on top of the traces
# Specify max number of ticks
nticks <- NULL
independ.axis <- side %in% c("top", "bottom") == axisLabels$labels.on.x
if (axis.type != "category" && tickmode == "auto" && independ.axis &&
!(length(axisLabels$labels) == 1 && is.numeric(axisLabels$labels)))
nticks <- min(length(axisLabels$labels) + 1, 11)
if (any(nzchar(title)))
title <- list(text = title, font = titlefont)
else
title <- NULL
if (!is.null(num.maxticks) && tickmode == "auto" && axis.type != "category")
{
# plotly only uses nticks when tickmode is auto
if (is.null(nticks) || nticks > num.maxticks)
nticks <- num.maxticks
}
return (list(title = title, fixedrange = !zoom.enable,
side = side, type = axis.type,
tickfont = tickfont,
showline = has.line, linecolor = linecolor,
linewidth = if (!has.line) NULL else linewidth,
showgrid = gridwidth > 0, gridwidth = gridwidth,
gridcolor = gridcolor, tickmode = tickmode, nticks = nticks,
tickvals = ticks$tickvals, ticktext = ticks$ticktext,
ticklabelposition = "outside", tickangle = tickangle,
ticklen = ticklen, tickfont = tickfont,
tickcolor = tickcolor,
dtick = tickdistance, tickformat = tickformat, tick0 = tick0,
tickprefix = tickprefix, ticksuffix = ticksuffix,
hoverformat = hoverformat, layer = "below traces",
autorange = autorange, range = range, rangemode = rangemode,
zeroline = show.zero, zerolinewidth = gridwidth,
zerolinecolor = zero.line.color,
showexponent="all", showtickprefix=TRUE, showticksuffix=TRUE,
showticklabels=tickshow))
}
zerolines <- function(x.zero, x.zero.line.width, x.zero.line.color, y.zero, y.zero.line.width, y.zero.line.color)
{
result <- NULL
if (isTRUE(x.zero))
result <- list(type = "line", layer = "above",
x0 = 0, x1 = 0, xref = "x", y0 = 0, y1 = 1, yref = "paper",
line = list(color = x.zero.line.color, width = x.zero.line.width))
if (isTRUE(y.zero))
{
y.zeroline <- list(type = "line", layer = "above",
y0 = 0, y1 = 0, yref = "y", x0 = 0, x1 = 1, xref = "paper",
line = list(color = y.zero.line.color, width = y.zero.line.width))
if (is.null(result))
return (y.zeroline)
else
result <- list(result, y.zeroline)
}
return (result)
}
fontAspectRatio <- function(font)
{
if (length(font) == 0)
return (0.54)
font <- as.character(font)
font.asp <- switch(tolower(font),
'arial'= 0.54,
'arial black' = 0.63,
'century gothic' = 0.61,
'courier new' = 0.63,
'impact' = 0.48,
'open sans' = 0.45,
'times new roman' = 0.45,
'tahoma' = 0.52,
'trebuchet' = 0.48,
'verdana' = 0.63,
0.54)
font.asp
}
#' @importFrom verbs Sum
setMarginsForAxis <- function(margins, labels, axis)
{
if (!is.character(labels) && !is.null(labels$labels))
labels <- labels$labels
lab.len <- 0
lab.nline <- 0
lab.nchar <- 1
lab.nchar <- max(c(0, nchar(unlist(strsplit(split="<br>", as.character(labels))))), na.rm = TRUE)
font.asp <- fontAspectRatio(axis$tickfont$family)
lab.len <- font.asp * axis$tickfont$size * lab.nchar * 1.25
lab.nline <- if (is.character(labels) && any(nzchar(labels))) max(0, sapply(gregexpr("<br>", labels),
function(x) Sum(x > -1, remove.missing = FALSE)), na.rm = TRUE)
else 0
new.margin <- 0
if (lab.len > 2 || (!is.null(lab.nline) && lab.nline > 0))
new.margin <- lab.len
title.nline <- 0
if (any(nzchar(axis$title)) && !isTRUE(axis$title == " "))
title.nline <- Sum(gregexpr("<br>", axis$title)[[1]] > -1, remove.missing = FALSE) + 1
title.pad <- max(0, axis$title$font$size) * title.nline * 1.25
if (axis$side == "right")
margins$r <- max(margins$r, new.margin + title.pad)
else if (axis$side == "left")
margins$l <- max(margins$l, new.margin + title.pad)
else if (axis$side == "bottom")
{
# tickangle is changed in function setAxis
lab.nchar <- max(c(0,nchar(unlist(strsplit(split = "<br>", as.character(labels))))), na.rm = TRUE)
if (is.null(axis$tickangle))
axis$tickangle <- 0
if (axis$tickangle != 0)
margins$b <- margins$b + 0.65 * new.margin + title.pad
else
margins$b <- margins$b + 1.25 * axis$tickfont$size*(floor(lab.nline)+1) + title.pad
}
return(margins)
}
#' @importFrom verbs Sum
setMarginsForText <- function(margins, title, subtitle, footer,
title.font.size, subtitle.font.size, footer.font.size)
{
title.nline <- 0
if (any(nzchar(title)))
{
title.nline <- Sum(gregexpr("<br>", title)[[1]] > -1, remove.missing = FALSE) + 1
margins$t <- margins$t + (title.font.size * title.nline * 1.25)
}
if (any(nzchar(subtitle)))
{
# We leave twice the space for subtitles, because titles are always
# positioned halfway down the top margin
subtitle.nline <- Sum(gregexpr("<br>", subtitle)[[1]] > -1, remove.missing = FALSE) + 1.5
margins$t <- margins$t + (subtitle.font.size * subtitle.nline) * 0.8 * 2
}
if (any(nzchar(footer)) && !isTRUE(footer == " "))
{
footer.nline <- Sum(gregexpr("<br>", footer)[[1]] > -1) + 4
margins$b <- margins$b + (footer.font.size * footer.nline * 1.25)
}
margins
}
setMarginsForLegend <- function(margins, showlegend, legend, text,
type = "", right.axis = FALSE)
{
if (showlegend && legend$x > 0.99)
{
# Needed to preserve subtitle alignment
if (is.factor(text))
text <- levels(text)
len <- max(c(0, nchar(unlist(strsplit(split = "<br>", text)))), na.rm = TRUE)
margins$r <- min(300, 70 + (legend$font$size * max(0, len) * 0.7))
} else if (type != "radar" && !right.axis)
margins$r <- 20
margins
}
setCustomMargins <- function(margins, margin.top, margin.bottom, margin.left,
margin.right, margin.inner.pad)
{
if (!is.null(margin.top))
margins$t <- margin.top
if (!is.null(margin.bottom))
margins$b <- margin.bottom
if (!is.null(margin.left))
margins$l <- margin.left
if (!is.null(margin.right))
margins$r <- margin.right
if (!is.null(margin.inner.pad))
margins$pad <- margin.inner.pad
margins
}
# setTitle, setSubtitle and setFooter return a list which can be used
# in plotly to create an annotation. The allowed names of the
# components in the list are described in
# https://plotly.com/r/reference/layout/annotations/
setTitle <- function(title, title.font, margins, x.align = "center")
{
if (!any(nzchar(title)))
return(NULL)
x.align <- tolower(x.align)
xpos <- switch(x.align, center = 0.5, left = 0, right = 1)
return(list(text = title, font = title.font, align = x.align,
xref = "paper", x = xpos, xanchor = x.align,
yref = "paper", y = 1.0, yanchor = "middle",
yshift = margins$t * 0.5, showarrow = FALSE))
}
setSubtitle <- function(subtitle, subtitle.font, margins, x.align = "center")
{
if (!any(nzchar(subtitle)))
return(NULL)
x.align <- tolower(x.align)
xpos <- switch(x.align, center = 0.5, left = 0, right = 1)
return(list(text = subtitle, font = subtitle.font,
xref = "paper", x = xpos, xanchor = x.align,
yref = "paper", y = 1.0, yanchor = "bottom", showarrow = FALSE))
}
setFooter <- function(footer, footer.font, margins, x.align = "center")
{
if (!any(nzchar(footer)))
return(NULL)
x.align <- tolower(x.align)
xpos <- switch(x.align, center = 0.5, left = 0, right = 1)
footer.nline <- Sum(gregexpr("<br>", footer)[[1]] > -1, remove.missing = FALSE) + 1
footer.npad <- max(0, ceiling(margins$b/footer.font$size/1.25) - footer.nline - 2)
footer <- paste0(" ", paste(rep("<br>", footer.npad), collapse = ""), footer)
return(list(text = footer, font = footer.font, align = x.align,
xref = "paper", x = xpos, yref = "paper", y = 0.0,
yanchor = "top", xanchor = x.align, showarrow = FALSE))
}
# This differs from as.numeric in that it returns NULL
# instead of NA if there is no valid output
# Also so basic substitution such as removing commas
charToNumeric <- function(x)
{
if (!is.character(x))
return(x)
if (length(x) == 0 || is.na(x))
return(NULL)
if (nchar(x) == 0)
return(NULL)
x.orig <- x
x <- gsub(" ", "", x)
x <- gsub(",", "", x) # e.g. '5,000'
xnum <- suppressWarnings(as.numeric(x))
xnum <- xnum[!is.na(xnum)]
if (length(xnum) != 1)
{
warning("Value '", x.orig, "' is not numeric.")
return(NULL)
}
return(xnum)
}
# Modified warning message
charToDate <- function(x)
{
x <- as.character(x)
if (length(x) == 0 || is.na(x))
return(NULL)
if (nchar(x) == 0)
return(NULL)
res <- AsDate(x, on.parse.failure = FALSE)
if (any(is.na(res)))
warning("Value '", x, "' could not be parsed as a date.")
return(res)
}
charToDateTime <- function(x)
{
x <- as.character(x)
res <- AsDateTime(x, on.parse.failure = FALSE)
if (any(is.na(res)))
warning("Value '", x, "' could not be parsed as a date.")
return(res)
}
isBlank <- function(x)
{
if (is.null(x))
return(TRUE)
if (is.na(x))
return(TRUE)
if (x == "")
return(TRUE)
return(FALSE)
}
# This is only applied to the values axis.
# It can handle categorical and date axes types but only for the values axis
# (date categorical axis range is set using getDateAxisRange in setAxis)
setValRange <- function(min, max, values, show.zero = FALSE, use.defaults = TRUE, is.bar = FALSE)
{
if (is.null(min) || is.na(min) || min == "")
min <- NULL
if (is.null(max) || is.na(max) || max == "")
max <- NULL
# If no range is specified, then use defaults
if (use.defaults && is.null(min) && is.null(max))
return(list(min = NULL, max = NULL))
if (is.list(values) && !is.null(values$labels.on.x))
{
axis.type <- if (values$labels.on.x) values$x.axis.type else values$y.axis.type
if (axis.type == "date")
values <- values$ymd
else if (axis.type %in% c("numeric", "linear"))
values <- suppressWarnings(as.numeric(values$labels))
else
values <- 0:(length(values$labels)-1)
}
if (length(values) == 1 && is.bar && is.null(min) && is.null(max))
return(list(min = NULL, max = NULL))
if (is.factor(values) || is.character(values))
values <- as.numeric(as.factor(values)) - 1
if (inherits(values, "POSIXct"))
{
if (!is.null(min) && !is.na(min))
min <- charToDateTime(min)
if (!is.null(max) && !is.na(max))
max <- charToDateTime(max)
} else if (inherits(values, "Date") || inherits(values, "POSIXct"))
{
if (!is.null(min) && !is.na(min))
min <- charToDate(min)
if (!is.null(max) && !is.na(max))
max <- charToDate(max)
} else
{
min <- charToNumeric(min)
max <- charToNumeric(max)
}
if (length(min) == 0 || is.na(min))
min <- min(unlist(values), if (show.zero) 0 else NULL, na.rm = TRUE)
if (length(max) == 0 || is.na(max))
max <- max(unlist(values), na.rm = TRUE)
if (is.bar && length(values) > 1)
{
diff <- if (length(values) > 1) min(abs(diff(values)), na.rm = TRUE)/2
else 0.5
min <- min - diff
max <- max + diff
}
return(list(min = min, max = max))
}
setTicks <- function(minimum, maximum, distance, reversed = FALSE,
data = NULL, labels = NULL, type="scatter", label.font.size = 10, is.bar = FALSE)
{
#if (is.null(minimum) != is.null(maximum))
# warning("To specify the range of an axis, you must specify both the minimum and maximum values.")
if ((is.null(minimum) || is.null(maximum)) && !is.null(distance))
stop("If specifying the distance between ticks on an axis,",
"you must also specify the minimum and maximum values.")
# starting values
mode <- "auto"
range <- NULL
tickvals <- NULL
ticktext <- NULL
autorange <- TRUE
if (reversed)
autorange <- "reversed"
if (!is.null(data))
{
is.bar <- grepl("Bar", type) && !grepl("Stacked", type)
if (is.null(minimum))
minimum <- min(0, min(data, na.rm = TRUE))
if (is.null(maximum))
maximum <- max(data, na.rm = TRUE)
# Add horizontal space for data labels in bar charts
pad <- 0
lab.len <- 1
if (!is.null(labels) && is.bar)
{
lab.len <- max(nchar(as.character(unlist(labels))))
pad <- (maximum - minimum) * (lab.len+2) * label.font.size / 200
}
if (!is.bar || min(data, na.rm = TRUE) < 0)
minimum <- minimum - pad
maximum <- maximum + pad
}
if (!is.null(minimum) && !is.null(maximum))
{
autorange <- FALSE
range <- c(minimum, maximum)
if (reversed)
range <- rev(range)
}
if (!is.null(distance) && is.numeric(minimum) && is.numeric(maximum))
{
# error msg if axis is not numeric
autorange <- FALSE
mode <- "array"
if (is.bar && distance == round(distance))
{
minimum <- ceiling(minimum)
maximum <- floor(maximum)
}
tickvals <- seq(minimum, maximum, by=distance)
}
return (list(autorange=autorange, mode=mode, range=range,
tickvals=tickvals, ticktext=ticktext))
}
## Takes a matrix, and returns a matrix of either a cumulative sum,
## or a cumulative sum of percentages, over each row.
cum.data <- function(x, output = "cumulative.percentage")
{
result <- if (output == "cumulative.sum")
apply(x, 1, function(z) cumsum(z))
else if (output == "cumulative.percentage")
apply(x, 1, function(z) cumsum(prop.table(z)))
else if (output == "column.percentage")
apply(x, 1, function(z) prop.table(z))
t(result)
}
# Takes a single string and puts <br> in place of the closest space
# preceding the word at the max.nchar position.
# E.g. if n = 20 then count 20 characters. The space preceding character 20
# is replaced by "<br>".
lineBreakEveryN <- function(x, max.nchar = 21, remove.empty = TRUE)
{
if (max.nchar <= 0)
stop("Wrap line length cannot be smaller than 1")
patt <- if (remove.empty) "\\s+"
else " "
tot.nchar <- nchar(x)
next.wb <- regexpr(patt, x, perl = TRUE)
if (next.wb == -1 || is.na(next.wb))
return(x)
x <- TrimWhitespace(x)
final <- ""
cur.nchar <- 0
while (next.wb != -1)
{
# Find position of next wordbreak or html tag
next.wb <- regexpr(patt, x, perl = TRUE)
next.html <- regexpr("<.*?>", x, perl = TRUE)
line.is.empty <- cur.nchar == 0
if (next.wb == -1)
break
# Decide whether to place a line break before the
# next html tag or word (whichever comes first)
if (next.html != -1 && next.html < next.wb)
{
tmp.text <- substr(x, 1, next.html + attr(next.html, "match.length") - 1)
if (tmp.text == "<br>")
{
final <- paste0(final, tmp.text)
cur.nchar <- 0
} else if (next.html == 1)
{
final <- paste0(final, tmp.text)
# cur.nchar and unchanged
} else if (!line.is.empty && cur.nchar + next.html - line.is.empty > max.nchar)
{
final <- paste0(final, "<br>", tmp.text)
cur.nchar <- next.html - 1
} else
{
final <- paste(final, tmp.text, sep = if (line.is.empty) "" else " ")
cur.nchar <- cur.nchar + next.html - line.is.empty
}
x <- substr(x, next.html + attr(next.html, "match.length"), tot.nchar)
} else
{
tmp.text <- substr(x, 1, next.wb - 1)
if (next.wb == 1)
{
# final and cur.nchar unchanged
} else if (!line.is.empty && cur.nchar + next.wb > max.nchar)
{
final <- paste0(final, "<br>", tmp.text)
cur.nchar <- next.wb - 1
} else
{
final <- paste(final, tmp.text, sep = if (line.is.empty) "" else " ")
cur.nchar <- cur.nchar + next.wb - line.is.empty
}
x <- substr(x, next.wb + attr(next.wb, "match.length"), tot.nchar)
}
}
if (nchar(final) == 0)
final <- TrimWhitespace(x)
else if (nchar(x) > 0)
final <- paste(final, x, sep = if (cur.nchar + nchar(x) + 1 > max.nchar) "<br>" else " ")
return(final)
}
#' Format long labels for html by truncating and wrapping
#'
#' @param x Character; the text to format.
#' @param wordwrap Logical; whether line breaks ('<br>') should be inserted.
#' @param n Integer; the maximum number of characters before a line breaks is added. The break is added at the nearest word boundary.
#' @param truncate Logical; whether long labels should be truncated and appended with '...' instead.
#' @param remove.empty Logical; whether to remove zero-length strings
#' @export
autoFormatLongLabels <- function(x, wordwrap = FALSE, n = 21, truncate = FALSE, remove.empty = TRUE)
{
if (truncate)
warning("autoFormatLongLabels: truncate not longer does anything.")
if (is.null(x))
return("")
if (!is.character(x))
x <- as.character(x)
# Check for zero-length strings which are ignored by plotly
if (length(x) > 1)
{
ind <- which(sapply(x, nchar) == 0)
if (length(ind) > 0)
x[ind] <- " "
}
output.text <- x
if (wordwrap && length(output.text) > 0)
output.text <- sapply(output.text, function(x) lineBreakEveryN(x, n, remove.empty = remove.empty))
if (length(output.text) == 0 || all(is.na(output.text)))
output.text <- ""
attributes(output.text) <- NULL
output.text
}
stripClassAndCallFromXtabs <- function(chart.matrix)
{
if (inherits(chart.matrix, "xtabs") || inherits(chart.matrix, "table"))
{
attr(chart.matrix, "class") <- NULL
attr(chart.matrix, "call") <- NULL
return(chart.matrix)
}
else
return(chart.matrix)
}
decimalsToDisplay <- function(x)
{
mx <- max(x, na.rm = TRUE)
mn <- min(x, na.rm = TRUE)
rng <- max(c(mx - mn, abs(mx), abs(mn)))
if (!is.na(rng) && rng > 0)
max(-floor(log10(rng)) + 1, 0)
else
NULL
}
#' Force evaluation of variables in an environment
#'
#' Used by some plotting functions before calling Distribution
#' important for unit testing with testthat.
#' Also evaluates variables that have been assigned
#' another variable in the signature (relevant if
#' try eval(cl, parent.frame()) )
#' @noRd
#' @param x Component of a \code{\link{call}}
#' @param env Environment to evaluate \code{x} in
#' @return \code{x} or if it has class \code{"name"}
#' or \code{"call"}, its value when evaluated in \code{env}.
evalc <- function(x, env)
{
if (inherits(x, c("name", "call")))
return(eval(x, env))
x
}
#' Extract the number of decimal places from a d3 format string.
#'
#' All chart functions should accept d3 formats. This is used by functions
#' that do not handle d3 to find the number of decimal places used to
#' format labels and hovertext.
#' #' @noRd
#' @param format d3 formatting string
#' @param default The number of decimal places if \code{format} is
#' not provided (usually signifying automatic formatting).
#' @importFrom verbs SumEmptyHandling
#' @return integer
decimalsFromD3 <- function(format, default = 0)
{
if (length(format) == 0 || format == "")
return(default)
# If no matches, the result will be a length 0 numeric value
return(SumEmptyHandling(as.numeric(regmatches(format, regexpr("\\d+", format))), remove.missing = FALSE))
}
#' Whether to format as percentages based on a d3 format string.
#'
#' All chart functions should accept d3 formats. This is used by functions
#' that do not handle d3 to determine whether to format labels and hovertext as percentages.
#' #' @noRd
#' @param format d3 formatting string
#' @return logical
percentFromD3 <- function(format)
{
return(substr(format, nchar(format), nchar(format)) == "%")
}
#' Output data in D3-formatting
#'
#' Returns a strings according to the d3 format specified.
#' @noRd
#' @param x Input data (may be a vector) to format
#' @param format D3 formatting string. Accepts percentages, numeric and scientific notation
#' @param prefix Optional string to prepend to output
#' @param suffix Optional string to append to output
#' @param decimals Default number of decimals shown; used if not specified in \code{format}
formatByD3 <- function(x, format, prefix = "", suffix = "", percent = FALSE, decimals = 2)
{
n <- length(x)
is.vectorized <- FALSE
if (n > 1 && length(format) > 1)
{
is.vectorized <- TRUE
format <- vectorize(format, n)
prefix <- vectorize(prefix, n)
suffix <- vectorize(suffix, n)
return(sapply(1:n, function(i)
formatByD3(x[i], format[i], prefix[i], suffix[i], percent = percent, decimals = decimals)))
}
x.str <- as.character(x)
if (format == "Category")
return(x.str)
if (is.numeric(x))
{
use.comma <- commaFromD3(format) || format == ""
big.mark <- if (use.comma) "," else ""
tmp.fmt <- gsub("[^deEfgGs]", "", format)
tmp.fmt <- gsub("s", "g", tmp.fmt) # switch d3 SI-prefix format to scientific
num.decimals <- decimalsFromD3(format, decimals)
if (percentFromD3(format) || percent)
{
num.decimals <- decimalsFromD3(format, 0)
x.str <- paste0(formatC(round_half_up(x*100, num.decimals),
format = "f", digits = num.decimals, big.mark = big.mark), "%")
}
else if (!any(nzchar(tmp.fmt)) || tmp.fmt == "f")
x.str <- FormatAsReal(x, decimals = num.decimals, comma.for.thousands = use.comma)
else
x.str <- formatC(x, format = tmp.fmt, digits = num.decimals, big.mark = big.mark)
}
if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXt"))
x.str <- format(x, format)
x.str <- paste0(prefix, x.str, suffix)
x.missing <- !is.finite(x)
if (is.vectorized && any(x.missing))
x.str[x.missing] <- ""
return(x.str)
}
#' Whether to format numbers with comma separation of thousands based on a d3 format string.
#'
#' All chart functions should accept d3 formats. This is used by functions
#' that do not handle d3 to determine how to format labels and hovertext.
#' #' @noRd
#' @param format d3 formatting string
#' @return logical
commaFromD3 <- function(format)
{
return(grepl(",", format, fixed = TRUE))
}
# Gives a warning if the axis.type is incompatible
# Will also specify a numeric format if none is supplied
# convert is only used by LabeledScatter
checkD3Format <- function(format, axis.type, warning.type = "Axis label", convert = FALSE)
{
# This is to avoid LabeledScatter's problem with date formatting
if (convert && axis.type == "date" && !any(nzchar(format)))
return("%b %d %Y")
if (!any(nzchar(format)))
return("")
if (substr(format, nchar(format), nchar(format)) %in% c("", 0:9)) # automatic formatting
{
if (axis.type == "numeric")
return(paste0(format, "f"))
else
return(format)
}
mismatch <- FALSE
if (d3FormatType(format) != axis.type)
{
warning(warning.type, " format of type '", d3FormatType(format),
"' incompatible with axis type '", axis.type, "'")
mismatch <- TRUE
}
if (format == "%")
return ("0%")
if (convert && axis.type == "date" && d3FormatType(format) != axis.type)
return("%b %d %Y")
if (mismatch)
return ("")
if (convert)
format <- sub("^~", "", format)
return(format)
}
notAutoRange <- function(axis)
{
return(!isTRUE(axis$autorange) && length(axis$range) > 0 &&
all(!is.na(axis$range)) && min(abs(axis$range)) > 0)
}
getSign <- function(values, axis)
{
res <- sign(values)
if (any(is.na(res)))
res[which(is.na(res))] <- 0
if (length(axis$range) >= 2 && isTRUE(axis$range[2] < axis$range[1]))
res <- -res
else if (axis$autorange == "reversed")
res <- -res
return(res)
}
#' use black or white for good contrast against colors
#'
#' @param colors vector of colors which will be the background color of the
#' @importFrom grDevices col2rgb rgb2hsv
autoFontColor <- function (colors)
{
tmp.rgb <- col2rgb(colors)
tmp.lum <- apply(tmp.rgb, 2, function(x) return(0.299*x[1] + 0.587*x[2] + 0.114*x[3]))
return(ifelse(tmp.lum > 126, "#2C2C2C", "#FFFFFF"))
}
# By default vectorize will convert x into a vector of length n
# However, if nrow is specified, it will convert to a matrix of nrow x n columns
vectorize <- function(x, n, nrow = NULL, split = ",")
{
input.is.matrix <- length(dim(x)) >= 2
if (!is.null(nrow) && is.finite(nrow))
n <- n * nrow
if (is.logical(x))
res <- suppressWarnings(rep(TRUE, n) & x)
else if (is.numeric(x))
res <- suppressWarnings(rep(0, n) + x)
else
{
if (!is.null(split))
x <- TextAsVector(x, split = split)
res <- suppressWarnings(paste0(x, rep("", n)))
}
if (!is.null(nrow))
res <- matrix(res, nrow = nrow, byrow = !input.is.matrix)
return(res)
}
getColumn <- function(x, i)
{
res <- x
if (length(dim(x)) == 2)
res <- x[,i,drop = FALSE]
if (length(dim(x)) == 3)
res <- x[,i, , drop = FALSE]
if (!is.null(attr(x, "statistic", exact = TRUE)))
attr(res, "statistic") <- attr(x, "statistic")
return(res)
}
readLineThickness <- function(line.thickness, n)
{
if (is.character(line.thickness))
{
tmp.txt <- TextAsVector(line.thickness)
line.thickness <- suppressWarnings(as.numeric(tmp.txt))
na.ind <- which(is.na(line.thickness))
if (length(na.ind) == 1)
warning("Non-numeric line thickness value '", tmp.txt[na.ind], "' was ignored.")
if (length(na.ind) > 1)
warning("Non-numeric line thickness values '",
paste(tmp.txt[na.ind], collapse = "', '"), "' were ignored.")
}
line.thickness <- suppressWarnings(line.thickness * rep(1, n)) # suppress warnings about recyling
return(line.thickness)
}
# Returns true if the d3 format corresponds to the output
# of PrepareNumbers when the user has set Number Type to "Automatic"
isAutoFormat <- function(x)
{
if (isTRUE(nchar(x) == 0))
return(TRUE)
if (isTRUE(x == ""))
return(TRUE)
if (isTRUE(grepl("\\d$", x)))
return(TRUE)
return(FALSE)
}
isPercentData <- function(data)
{
stat <- attr(data, "statistic", exact = TRUE)
if (isTRUE(grepl("%", stat)))
return(TRUE)
ndim <- length(dim(data))
if (is.null(stat) && !is.null(dimnames(data)))
{
stat <- dimnames(data)[[ndim]][1]
if (ndim >= 3 || all(c("questions", "name") %in% names(attributes(data))))
return(isTRUE(grepl("%", stat)))
}
return(FALSE)
}
# y.tick.format, y.hovertext.format, y2.tick.format, y2.hovertext.format
# data.label.format
checkSuffixForExtraPercent <- function(suffix, format)
{
new.suffix <- suffix
for (i in seq_along(suffix))
{
if (isTRUE(grepl("%", format[i])) && isTRUE(grepl("%", suffix[i])))
new.suffix[i] <- sub("%", "", suffix[i])
}
if (any(new.suffix != suffix))
warning("A percentage sign is automatically added to percent data. ",
"The first '%' in the suffix will be ignored.")
return(new.suffix)
}
validNonNegativeInteger <- function(x)
is.integer(x) && !is.na(x) && x > 0
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.