R/legend.R

In colorist: Coloring Wildlife Distributions in Space-Time

# legend_timecycle ----

#' Make an HCL legend for a cyclical sequence of distributions
#'
#' @description This function creates a legend to accompany a map describing
#'   a cyclical sequence of distributions.
#'
#' @param palette data frame containing a color palette generated by
#'   [palette_timecycle].
#' @param specificity logical indicating whether to visualize intensity
#'   and layer information for three specificity values (i.e., 0, 50, 100) or
#'   for a single specificity value (i.e., 100). Typically, a single specificity
#'   value is appropriate for [map_multiples] visualizations.
#' @param origin_label character vector with a single element to be used as the
#'   label at the 12 o'clock position of the legend wheel.
#' @param label_i character vector with a single element describing the meaning
#'   of intensity values.
#' @param label_l character vector with a single element describing the meaning
#'   of layer values.
#' @param label_s character vector with three elements describing differences
#'   in the meaning of three specificity values (i.e., 0, 50, 100).
#' @param return_df logical indicating whether to return the legend as a
#'   `ggplot2` object or return a data frame containing the necessary data to
#'   build the legend.
#'
#' @return A `ggplot2` plot object of the legend. Alternatively,
#'   `return_df = TRUE` will return a data frame containing the data needed
#'   to build the legend. The data frame columns are:
#'   - `specificity`: the degree to which intensity values are unevenly
#'   distributed across layers; mapped to chroma.
#'   - `layer_id`: integer identifying the layer containing the maximum
#'   intensity value; mapped to hue.
#'   - `color`: the hexadecimal color associated with the given layer and
#'   specificity values.
#'   - `intensity`: maximum cell value across layers divided by the maximum
#'   value across all layers and cells; mapped to alpha level.
#'
#' @family legend
#' @seealso [legend_timeline] for linear sequences of distributions and
#'   [legend_set] for distributions of distinct groups.
#' @export
#' @examples
#' # load field sparrow data
#' data(fiespa_occ)
#'
#' # generate hcl palette
#' pal <- palette_timecycle(fiespa_occ)
#'
#' # create legend for palette
#' legend_timecycle(pal)
legend_timecycle <- function(palette, specificity = TRUE, origin_label = NULL,
                             label_i = "Maximum\nintensity",
                             label_l = "Layer",
                             label_s =  c("Low specificity",
                                          "Moderate specificity",
                                          "High specificity"),
                             return_df = FALSE) {
  if (!is.data.frame(palette) || !inherits(palette, "palette_timecycle")) {
    stop("palette must be a color palette generated by palette_timecycle().")
  }
  if (!all(c("specificity", "layer_id", "color") %in% names(palette)) ||
      !all(c(0, 50, 100) %in% palette[["specificity"]])) {
    stop("Improperly formatted color palette, try using palette_timecycle().")
  }
  stopifnot(is.logical(specificity), length(specificity) == 1)
  if (!is.null(origin_label)) {
    stopifnot(is.character(origin_label), length(origin_label) == 1)
  }
  stopifnot(is.character(label_i), length(label_i) == 1)
  stopifnot(is.character(label_l), length(label_l) == 1)
  stopifnot(is.character(label_s), length(label_s) == 3)
  names(label_s) <- c(0, 50, 100)
  stopifnot(is.logical(return_df), length(return_df) == 1)

  # whether to show 3 or 1 wheels
  if (isTRUE(specificity)) {
    wheel <- palette[palette$specificity %in% c(0, 50, 100), ]
  } else {
    wheel <- palette[palette$specificity == 100, ]
    label_s <- c("100" = "")
  }

  # add intensity values
  wheel <- merge(wheel, data.frame(intensity = seq(0, 1, 0.05)))
  wheel <- wheel[order(wheel[["specificity"]], wheel[["layer_id"]],
                       wheel[["intensity"]]), ]
  row.names(wheel) <- NULL
  class(wheel) <- c("legend_timecycle", "data.frame")

  # return data without plotting if requested
  if (isTRUE(return_df)) {
    return(wheel)
  }

  # make named vector of colors
  tile_colors <- sort(unique(wheel$color))
  names(tile_colors) <- tile_colors

  # describe ggplot
  p <- ggplot2::ggplot(data = wheel) +
    ggplot2::aes_(x = ~ layer_id, y = ~ intensity, fill = ~ color,
                  alpha = ~ intensity) +
    ggplot2::facet_wrap(~ specificity, nrow = 1,
                        labeller = ggplot2::labeller(specificity = label_s)) +
    ggplot2::geom_tile(size = 0) +
    ggplot2::scale_fill_manual(values = tile_colors) +
    ggplot2::scale_alpha_continuous(range = c(0, 1)) +
    ggplot2::geom_linerange(x = 0.5, ymin = 0, ymax = 1, size = 0.5,
                            linetype = 3) +
    ggplot2::theme(plot.background = ggplot2::element_rect(fill = "white"),
                   panel.background = ggplot2::element_rect(fill = "white"),
                   panel.grid = ggplot2::element_blank(),
                   panel.spacing = ggplot2::unit(0, "lines"),
                   strip.background = ggplot2::element_blank(),
                   strip.text = ggplot2::element_text(size = 11),
                   axis.ticks = ggplot2::element_blank(),
                   axis.text = ggplot2::element_blank()) +
    ggplot2::xlab(label_l) +
    ggplot2::ylab(label_i) +
    ggplot2::guides(fill = FALSE, alpha = FALSE) +
    ggplot2::coord_polar(theta = "x", start = 0)


  # add origin label
  if (!is.null(origin_label)) {
    p <- p +
      ggplot2::geom_text(ggplot2::aes(x = 0.5, y = 1, label = origin_label),
                         fontface = "plain", vjust = -1, color = "gray60", size = 3)
  }

  return(p)
}


