Nothing
#' @title Plotting boxplot using rAmCharts
#'
#' @description amBoxplot computes a boxplot of the given data values.
#' Can be a vector, a data.frame, or a matrix.
#'
#' @param object a vector, data.frame, a matrix, or a formula.
#' @param data \code{data.frame}, from which the variables in formula should be taken.
#' @param use.cols \code{logical}, for matrix only. Set to TRUE to display boxplot
#' based on columns.
#' @param xlab,ylab \code{character}, labels of the axis.
#' @param ylim \code{numeric}, y values range with sensible defaults.
#' @param names \code{character}, name on x-axis, if object is a vector.
#' @param col \code{character}, color(s) to be used to fill the boxplot.
#' @param horiz \code{logical}, TRUE to rotate chart.
#' @param id \code{character}, column name of id to
#' identify outliers, if object is a dataframe.
#' @param ... see \link{amOptions} for more options.
#'
#' @return An object of class \linkS4class{AmChart}.
#'
#' @examples
#'
#' \dontrun{
#' # 'numeric' (default)
#' amBoxplot(rnorm(100))
#'
#' # 'formula'
#' amBoxplot(count ~ spray, data = InsectSprays)
#'
#' # 'formula', two group
#' data <- InsectSprays
#' data$group <- c("H", "F")
#' amBoxplot(count ~ spray + group, data = data, col = c("purple", "darkblue"))
#'
#' # 'matrix'
#' x <- matrix(nrow = 10, ncol = 5, rnorm(50))
#' amBoxplot(x)
#'
#' # 'data.frame'
#' amBoxplot(iris[, 1:4])
#'
#' }
#' # Other examples available which can be time consuming depending on your configuration.
#'
#' @import data.table
#' @rdname amBoxplot
#'
#' @seealso \link{amOptions}, \link{amBarplot}, \link{amBoxplot}, \link{amHist}, \link{amPie},
#' \link{amPlot}, \link{amTimeSeries}, \link{amStockMultiSet}, \link{amBullet}, \link{amRadar},
#' \link{amWind}, \link{amFunnel}, \link{amAngularGauge}, \link{amSolidGauge}, \link{amMekko},
#' \link{amCandlestick}, \link{amFloatingBar}, \link{amOHLC}, \link{amWaterfall}
#'
#' @export
#'
#' @references See online documentation \url{https://datastorm-open.github.io/introduction_ramcharts/}
#' and \link{amChartsAPI}
amBoxplot <- function(object, ...) UseMethod("amBoxplot")
#' @rdname amBoxplot
#' @export
amBoxplot.default <- function(object, xlab = NULL, ylab = NULL, ylim = NULL,
names = NULL, col = "#1e90ff", horiz = FALSE, ...)
{
x <- object
value <- x
if (!is.null(xlab))
.testCharacterLength1(char = xlab)
if (!is.null(ylab))
.testCharacterLength1(char = ylab)
if (is.null(names(x))) {
id <- 1:length(x)
} else {
id <- names(x)
}
if (is.null(names)) {
names <- "x"
} else {
names <- names[1]
}
data <- data.table(value, id, group = names)
res <- data[, list(.dtBoxplotStat(list(value, id))), by = "group"]
sup_options <- list(...)
if("precision" %in% names(sup_options)){
precision <- sup_options$precision
} else {
precision <- 2
}
final.outliers <- .finalDataBoxplot(res, col = col, precision = precision)
chart <- .plotAmBoxplot(final.outliers, xlab = xlab,
ylab = ylab, ylim = ylim, horiz = horiz)
# return the object
amOptions(chart, ...)
}
#' @rdname amBoxplot
#' @examples
#' \donttest{
#' don <- data.frame(a = 1:10, b = 1:5)
#' amBoxplot(don, ylim = c(0,15))
#' }
#' @export
amBoxplot.data.frame <- function(object, id = NULL, xlab = NULL, ylab = NULL,
ylim = NULL, col = NULL, horiz = FALSE, ...)
{
x <- object
# quantitative variables
num_variables <- sapply(x, class)
num_variables <- names(num_variables)[!num_variables %in% c("character", "factor", "logical")]
xx <- x[, num_variables[!num_variables%in%id], drop = FALSE]
value <- do.call("c", xx)
if (is.null(colnames(xx))) {
group <- rep(1:ncol(x), each = nrow(xx))
} else {
group <- rep(colnames(xx), each = nrow(x))
}
if(is.null(id)){
id <- rep(1:nrow(x), ncol(x))
} else {
id <- rep(x[, id], nrow(x))
}
data <- data.table(value, group, id)
res <- data[, list(.dtBoxplotStat(list(value, id))), by = group]
sup_options <- list(...)
if("precision" %in% names(sup_options)){
precision <- sup_options$precision
} else {
precision <- 2
}
final.outliers <- .finalDataBoxplot(res, col = col, precision = precision)
chart <- .plotAmBoxplot(dp = final.outliers, xlab = xlab, ylab = ylab, ylim = ylim, horiz = horiz)
# return the object
chart <- setProperties(.Object = chart, RType_ = "barplot")
amOptions(chart, ...)
}
#' @rdname amBoxplot
#' @examples
#' \donttest{
#' # --- matrix
#' x <- matrix(nrow = 10, ncol = 5, rnorm(50))
#'
#' amBoxplot(x) # on columns
#' colnames(x) <- LETTERS[1:5]
#' amBoxplot(x) # with names
#' amBoxplot(x, use.cols = FALSE, col = c("blue", "red"))
#'
#' # Parameter for amOptions
#' amBoxplot(x, export = TRUE, exportFormat = "SVG")
#' }
#' @export
amBoxplot.matrix <- function(object, use.cols = TRUE, xlab = NULL, ylab = NULL,
ylim = NULL, col = NULL, horiz = FALSE, ...)
{
x <- object
if (use.cols) {
value <- as.vector(x)
if (is.null(colnames(x))) {
group <- rep(1:ncol(x), each = nrow(x))
} else {
group <- rep(colnames(x), each = nrow(x))
}
id <- rep(1:nrow(x), ncol(x))
} else {
value <- as.vector(t(x))
if (is.null(rownames(x))) {
group <- rep(1:nrow(x), each = ncol(x))
} else {
group <- rep(rownames(x), each = ncol(x))
}
id <- rep(1:ncol(x), nrow(x))
}
data <- data.table(value, group, id)
res <- data[, list(.dtBoxplotStat(list(value, id))), by = group]
sup_options <- list(...)
if("precision" %in% names(sup_options)){
precision <- sup_options$precision
} else {
precision <- 2
}
final.outliers <- .finalDataBoxplot(res, col = col, precision = precision)
chart <- .plotAmBoxplot(dp = final.outliers,xlab = xlab, ylab = ylab,
ylim = ylim, horiz = horiz)
# return the object
amOptions(chart, ...)
}
#' @rdname amBoxplot
#' @examples
#' \donttest{
#' # --- Formula
#' (obj <- amBoxplot(count ~ spray, data = InsectSprays))
#'
#' # Adding parameters
#' amBoxplot(count ~ spray, data = InsectSprays, ylim = c(0,50),
#' xlab = "spray", col = c("darkblue", "gray"))
#'
#' # Transpose
#' amBoxplot(count ~ spray, data = InsectSprays, ylim = c(0,50), xlab = "spray", horiz = FALSE)
#'
#' # Using a custom colum to identify outliers
#' InsectSprays$id <- paste0("ID : ", 1:nrow(InsectSprays))
#' amBoxplot(count ~ spray, data = InsectSprays, id = "id")
#'
#' # Parameter for amOptions
#' amBoxplot(count ~ spray, data = InsectSprays, main = "amcharts")
#' }
#' @export
amBoxplot.formula <-function(object, data = NULL, id = NULL, xlab = NULL, ylab = NULL,
ylim = NULL, col = NULL, horiz = FALSE, ...)
{
formula <- object
if (missing(formula) || (length(formula) != 3L))
stop("'formula' missing or incorrect")
data <- data.table(data)
if (is.null(id)) {
data[, id := 1:.N]
} else {
if (!id%in%colnames(data)) {
stop("Can't find '", id, "' column in data")
}
setnames(data, id, "id")
}
x <- as.character(formula)[2]
y <- gsub("^[[:space:]]|[[:space:]]$", "",
unlist(strsplit(as.character(formula)[3], "+", fixed = T)))
if(length(y) > 2){
stop("Invalid formula. Can only group per one or two variables, not more.")
}
res <- data[, list(.dtBoxplotStat(list(eval(parse(text = x)), id))), keyby = y]
# res <- res[order(res[, eval(parse(text = y))])]
sup_options <- list(...)
if("precision" %in% names(sup_options)){
precision <- sup_options$precision
} else {
precision <- 2
}
final.outliers <- .finalDataBoxplot(res, col = col, precision = precision)
chart <- .plotAmBoxplot(dp = final.outliers, xlab = xlab,
ylab = ylab, ylim = ylim, horiz = horiz)
# return the object
amOptions(chart, ...)
}
.plotAmBoxplot <- function(dp, xlab = NULL, ylab = NULL, ylim = NULL, horiz = FALSE)
{
if (!requireNamespace(package = "pipeR")) {
warning("Please install the package pipeR for running this function")
return (NULL)
} else {}
chart <- pipeR::pipeline(
amSerialChart(categoryField = "cat", theme = "light", rotate = horiz),
setDataProvider(dp, keepNA = FALSE),
addGraph(id = "g1", type = "candlestick",
balloonText = "High = <b>[[high_outlier]]</b><br/>3rd quart. = <b>[[close]]</b><br/>Median = <b>[[median]]</b><br/>1st quart. = <b>[[open]]</b><br/>Low = <b>[[low_outlier]]</b><br/>",
closeField = "close", fillColorsField = "color", highField = "high",
lineColor = "#7f8da9", lineAlpha = 1, lowField = "low",
fillAlphas = "0.9", negativeLineColor = "#7f8da9",
openField = "open", title = "Price:", valueField = "close",
columnWidth = 0.4),
addGraph(id = "g2", type = "step", valueField = "median",lineColor = "black",
noStepRisers = TRUE, balloonText = "", lineThickness = 3, periodSpan = 0.4),
addGraph(id = "g3", type = "step", valueField = "low_outlier",lineColor = "black",
noStepRisers = TRUE, balloonText = "", periodSpan = 0.3),
addGraph(id = "g4", type = "step", valueField = "high_outlier",lineColor = "black",
noStepRisers = TRUE, balloonText = "", periodSpan = 0.3),
addGraph(id = "g5", type = "line", valueField = "real_outlier",lineColor = "black",
lineAlpha = 0, bullet = "round", noStepRisers = TRUE, balloonText = "", periodSpan = 0.5)
)
if (ncol(dp) > 8) {
for (i in 1:(ncol(dp)-8)) {
chart <- addGraph(chart, type = "line", valueField = paste0("real_outlier_", i) ,lineColor = "black",
lineAlpha = 0, bullet = "round", noStepRisers = TRUE, periodSpan = 0.5,
balloonText = paste0("[[individual_",i,"]]<br/><b> Value </b>: [[real_outlier_",i,"]]"))
}
}
if (!is.null(ylab) & !is.null(ylim)) {
chart <- addValueAxes(chart, title = ylab, minimum = ylim[1], maximum = ylim[length(ylim)])
}
if (!is.null(ylab) & is.null(ylim)) {
chart <- addValueAxes(chart, title = ylab)
}
if (is.null(ylab) & !is.null(ylim)) {
chart <- addValueAxes(chart, minimum = ylim[1], maximum = ylim[length(ylim)])
}
info_guide <- NULL
if(all(c("cat1", "cat2") %in% colnames(dp))){
info_guide <- dp[, eval(parse(text = "list(category = cat[1], toCategory = cat[.N])")), by = "cat1"]
}
if (!is.null(xlab) & is.null(info_guide)) {
chart <- setCategoryAxis(chart, title = xlab)
}
if (!is.null(info_guide)) {
guides <- lapply(1:nrow(info_guide), function(x){
list(category = info_guide[x, eval(parse(text = "category"))],
toCategory = info_guide[x, eval(parse(text = "toCategory"))],
lineAlpha = 0.15,
tickLength = 30,
expand = TRUE,
label = info_guide[x, eval(parse(text = "cat1"))])
})
if(is.null(xlab)){
xlab = ""
}
cur_warn <- options("warn")$warn
options(warn = -1)
chart <- setCategoryAxis(chart, gridPosition = "start", axisAlpha = 0.5, gridAlpha = 0,
position = "left", guides = guides,
labelFunction = htmlwidgets::JS("function( label, item ) {
return item.dataContext.cat2;
}"), title = xlab)
options(warn = cur_warn)
}
# return the chart with argument 'RType_' for amOptions
setProperties(.Object = chart, RType_ = "boxplot")
}
.dtBoxplotStat <- function (data, coef = 1.5, do.out = TRUE)
{
xx <- data.table(x = data[[1]], id = data[[2]])[eval(parse(text = "!is.na(x)"))]
setkeyv(xx, "x")
n <- xx[, eval(parse(text = "sum(x)"))]
stats <- .dtFivenum(xx, na.rm = TRUE)
iqr <- diff(stats[c(2, 4)])
if (coef == 0) {
do.out <- FALSE
} else {
out <- if (!is.na(iqr)) {
xx[eval(parse(text = "x < (stats[2L] - coef * iqr) | x > (stats[4L] + coef *
iqr)")), eval(parse(text = "list(x, id)"))]
} else {
data.table()
}
if (nrow(out) > 0) {
stats[1] <- xx[eval(parse(text = "!id%in%out[, id]"))][, eval(parse(text = "min(x)"))]
stats[5] <- xx[eval(parse(text = "!id%in%out[, id]"))][, eval(parse(text = "max(x)"))]
# control des outliers
if(class(out$x) == "integer"){
out[, eval(parse(text = "x := as.numeric(x)"))]
}
out <- out[, eval(parse(text = "list(N = .N, id)")), by = "x"]
signif_n <- 6
in_wh <- FALSE
while(nrow(out[, eval(parse(text = "list(.N)")), by = "x"]) >= 500){
out[, eval(parse(text = "x := signif(x, signif_n)"))]
signif_n <- signif_n -1
in_wh <- TRUE
}
if(in_wh){
out <- out[, eval(parse(text = "list(N = .N, id)")), by = "x"]
}
out[eval(parse(text = 'N == 1')), eval(parse(text = 'label := "<b> Individual </b>: "'))]
out[eval(parse(text = 'N > 1')), eval(parse(text = '`:=`(label = "<b> Number of outliers </b>: ", id = N)'))]
out <- unique(out[, c("x", "id", "label"), with = FALSE])
out[, eval(parse(text = '`:=`(id = paste0(label, id), label = NULL)'))]
out
}
}
list(stats = stats, out = out)
}
.dtFivenum <- function (xx, na.rm = TRUE)
{
n <- nrow(xx)
if (n == 0) {
rep.int(NA, 5)
} else {
n4 <- floor((n + 3)/2)/2
d <- c(1, n4, (n + 1)/2, n + 1 - n4, n)
0.5 * (xx[floor(d), eval(parse(text = "x"))] + xx[ceiling(d), eval(parse(text = "x"))])
}
}
.finalDataBoxplot <- function(res, col = NULL, precision = 2)
{
if(ncol(res) == 2){
dp <- data.table(cat = as.character(res[seq(1, nrow(res), by = 2), eval(parse(text = colnames(res)[1]))]),
round(t(data.frame(res[seq(1, nrow(res), by = 2), eval(parse(text = "V1"))]))[, c(1,1:5, 5), drop = FALSE], precision))
setnames(dp, c("cat", "low_outlier", "low", "open", "median", "close", "high", "high_outlier"))
} else {
dp <- data.table(cat1 = as.character(res[seq(1, nrow(res), by = 2), eval(parse(text = colnames(res)[1]))]),
cat2 = as.character(res[seq(1, nrow(res), by = 2), eval(parse(text = colnames(res)[2]))]),
round(t(data.frame(res[seq(1, nrow(res), by = 2), eval(parse(text = "V1"))]))[, c(1,1:5, 5), drop = FALSE], precision))
setnames(dp, c("cat1", "cat2", "low_outlier", "low", "open", "median", "close", "high", "high_outlier"))
dp[, eval(parse(text = 'cat:= paste(cat1, cat2, sep = "-")'))]
}
if(is.null(col)){
col <- "#1e90ff"
}
dp$color <- rep(col, length.out=nrow(dp)) # recyle colors such as c("blue", "red") in test_amBoxplot.R
outliers <- as.list(res[seq(2, nrow(res), by = 2)])
# cat <- as.character(outliers[[1]])
cat <- dp$cat
addcat <- sapply(1:length(outliers[[ncol(res)]]), function(x){
if(nrow(outliers[[ncol(res)]][[x]]) > 0){
outliers[[ncol(res)]][[x]]$cat <<- cat[x]
} else {
outliers[[ncol(res)]][[x]] <<- data.table(x = 1, id = 1, cat = "")[x == 0]
}
})
outliers <- do.call("rbind", outliers[[ncol(res)]])
if(nrow(outliers) > 0){
outliers[, eval(parse(text = paste0("x := list(round(x, ", precision, "))")))]
split.outliers <- split(outliers, outliers$cat)
final.outliers <- NULL
ctrl <- lapply(split.outliers, function(x){
inter <- .formatOutlier(x)
if(is.null(final.outliers)){
final.outliers <<- inter
}else{
final.outliers <<- rbind(final.outliers, inter, fill = TRUE)
}
NULL
})
final.outliers$cat <- as.character(final.outliers$cat)
final.outliers <- merge(dp, final.outliers, all = TRUE, sort = FALSE, by = "cat")
}else{
final.outliers <- dp
}
final.outliers
}
.formatOutlier <- function(data)
{
if(is.list(data) & !"data.table"%in%class(data)){
data <- data.frame(rev(data))
}else{
data <- data.frame(t(c(data[, unique(cat)],data[, eval(parse(text = "x"))],data[, eval(parse(text = "id"))])))
}
colnames(data) <- c("cat", paste0("real_outlier_", 1:((ncol(data)-1)/2)),
paste0("individual_", 1:((ncol(data)-1)/2)))
data <- data.table(data[, c("cat",paste0(c("real_outlier_", "individual_"), rep(1:((ncol(data)-1)/2), each = 2)))])
setkey(data, cat)
data
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.