apexcharter/R/annotations.R

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)
}





#' 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 label’s 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]
      )
    ))
  ))
}


#' @title Add a shaded area to a chart
#' 
#' @description \code{add_shade()} allow to add a shaded area on specified range,
#'  \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.
#' @param label Add a label to the shade, see \code{\link{label}}.
#' @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
add_shade <- function(ax, from, to, color = "#848484", opacity = 0.2, label = NULL, ...) {
  if (length(from) != length(to)) {
    stop("In add_shade: from and to must be of same length!", call. = FALSE)
  }
  add_annotation(
    ax = ax, 
    type_annotation = "xaxis", 
    as_date = TRUE, 
    x = from,
    x2 = to,
    fillColor = color,
    opacity = opacity,
    label = label,
    ...
  )
}



#' @export
#' @rdname add-shade
add_shade_weekend <- function(ax, color = "#848484", opacity = 0.2, label = NULL, ...) {
  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,
      label = label,
      ...
    )
  }
  return(ax)
}