# legend_timeline ----

#' Make an HCL legend for a linear sequence of distributions
#'
#' @description This function creates a legend to accompany a map describing
#'   a linear sequence of distributions.
#'
#' @param palette data frame containing a color palette generated by
#'   [palette_timeline].
#' @param specificity logical indicating whether to visualize intensity
#'   and layer information for three specificity values (i.e., 0, 50, 100) or
#'   for a single specificity value (i.e., 100). Typically, a single specificity
#'   value is appropriate for [map_multiples] visualizations.
#' @param time_labels character vector with two elements to be used as labels
#'   for the start and end points of the time axis (i.e. x-axis) in the legend.
#' @param label_i character vector with a single element describing the meaning
#'   of intensity values.
#' @param label_l character vector with a single element describing the meaning
#'   of layer values.
#' @param label_s character vector with three elements describing differences
#'   in the meaning of specificity across three legend wheels.
#' @param axis_i character vector with two elements describing the meaning of
#'   low and high intensity values.
#' @param return_df logical indicating whether to return the legend as a
#'   `ggplot2` object or return a data frame containing the necessary data to
#'   build the legend.
#'
#' @return A `ggplot2` plot object of the legend. Alternatively,
#'   `return_df = TRUE` will return a data frame containing a data frame
#'   containing the data needed to build the legend. The data frame columns are:
#'   - `specificity`: the degree to which intensity values are unevenly
#'   distributed across layers; mapped to chroma.
#'   - `layer_id`: integer identifying the layer containing the maximum
#'   intensity value; mapped to hue.
#'   - `color`: the hexadecimal color associated with the given layer and
#'   specificity values.
#'   - `intensity`: maximum cell value across layers divided by the maximum
#'   value across all layers and cells; mapped to alpha level.
#'
#' @family legend
#' @seealso [legend_timecycle] for cyclical sequences of distributions and
#'   [legend_set] for distributions of distinct groups.
#' @export
#' @examples
#' # load fisher data
#' data(fisher_ud)
#'
#' # generate hcl palette
#' pal <- palette_timeline(fisher_ud)
#'
#' # create legend for palette
#' legend_timeline(pal)
legend_timeline <- function(palette, specificity = TRUE, time_labels = NULL,
                            label_i = "Maximum\nintensity",
                            label_l = "Layer",
                            label_s =  c("Low specificity",
                                         "Moderate specificity",
                                         "High specificity"),
                            axis_i = c("low", "high"),
                            return_df = FALSE) {
  if (!is.data.frame(palette) || !inherits(palette, "palette_timeline")) {
    stop("palette must be a color palette generated by palette_timeline().")
  }
  if (!all(c("specificity", "layer_id", "color") %in% names(palette)) ||
      !all(c(0, 50, 100) %in% palette[["specificity"]])) {
    stop("Improperly formatted color palette, try using palette_timeline().")
  }
  stopifnot(is.logical(specificity), length(specificity) == 1)
  if (!is.null(time_labels)) {
    stopifnot(is.character(time_labels), length(time_labels) == 2)
  }
  stopifnot(is.character(label_i), length(label_i) == 1)
  stopifnot(is.character(label_l), length(label_l) == 1)
  stopifnot(is.character(label_s), length(label_s) == 3)
  names(label_s) <- c(0, 50, 100)
  stopifnot(is.character(axis_i), length(axis_i) == 2)
  stopifnot(is.logical(return_df), length(return_df) == 1)

  # whether to show 3 or 1 timelines
  if (isTRUE(specificity)) {
    wheel <- palette[palette$specificity %in% c(0, 50, 100), ]
  } else {
    wheel <- palette[palette$specificity == 100, ]
    label_s <- c("100" = "")
  }

  # add intensity
  wheel <- merge(wheel, data.frame(intensity = seq(0, 1, 0.02)))
  wheel <- wheel[order(wheel[["specificity"]], wheel[["layer_id"]],
                       wheel[["intensity"]]), ]
  class(wheel) <- c("legend_timeline", "data.frame")

  # return data without plotting if requested
  if (isTRUE(return_df)) {
    return(wheel)
  }

  # make specificity labels for legend
  wheel$specificity <- factor(wheel$specificity, levels = c(100, 50, 0))

  # make named vector of colors
  tile_colors <- sort(unique(wheel$color))
  names(tile_colors) <- tile_colors

  # describe ggplot
  p <- ggplot2::ggplot(data = wheel) +
    ggplot2::aes_(x = ~ layer_id, y = ~ intensity, fill = ~ color,
                  alpha = ~ intensity) +
    ggplot2::facet_wrap(~ specificity, ncol = 1,
                        labeller = ggplot2::labeller(specificity = label_s)) +
    ggplot2::geom_tile(size = 0) +
    ggplot2::scale_fill_manual(values = tile_colors) +
    ggplot2::scale_alpha_continuous(range = c(0, 1)) +
    ggplot2::theme(plot.background = ggplot2::element_rect(fill = "white"),
                   panel.background = ggplot2::element_blank(),
                   panel.grid = ggplot2::element_blank(),
                   panel.spacing = ggplot2::unit(0, "lines"),
                   aspect.ratio = 0.4,
                   strip.background = ggplot2::element_blank(),
                   strip.text = ggplot2::element_text(size = 11),
                   axis.ticks = ggplot2::element_blank(),
                   axis.text.x = ggplot2::element_text(size = 9, hjust = 0.5,
                                                       vjust = 0.5),
                   axis.text.y = ggplot2::element_text(size = 9, hjust = 0.5,
                                                       vjust = 0.5,
                                                       angle = 90)) +
    ggplot2::scale_x_continuous(breaks = c(1, max(palette[["layer_id"]])),
                                labels = time_labels) +
    ggplot2::scale_y_continuous(breaks = c(0.15, 0.85),
                                labels = axis_i) +
    ggplot2::xlab(label_l) +
    ggplot2::ylab(label_i) +
    ggplot2::guides(fill = FALSE, alpha = FALSE) +
    ggplot2::coord_fixed(expand = F)

  return(p)
}

