## plots
# iscatter, idot, icorr, itree, icurve
##
#' iscatter
#'
#' @description
#' Interactive scatter plot with labelled points.
#'
#' If \code{labels} is a vector, points are labeled as-is and recycled if
#' necessary. Optionally, \code{labels} can be a \emph{named} list where each
#' element of the list is a character vector (or one which can be coerced)
#' having the same length of \code{x}; see examples. If \code{x} and \code{y}
#' are named vectors, points will be labeled without needing to use
#' \code{labels}.
#'
#' @param x,y vectors of x- and y-coordinates; if \code{y} is \code{NULL},
#' \code{x} will be plotted along the y-axis by index of \code{x}
#' @param group vector of group (\code{\link{factor}}-like) variables used for
#' additional aesthetics such as \code{col}
#' @param col a vector of colors for each unique \code{group}; note that colors
#' will be assigned to the sorted levels of \code{group}
#' @param cex point size in pixels
#' @param xlim,ylim x- and y-limits
#' @param xlab,ylab,main the x-, y-, and main labels
#' @param labels optional character vector or named list of character vectors
#' to label each point; if \code{NULL}, points will be labeled by index
#' @param plotOpts list of additional plot options; see
#' \code{\link{iscatterOpts}}
#' @param digits integer indicating number of significant digits to use
#'
#' @family iplots
#'
#' @seealso
#' \code{\link[qtlcharts]{iplot}} from the \pkg{qtlcharts} package
#'
#' \code{\link[htmlwidgets]{saveWidget}}
#'
#' @examples
#' ## basic usage
#' iscatter(1:5, col = 1:5)
#'
#' ## using named vectors
#' x <- with(mtcars, setNames(mpg, mpg))
#' y <- with(mtcars, setNames(wt, wt))
#' iscatter(x, y)
#'
#' ## using the labels parameter
#' with(mtcars, {
#' iscatter(wt, mpg, group = cyl, col = 1:3,
#' main = 'Motor Trend car road tests',
#' labels = list(model = rownames(mtcars), mpg = mpg, hp = hp))
#' })
#'
#' ## compare with base graphics
#' with(mtcars, plot(wt, mpg, col = factor(cyl), pch = 19))
#'
#' ## labels parameter supports additional formatting with html tags
#' with(ivolcano, {
#' iscatter(logFC, -log10(pval), group = pval < 0.05 & abs(logFC) > 1,
#' col = c('lightgrey','green'),
#' labels = list(
#' ' ' = rownames(ivolcano),
#' 'log<sub>2</sub>(FC)' = round(logFC, 2),
#' '<em>p</em>-value' =
#' format.pval(ivolcano$pval, digits = 2, eps = .05)))
#' })
#'
#' @export
iscatter <- function(x, y = NULL, group, col, cex = 5,
xlim = NULL, ylim = NULL,
xlab = NULL, ylab = NULL, main = NULL,
labels = NULL, plotOpts = NULL, digits = NULL) {
if (is.null(y)) {
xl <- 'Index'
yl <- deparse(substitute(x))
ll <- names(x)
y <- x
x <- seq_along(y)
} else {
xl <- deparse(substitute(x))
yl <- deparse(substitute(y))
ll <- list(x = names(x), y = names(y))
if (all(sapply(ll, is.null)))
ll <- NULL
}
if (missing(group)) {
if (missing(col)) {
group <- rep_len(1, length(x))
col <- NULL
} else {
group <- rep_len(seq_along(col), length(x))
col <- numeric2col(col)
}
} else {
if (missing(col)) {
col <- NULL
group <- group2numeric(rep_len(group, length(x)))
} else {
group <- group2numeric(rep_len(group, length(x)))
col <- numeric2col(col)
}
}
group <- group2numeric(group)
## if x,y are named, use those names, otherwise use labels or index
labels <- if (is.null(labels)) {
if (is.null(ll)) seq_along(x) else get_labels(ll, length(x))
} else get_labels(labels, length(x))
names(x) <- names(y) <- NULL
opts <- list(xlab = xlab %||% xl, ylab = ylab %||% yl, title = main,
pointsize = cex, xlim = xlim, ylim = ylim, pointcolor = col)
x <- list(data = data.frame(x = x, y = y, group = group, indID = labels),
chartOpts = rm_alpha_plotOpts(c(opts, plotOpts)))
if (!is.null(digits))
attr(x, 'TOJSON_ARGS') <- list(digits = digits)
defaultAspect <- 1.33
browsersize <- getPlotSize(defaultAspect)
htmlwidgets::createWidget(
name = 'iplot', x = x,
width = plotOpts$width, height = plotOpts$height,
sizingPolicy = htmlwidgets::sizingPolicy(
browser.defaultWidth = browsersize$width,
browser.defaultHeight = browsersize$height
), package = 'qtlcharts'
)
}
#' idot
#'
#' @description
#' Interactive dot plot.
#'
#' Any numeric data can be plotted on the y-axis but the x-axis should be
#' discrete groups. Points will be labeled with the vector names, the
#' \code{labels} parameter, or by index otherwise.
#'
#' @param x a numeric vector of y values (if \code{y} is \code{NULL}) or if
#' \code{y} is given, a vector of x values; if \code{x} is an named vector,
#' these labels will be passed on to \code{labels}
#' @param y optional numeric vector of y values; if missing, \code{x} is used
#' @param group optional vector of categories for coloring points
#' @param cex point size in pixels
#' @param xlim,ylim x- and y-limits
#' @param xlab,ylab,main the x-, y-, and main labels
#' @param names labels under each group of dots
#' @param labels optional character vector or named list of character vectors
#' to label each point; if \code{NULL}, points will be labeled by index
#' @param plotOpts list of additional plot options; see
#' \code{\link{idotOpts}}
#' @param digits integer indicating number of significant digits to use
#'
#' @family iplots
#'
#' @seealso
#' \code{\link[qtlcharts]{iplotPXG}} from the \pkg{qtlcharts} package
#'
#' \code{\link[htmlwidgets]{saveWidget}}
#'
#' @examples
#' ## basic usage with named vectors
#' idot(setNames(mtcars$mpg, rownames(mtcars)))
#'
#' ## using group and subgroup (a vector of logicals to color points)
#' with(mtcars, {
#' idot(gear, mpg, group = am + 1L, cex = 5, ylim = c(0, 40),
#' labels = rownames(mtcars))
#' })
#'
#' ## labels parameter supports additional formatting with html tags
#' with(ivolcano, {
#' idot(substr(rownames(ivolcano), 1, 1), logFC,
#' group = cut(pval, c(0, 0.05, .1, 1)), xlab = 'Treatment arm',
#' labels = list(
#' ' ' = rownames(ivolcano),
#' 'log2(FC)' = round(logFC, 2),
#' '<em>p</em>-value' =
#' format.pval(ivolcano$pval, digits = 2, eps = .05)))
#' })
#'
#' @export
idot <- function(x, y = NULL, group = NULL, cex = 5,
xlim = NULL, ylim = NULL,
xlab = NULL, ylab = NULL, main = NULL,
names = NULL, labels = NULL,
plotOpts = NULL, digits = NULL) {
xl <- deparse(substitute(x))
yl <- deparse(substitute(y))
if (is.null(y)) {
y <- x
x <- rep_len(' ', length(x))
}
x <- rep_len(x, length(y))
x <- as.factor(x)
x_levels <- if (is.factor(x))
levels(x) else sort(unique(x))
x_labels <- if (is.null(names))
x_levels else rep_len(names, length(x_levels))
x <- group2numeric(x, preserveNA = TRUE)
if (is.null(group))
group <- rep_len(1L, length(x))
stopifnot(length(group) == length(x))
group <- group2numeric(group)
## named vectors not supported in jsonlite
if (!is.null(nn <- names(y)))
names(y) <- NULL
ll <- deparse(substitute(labels))
labels <- if (is.null(labels)) nn else {
if (!is.list(labels))
labels <- setNames(list(labels), ll)
if (!is.null(nn))
labels <- c(list(' ' = nn), labels)
get_labels(labels, length(y))
}
opts <- list(
xlab = xlab %||% xl, ylab = ylab %||% yl, title = main,
pointsize = cex, xlim = xlim, ylim = ylim,
xcategories = seq_along(x_levels), xcatlabels = x_labels
)
x <- list(
data = list(x = x, y = y, indID = labels, group = group),
chartOpts = rm_alpha_plotOpts(c(opts, plotOpts)))
if (!is.null(digits))
attr(x, 'TOJSON_ARGS') <- list(digits = digits)
defaultAspect <- 1
browsersize <- getPlotSize(defaultAspect)
htmlwidgets::createWidget(
name = 'idotplot', x = x,
width = plotOpts$width, height = plotOpts$height,
sizingPolicy = htmlwidgets::sizingPolicy(
browser.defaultWidth = browsersize$width,
browser.defaultHeight = browsersize$height, knitr.defaultWidth = 1000,
knitr.defaultHeight = 1000 / defaultAspect
), package = 'qtlcharts'
)
}
#' icorr
#'
#' @description
#' Interactive correlation matrices (heat maps) with optional scatter plots.
#'
#' Variables will be clustered (see details) and reordered by default. Cells
#' will be labeled with the column names of the input data, and if a scatter
#' plot is created, points will be labeled with the row names (this can be
#' over-ridden by using the \code{labels} parameter).
#'
#' @details
#' If \code{col} is given with no \code{group} variable, the colors for each
#' observation will be recycled in order.
#'
#' Default cluster method is \code{stats::hclust(dist(x), method = 'average')}
#' which will return a list containing a named vector, \code{"order"}, which is
#' used to reorder the variables.
#'
#' In order to pass a custom clustering function to \code{cluster}, the
#' function must take a single input (a correlation matrix) and return either
#' a vector or a list with a named vector, \code{"order"}.
#'
#' @param mat data matrix (observations x variables) of numeric values
#' @param group vector of grouping (\code{\link{factor}}-like) variables for
#' each observation
#' @param col a vector of colors for each unique \code{group} of points in
#' the scatter plots; note that colors will be assigned to the sorted levels
#' of \code{group}
#' @param labels optional character vector or named list of character vectors
#' to label each point; if \code{NULL}, points will be labeled by index
#' @param cluster logical or function; if \code{TRUE}, the variables will be
#' clustered and reordered; if \code{FALSE}, no reordering will be done;
#' otherwise, a custom clustering function may be given; see details
#' @param cor_method character string indicating which correlation coefficient
#' is to be computed; one of \code{'pearson'} (default), \code{'kendall'}, or
#' \code{'spearman'}: can be abbreviated; see \code{\link{cor}}
#' @param scatterplots logical; if \code{TRUE}, scatter plots of the linked
#' underlying data will be included
#' @param plotOpts list of additional plot options; see
#' \code{\link{icorrOpts}}
#' @param digits integer indicating number of significant digits to use
#'
#' @family iplots
#'
#' @seealso
#' \code{\link[qtlcharts]{iplotCorr}} from the \pkg{qtlcharts} package
#'
#' \code{\link[htmlwidgets]{saveWidget}}
#'
#' @examples
#' ## heatmap only
#' icorr(mtcars, scatterplots = FALSE)
#'
#' ## with scatter plots
#' icorr(mtcars, group = mtcars$cyl, col = c('blue','red','green'),
#' plotOpts = list(corcolors = heat.colors(3)))
#'
#' ## larger matrix example
#' set.seed(1)
#' dat <- replicate(50, mtcars[, sample(1:11, 1), drop = FALSE])
#' dat <- do.call('cbind', dat)
#' icorr(dat, cluster = TRUE, group = mtcars$cyl)
#'
#' ## using a custom clustering function
#' icorr(dat, cluster = function(x) hclust(dist(x, method = 'maximum')))
#' icorr(dat, cluster = function(x) sample(seq.int(ncol(x))))
#' icorr(dat, cluster = function(x) list(order = order(rowMeans(x))))
#'
#' @export
icorr <- function(mat, group, col, labels = NULL, cluster = TRUE,
cor_method = 'pearson', scatterplots = TRUE,
plotOpts = NULL, digits = NULL) {
mat <- as.matrix(mat)
nr <- nrow(mat)
if (!is.null(labels))
rownames(mat) <- get_labels(labels, nr)
if (missing(group)) {
if (missing(col)) {
group <- rep_len(1, nr)
col <- NULL
} else {
group <- rep_len(seq_along(col), nr)
col <- numeric2col(col)
}
} else {
if (missing(col)) {
col <- NULL
group <- group2numeric(group)
} else {
group <- group2numeric(group)
col <- numeric2col(rep_len(col, length(unique(group))))
}
}
stopifnot(class(cluster) %in% c('logical','function'))
if (is.function(cluster)) {
cFUN <- cluster
cluster <- TRUE
} else cFUN <- NULL
co <- plotOpts
opts <- list(
cortitle = co$cortitle %||% 'Correlation matrix',
scattitle = co$scattitle %||% 'Scatter plot of values',
scatcolors = col
)
group <- group2numeric(group)
data_list <- convert4iplotcorr(
mat, group, reorder = cluster,
rows = seq.int(ncol(mat)), cols = seq.int(ncol(mat)),
corr = stats::cor(mat, use = 'pairwise.complete.obs', method = cor_method),
scatterplots = scatterplots, corr_was_presubset = FALSE, cFUN = cFUN
)
if (!is.null(digits))
attr(x, 'TOJSON_ARGS') <- list(digits = digits)
defaultAspect <- 2
browsersize <- getPlotSize(defaultAspect)
htmlwidgets::createWidget(
name = 'iplotCorr',
x = list(data = data_list, chartOpts = rm_alpha_plotOpts(c(opts, plotOpts))),
width = plotOpts$width, height = plotOpts$height,
sizingPolicy = htmlwidgets::sizingPolicy(
browser.defaultWidth = browsersize$width,
browser.defaultHeight = browsersize$height, knitr.defaultWidth = 1000,
knitr.defaultHeight = 1000 / defaultAspect
), package = 'qtlcharts'
)
}
#' itree
#'
#' @description
#' Interactive tree plot with search bar.
#'
#' Any numeric data can be plotted on the y-axis but the x-axis should be
#' discrete groups. Points will be labeled with their \emph{unique} names
#' and y-value.
#'
#' @param y a \emph{uniquely-named} numeric vector
#' @param group vector of grouping (\code{\link{factor}}-like) variables the
#' same length as \code{y}
#' @param ylim y-axis limits
#' @param xlab,ylab,main the x-, y-, and main labels
#' @param plotOpts list of additional plot options; see
#' \code{\link{itreeOpts}}
#' @param digits integer indicating number of significant digits to use
#'
#' @family iplots
#'
#' @seealso
#' \code{\link[qtlcharts]{iplotMap}} from the \pkg{qtlcharts} package
#'
#' \code{\link[htmlwidgets]{saveWidget}}
#'
#' @examples
#' ## basic usage with and without groups
#' itree(setNames(rnorm(10), letters[1:10]))
#' itree(setNames(rnorm(20), letters[1:20]), group = 1:4)
#'
#' ## another example
#' set.seed(1)
#' n <- 100
#' ng <- 5
#' gr <- sort(sample(LETTERS[1:ng], n, replace = TRUE))
#' yv <- kinda_sort(runif(n, -1, 1), n = n / 2) * 100
#' itree(yv, gr, main = 'Subject response from baseline',
#' ylim = c(-100,100), xlab = 'Treatment arm', ylab = '% change')
#'
#' ## search is more useful with lots of data
#' set.seed(1)
#' p0 <- function(x) paste0(x, collapse = '')
#' n <- 500
#' gr <- replicate(n, (function()
#' p0(sample(c('A','T','C','G'), 15, replace = TRUE)))())
#' y <- setNames(rpois(n, 40), gr)
#'
#' ## hacky way to remove tick labels which start running together
#' gr_labels <- Map(function(x) p0(rep(' ', x)), sequence(n))
#'
#' itree(y, unlist(gr_labels), ylab = 'Frequency', xlab = 'Sequence',
#' plotOpts = list(tickwidth = 2, linewidth = 5, width = 2000))
#'
#' @export
itree <- function(y, group, ylim = NULL, xlab = NULL, ylab = NULL,
main = NULL, plotOpts = NULL, digits = NULL) {
xl <- deparse(substitute(group))
yl <- deparse(substitute(y))
## reverse ylim since default axis is reversed
ylim <- rev(if (is.null(ylim)) range(y) else ylim)
group <- rep_len(if (missing(group)) 1 else group, length(y))
## make sure y names are unique--search is not useful without proper names
## doesnt seem to work with some characters or names with leading digits
y <- if (!is.null(names(y))) {
if (!length(y) == length(unique(names(y)))) {
message('duplicate names found in \'y\' - creating unique names')
setNames(y, make.unique(names(y)))
} else y
} else setNames(y, sprintf('%s-%s', group,
ave(seq_along(y), group, FUN = seq_along)))
# names(y) <- make.names(names(y))
sp <- split(y, group)
lg <- vapply(sp, length, integer(1))
map <- structure(
lapply(sp, function(x) structure(x, class = 'A')),
class = 'map'
)
map_list <- convert_map(map)
opts <- list(xlab = xlab %||% xl, ylab = ylab %||% yl,
title = main, ylim = ylim)
x <- list(data = map_list,
chartOpts = rm_alpha_plotOpts(c(opts, plotOpts)))
if (!is.null(digits))
attr(x, 'TOJSON_ARGS') <- list(digits = digits)
defaultAspect <- 1.5
browsersize <- getPlotSize(defaultAspect)
htmlwidgets::createWidget(
name = 'iplotMap', x = x,
width = plotOpts$width, height = plotOpts$height,
sizingPolicy = htmlwidgets::sizingPolicy(
browser.defaultWidth = browsersize$width,
browser.defaultHeight = browsersize$height, knitr.defaultWidth = 1000,
knitr.defaultHeight = 1000 / defaultAspect
), package = 'qtlcharts'
)
}
#' icurve
#'
#' @description
#' Interactive curves over time with optional interactive scatter plots.
#'
#' Each timepoint is a column of \code{mat}, that is, times are treated as
#' discrete and assumed to be uniformly-spaced. Observations will be linked
#' across all plots (curves and optional scatter plots) by row index, so
#' observations should be in the same order in all data provided.
#'
#' @param mat a numeric matrix, \code{observations x timepoints}
#' @param labels optional character vector or named list of character vectors
#' to label each point; if \code{NULL}, points will be labeled by index
#' @param group vector of group (\code{\link{factor}}-like) variables
#' @param iscatter1 a numeric matrix or \code{NULL}, \code{nobs x 2}
#' @param iscatter2 see \code{iscatter1}
#' @param plotOpts list of additional plot options; see
#' \code{\link{icurveOpts}}
#' @param digits integer indicating number of significant digits to use
#'
#' @family iplots
#'
#' @seealso
#' \code{\link[qtlcharts]{iplotCurves}} from the \pkg{qtlcharts} package
#'
#' \code{\link[htmlwidgets]{saveWidget}}
#'
#' @examples
#' ## basic usage, no scatter plots
#' icurve(matrix(AirPassengers, ncol = 12, byrow = TRUE), labels = 1949:1960)
#'
#' ## connecting observations over time with additional linked scatter plots
#' set.seed(1)
#' n <- 25
#' ## 25 observations and 5 timepoints
#' mm <- cbind(runif(n, 0, 10), runif(n, 10, 50), runif(n, 30, 60),
#' runif(n, 40, 80), runif(n, 60, 100))
#' mm <- mm[order(mm[, 5]), ]
#'
#' ## two sets of data (25 obs x 2 columns: id and numeric data)
#' x1 <- cbind(1:n, kinda_sort(rnorm(n), n / 2))
#' x2 <- cbind(1:n, kinda_sort(sample(1:100, n), n / 2))
#'
#' icurve(
#' mat = mm, group = 1:25 %% 5 == 0,
#' iscatter1 = x1, iscatter2 = x2,
#' labels = list(
#' Patient = 1:25,
#' Disease = sample(c('ALL','CLL'), 25, replace = TRUE)
#' ),
#' plotOpts = list(
#' curves_xlab = 'Response evaluation time point',
#' curves_ylab = '% response',
#' scat1_xlab = 'Patient', scat1_ylab = 'Lab var 1',
#' scat2_xlab = 'Patient', scat2_ylab = 'Lab var 2'
#' )
#' )
#'
#' @export
icurve <- function(mat, labels, group, iscatter1 = NULL, iscatter2 = NULL,
plotOpts = NULL, digits = NULL) {
mat <- as.matrix(mat)
nr <- nrow(mat)
nc <- ncol(mat)
if (!is.null(iscatter1))
iscatter1 <- as.matrix(iscatter1)
if (!is.null(iscatter2))
iscatter2 <- as.matrix(iscatter2)
if (!is.numeric(iscatter1 %||% numeric(1)) ||
!is.numeric(iscatter2 %||% numeric(1)))
stop('Scatter matrices should be numeric')
if (!ident(nr, nrow(iscatter1) %||% nr, nrow(iscatter2) %||% nr))
stop('All matrices should have same number of observations (rows)')
if (!ident(ncol(iscatter1) %||% 2L, ncol(iscatter2) %||% 2L))
stop('Scatter matrices should have two columns')
if (is.null(iscatter1) && !is.null(iscatter2)) {
scatter1 <- scatter2
scatter2 <- NULL
}
times <- seq.int(nc)
group <- rep_len(if (missing(group)) 1 else group, nr)
group <- group2numeric(group)
indID <- if (!missing(labels)) get_labels(labels, nr) else rownames(mat)
dimnames(mat) <- dimnames(iscatter1) <- dimnames(iscatter2) <-
names(group) <- names(times) <- NULL
data_list <-
list(curve_data = list(x = list(times), y = mat, group = group, indID = indID))
if (!is.null(iscatter1))
data_list$scatter1_data <-
list(x = iscatter1[, 1L], y = iscatter1[, 2L], group = group, indID = indID)
if (!is.null(iscatter2))
data_list$scatter2_data <-
list(x = iscatter2[, 1L], y = iscatter2[, 2L], group = group, indID = indID)
x <- list(data = data_list, chartOpts = plotOpts)
if (!is.null(digits))
attr(x, 'TOJSON_ARGS') <- list(digits = digits)
defaultAspect <- 1.25
browsersize <- getPlotSize(defaultAspect)
htmlwidgets::createWidget(
name = 'iplotCurves', x = x,
width = plotOpts$width, height = plotOpts$height,
sizingPolicy = htmlwidgets::sizingPolicy(
browser.defaultWidth = browsersize$width,
browser.defaultHeight = browsersize$height,
knitr.defaultWidth = 1000,
knitr.defaultHeight = 1000 / defaultAspect
), package = 'qtlcharts'
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.