Skip to content

Commit

Permalink
Merge pull request #33 from huichen99/patch-2
Browse files Browse the repository at this point in the history
Create discrete-bmj.R
  • Loading branch information
nanxstats authored May 20, 2024
2 parents 3c813ad + d440912 commit 1df1f09
Showing 1 changed file with 99 additions and 0 deletions.
99 changes: 99 additions & 0 deletions R/discrete-bmj.R
Original file line number Diff line number Diff line change
@@ -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), ...)
}
}

0 comments on commit 1df1f09

Please sign in to comment.