R/decoration.R

In ggspectra: Extensions to 'ggplot2' for Radiation Spectra

#' Add decorations to spectrum plot (private)
#'
#' Add decorations to plots generated by the \code{autoplot()} methods defined in
#' this package. It collects code that is common to \code{autoplot()} methods for
#' different types of spectra but as it may change in the future it is not
#' exported.
#'
#' @param w.band waveband object or list of waveband objects
#' @param y.max,y.min,x.max,x.min,x.expanse,y.expanse numeric
#' @param annotations character vector
#' @param span numeric
#' @param strict logical
#' @param wls.target numeric or character vector
#' @param label.qty character
#' @param summary.label character
#' @param text.size numeric
#' @param label.color color definition or name
#' @param chroma.type character one of "CMF" (color matching function) or "CC"
#'   (color coordinates) or a \code{\link[photobiology]{chroma_spct}} object.
#' @param pos.shift numeric
#' @param na.rm logical
#'
#' @return A list of ggplot "components" that can be added to a ggplot object
#'   with operator \code{+}. The length of the list depends on the value of argument
#'   \code{annotations}.
#'
#' @section Plot Annotations: The recognized annotation names are: \code{"summaries"}, \code{"peaks"},
#'   \code{"peak.labels"}, \code{"valleys"}, \code{"valley.labels"},
#'   \code{"wls"}, \code{"wls.labels"}, \code{"colour.guide"},
#'   \code{"color.guide"}, \code{"boxes"}, \code{"segments"}, \code{"labels"}.
#'   In addition, \code{"+"} is interpreted as a request to add to the already
#'   present default annotations, \code{"-"} as request to remove annotations
#'   and \code{"="} or missing\code{"+"} and \code{"-"} as a request to reset
#'   annotations to those requested. If used, \code{"+"}, \code{"-"} or
#'   \code{"="} must be the first member of a character vector, and followed by
#'   one or more of the names given above. To simultaneously add and remove
#'   annotations one can pass a \code{list} containing \code{character} vectors
#'   each assembled as described. The vectors are applied in the order they
#'   appear in the list. To disable all annotations pass \code{""} or
#'   \code{c("=", "")} as argument. Adding a variation of an annotation already
#'   present, replaces the existing one automatically: e.g., adding
#'   \code{"peak.labels"} replaces\code{"peaks"} if present.
#'
#' @details Vectors of character strings passed as argument to
#' \code{annotations} are parsed so that if the first member string is
#' \code{"+"}, the remaining members are added to the current default for
#' annotations; if it is \code{"-"} the remaining members are removed from the
#' current default for annotations; and if it is \code{"="} the remaining
#' members become the new default. If the first member is none of these three
#' strings, the whole vector becomes the new default. If \code{annotations} is
#' \code{NULL} the annotations are reset to the package defaults. When removing
#' annotations \code{"title*"}, \code{"peaks*"} and \code{"valleys*"} will
#' remove any variation of these annotations. The string \code{""} means no
#' annotations while \code{"reserve.space"} means no annotations but expand y
#' scale to reserve space for annotations. These two values take precedence over
#' any other values in the character vector. The order of the names of
#' annotations has no meaning: the vector is interpreted as a set except for the
#' three possible "operators" at position 1.
#'
#' @keywords internal
#'
decoration <- function(w.band,
                       y.max,
                       y.min,
                       x.max,
                       x.min,
                       x.expanse = x.max - x.min,
                       y.expanse = y.max - y.min,
                       annotations,
                       span,
                       strict = is.null(span),
                       wls.target = "HM",
                       label.qty,
                       label.mult = 1,
                       summary.label,
                       unit.out = NULL,
                       time.unit = NULL,
                       text.size = 2.5,
                       label.color = NULL,
                       chroma.type = "CMF",
                       pos.shift = 0,
                       na.rm = TRUE) {
  if (grepl(".pc", label.qty, fixed = TRUE)) {
    label.mult = 100
    label.qty <- sub(".pc", "", label.qty, fixed = TRUE)
  }
  if (!"summaries" %in% annotations) {
    label.qty <- "none"
  }
  stat_wb_summary <- switch(label.qty,
                            total = stat_wb_total,
                            mean = stat_wb_mean,
                            average = stat_wb_mean,
                            irrad = stat_wb_irrad,
                            sirrad = stat_wb_sirrad,
                            contribution = stat_wb_contribution,
                            relative = stat_wb_relative,
                            none = stat_wb_label,
                            function(...) {NA_real_},
                            na.rm = na.rm)
  z <- list()
  if ("peaks" %in% annotations) {
    nudge.y <- 0.012 * y.expanse
    z <- c(z,
           stat_peaks(geom = "text",
                      span = span,
                      ignore_threshold = 0.02,
                      strict = strict,
                      chroma.type = chroma.type,
                      label.fmt = "%.4g",
                      color = "red",
                      vjust = 0,
                      hjust = 0.5,
                      position = ggplot2::position_nudge(y = nudge.y),
                      size = text.size,
                      na.rm = na.rm),
           stat_peaks(geom = "point",
                      chroma.type = chroma.type,
                      color = "red",
                      span = span,
                      ignore_threshold = 0.02,
                      strict = strict,
                      shape = 16,
                      na.rm = na.rm))
  }
  if ("peak.labels" %in% annotations) {
    nudge.y <- 0.04 * y.expanse
    z <- c(z,
           stat_label_peaks(geom = "label_repel",
                            mapping = ggplot2::aes(color = after_stat(BW.color)),
                            span = span,
                            ignore_threshold = 0.02,
                            strict = strict,
                            chroma.type = chroma.type,
                            label.fmt = "%.4g",
                            size = text.size,
                            position = ggrepel::position_nudge_repel(y = nudge.y),
                            max.overlaps = Inf,
                            segment.colour = "black",
                            min.segment.length = 0,
                            box.padding = unit(0.1, "lines"),
                            direction = "both",
                            force = 1,
                            force_pull = 0.1,
                            na.rm = na.rm),
           stat_peaks(geom = "point",
                      chroma.type = chroma.type,
                      color = "black",
                      span = span,
                      ignore_threshold = 0.02,
                      strict = strict,
                      shape = "circle filled",
                      na.rm = na.rm))
  }
  if ("valleys" %in% annotations) {
    nudge.y <- -0.01 * y.expanse
    z <- c(z,
           stat_valleys(geom = "text",
                        span = span,
                        ignore_threshold = 0.02,
                        strict = strict,
                        chroma.type = chroma.type,
                        label.fmt = "%.4g",
                        size = text.size,
                        color = "blue",
                        vjust = 1,
                        hjust = 0.5,
                        position = ggplot2::position_nudge(y = nudge.y),
                        na.rm = na.rm),
           stat_valleys(geom = "point",
                        span = span,
                        ignore_threshold = 0.02,
                        strict = strict,
                        chroma.type = chroma.type,
                        color = "blue",
                        shape = 16,
                        na.rm = na.rm))
  }
  if ("valley.labels" %in% annotations) {
    nudge.y <- -0.04 * y.expanse
    z <- c(z,
           stat_label_valleys(geom = "label_repel",
                              mapping = ggplot2::aes(color = after_stat(BW.color)),
                              span = span,
                              ignore_threshold = -0.02,
                              strict = strict,
                              chroma.type = chroma.type,
                              label.fmt = "%.4g",
                              size = text.size,
                              position = ggrepel::position_nudge_repel(y = nudge.y),
                              max.overlaps = Inf,
                              segment.colour = "black",
                              min.segment.length = 0,
                              box.padding = unit(0.1, "lines"),
                              direction = "both",
                              force = 1,
                              force_pull = 0.1,
                              na.rm = na.rm),
           stat_valleys(geom = "point",
                        span = span,
                        ignore_threshold = -0.02,
                        strict = strict,
                        chroma.type = chroma.type,
                        color = "black",
                        shape = "circle filled",
                        na.rm = na.rm))
  }
  if ("wls" %in% annotations) {
    nudge.x <- 0.005 * x.expanse
    z <- c(z,
           stat_find_wls(geom = "text",
                         target = wls.target,
                         interpolate = TRUE,
                         chroma.type = chroma.type,
                         label.fmt = "%.4g",
                         color = "black",
                         hjust = 0,
                         position = ggplot2::position_nudge(x = nudge.x),
                         size = text.size,
                         na.rm = na.rm),
           stat_find_wls(geom = "point",
                         target = wls.target,
                         interpolate = TRUE,
                         chroma.type = chroma.type,
                         color = "black",
                         shape = 16,
                         na.rm = na.rm))
  }
  if ("wls.labels" %in% annotations) {
    nudge.x <- 0.03 * x.expanse
    z <- c(z,
           stat_find_wls(geom = "label_repel",
                         mapping = ggplot2::aes(color = after_stat(BW.color)),
                         target = wls.target,
                         interpolate = TRUE,
                         chroma.type = chroma.type,
                         label.fmt = "%.4g",
                         size = text.size,
                         position = ggrepel::position_nudge_repel(x = nudge.x),
                         vjust = 0.5,
                         hjust = 0,
                         segment.colour = "black",
                         min.segment.length = 0,
                         box.padding = unit(0.02, "lines"),
                         direction = "y",
                         force = 1,
                         force_pull = 1/4,
                         na.rm = na.rm),
           stat_find_wls(geom = "point",
                         target = wls.target,
                         interpolate = TRUE,
                         chroma.type = chroma.type,
                         color = "black",
                         shape = "circle filled",
                         na.rm = na.rm))
  }
  if ("colour.guide" %in% annotations) {
    z <- c(z,
           stat_wl_strip(chroma.type = chroma.type,
                         ymax = y.min + y.expanse * 1.26,
                         ymin = y.min + y.expanse * 1.22,
                         na.rm = na.rm,
                         color = NA))
  }
  if ("boxes" %in% annotations) {
    z <- c(z,
           stat_wl_strip(w.band = w.band,
                         chroma.type = chroma.type,
                         ymax = y.min + y.expanse * 1.20,
                         ymin = y.min + y.expanse * 1.08,
                         color = "white",
                         linetype = "solid",
                         na.rm = na.rm
           ))
  } else {
    label.color <- if (is.null(label.color)) {
      label.color <- "black"
    }
  }
  if ("segments" %in% annotations) {
    z <- c(z,
           stat_wl_strip(w.band = w.band,
                         chroma.type = chroma.type,
                         ymax = y.min + y.expanse * 1.10,
                         ymin = y.min + y.expanse * 1.07,
                         color = "white",
                         linetype = "solid",
                         na.rm = na.rm
           ))
    label.color <- "black"
    pos.shift <- 0.01
  }
  if ("labels" %in% annotations || "summaries" %in% annotations) {

    if ("labels" %in% annotations && "summaries" %in% annotations) {
      mapping <- ggplot2::aes(label = paste(after_stat(wb.name), after_stat(y.label), sep = "\n"),
                      color = after_stat(BW.color))
    } else if ("labels" %in% annotations) {
      mapping <- ggplot2::aes(label = after_stat(wb.name), color = after_stat(BW.color))
    } else if ("summaries" %in% annotations) {
      mapping <- ggplot2::aes(label = after_stat(y.label), color = after_stat(BW.color))
    }

    if ("summaries" %in% annotations) {
      if (label.qty %in% c("irrad", "sirrad")) {
        if (is.null(label.color)) {
          z <- c(z,
                 stat_wb_summary(geom = "text",
                                 unit.in = unit.out,
                                 time.unit = time.unit,
                                 w.band = w.band,
                                 label.mult = label.mult,
                                 chroma.type = chroma.type,
                                 ypos.fixed = y.min  + y.expanse * 1.143 + pos.shift,
                                 mapping = mapping,
                                 size = text.size,
                                 na.rm = na.rm))
        } else {
          z <- c(z,
                 stat_wb_summary(geom = "text",
                                 unit.in = unit.out,
                                 time.unit = time.unit,
                                 w.band = w.band,
                                 label.mult = label.mult,
                                 chroma.type = chroma.type,
                                 ypos.fixed = y.min  + y.expanse * 1.143 + pos.shift,
                                 color = label.color,
                                 mapping = mapping,
                                 size = text.size,
                                 na.rm = na.rm))
        }
      } else {
        if (is.null(label.color)) {
          z <- c(z, stat_wb_summary(geom = "text",
                                    w.band = w.band,
                                    label.mult = label.mult,
                                    chroma.type = chroma.type,
                                    ypos.fixed = y.min + y.expanse * 1.143 + pos.shift,
                                    mapping = mapping,
                                    size = text.size,
                                    na.rm = na.rm))
        } else {
          z <- c(z, stat_wb_summary(geom = "text",
                                    w.band = w.band,
                                    label.mult = label.mult,
                                    chroma.type = chroma.type,
                                    ypos.fixed = y.min  + y.expanse * 1.143 + pos.shift,
                                    color = label.color,
                                    mapping = mapping,
                                    size = text.size,
                                    na.rm = na.rm))
        }
      }
      z <- c(z,
             annotate(geom = "text",
                      x = x.min, y = y.min  + y.expanse * 1.09 + 0.5 * y.expanse * 0.085,
                      size = rel(2), vjust = -0.3, hjust = 0.5, angle = 90,
                      label = summary.label, parse = TRUE,
                      na.rm = na.rm))
    } else {
      if (is.null(label.color)) {
        z <- c(z,
               stat_wb_label(mapping = ggplot2::aes(color = after_stat(BW.color)),
                             w.band = w.band,
                             chroma.type = chroma.type,
                             ypos.fixed = y.min + y.expanse * (1.143 + pos.shift),
                             size = text.size,
                             na.rm = na.rm))
      } else {
        z <- c(z,
               stat_wb_label(w.band = w.band,
                             ypos.fixed = y.min + y.expanse * (1.143 + pos.shift),
                             color = label.color,
                             chroma.type = chroma.type,
                             size = text.size,
                             na.rm = na.rm))
      }

    }
  }
  z
}
# Silence NOTE in CRAN checks
utils::globalVariables(c("BW.color", "wb.name", "y.label"))

