apexcharter/R/annotations.R

207 lines
5.9 KiB
R
Raw Normal View History

2020-04-02 19:33:39 +02:00
2020-04-03 16:15:18 +02:00
add_annotation <- function(ax, type_annotation = c("xaxis", "yaxis", "points"),
as_date = FALSE, ...) {
type_annotation <- match.arg(type_annotation)
config <- dropNullsOrEmpty(list(...))
if (identical(type_annotation, "yaxis")) {
len <- length(config$y)
} else {
len <- length(config$x)
}
config <- rapply(
object = config,
f = rep_len,
length.out = len,
how = "replace"
)
extract <- function(el, position) {
`[`(el, position)
}
annotations <- lapply(
X = seq_len(len),
FUN = function(i) {
this <- rapply(
object = config,
f = extract,
position = i,
how = "list"
)
if (isTRUE(as_date)) {
this$x <- format_date(this$x)
this$x2 <- format_date(this$x2)
}
this
}
)
if (identical(type_annotation, "xaxis")) {
if (!is.null(ax$x$ax_opts$annotations$xaxis)) {
annotations <- c(annotations, ax$x$ax_opts$annotations$xaxis)
ax$x$ax_opts$annotations$xaxis <- NULL
}
ax <- ax_annotations(
ax = ax,
position = "back",
xaxis = annotations
)
} else if (identical(type_annotation, "yaxis")) {
if (!is.null(ax$x$ax_opts$annotations$yaxis)) {
annotations <- c(annotations, ax$x$ax_opts$annotations$yaxis)
ax$x$ax_opts$annotations$yaxis <- NULL
}
ax <- ax_annotations(
ax = ax,
position = "back",
yaxis = annotations
)
} else if (identical(type_annotation, "points")) {
if (!is.null(ax$x$ax_opts$annotations$points)) {
annotations <- c(annotations, ax$x$ax_opts$annotations$points)
ax$x$ax_opts$annotations$points <- NULL
}
ax <- ax_annotations(
ax = ax,
position = "back",
points = annotations
)
}
return(ax)
}
2020-04-03 15:26:01 +02:00
#' Label for annotations
#'
#' @param borderColor Border Color for the label.
#' @param borderWidth Border width for the label.
#' @param text Text for tha annotation label.
#' @param textAnchor The alignment of text relative to labels drawing position.
#' @param position Available options: left or right.
#' @param offsetX Sets the left offset for annotation label.
#' @param offsetY Sets the top offset for annotation label.
#' @param background Background Color for the annotation label.
#' @param color ForeColor for the annotation label.
#' @param fontSize FontSize for the annotation label.
#' @param fontWeight Font-weight for the annotation label.
#' @param fontFamily Font-family for the annotation label.
#' @param cssClass A custom Css Class to give to the annotation label elements.
#' @param padding Padding for the label: top, right, bottom, left.
#'
#' @return A \code{list} that can be used in \code{\link{add_shade}}.
#' @export
#'
label <- function(borderColor = NULL,
borderWidth = NULL,
text = NULL,
textAnchor = NULL,
position = NULL,
offsetX = NULL,
offsetY = NULL,
background = NULL,
color = NULL,
fontSize = NULL,
fontWeight = NULL,
fontFamily = NULL,
cssClass = NULL,
padding = NULL) {
dropNulls(list(
borderColor = borderColor,
borderWidth = borderWidth,
text = text,
textAnchor = textAnchor,
position = position,
offsetX = offsetX,
offsetY = offsetY,
style = dropNulls(list(
background = background,
color = color,
fontSize = fontSize,
fontWeight = fontWeight,
fontFamily = fontFamily,
padding = list(
top = padding[1],
right = padding[2],
bottom = padding[3],
left = padding[4]
)
))
))
}
2020-04-02 19:33:39 +02:00
#' @title Add a shaded area to a chart
#'
2020-04-02 19:38:49 +02:00
#' @description \code{add_shade()} allow to add a shaded area on specified range,
2020-04-02 19:33:39 +02:00
#' \code{add_shade_weekend()} add a shadow on every week-end.
#'
#' @param ax An \code{apexcharts} \code{htmlwidget} object.
#' @param from Vector of position to start shadow.
#' @param to Vector of position to end shadow.
#' @param color Color of the shadow.
#' @param opacity Opacity of the shadow.
2020-04-03 15:26:01 +02:00
#' @param label Add a label to the shade, see \code{\link{label}}.
2020-04-02 19:33:39 +02:00
#' @param ... Additional arguments, see
#' \url{https://apexcharts.com/docs/options/annotations/} for possible options.
#'
#' @note \code{add_shade_weekend} only works if variable
#' used for x-axis is of class \code{Date} or \code{POSIXt}.
#'
#' @return An \code{apexcharts} \code{htmlwidget} object.
#' @export
#'
#' @name add-shade
#'
#' @example examples/add_shade.R
2020-04-03 15:26:01 +02:00
add_shade <- function(ax, from, to, color = "#848484", opacity = 0.2, label = NULL, ...) {
2020-04-02 19:33:39 +02:00
if (length(from) != length(to)) {
stop("In add_shade: from and to must be of same length!", call. = FALSE)
}
2020-04-03 16:15:18 +02:00
add_annotation(
ax = ax,
type_annotation = "xaxis",
as_date = TRUE,
2020-04-02 19:33:39 +02:00
x = from,
x2 = to,
fillColor = color,
opacity = opacity,
2020-04-03 15:26:01 +02:00
label = label,
2020-04-02 19:33:39 +02:00
...
)
}
#' @export
#' @rdname add-shade
2020-04-03 15:26:01 +02:00
add_shade_weekend <- function(ax, color = "#848484", opacity = 0.2, label = NULL, ...) {
2020-04-02 19:33:39 +02:00
if (is.null(ax$x$xaxis)) {
stop("add_shade_weekend can only be used with apex().", call. = FALSE)
}
if (inherits(ax$x$xaxis$min, c("Date", "POSIXt"))) {
from <- as.Date(format(ax$x$xaxis$min, format = "%Y-%m-%d"))
to <- as.Date(format(ax$x$xaxis$max, format = "%Y-%m-%d"))
dates <- seq(from = from - 2, to = to + 2, by = "day")
if (inherits(ax$x$xaxis$min, "Date")) {
sat <- dates[format(dates, format = "%u") == 5]
time <- "12:00:00"
} else {
sat <- dates[format(dates, format = "%u") == 6]
time <- "00:00:00"
}
sun <- sat + 2
ax <- add_shade(
ax = ax,
from = paste(format(sat, format = "%Y-%m-%d"), time),
to = paste(format(sun, format = "%Y-%m-%d"), time),
color = color,
opacity = opacity,
2020-04-03 15:26:01 +02:00
label = label,
2020-04-02 19:33:39 +02:00
...
)
}
return(ax)
}