Merge pull request #33 from huichen99/patch-2

Create discrete-bmj.R

R/discrete-bmj.R

@@ -0,0 +1,99 @@
+#' The BMJ Color Palettes
+#'
+#' Color palette inspired by plots in
+#' \emph{The BMJ}.
+#'
+#' @param palette Palette type.
+#' Currently there is one available option: \code{"default"}
+#' (7-color palette).
+#' @param alpha Transparency level, a real number in (0, 1].
+#' See \code{alpha} in \code{\link[grDevices]{rgb}} for details.
+#'
+#' @export pal_bmj
+#'
+#' @importFrom grDevices col2rgb rgb
+#' @importFrom scales manual_pal
+#'
+#' @author Hui Chen <\email{huichen@@zju.edu.cn}>
+#' Modified from Nan Xiao's code on JAMA pallett
+#'
+#' @examples
+#' library("scales")
+#' show_col(pal_bmj("default")(7))
+#' show_col(pal_bmj("default", alpha = 0.6)(7))
+pal_bmj <- function(palette = c("default"), alpha = 1) {
+  palette <- match.arg(palette)
+
+  if (alpha > 1L || alpha <= 0L) stop("alpha must be in (0, 1]")
+
+  raw_cols <- ggsci_db$"bmj"[[palette]]
+  raw_cols_rgb <- col2rgb(raw_cols)
+  alpha_cols <- rgb(
+    raw_cols_rgb[1L, ], raw_cols_rgb[2L, ], raw_cols_rgb[3L, ],
+    alpha = alpha * 255L, names = names(raw_cols),
+    maxColorValue = 255L
+  )
+
+  manual_pal(unname(alpha_cols))
+}
+
+#' Journal of the American Medical Association Color Scales
+#'
+#' See \code{\link{pal_bmj}} for details.
+#'
+#' @inheritParams pal_bmj
+#' @param ... additional parameters for \code{\link[ggplot2]{discrete_scale}}
+#'
+#' @export scale_color_bmj
+#'
+#' @importFrom ggplot2 discrete_scale
+#'
+#' @author Nan Xiao <\email{me@@nanx.me}> |
+#' <\href{https://nanx.me}{https://nanx.me}>
+#'
+#' @rdname scale_bmj
+#'
+#' @examples
+#' library("ggplot2")
+#' data("diamonds")
+#'
+#' ggplot(
+#'   subset(diamonds, carat >= 2.2),
+#'   aes(x = table, y = price, colour = cut)
+#' ) +
+#'   geom_point(alpha = 0.7) +
+#'   geom_smooth(method = "loess", alpha = 0.1, size = 1, span = 1) +
+#'   theme_bw() +
+#'   scale_color_bmj()
+#'
+#' ggplot(
+#'   subset(diamonds, carat > 2.2 & depth > 55 & depth < 70),
+#'   aes(x = depth, fill = cut)
+#' ) +
+#'   geom_histogram(colour = "black", binwidth = 1, position = "dodge") +
+#'   theme_bw() +
+#'   scale_fill_bmj()
+scale_color_bmj <- function(palette = c("default"), alpha = 1, ...) {
+  palette <- match.arg(palette)
+  if (is_ggplot2_350()) {
+    discrete_scale("colour", palette = pal_bmj(palette, alpha), ...)
+  } else {
+    discrete_scale("colour", scale_name = "bmj", palette = pal_bmj(palette, alpha), ...)
+  }
+}
+
+#' @export scale_colour_bmj
+#' @rdname scale_bmj
+scale_colour_bmj <- scale_color_bmj
+
+#' @export scale_fill_bmj
+#' @importFrom ggplot2 discrete_scale
+#' @rdname scale_bmj
+scale_fill_bmj <- function(palette = c("default"), alpha = 1, ...) {
+  palette <- match.arg(palette)
+  if (is_ggplot2_350()) {
+    discrete_scale("fill", palette = pal_bmj(palette, alpha), ...)
+  } else {
+    discrete_scale("fill", scale_name = "bmj", palette = pal_bmj(palette, alpha), ...)
+  }
+}