#' Merge user supplied annotations with default ones
#'
#' Allow users to add and subract from default annotations in addition
#' to providing a given set of annotations.
#'
#' @inheritSection decoration Plot Annotations
#' @inheritSection autotitle Title Annotations
#'
#' @param annotations,annotations.default character vector or a list of
#'   character vectors.
#'
#' @keywords internal
#'
decode_annotations <- function(annotations,
                               annotations.default = "colour.guide") {
  if (length(annotations) == 0L) { # handle character(0) and NULL without delay
    return(annotations.default)
  } else if (is.list(annotations)) {
    annotations.ls <- annotations
  } else if (is.character(annotations)) {
    annotations.ls <- list(annotations)
  }
  annotations <- NULL

  for (annotations in annotations.ls) {
    stopifnot(is.character(annotations))
    if ("color.guide" %in% annotations) {
      annotations <- c(setdiff(annotations, "color.guide"), "colour.guide")
    }
    if ("color.guide" %in% annotations.default) {
      annotations.default <- c(setdiff(annotations.default, "color.guide"), "colour.guide")
    }
    if (length(annotations) == 0L) { # we can receive character(0) from preceding iteration
      z <- annotations.default
    } else if ("" %in% annotations) {
      # no annotations and do not not expand y scale
      z <- ""
    } else if ("reserve.space" %in% annotations) {
      # no annotations but expand y scale to accomodate them
      z <- "reserve.space"
    } else if (annotations[1] == "-") {
      # remove any member of a "family" of annotations if '*' wild card is present
      if (any(grepl("^title[*]$", annotations))) {
        annotations.default <- annotations.default[!grepl("^title.*", annotations.default)]
      }
      if (any(grepl("^peaks[*]", annotations))) {
        annotations.default <- annotations.default[!grepl("^peak.*", annotations.default)]
      }
      if (any(grepl("^valleys[*]$", annotations))) {
        annotations.default <- annotations.default[!grepl("^valley.*", annotations.default)]
      }
      if (any(grepl("^wls[*]$", annotations))) {
        annotations.default <- annotations.default[!grepl("^wls.*", annotations.default)]
      }
      # remove exact matches
      z <- setdiff(annotations.default, annotations[-1])
    } else if (annotations[1] == "+") {
      annotations <- annotations[-1]
      # remove from default items to be replaced
      if (any(grepl("^title.*", annotations))) {
        annotations.default <- annotations.default[!grepl("^title.*", annotations.default)]
      }
      if (any(grepl("^peak.*", annotations))) {
        annotations.default <- annotations.default[!grepl("^peak.*", annotations.default)]
      }
      if (any(grepl("^valley.*$", annotations))) {
        annotations.default <- annotations.default[!grepl("^valley.*", annotations.default)]
      }
      if (any(grepl("^wls.*$", annotations))) {
        annotations.default <- annotations.default[!grepl("^wls.*", annotations.default)]
      }
      if (any(grepl("^boxes$|^segments$", annotations))) {
        annotations.default <- annotations.default[!grepl("^boxes$|^segments$", annotations.default)]
      }
      # merge default with addition
      z <- union(annotations.default, annotations)
    } else if (annotations[1] == "=") {
      # replace
      z <- annotations[-1]
      # handle character(0), using "" is a kludge but produces intuitive behaviour
      if (length(z) == 0L) {
        z <- ""
      }
    } else {
      z <- annotations
    }
    annotations.default <- z
  }

  unique(z) # remove duplicates for tidiness
}

