#' Stacked Column with annotations
#'
#' Stacked Column charts with annotations showing statistical
#' significance of z-Statistics or Column Comparisons
#'
#' @inherit Column
#' @param x Input data may be a matrix or a vector, containing the height of the columns
#' to be plotted, with the name/rownames used as the column names of the chart. Numeric and date labels
#' will be parsed automatically.
#' @param type One of "Column", "Stacked Column" or "100\% Stacked Column"
#' @param font.unit One of "px" of "pt". By default all font sizes are
#' specified in terms of pixels ("px"). But changing this to "pt" will
#' mean that the font sizes will be in terms points ("pt"), which will
#' be consistent with font sizes in text boxes.
#' @param num.categories.below.axis Number of categories shown below
#' x-axis pointing downwards.
#' @param transpose Swaps the rows and columns of \code{x}. The rows
#' and columns of the additional statistics used to create annotations
#' are also respected. Note that PrepareData is not used before the function.
#' @param row.names.to.remove Names of rows that are not shown in the chart.
#' @param column.names.to.remove Names of columns that are not shown in the chart.
#' @param reverse.series.order Reverse the order in which the data series are shown
#' (i.e. the order of the columns in \code{x}).
#' @param annot.footer.show Append a description explaining annotations in chart footer.
#' @param annot.arrow.size Size of the arrows in pixels.
#' @param annot.arrow.offset Horizontal offset (towards the right) of
#' the arrows from the bars. If not specified, then it will be
#' determined from \code{bar.gap}.
#' @param annot.legend.sep The string used between different entries describing
#' the annotation symbols in the legend. By default it is a space as it works
#' with line-wrap etc. But "<br>" can also be a good option for readibility.
#' @param annot.arrow.symbols A vector of three characters (or html symbols)
#' used to show arrows. They are (in order):
#' 1. Up arrow for z-Statistics and upper-case Column Comparisons
#' 2. Down arrow for z-Statistics
#' 3. Up arrow for lower-case Column Comparisons
#' @param annot.arrow.colors A vector of colors for the arrows.
#' For column comparisons, the number of colors should equal the number of columns.
#' For z-Statistic, the colors are assigned to 'down' and 'up' arrows.
#' @param annot.sig.level Significance level above which arrows are shown
#' next to the columns.
#' @param annot.differences.show Logical; whether to show the difference
#' statistics if they are included in the input table.
#' @param annot.differences.decimals Number of decimals shown in the
#' difference annotations.
#' @param append.annot.differences.to.datalabel Logical; Show difference statistics
#' appended to the data labels (inside the bars).
#' @param annot.differences.prefix Option text to prepend to annot.differences.
#' @param annot.differences.suffix Option text to append to annot.differences.
#' @param annot.differences.sign.show Logical; whether to show the sign
#' of the difference.
#' @param annot.differences.offset Horizontal offset (towards the right)
#' of the difference annotation from the bars. If not specified, then
#' it will be determined from \code{bar.gap}.
#' @param annot.differences.font.family Font family of the
#' differences annotations
#' @param annot.differences.font.color Font color of the
#' differences annotations
#' @param annot.differences.font.size Font size of the
#' differences annotations
#' @param annot.hide.small.bar Hide annotations (arrow and differences)
#' when the bar is smaller than the proportion of total range
#' (the proportion as specified by \code{data.label.threshold}.
#' @param column.totals.above.show Show data labels containing the total of
#' the categories above the x-axis.
#' @param column.totals.above.font.family Font family of \code{column.totals.above}.
#' @param column.totals.above.font.color Font color of \code{column.totals.above}.
#' @param column.totals.above.font.size Font size of \code{column.totals.above}.
#' @param column.totals.below.show Show data labels containing the total of
#' the categories below the x-axis.
#' @param column.totals.below.font.family Font family of \code{column.totals.below}.
#' @param column.totals.below.font.color Font color of \code{column.totals.below}.
#' @param column.totals.below.font.size Font size of \code{column.totals.below}.
#' @param grid.show Logical; whether to show grid lines.
#' @param opacity Opacity of bars as an alpha value (0 to 1).
#' @param colors Character; a vector containing one or more colors specified
#' as hex codes.
#' @param background.fill.color Background color in character format
#' (e.g. "black") or a hex code.
#' @param background.fill.opacity Background opacity as an alpha value (0 to 1).
#' @param charting.area.fill.color Charting area background color as
#' a named color in character format (e.g. "black") or a hex code.
#' @param charting.area.fill.opacity Charting area background opacity
#' as an alpha value (0 to 1).
#' @importFrom grDevices rgb
#' @importFrom flipChartBasics ChartColors
#' @importFrom flipTables AsTidyTabularData RemoveRowsAndOrColumns ConvertQTableToArray
#' @importFrom plotly plot_ly config toRGB add_trace add_text layout hide_colorbar
#' @importFrom stats qnorm
#' @importFrom verbs SumEmptyHandling
#' @export
StackedColumnWithStatisticalSignificance <- function(x,
num.categories.below.axis = 0,
transpose = FALSE,
row.names.to.remove = "NET, SUM, Total",
column.names.to.remove = "NET, SUM, Total",
reverse.series.order = FALSE,
colors = ChartColors(max(1, NCOL(x), na.rm = TRUE)),
opacity = NULL,
type = "Stacked",
global.font.family = "Arial",
global.font.color = rgb(44, 44, 44, maxColorValue = 255),
font.unit = "px",
annot.footer.show = TRUE,
annot.arrow.size = 15,
annot.arrow.colors = ChartColors(9, "Strong colors"),
annot.arrow.offset = NULL,
annot.arrow.symbols = c("↑", "↓", "⇡"),
annot.sig.level = 0.05,
annot.legend.sep = " · ",
append.annot.differences.to.datalabel = FALSE,
annot.differences.show = TRUE,
annot.differences.decimals = 0,
annot.differences.prefix = "",
annot.differences.suffix = "",
annot.differences.sign.show = TRUE,
annot.differences.font.family = global.font.family,
annot.differences.font.color = global.font.color,
annot.differences.font.size = 10,
annot.differences.offset = NULL,
annot.hide.small.bar = FALSE,
column.totals.above.show = FALSE,
column.totals.above.font.family = global.font.family,
column.totals.above.font.color = global.font.color,
column.totals.above.font.size = 10,
column.totals.below.show = FALSE,
column.totals.below.font.family = global.font.family,
column.totals.below.font.color = global.font.color,
column.totals.below.font.size = 10,
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.wrap = TRUE,
footer.wrap.nchar = 150,
footer.align = "center",
background.fill.color = "transparent",
background.fill.opacity = 1,
charting.area.fill.color = background.fill.color,
charting.area.fill.opacity = 0,
legend.show = NA,
legend.orientation = 'Vertical',
legend.wrap = TRUE,
legend.wrap.nchar = 30,
legend.position.x = NULL,
legend.position.y = NULL,
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.ascending = NA,
hovertext.font.family = global.font.family,
hovertext.font.size = 11,
margin.top = NULL,
margin.bottom = NULL,
margin.left = NULL,
margin.right = NULL,
margin.inner.pad = NULL,
margin.autoexpand = TRUE,
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.zero = TRUE,
y.zero.line.width = 3,
y.zero.line.color = rgb(0, 0, 0, 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.suffix = "",
y.tick.prefix = "",
y.tick.format = "",
y.hovertext.format = y.tick.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.marks = "",
x.tick.mark.length = 3,
x.tick.mark.color = "transparent",
x.bounds.minimum = NULL,
x.bounds.maximum = NULL,
x.tick.distance = NULL,
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 = 0 * grid.show,
x.grid.color = rgb(225, 225, 225, maxColorValue = 255),
x.tick.show = TRUE,
x.tick.suffix = "",
x.tick.prefix = "",
x.tick.format = "",
x.hovertext.format = x.tick.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,
marker.border.width = 1,
marker.border.colors = colors,
marker.border.opacity = NULL,
tooltip.show = TRUE,
modebar.show = FALSE,
zoom.enable = TRUE,
axis.drag.enable = FALSE,
bar.gap = 0.5,
data.label.show = FALSE,
data.label.centered = TRUE,
data.label.font.autocolor = FALSE,
data.label.font.family = global.font.family,
data.label.font.size = 10,
data.label.font.color = global.font.color,
data.label.format = "",
data.label.prefix = "",
data.label.suffix = "",
data.label.threshold = NULL)
{
ErrorIfNotEnoughData(x)
x <- ConvertQTableToArray(x)
if (length(dim(x)) < 3 ||
!any(dimnames(x)[[3]] %in% c("z-Statistic", "Column Comparisons", "p")))
warning("No annotations for statistical signficance are shown ",
"as input tables do not contain additional cell statistics ",
"such as 'Column Comparisons' or 'z-Statistic'.")
colcmp.names <- colnames(x) # used for column comparisons
if (isPercentData(x))
{
if (isAutoFormat(y.tick.format))
y.tick.format <- paste0(y.tick.format, "%")
if (isAutoFormat(y.hovertext.format))
y.hovertext.format <- paste0(y.hovertext.format, "%")
if (isAutoFormat(data.label.format))
data.label.format <- paste0(data.label.format, "%")
sfx <- checkSuffixForExtraPercent(c(y.tick.suffix, data.label.suffix),
c(y.tick.format, data.label.format))
y.tick.suffix <- sfx[1]
data.label.suffix <- sfx[2]
}
# Save data for annotating column totals before
# rows/columns are removed
col.totals.annot.data <- NULL
ind <- grep("NET|SUM|Total", dimnames(x)[[1L + !transpose]])
if (length(ind) > 0 && column.totals.above.show) {
ind <- ind[1L]
col.totals.annot.data <- if (transpose) x[ind, , , drop = FALSE] else x[, ind, , drop = FALSE]
}
x <- RemoveRowsAndOrColumns(x,
row.names.to.remove = row.names.to.remove,
column.names.to.remove = column.names.to.remove)
if (transpose)
{
x <- aperm(x, c(2,1,3))
if (!is.null(col.totals.annot.data))
col.totals.annot.data <- aperm(col.totals.annot.data, c(2,1,3))
}
# Some names might be missing or no names exist
if (!is.null(col.totals.annot.data) && SumEmptyHandling(nchar(rownames(x))) > 0)
col.totals.annot.data <- col.totals.annot.data[rownames(x)[!is.na(rownames(x))], , , drop = FALSE]
if (bar.gap < 0.0 || bar.gap >= 1.0)
{
warning("Parameter 'bar gap' must be between 0 and 1. ",
"Invalid 'bar gap' set to default value of 0.15.")
bar.gap <- 0.15
}
if (reverse.series.order)
x <- x[,NCOL(x):1,,drop = FALSE]
# Store data for chart annotations
annot.data <- x
# Prepare data for plotting chart
chart.matrix <- checkMatrixNames(x)
if (!is.numeric(chart.matrix))
stop("Input data should be numeric.")
if (num.categories.below.axis > 0 &&
any(!is.na(chart.matrix) & chart.matrix < 0))
stop("All values in input data must be positive when some categories are shown below the axis")
n <- nrow(chart.matrix)
m <- ncol(chart.matrix)
x.labels.full <- rownames(chart.matrix)
if (num.categories.below.axis > 0)
{
if (num.categories.below.axis > ncol(chart.matrix))
{
warning("The number of categories shown below the axis has been set to the maximum number of categories(", ncol(chart.matrix), ")")
num.categories.below.axis <- ncol(chart.matrix)
}
m.sign <- matrix(1, nrow = nrow(chart.matrix), ncol = ncol(chart.matrix))
m.sign[,1:num.categories.below.axis] <- -1
chart.matrix <- chart.matrix * m.sign
}
if (any(!is.finite(as.matrix(chart.matrix))))
warning("Missing values have been set to zero.")
# Some minimal data cleaning
# Assume formatting and Qtable/attribute handling already done
data.label.mult <- 1
data.label.suffix.2 <- data.label.suffix
if (percentFromD3(data.label.format))
{
data.label.mult <- 100
data.label.suffix.2 <- paste0("%", data.label.suffix.2)
}
data.label.decimals <- decimalsFromD3(data.label.format)
data.label.prefix <- vectorize(data.label.prefix, ncol(chart.matrix), nrow(chart.matrix), split = NULL)
data.label.suffix <- vectorize(data.label.suffix, ncol(chart.matrix), nrow(chart.matrix), split = NULL)
matrix.labels <- names(dimnames(chart.matrix))
if (nchar(x.title) == 0 && length(matrix.labels) == 2)
x.title <- matrix.labels[1]
# Constants
barmode <- "relative"
if (is.null(opacity))
opacity <- 1
if (is.null(marker.border.opacity))
marker.border.opacity <- opacity
colors <- paste0(rep("", NROW(chart.matrix)), colors)
if (data.label.font.autocolor)
dlab.color <- autoFontColor(colors)
else
dlab.color <- vectorize(data.label.font.color, ncol(chart.matrix))
data.label.show <- vectorize(data.label.show, NCOL(chart.matrix), NROW(chart.matrix))
data.label.font = lapply(dlab.color,
function(cc) list(family = data.label.font.family, size = data.label.font.size, color = cc))
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)
xtick.font = list(family = x.tick.font.family, size = x.tick.font.size, color = x.tick.font.color)
ytick.font = list(family = y.tick.font.family, size = y.tick.font.size, color = y.tick.font.color)
footer.font = list(family = footer.font.family, size = footer.font.size, color = footer.font.color)
legend.font = list(family = legend.font.family, size = legend.font.size, color = legend.font.color)
# Stacked charts cannot be toggled so annotations can be added
# as a single trace, which will render faster than multiple traces
# These annotations will be shown on the right of the bars
annot.text <- NULL
diff.annot.text <- NULL
totals.annot.text <- NULL
tmp.arrow.html <- NULL
if (nchar(footer) > 0)
footer <- paste0(footer, "<br>")
if ("Column Comparisons" %in% dimnames(annot.data)[[3]])
{
ind.colcmp <- which(dimnames(annot.data)[[3]] == "Column Comparisons")
n.colcmp <- length(colcmp.names)
annot.arrow.colors <- rep(annot.arrow.colors, length = n.colcmp)
tmp.arrow.html <- matrix(nrow = n.colcmp, ncol = 2,
sprintf("<span style=\"color:%s; font-size:%.0fpx;\">%s</span>",
rep(annot.arrow.colors, 2), annot.arrow.size,
rep(annot.arrow.symbols[c(1,3)], each = n.colcmp)))
annot.text <- getColCmpAnnot(annot.data[,,ind.colcmp], tmp.arrow.html)
if (column.totals.above.show && !is.null(col.totals.annot.data))
totals.annot.text <- getColCmpAnnot(
col.totals.annot.data[,,ind.colcmp], tmp.arrow.html)
if (annot.footer.show)
{
arrow.desc <- sprintf("Significantly %s %s %s",
"greater than",
rep(colcmp.names, 2),
rep(c("at the 99.9% confidence level",
"at the 95% confidence level"), each = n.colcmp))
footer <- paste0(footer,
paste(rmFontSize(tmp.arrow.html), arrow.desc, sep = "", collapse = annot.legend.sep))
}
} else if (all(c("Differences", "p") %in% dimnames(annot.data)[[3]]))
{
tmp.arrow.html <- sprintf("<span style=\"color:%s; font-size:%.0fpx;\">%s</span>",
annot.arrow.colors[1:2], annot.arrow.size,
annot.arrow.symbols[1:2])
annot.text <- getPDiffAnnot(annot.data, annot.sig.level, tmp.arrow.html)
if (column.totals.above.show && !is.null(col.totals.annot.data))
totals.annot.text <- getPDiffAnnot(
col.totals.annot.data, annot.sig.level, tmp.arrow.html)
if (annot.differences.show)
{
empty.arrow <- ""
if (!append.annot.differences.to.datalabel)
empty.arrow <- paste0("<span style='color:transparent; font-size:",
round(annot.arrow.size), "px;'>", annot.arrow.symbols[1], "</span>")
diff.annot.labels <- paste0(annot.differences.prefix,
formatC(annot.data[,,"Differences"],
format = "f", digits = annot.differences.decimals,
flag = if (annot.differences.sign.show) "+" else ""),
annot.differences.suffix)
diff.annot.text <- paste0(empty.arrow, diff.annot.labels)
diff.annot.text <- matrix(diff.annot.text, NROW(chart.matrix), NCOL(chart.matrix))
diff.annot.labels <- matrix(diff.annot.labels, NROW(chart.matrix), NCOL(chart.matrix))
}
if (annot.footer.show)
{
footer <- paste0(footer,
paste(rmFontSize(tmp.arrow.html), sprintf("Significant %s at the %s%% confidence level",
c("increase", "decrease"), round_half_up((1-annot.sig.level) * 100)),
sep = "", collapse = annot.legend.sep))
}
} else if ("z-Statistic" %in% dimnames(annot.data)[[3]])
{
ind.zstat <- which(dimnames(annot.data)[[3]] == "z-Statistic")
z.threshold <- qnorm(1 - (annot.sig.level/2))
tmp.arrow.html <- sprintf("<span style=\"color:%s; font-size:%.0fpx;\">%s</span>",
annot.arrow.colors[1:2], annot.arrow.size,
annot.arrow.symbols[1:2])
annot.text <- getZStatAnnot(annot.data[,,ind.zstat,drop = FALSE], z.threshold, tmp.arrow.html)
if (column.totals.above.show && !is.null(col.totals.annot.data))
totals.annot.text <- getZStatAnnot(
col.totals.annot.data[,,ind.zstat], z.threshold, tmp.arrow.html)
if (annot.footer.show)
{
footer <- paste0(footer,
paste(rmFontSize(tmp.arrow.html), sprintf("Significant %s at the %s%% confidence level",
c("increase", "decrease"), round_half_up((1-annot.sig.level) * 100)),
sep = "", collapse = annot.legend.sep))
}
}
legend.show <- setShowLegend(legend.show, NCOL(chart.matrix))
legend <- setLegend(type, legend.font, legend.ascending, legend.fill.color, legend.fill.opacity,
legend.border.color, legend.border.line.width,
legend.position.x, legend.position.y, y.data.reversed,
legend.orientation)
footer <- autoFormatLongLabels(footer, footer.wrap, footer.wrap.nchar, truncate = FALSE)
# Format axis labels
axisFormat <- formatLabels(chart.matrix, type, x.tick.label.wrap, x.tick.label.wrap.nchar,
x.tick.format, y.tick.format)
x.range <- setValRange(x.bounds.minimum, x.bounds.maximum, axisFormat, x.zero, is.null(x.tick.distance), is.bar = TRUE)
y.range <- setValRange(y.bounds.minimum, y.bounds.maximum, chart.matrix, y.zero, is.null(y.tick.distance))
xtick <- setTicks(x.range$min, x.range$max, x.tick.distance, x.data.reversed, is.bar = TRUE)
ytick <- setTicks(y.range$min, y.range$max, y.tick.distance, y.data.reversed)
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, 0, y.zero.line.color,
y.hovertext.format, 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.series = NCOL(chart.matrix), tickcolor = x.tick.mark.color,
with.bars = TRUE, zoom.enable = zoom.enable)
x.labels <- axisFormat$labels
y.labels <- colnames(chart.matrix)
x.all.labels <- x.labels
x.range <- getRange(x.labels, xaxis, axisFormat)
# Set up second x-axis for data labels
# Even when data.label.show is false, data.annotations
# is used to position arrow annotations etc
xaxis2 <- list(overlaying = "x", visible = FALSE, range = x.range,
fixedrange = !zoom.enable)
data.annotations <- dataLabelPositions(chart.matrix = chart.matrix,
axis.type = xaxis$type,
annotations = NULL,
data.label.mult = data.label.mult,
bar.decimals = data.label.decimals,
bar.prefix = data.label.prefix,
bar.suffix = data.label.suffix.2,
barmode = barmode,
swap.axes.and.data = FALSE,
bar.gap = bar.gap,
display.threshold = data.label.threshold,
dates = axisFormat$ymd,
reversed = isReversed(yaxis),
font = data.label.font,
hide.sign = TRUE,
center.data.labels = data.label.centered)
if (append.annot.differences.to.datalabel)
{
tmp.n <- NROW(data.annotations$text)
tmp.m <- NCOL(data.annotations$text)
ind.blank <- which(nchar(data.annotations$text) == 0)
data.annotations$text <- matrix(paste0(data.annotations$text,
"<span style='font-family:", annot.differences.font.family,
"; font-size:", annot.differences.font.size, font.unit,
"; color:", annot.differences.font.color, ";'>",
diff.annot.text, "</span>"), nrow = tmp.n, ncol = tmp.m)
data.annotations$text[ind.blank] <- ""
}
# Work out margin spacing
margins <- list(t = 20, b = 20, r = if (!legend.show) 80 else 60, l = 80, pad = 0)
margins <- setMarginsForAxis(margins, axisFormat, xaxis)
margins <- setMarginsForText(margins, title, subtitle, footer, title.font.size,
subtitle.font.size, footer.font.size)
legend.text <- autoFormatLongLabels(colnames(chart.matrix), legend.wrap, legend.wrap.nchar)
margins <- setMarginsForLegend(margins, legend.show, legend, legend.text, right.axis = FALSE)
# Set default margin on the right to ensure there is space
# for annotation arrows on the right of the bars
# This default is also smaller than the space estimated by
# to be needed for the legend
margins$r <- 80
margins <- setCustomMargins(margins, margin.top, margin.bottom, margin.left,
margin.right, margin.inner.pad)
margins$autoexpand <- margin.autoexpand
chart.labels <- list(SeriesLabels = list())
# Add invisible line to force all categorical labels to be shown
# Type "scatter" ensures y-axis tick bounds are treated properly
# but it also adds extra space next to the y-axis
p <- plot_ly(as.data.frame(chart.matrix))
tmp.min <- if (any(is.finite(chart.matrix))) min(chart.matrix[is.finite(chart.matrix)])
else y.bounds.minimum
p <- add_trace(p, x = x.all.labels,
y = rep(tmp.min, length(x.all.labels)),
mode = if (notAutoRange(yaxis)) "markers" else "lines",
type = "scatter", cliponaxis = TRUE,
hoverinfo = "skip", showlegend = FALSE, opacity = 0)
## Add a trace for each col of data in the matrix
for (i in 1:ncol(chart.matrix))
{
y <- as.numeric(chart.matrix[, i])
y.filled <- ifelse(is.finite(y), y, 0)
x <- x.labels
marker <- list(color = toRGB(colors[i], alpha = opacity),
line = list(color = toRGB(marker.border.colors[i],
alpha = marker.border.opacity),
width = marker.border.width))
tmp.y <- if (num.categories.below.axis) abs(y) else y
tmp.y.str <- formatByD3(tmp.y, y.hovertext.format, y.tick.prefix, y.tick.suffix)
tmp.x.str <- formatByD3(x, x.hovertext.format, x.tick.prefix, x.tick.suffix)
if (xaxis$type == "category")
tmp.hover.text <- paste0(tmp.x.str, ": ", tmp.y.str)
else
tmp.hover.text <- paste0("(", tmp.x.str, ", ", tmp.y.str, ")")
# This is the main trace for each data series
p <- add_trace(p, x = x, y = y.filled, type = "bar",
orientation = "v", marker = marker, name = legend.text[i],
hoverlabel = list(font = list(color = autoFontColor(colors[i]),
size = hovertext.font.size, family = hovertext.font.family)),
hoverinfo = "text+name", text = tmp.hover.text, textposition = "none",
legendgroup = i)
# Add attribute for PPT exporting
# Note that even without data labels, overlay annotations can still be present
chart.labels$SeriesLabels[[i]] <- list(Font = setFontForPPT(data.label.font[[i]]), ShowValue = FALSE)
tmp.suffix <- if (percentFromD3(data.label.format)) sub("%", "", data.label.suffix[,i])
else data.label.suffix[,i]
pt.segs <- lapply(1:nrow(chart.matrix),
function(ii)
{
pt <- list(Index = ii-1)
if (data.label.show[ii,i])
pt$Segments <- c(
if (nzchar(data.label.prefix[ii,i])) list(list(Text = data.label.prefix[ii,i])) else NULL,
list(list(Field="Value")),
if (nzchar(tmp.suffix[ii])) list(list(Text = tmp.suffix[ii])) else NULL)
else
pt$ShowValue <- FALSE
return(pt)
}
)
# Plotly text marker positions are not spaced properly when placed to
# the below the bar (i.e. negative values or reversed axis).
# Adjusted by controlling the size of the marker
# Hover must be included because this trace hides existing hover items
# Always show data label trace - firstly to ensure stacking covers all series
# and secondly because it is used for column totals
if (TRUE)
{
# Apply annotations to data label
ind.show <- which(data.label.show[,i])
data.label.text <- data.annotations$text[,i]
data.label.nchar <- nchar(data.label.text) # get length before adding html tags
attr(data.label.text, "customPoints") <- pt.segs
if (length(ind.show) > 0)
{
data.label.text[!data.label.show[,i]] <- ""
data.label.text <- applyAllAnnotationsToDataLabels(data.label.text, NULL,
annot.data, i, ind.show, "Bar", clean.pt.segs = FALSE)
pt.segs <- attr(data.label.text, "customPoints")
} else
data.label.text <- rep("", n)
p <- addTraceForBarTypeDataLabelAnnotations(p, type = "Column", legend.text[i],
data.label.xpos = data.annotations$x[,i],
data.label.ypos = data.annotations$y[,i],
data.label.show = data.label.show[,i],
data.label.text = data.label.text,
data.label.sign = getSign(data.annotations$y[,i], yaxis), data.label.nchar,
NULL, annot.data, i,
xaxis = "x2", yaxis = "y",
data.label.font[[i]], TRUE, data.label.centered)
}
# Add difference annotations to chart label attributes
if (!is.null(diff.annot.text))
{
if (annot.hide.small.bar)
ind.diff.show <- which(nchar(data.annotations$text[,i]) > 0)
else
ind.diff.show <- 1:NROW(diff.annot.text)
if (length(ind.diff.show) > 0)
pt.segs <- getPointSegmentsForPPT(pt.segs, ind.diff.show,
list(type = "Text - after data label", color = annot.differences.font.color,
size = annot.differences.font.size, font.family = annot.differences.font.family,
format = "Category"), diff.annot.labels[ind.diff.show, i])
}
# Add arrow annotations to chart label attributes
for (tmp.arrow in tmp.arrow.html)
{
ind.tmp <- grep(tmp.arrow, annot.text[,i], fixed = TRUE)
if (length(ind.tmp) > 0)
{
tmp.color <- regmatches(tmp.arrow, regexec("color:(\\S+);", tmp.arrow))[[1]][2]
tmp.symbol <- regmatches(tmp.arrow, regexec(">(\\S+)</span>", tmp.arrow))[[1]][2]
pt.segs <- getPointSegmentsForPPT(pt.segs, ind.tmp,
annot = list(type = "Custom text", format = "Category", size = annot.arrow.size,
font.family = "Arial", color = tmp.color, custom.symbol = tmp.symbol))
}
}
# Clean up PPT chart labels
pt.segs <- tidyPointSegments(pt.segs, nrow(chart.matrix))
if (!is.null(pt.segs))
{
if (isTRUE(attr(pt.segs, "SeriesShowValue")))
{
chart.labels$SeriesLabels[[i]]$ShowValue <- TRUE
attr(pt.segs, "SeriesShowValue") <- NULL
}
if (length(pt.segs) > 0)
chart.labels$SeriesLabels[[i]]$CustomPoints <- pt.segs
}
}
# Arrow Annotations to the right of the bar
# These are shown even if no data labels are shown
if (is.null(annot.arrow.offset) || !is.numeric(annot.arrow.offset))
annot.arrow.offset <- (1 - bar.gap)/2
xdiff <- annot.arrow.offset # in case the data only has one row
if (nrow(data.annotations$x) >= 2)
xdiff <- (data.annotations$x[2,1] - data.annotations$x[1,1]) * annot.arrow.offset
if (annot.hide.small.bar)
{
ind <- which(nchar(data.annotations$text) == 0)
if (length(ind) > 0)
warning("Some significant values were not shown because the bars were too small.")
annot.text[ind] <- ""
}
for (i in 1:ncol(chart.matrix))
p <- addTraceForBarTypeDataLabelAnnotations(p, type = "Column", "Annotations",
data.label.xpos = data.annotations$x[,i] + xdiff,
data.label.ypos = data.annotations$y[,i],
data.label.show = rep(TRUE, n),
data.label.text = annot.text[,i],
data.label.sign = getSign(data.annotations$y[,i], yaxis),
0, NULL, annot.data, i,
xaxis = "x2", yaxis = "y",
data.label.font = data.label.font[[1]],
TRUE, data.label.centered, "right", stackgroupname = "rightannot")
if (!is.null(diff.annot.text) && !append.annot.differences.to.datalabel)
{
if (is.null(annot.differences.offset) ||
!is.numeric(annot.differences.offset))
annot.differences.offset <- (1 - bar.gap)/2
xdiff <- annot.differences.offset
if (nrow(data.annotations$x) >= 2)
xdiff <- (data.annotations$x[2,1] - data.annotations$x[1,1]) *
annot.differences.offset
if (annot.hide.small.bar)
diff.annot.text[which(nchar(data.annotations$text) == 0)] <- ""
for (i in 1:ncol(chart.matrix))
p <- addTraceForBarTypeDataLabelAnnotations(p, type = "Column", "Differences",
data.label.xpos = data.annotations$x[,i] + xdiff,
data.label.ypos = data.annotations$y[,i],
data.label.show = rep(TRUE, n),
data.label.text = diff.annot.text[,i],
data.label.sign = getSign(data.annotations$y[,i], yaxis), 0,
NULL, annot.data, i,
xaxis = "x2", yaxis = "y",
data.label.font = list(family = annot.differences.font.family,
color = annot.differences.font.color, size = annot.differences.font.size),
TRUE, data.label.centered, "right", stackgroupname = "differences")
}
# Column totals
# These two sets of data labels are not added to ChartLabels because powerpoint has no way
# of adding labels associated with the whole column
if (column.totals.above.show)
{
# Add invisible string to center the column totals
pre.annot <- gsub("color:.*?;", "color:transparent;", totals.annot.text)
totals.above <- apply(chart.matrix, 1, function(xx) sum(xx[which(xx > 0)]))
p <- addAnnotScatterTrace(p, orientation = "v", name = "Column totals - above",
xpos = data.annotations$x[,1], ypos = rep(0, n),
text = paste0(pre.annot,
formatByD3(totals.above,
data.label.format, data.label.prefix[,m], data.label.suffix[,m]),
totals.annot.text),
textposition = "top center", marker = list(opacity = 0.0, size = 1),
xaxis = "x2", yaxis = "y", hoverinfo = "skip",
textfont = list(family = column.totals.above.font.family,
color = column.totals.above.font.color,
size = column.totals.above.font.size), stackgroup = "datalabel")
}
if (column.totals.below.show)
{
totals.below <- apply(chart.matrix, 1, function(xx) sum(xx[which(xx < 0)]))
p <- addAnnotScatterTrace(p, name = "Column totals - below", orientation = "v",
xpos = data.annotations$x[,1], ypos = rep(-.Machine$double.eps, n),
text = formatByD3(abs(totals.below),
data.label.format, data.label.prefix[,m], data.label.suffix[,m]),
textposition = "bottom center", marker = list(opacity = 0.0),
xaxis = "x2", yaxis = "y", hoverinfo = "skip",
textfont = list(family = column.totals.below.font.family,
color = column.totals.below.font.color,
size = column.totals.below.font.size), stackgroup = "datalabel")
}
# Add text elements surrounding chart
annotations <- NULL
n <- length(annotations)
annotations[[n+1]] <- setTitle(title, title.font, margins, title.align)
annotations[[n+2]] <- setFooter(footer, footer.font, margins, footer.align)
annotations[[n+3]] <- setSubtitle(subtitle, subtitle.font, margins, subtitle.align)
annotations <- Filter(Negate(is.null), annotations)
serieslabels.num.changes <- vapply(chart.labels$SeriesLabels, function(s) isTRUE(s$ShowValue) + length(s$CustomPoints), numeric(1L))
if (SumEmptyHandling(serieslabels.num.changes) == 0)
chart.labels <- NULL
p <- config(p, displayModeBar = modebar.show, showAxisDragHandles = axis.drag.enable)
p$sizingPolicy$browser$padding <- 0
p <- layout(p,
showlegend = legend.show,
legend = legend,
yaxis = yaxis,
xaxis2 = xaxis2,
xaxis = xaxis,
margin = margins,
annotations = annotations,
shapes = zerolines(x.zero, x.zero.line.width, x.zero.line.color,
y.zero, y.zero.line.width, y.zero.line.color),
plot_bgcolor = toRGB(charting.area.fill.color, alpha = charting.area.fill.opacity),
paper_bgcolor = toRGB(background.fill.color, alpha = background.fill.opacity),
hoverlabel = list(namelength = -1, bordercolor = "transparent",
font = list(size = hovertext.font.size, family = hovertext.font.family)),
hovermode = if (tooltip.show) "x" else FALSE,
bargap = bar.gap,
barmode = barmode
)
attr(p, "can-run-in-root-dom") <- TRUE
result <- list(htmlwidget = p)
class(result) <- c("StandardChart", "visualization-selector")
if (isPercentData(annot.data))
{
chart.matrix <- chart.matrix * 100
attr(chart.matrix, "statistic") <- "%"
}
attr(result, "ChartData") <- chart.matrix
attr(result, "ChartType") <- "Column Stacked"
attr(result, "ChartLabels") <- chart.labels
result
}
# z.data is matrix of z-statistics
# z.threshold is the threshold z-score use to determine significance
# arrow.html is a vector of two html strings: 1) up-arrow, 2) down-arrow
getZStatAnnot <- function(z.data, z.threshold, arrow.html)
{
if (length(dim(z.data)) < 2)
z.data <- as.matrix(z.data)
n <- NROW(z.data)
m <- NCOL(z.data)
annot.txt <- matrix("", n, m)
ind <- which(z.data > z.threshold)
annot.txt[ind] <- arrow.html[1]
ind <- which(z.data < -z.threshold)
annot.txt[ind] <- arrow.html[2]
return(annot.txt)
}
# annot.data is a 3d array containing p-values and Differences
# p.thres is the significance level of the test
# arrow.html is a vector of two html strings: 1) up-arrow, 2) down-arrow
getPDiffAnnot <- function(annot.data, p.thres, arrow.html)
{
n <- nrow(annot.data)
m <- ncol(annot.data)
annot.txt <- matrix("", n, m)
ind.p <- which(dimnames(annot.data)[[3]] == "p")
ind.d <- which(dimnames(annot.data)[[3]] == "Differences")
ind <- which(annot.data[,,ind.p,drop = FALSE] < p.thres, arr.ind = TRUE)
if (length(ind) == 0 || nrow(ind) == 0)
return(annot.txt)
for (i in 1:nrow(ind))
{
if (annot.data[ind[i,1], ind[i,2], ind.d] < 0)
annot.txt[ind[i,1], ind[i,2]] <- arrow.html[2]
else
annot.txt[ind[i,1], ind[i,2]] <- arrow.html[1]
}
return(annot.txt)
}
# colcmp is the 2d matrix that contains the letters describing column comparison
# arrow.html is a vector of
getColCmpAnnot <- function(colcmp.matrix, arrow.html)
{
if (length(dim(colcmp.matrix)) < 2)
colcmp.matrix <- as.matrix(colcmp.matrix)
n <- NROW(colcmp.matrix)
m <- NCOL(colcmp.matrix)
annot.txt <- matrix("", n, m)
for (i in 1:n)
{
for (j in 1:m)
{
if (is.na(colcmp.matrix[i,j]) || colcmp.matrix[i,j] == "" ||
colcmp.matrix[i, j] == "-")
next
c.list <- unlist(strsplit(colcmp.matrix[i,j], split = " "))
res <- ""
for (cc in c.list)
{
if (cc == tolower(cc))
{
ind <- which(letters == cc)
tmp <- arrow.html[ind,2]
} else
{
ind <- which(LETTERS == cc)
tmp <- arrow.html[ind,1]
}
res <- paste(res, tmp)
}
annot.txt[i,j] <- res
}
}
return(annot.txt)
}
# This function removes the font-size attribute
# of the arrows in the footer text. This avoids the problem of arrows overlapping
# when there are multiple rows of text
rmFontSize <- function(x)
{
return(gsub("font-size.*?;", "", x))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.