# legend_set ----

#' Make an HCL legend for an unordered set of distributions
#'
#' @description This function creates a legend to accompany a map describing
#'   an unordered set of distributions.
#'
#' @param palette data frame containing a color palette generated by
#'   [palette_set].
#' @param specificity logical indicating whether to visualize intensity and
#'   layer information for the full range of potential specificity values (i.e.,
#'   0-100) or for a single specificity value (i.e., 100). Typically, a single
#'   specificity value is appropriate for [map_multiples] visualizations.
#' @param group_labels (axis_l) character vector with labels for each distribution.
#' @param label_i character vector with a single element describing the meaning
#'   of specificity.
#' @param label_s character vector with a single element describing the meaning
#'   of intensity values.
#' @param axis_i character vector with two elements describing the meaning of
#'   low and high intensity values.
#' @param axis_s character vector with two elements describing the meaning of
#'   low and high specificity values.
#' @param return_df logical indicating whether to return the legend as a
#'   `ggplot2` object or return a data frame containing the necessary data to
#'   build the legend.
#'
#' @return A `ggplot2` plot object of the legend. Alternatively,
#'   `return_df = TRUE` will return a data frame containing a data frame
#'   containing the data needed to build the legend. The data frame columns are:
#'   - `specificity`: the degree to which intensity values are unevenly
#'   distributed across layers; mapped to chroma.
#'   - `layer_id`: integer identifying the layer containing the maximum
#'   intensity value; mapped to hue.
#'   - `color`: the hexadecimal color associated with the given layer and
#'   specificity values.
#'   - `intensity`: maximum cell value across layers divided by the maximum
#'   value across all layers and cells; mapped to alpha level.
#'
#' @family legend
#' @seealso [legend_timecycle] for cyclical sequences of distributions and
#'   [legend_timeline] for linear sequences of distributions.
#' @export
#' @examples
#' # load elephant data
#' data(elephant_ud)
#'
#' # generate hcl palette
#' pal <- palette_set(elephant_ud)
#'
#' # create legend for palettes
#' legend_set(pal)
legend_set <- function(palette, specificity = TRUE, group_labels = NULL,
                       label_i = "Maximum\nintensity",
                       label_s = "Specificity",
                       axis_i = c("low", "high"),
                       axis_s = c("low", "high"),
                       return_df = FALSE) {
  if (!is.data.frame(palette) || !inherits(palette, "palette_set")) {
    stop("palette must be a color palette generated by palette_set().")
  }
  if (!all(c("specificity", "layer_id", "color") %in% names(palette)) ||
      !all(c(0, 50, 100) %in% palette[["specificity"]])) {
    stop("Improperly formatted color palette, try using palette_set().")
  }
  stopifnot(is.logical(specificity), length(specificity) == 1)
  if (!is.null(group_labels)) {
    stopifnot(is.character(group_labels),
              length(group_labels) == length(unique(palette[["layer_id"]])))
  }
  stopifnot(is.character(label_i), length(label_i) == 1)
  stopifnot(is.character(label_s), length(label_s) == 1)
  stopifnot(is.character(axis_i), length(axis_i) == 2)
  stopifnot(is.character(axis_s), length(axis_s) == 2)
  stopifnot(is.logical(return_df), length(return_df) == 1)

  # whether to show multiple specificity values and labels
  if (isTRUE(specificity)) {
    wheel <- palette
  } else {
    wheel <- palette[palette$specificity == 100, ]
    label_s <- ""
  }

  # add intensity
  wheel <- merge(wheel, data.frame(intensity = seq(0, 1, 0.01)))
  wheel <- wheel[order(wheel[["specificity"]], wheel[["layer_id"]],
                       wheel[["intensity"]]), ]
  row.names(wheel) <- NULL
  class(wheel) <- c("legend_set", "data.frame")

  # return data without plotting if requested
  if (isTRUE(return_df)) {
    return(wheel)
  }

  # make labels for groups
  unique_ids <- sort(unique(palette[["layer_id"]]))
  if (is.null(group_labels)) {
    group_labels <- unique_ids
    names(group_labels) <- unique_ids
  } else {
    names(group_labels) <- unique_ids
  }

  # make named vector of colors
  tile_colors <- sort(unique(wheel$color))
  names(tile_colors) <- tile_colors

  # describe ggplot
  p <- ggplot2::ggplot(data = wheel) +
    ggplot2::aes_(x = ~ specificity, y = ~ intensity, fill = ~ color,
                  alpha = ~ intensity) +
    ggplot2::facet_wrap(~ layer_id, ncol = length(unique_ids),
                        labeller = ggplot2::labeller(layer_id = group_labels)) +
    ggplot2::geom_tile(size = 0) +
    ggplot2::scale_fill_manual(values = tile_colors) +
    ggplot2::scale_alpha_continuous(range = c(0, 1)) +
    ggplot2::theme(plot.background = ggplot2::element_rect(fill = "white"),
                   panel.background = ggplot2::element_rect(fill = "white"),
                   panel.grid = ggplot2::element_blank(),
                   panel.spacing = ggplot2::unit(0.5, "lines"),
                   aspect.ratio = 1,
                   strip.background = ggplot2::element_blank(),
                   strip.text = ggplot2::element_text(size = 11),
                   axis.ticks = ggplot2::element_blank(),
                   axis.text.x = ggplot2::element_text(size = 9, hjust = 0.5, vjust = 0.5),
                   axis.text.y = ggplot2::element_text(size = 9, hjust = 0.5, vjust = 0.5, angle = 90)) +
    ggplot2::scale_x_continuous(breaks = c(15, 85), labels = axis_s) +
    ggplot2::scale_y_continuous(breaks = c(0.15, 0.85), labels = axis_i) +
    ggplot2::xlab(label_s) +
    ggplot2::ylab(label_i) +
    ggplot2::guides(fill = FALSE, alpha = FALSE, color = FALSE) +
    ggplot2::coord_fixed(expand = F)

  return(p)
}