# photobiology.plot.annotations -----------------------------------------------------

#' @title Set defaults for autoplot annotations
#'
#' @description Set R options used when plotting spectra. Option
#'   "photobiology.plot.annotations" is used as default argument to formal
#'   parameter \code{annotations} and option "photobiology.plot.bands" is used
#'   as default argument to formal parameter \code{w.band} in all the
#'   \code{autoplot()} methods exported from package 'ggspectra'. These
#'   convenience functions make it easier to edit these two option which are
#'   stored as a vector of characters strings and a list of waveband objects,
#'   respectively.
#'
#' @inheritSection decoration Plot Annotations
#' @inheritSection autotitle Title Annotations
#'
#' @param annotations character vector Annotations to add or remove from
#'   defaults used by the \code{autoplot()} methods defined in this package..
#'
#' @note The syntax used and behaviour are the same as for the
#'   \code{annotations} parameter of the \code{autoplot()} methods for spectra,
#'   but instead of affecting a single plot, \code{set_annotations_default()}
#'   changes the default used for subsequent calls to \code{autoplot()}.
#'
#' @return Previous value of option "photobiology.plot.annotations", returned
#'   invisibly.
#'
#' @family autoplot methods
#'
#' @export
#'
set_annotations_default <- function(annotations = NULL) {
  if (!is.null(annotations)) {
    annotations.default <-
      getOption("photobiology.plot.annotations",
                default =
                  c("boxes", "labels", "summaries", "colour.guide", "peaks"))
    annotations <- decode_annotations(annotations = annotations,
                                      annotations.default = annotations.default)
  }
  options(photobiology.plot.annotations = annotations)
}

#' @rdname set_annotations_default
#'
#' @param w.band a single waveband object or a list of waveband objects.
#'
#' @export
#'
set_w.band_default <- function(w.band = NULL) {
  if (!is.null(w.band)) {
    # validation to avoid delayed errors
    if (photobiology::is.waveband(w.band)) {
      w.band <- list(w.band) # optimization: avoid repeating this step
    }
    if (!all(sapply(w.band, is.waveband))) {
      warning("Bad 'w.band' argument, default not changed.")
      return(getOption("photobiology.plot.bands"))
    }
  }
  options(photobiology.plot.bands = w.band)
}