#' \code{Table of differences}
#'
#' Creates a html table allowing comparison between values in
#' two tables with the same row/column labels.
#' @param table1 A Q Table containing a primary statistic, "Standard Error",
#' and "n" or "Count". The output table will compare \code{table1}
#' and \code{table2}, with values to highlight cells which are
#' significantly different.
#' @param table2 A Q Table with the same labels as \code{table1}.
#' @param output The type of output to return. The default is "htmlwidget" that
#' visualizes the significance levels of the differences. The alternative
#' is "qtable" which is a 3d array containing the primary statistic of table2,
#' the differences, and the p-values of the differences.
#' @param show Controls text shown in the output table. Select one of
#' "Primary statistic of Table 2 with differences",
#' "Primary statistic of Table 2" or "Differences".
#' @param cond.shade Controls which elements are colored differently
#' to show significance. Select one of "None", "Cell colors", "Arrows", "Boxes".
#' @param cond.shade.cutoffs A vector of significance levels; cells will be
#' colored if the p-value is smaller than one of the cutoffs.
#' @param cond.shade.ub.colors A vector of colors the same length as
#' \code{cond.shade.cutoffs}. Cells will be colored if \code{table2}
#' is significantly less than \code{table1}.
#' @param cond.shade.lb.colors A vector of colors the same length as
#' \code{cond.shade.cutoffs}. Cells will be colored if \code{table2}
#' is significantly greater than \code{table1}.
#' @param cond.shade.ub.bordercolors A vector of colors the same length as
#' \code{cond.shade.cutoffs}. Cells will be colored if \code{table2}
#' is significantly less than \code{table1}. These will be used
#' to color the borders when \code{cond.shade == "Boxes"}.
#' @param cond.shade.lb.bordercolors A vector of colors the same length as
#' \code{cond.shade.cutoffs}. Cells will be colored if \code{table2}
#' is significantly greater than \code{table1} These will be used
#' to color the borders when \code{cond.shade == "Boxes"}..
#' @param cell.fill The default background color of cells in the table.
#' @param font.family The font family of cells in the table.
#' @param font.color The font color of cells in the table.
#' @param cond.box.radius Numeric; roundness of box corner when
#' \code{cond.shade == "Boxes"} (e.g. 0 for sharp corners,
#' 50 for oval).
#' @param cond.box.borderwidth Numeric; line width of box when
#' \code{cond.shade == "Boxes"}.
#' @param cond.box.padding.right Number; controls how far the box extends
#' from the text when \code{cond.shade == "Boxes"}.
#' @param cond.box.padding.left Number; controls how far the box extends
#' from the text when \code{cond.shade == "Boxes"}.
#' @param cond.box.padding.top Number; controls how far the box extends
#' from the text when \code{cond.shade == "Boxes"}.
#' @param cond.box.padding.bottom Number; controls how far the box extends
#' from the text when \code{cond.shade == "Boxes"}.
#' @param cond.arrow.size Size of the arrows in font units.
#' @param font.family Default font family of the cells in the table.
#' @param font.color Default font color of the cells in the table.
#' @param font.size Default font size.
#' @param font.unit One of "px" or "pt".
#' @param format.statistic.decimals Numeric; The number of decimals shown
#' if the primary statistic is shown in the cells.
#' @param format.statistic.prefix Optional text that will be prepended
#' to the primary statistic if it is shown in the cells.
#' @param format.statistic.suffix Optional text that will be appended
#' to the primary statistic if it is shown in the cells.
#' @param format.statistic.font.family Font family of primary statistic.
#' @param format.statistic.font.size Font size of primary statistic.
#' @param format.statistic.font.autocolor Whether the font of the
#' primary statistic should be automatically set to black or white
#' to maximise the contrast to the cell fill.
#' Overrides \code{format.statistic.font.color}.
#' @param format.statistic.font.color Font color of primary statistic if it
#' is shown in the cell.
#' @param format.difference.sign Logical; whether a +/- sign should
#' always be prepended to the difference.
#' @param format.difference.decimals Numeric; The number of decimals shown
#' if the difference is shown in the cells.
#' @param format.difference.prefix Optional text that will be prepended
#' to the difference if it is shown in the cells.
#' @param format.difference.suffix Optional text that will be appended
#' to the difference if it is shown in the cells.
#' @param format.difference.font.family Font family of difference.
#' @param format.difference.font.size Font size of difference.
#' @param format.difference.font.autocolor Whether the font of the
#' difference should be automatically set to black or white
#' to maximise the contrast to the cell fill.
#' Overrides \code{format.difference.font.color}.
#' @param format.difference.font.color Font color of difference if it
#' is shown in the cell.
#' @param legend.show Logical; whether or not to show legend at the
#' bottom of the table.
#' @param legend.sep Character; the string used to separate entries in
#' the legend.
#' @param legend.fill Background color of the region behind the legend.
#' @param legend.lineheight Numeric; controls the spacing between
#' lines in the legend. It is applied as a multiple of the font size.
#' @param legend.decimals Numeric; the number of decimal places to
#' show for confidence levels in the legend.
#' @param legend.font.family Font family of text in the legend.
#' @param legend.font.color Font color of text in the legend.
#' @param legend.font.size Font size of text in the legend.
#' @param row.names.to.remove Character vector or delimited string of
#' row labels specifying rows to remove from the returned table.
#' @param column.names.to.remove Character vector or delimited string of
#' column labels specifying columns to remove from the returned table.
#' @param means.test The type of test used to compare a table of means
#' (i.e. from numeric variable). One of "tTest", "zTest", "Nonparametric".
#' More details available in the \href{https://wiki.q-researchsoftware.com/wiki/Independent_Sample_Tests_-_Comparing_Two_Means}{Q Wiki}.
#' The Standard R output will use the value in \code{QSettings$StatisticalAssumptions}.
#' @param proportions.test The type of test used to compare a table of proportions
#' (i.e. from PickOne or PickAny variable). One of "tTest", "zTest", "Nonparametric".
#' More details available in the \href{https://wiki.q-researchsoftware.com/wiki/Independent_Sample_Tests_-_Comparing_Two_Proportions}{Q Wiki}.
#' The Standard R output will use the value in \code{QSettings$StatisticalAssumptions}.
#' @param means.bessel Logical, specifying whether Bessel's correction is used to compare means.
#' The Standard R output will use the value in \code{QSettings$StatisticalAssumptions}.
#' @param proportions.bessel Logical, specifying whether Bessel's correction
#' is used to compare proportions.
#' The Standard R output will use the value in \code{QSettings$StatisticalAssumptions}.
#' @param design.effect.constant A constant used to account for the expected sampling
#' error in a survey. More details available in the \href{https://docs.displayr.com/wiki/Design_Effects_and_Effective_Sample_Size.}{Q Wiki}.
#' The Standard R output will use the value in \code{QSettings$StatisticalAssumptions}.
#' @param ... Other parameters passed to \link[flipFormat]{CreateCustomTable}.
#' @importFrom flipFormat CreateCustomTable
#' @importFrom flipTables RemoveRowsAndOrColumns
#' @export
TableOfDifferences <- function(table1,
table2,
means.test = "tTest",
means.bessel = TRUE,
proportions.test = "zTest",
proportions.bessel = FALSE,
output = c("widget", "qtable"),
show = c("Primary statistic of Table 2 with differences"),
cond.shade = c("None", "Cell colors", "Arrows", "Boxes")[2],
cond.shade.cutoffs = c(0.05, 0.1),
cond.shade.ub.colors = c("#82A5CB", "#A9C0DA"),
cond.shade.lb.colors = c("#E99598", "#E5C8C4"),
cond.shade.ub.bordercolors = cond.shade.ub.colors,
cond.shade.lb.bordercolors = cond.shade.lb.colors,
cell.fill = "#FFFFFF",
font.color = "#2C2C2C",
font.size = 10,
font.unit = "px",
font.family = "Arial",
legend.show = TRUE,
legend.sep = " ",
legend.fill = "transparent",
legend.font.family = font.family,
legend.font.color = font.color,
legend.font.size = font.size,
legend.lineheight = 2,
legend.decimals = 1,
format.statistic.decimals = NULL,
format.statistic.prefix = "",
format.statistic.suffix = "",
format.statistic.font.autocolor = TRUE,
format.statistic.font.color = "#2C2C2C",
format.statistic.font.size = font.size,
format.statistic.font.family = font.family,
format.difference.decimals = NULL,
format.difference.prefix = "",
format.difference.suffix = "",
format.difference.sign = TRUE,
format.difference.font.autocolor = TRUE,
format.difference.font.color = font.color,
format.difference.font.size = font.size,
format.difference.font.family = font.family,
cond.arrow.size = font.size,
cond.box.radius = 0,
cond.box.borderwidth = 2,
cond.box.padding.right = 5,
cond.box.padding.left = 0,
cond.box.padding.top = 0,
cond.box.padding.bottom = 0,
row.names.to.remove = "NET, Total, Sum",
column.names.to.remove = "NET, Total, Sum",
design.effect.constant = 1,
...)
{
# Check input data
output <- match.arg(output)
q.type <- attr(table1, "questiontype")
if (!is.null(attr(table1, "statistic")) || !is.null(attr(table2, "statistic")))
stop("Input tables must contain cell statistics for the sample size and standard error.")
is.weighted <- !is.null(attr(table1, "weight.name")) || !is.null(attr(table2, "weight.name"))
# Check key QTable attributes exist. Otherwise there is ambiguity as to whether
# the tables are unweighted tables, or they are weighted tables whose attributes
# have been obliterated by R.
if (!is.weighted &&
is.null(attr(table1, "questions")) ||
is.null(attr(table2, "questions")))
{
warning("Could not determine if the input tables contain weighted data because their ",
"table attributes are missing. If the tables have been constructed using R Code ",
"and are meant to contain weighted data, please ensure to set ",
"attr(<tablename>, 'weight.name') = <weightname>). Tests have been conducted ",
"assuming the data is not weighted.")
}
table1 <- convertToTableWithStatistics(table1)
table2 <- convertToTableWithStatistics(table2)
table1 <- RemoveRowsAndOrColumns(table1, row.names.to.remove, column.names.to.remove)
table2 <- RemoveRowsAndOrColumns(table2, row.names.to.remove, column.names.to.remove)
if (any(rownames(table1) != rownames(table2)))
stop("Row names of Table 1 and Table 2 should be identical and in the same order.")
if (any(colnames(table1) != colnames(table2)))
stop("Column names of Table 1 and Table 2 should be identical and in the same order.")
# Check that input tables contain the required statistics
# which depends on the primary statistic in the table
stat1 <- dimnames(table1)[[3]]
stat2 <- dimnames(table2)[[3]]
if (stat1[1] != stat2[1])
stop("The primary statistic of Table 1 (", stat1[1],
") does not match the primary statistic of Table 2 (",
stat2[1], ").")
allowed.primary <- c("Average", "%", "Total %", "Column %")
if (isTRUE(q.type == "PickOneMulti"))
allowed.primary <- c(allowed.primary, "Row %")
if (!(stat1[1] %in% allowed.primary))
stop("The primary statistic in the input table cannot be '", stat1[1],
"'. A t-test can only be computed on '",
paste(allowed.primary, collapse = "', '"), "'.")
if (stat1[1] == "Column %")
{
n.stat.name <- c("Column Sample Size", "Column n")
se.stat.name <- "Column Standard Error"
} else if (stat1[1] == "Row %") # Only for PickOneMulti tables
{
n.stat.name <- c("Sample Size", "Base n")
se.stat.name <- "Standard Error"
} else
{
n.stat.name <- c("Sample Size", "Base n")
se.stat.name <- "Standard Error"
}
# Get sample size and standard errors
ind1.n <- findIndexOfStat(stat1, n.stat.name)
ind2.n <- findIndexOfStat(stat2, n.stat.name)
ind1.se <- findIndexOfStat(stat1, se.stat.name)
ind2.se <- findIndexOfStat(stat2, se.stat.name)
if (length(ind1.n) == 0 || length(ind1.se) == 0 ||
length(ind2.n) == 0 || length(ind2.se) == 0)
stop("To test whether the difference in the primary statistic '",
stat1[1], "' is significant, input tables need to contain the cell statistic '",
se.stat.name, "' and one of '", n.stat.name[1], "' or '", n.stat.name[2], "'.")
# Compute significance of differences
is.percentage <- grepl("%", stat1[1], fixed = TRUE)
denom <- if (is.percentage) 100 else 1
test.type <- if (is.percentage) proportions.test else means.test
bessel.constant <- if (is.percentage) proportions.bessel else means.bessel
test.type <- validateTestTypeForTableOfDifferences(test.type, is.percentage, is.weighted)
cell.diff <- table2[,,1] - table1[,,1]
pvals <- compareTwoSamples(test.type, a = list(Average = table2[,,1]/denom,
"Standard Error" = table2[,,ind2.se], "Base n" = table2[,,ind2.n]),
b = list(Average = table1[,,1]/denom, "Standard Error" = table1[,,ind1.se],
"Base n" = table1[,,ind1.n]), is.percentage, is.weighted,
bessel.constant, design.effect.constant)
if (output == "qtable")
{
output <- array(NA, dim = c(nrow(table2), ncol(table2), 4),
dimnames = list(rownames(table2), colnames(table2),
c(stat2[1], "Differences", "p", "z-Statistic")))
output[,,1] <- table2[,,1]
output[,,2] <- cell.diff
output[,,3] <- pvals
output[,,4] <- sign(cell.diff) * abs(qnorm(pvals/2))
return(CopyAttributes(output, table2, c("name", "basedescription",
"basedescriptiontext", "dimnames", "names", "row.names",
"dim", "class", "levels")))
}
if (is.null(format.statistic.decimals))
format.statistic.decimals <- if (is.percentage) 0 else 2
if (is.null(format.difference.decimals))
format.difference.decimals <- if (is.percentage) 0 else 2
# Conditional shading
cond.ord <- order(cond.shade.cutoffs, decreasing = TRUE)
tmp.prefix <- matrix("", nrow = nrow(table1), ncol(table1))
tmp.suffix <- matrix("", nrow = nrow(table1), ncol(table1))
tmp.fill <- NULL
if (cond.shade == "Cell colors")
{
cell.fill <- matrix(cell.fill, nrow = nrow(table1), ncol = ncol(table1))
for (i in cond.ord)
{
ind <- which(pvals < cond.shade.cutoffs[i] & cell.diff < 0)
cell.fill[ind] <- cond.shade.lb.colors[i]
ind <- which(pvals < cond.shade.cutoffs[i] & cell.diff > 0)
cell.fill[ind] <- cond.shade.ub.colors[i]
}
} else if (cond.shade == "Boxes")
{
cell.fill <- matrix(cell.fill, nrow = nrow(table1), ncol = ncol(table1))
tmp.fill <- cell.fill
for (i in cond.ord)
{
ind <- which(pvals < cond.shade.cutoffs[i] & cell.diff < 0)
tmp.prefix[ind] <- paste0("<span style='border:",
cond.box.borderwidth, "px solid ",cond.shade.lb.bordercolors[i],
"; background-color:", cond.shade.lb.colors[i],
"; border-radius:", cond.box.radius, "%",
"; padding-top:", cond.box.padding.top, "px",
"; padding-bottom:", cond.box.padding.bottom, "px",
"; padding-left:", cond.box.padding.left, "px",
"; padding-right:", cond.box.padding.right, "px;'>")
tmp.suffix[ind] <- "</span>"
tmp.fill[ind] <- cond.shade.lb.colors[i]
ind <- which(pvals < cond.shade.cutoffs[i] & cell.diff > 0)
tmp.prefix[ind] <- paste0("<span style='border:",
cond.box.borderwidth, "px solid ",cond.shade.ub.bordercolors[i],
"; background-color:", cond.shade.ub.colors[i],
"; border-radius:", cond.box.radius, "%",
"; padding-top:", cond.box.padding.top, "px",
"; padding-bottom:", cond.box.padding.bottom, "px",
"; padding-left:", cond.box.padding.left, "px",
"; padding-right:", cond.box.padding.right, "px;'>")
tmp.suffix[ind] <- "</span>"
tmp.fill[ind] <- cond.shade.ub.colors[i]
}
}
# Construct text to be shown inside table cells
if (show == "Primary statistic of Table 2" ||
show == "Primary statistic of Table 2 with differences")
{
cell.text <- paste0(format.statistic.prefix,
formatC(table2[,,1], format.statistic.decimals,
format = "f", big.mark = ","),
format.statistic.suffix)
} else
{
cell.text <- paste0(format.difference.prefix,
formatC(cell.diff, format.difference.decimals,
format = "f", big.mark = ",",
flag = if (format.difference.sign) "+" else ""),
format.difference.suffix)
}
max.width <- max(nchar(cell.text))
cell.text <- formatC(cell.text, format = "s", width = max.width)
cell.text <- gsub(" ", " ", cell.text)
# This occurs later than the "Cell colors" and "Boxes" options
# because we need to add spaces to cell.text to re-align characters
if (cond.shade == "Arrows")
{
for (i in cond.ord)
{
ind <- which(pvals < cond.shade.cutoffs[i] & cell.diff < 0)
tmp.suffix[ind] <- paste0("<span style='color:",
cond.shade.lb.colors[i], "; font-size:",
cond.arrow.size, font.unit, "'>▼</span>")
cell.text[ind] <- sub(" ", " ", cell.text[ind])
ind <- which(pvals < cond.shade.cutoffs[i] & cell.diff > 0)
tmp.suffix[ind] <- paste0("<span style='color:",
cond.shade.ub.colors[i], "; font-size:",
cond.arrow.size, font.unit, "'>▲</span>")
cell.text[ind] <- sub(" ", " ", cell.text[ind])
}
}
cell.text <- paste0(tmp.prefix, cell.text, tmp.suffix)
if (show == "Primary statistic of Table 2 with differences")
{
if (format.difference.font.autocolor)
format.difference.font.color <- autoFontColor(cell.fill)
tmp.text <- paste0(format.difference.prefix,
formatC(cell.diff, format.difference.decimals,
format = "f", big.mark = ",",
flag = if (format.difference.sign) "+" else ""),
format.difference.suffix)
# Add spaces so that the +/- signs line up
# Difference values need to be left-aligned so that
# extra padding preceding the +/- sign is not seen
max.width <- max(nchar(tmp.text))
tmp.text <- formatC(tmp.text, format = "s", width = max.width, flag = "-")
tmp.text <- gsub(" ", " ", tmp.text)
cell.text <- paste0(cell.text,
"<span style='font-family:", format.difference.font.family,
"; color:", format.difference.font.color,
"; font-size:", format.difference.font.size, font.unit, "'>",
tmp.text,
"</span>")
}
# Set fonts to pass to CreateCustomTable
# This needs to be done after the conditional shading
# so the autoFontColor can be called appropriately
if (show == "Differences")
{
cell.font.family = format.difference.font.family
cell.font.size = format.difference.font.size
if (format.difference.font.autocolor)
format.difference.font.color <- if (cond.shade == "Boxes") autoFontColor(tmp.fill)
else autoFontColor(cell.fill)
cell.font.color = format.difference.font.color
} else
{
cell.font.family = format.statistic.font.family
cell.font.size = format.statistic.font.size
if (format.statistic.font.autocolor)
format.statistic.font.color <- if (cond.shade == "Boxes") autoFontColor(tmp.fill)
else autoFontColor(cell.fill)
cell.font.color = format.statistic.font.color
}
legend.text <- ""
if (legend.show && cond.shade != "None")
{
conf <- (1 - cond.shade.cutoffs) * 100
tmp.lev <- length(conf)
tmp.fill <- c(cond.shade.ub.colors, rev(cond.shade.lb.colors))
empty.text <- paste(rep(" ", 4), collapse = "")
if (cond.shade == "Cell colors")
tmp.text <- sprintf("<span style='border:1px solid %s; background-color: %s'>%s</span>",
tmp.fill, tmp.fill, empty.text)
else if (cond.shade == "Arrows")
tmp.text <- sprintf("<span style='color:%s; font-size: %.0f%s'>%s</span>",
tmp.fill, cond.arrow.size, font.unit, rep(c("▲", "▼"), each = tmp.lev))
else if (cond.shade == "Boxes")
tmp.text <- sprintf("<span style='border:%.0fpx solid %s; background-color: %s; border-radius:%.0f%%'>%s</span>",
cond.box.borderwidth,
c(cond.shade.ub.bordercolors, rev(cond.shade.lb.bordercolors)),
tmp.fill, cond.box.radius, empty.text)
tmp.text <- paste("<nobr>", tmp.text,
sprintf(paste0("Signficant %s at %.", legend.decimals, "f%% confidence level"),
rep(c("increase", "decrease"), each = tmp.lev),
c(conf, rev(conf))), "</nobr>")
legend.text <- paste(tmp.text, collapse = legend.sep)
}
cell.text <- matrix(cell.text,
nrow(table1), ncol(table1), dimnames = dimnames(table1)[1:2])
result <- CreateCustomTable(cell.text, cell.fill = cell.fill,
cell.font.family = cell.font.family, cell.font.size = cell.font.size,
cell.font.color = cell.font.color,
footer = legend.text, footer.fill = legend.fill,
footer.font.color = legend.font.color,
footer.font.family = legend.font.family,
footer.font.size = legend.font.size,
footer.lineheight = legend.lineheight,
font.unit = font.unit, ...)
attr(result, "p-values") <- pvals
return(result)
}
#' 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"))
}
# Tries to convert the QTable into a 3d array
# An error will be thrown if the input is not a QTable
# or it does not contain multiple statistics
convertToTableWithStatistics <- function(x)
{
#if (is.null(attr(x, "questions")) || is.null(attr(x, "name")))
# stop("Input tables must be Q Tables showing statistics computed from questions or variable sets")
if (is.character(x))
x <- array(suppressWarnings(as.numeric(x)), dim = dim(x), dimnames = dimnames(x))
if (length(dim(x)) > 3)
stop("Output cannot be produced because the input table has too many dimensions. ",
"Try removing one of the questions from the crosstab or ",
"splitting up the multinomial question.")
# 1-column table with multiple stats in 2nd dimension
if (length(dim(x)) == 2)
{
dn <- dimnames(x)
dn <- c(dn[1], "", dn[2])
x <- array(x, dim = sapply(dn, length), dimnames = dn)
} else if (length(dim(x)) < 2)
stop("Input tables must be Q Tables showing statistics computed from questions or variable sets")
return(x)
}
# Tries to find target in the stat.names list
# If multiple entries in target are in stat.names, the index of the first match is returned
findIndexOfStat <- function(stat.names, target)
{
ind <- integer(0)
for (tt in target)
{
ind <- which(stat.names == tt)
# stop after first match is found
if (length(ind) > 0)
break
}
return(ind)
}
# A number of tests that are used by Displayr's tables require access to the
# raw data in order to compute test statistics. These are not supported by
# the Table of Differences.
validateTestTypeForTableOfDifferences <- function(test.type, is.percentage, is.weighted) {
valid.displayr.test.types <- c("tTest", "zTest", "Nonparametric", "ChiSquare", "Quantum", "SurveyReporter")
test.valid <- test.type %in% valid.displayr.test.types
fallback.msg <- if (is.percentage) "A z-test has been used instead." else "A t-test has been used instead."
fallback.type <- if (is.percentage) "zTest" else "tTest"
if (!test.valid) {
msg <- paste0(
"The selected test.type '",
test.type,
"' is not supported by the Table of Differences. ",
fallback.msg)
warning(msg)
return(fallback.type)
}
if (test.type %in% c("Quantum", "SurveyReporter")) {
warning("Quantum and Survey Reporter tests are not supported by the Table of Differences. ", fallback.msg)
return(fallback.type)
}
if (is.percentage && test.type %in% c("Nonparametric", "ChiSquare") && is.weighted)
{
warning("Non-parametric tests for weighted proportions are not supported by the Table of Differences. ", fallback.msg)
return(fallback.type)
}
if (!is.percentage && test.type == "Nonparametric")
{
warning("Non-parametric tests for means are not supported by the Table of Differences. ", fallback.msg)
return(fallback.type)
}
test.type
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.