##' @title sc_geom_point ##' @rdname sc-geom-point ##' @param mapping aesthetic mapping ##' @param ... additional parameters pass to 'scattermore::geom_scattermore()' ##' @return layer of points ##' @importFrom scattermore geom_scattermore ##' @seealso [sc_dim()] and [sc_feature()] ##' @export ##' @examples ##' library(ggplot2) ##' ggplot(iris, ##' aes(x= Sepal.Length, y = Petal.Width, color=Species) ##' ) + ##' sc_geom_point() sc_geom_point <- function(mapping=NULL, ...){ default_params <- list(mapping = mapping, pointsize = 3, pixels = c(700, 700) ) params <- modifyList(default_params, list(...)) do.call(geom_scattermore2, params) } #' @title geom_bgpoint #' @description #' this add the background color for \code{\link[ggplot2]{geom_point}} #' @eval rd_aesthetics("geom", "bgpoint") #' @inheritParams ggplot2::layer #' @param na.rm If \code{FALSE}, the default, missing values are removed #' with a warning, if \code{TRUE}, missing values are silently removed. #' @param gap_colour colour of gap background between the bottom background #' and top point point layer, default is \code{white}. #' @param gap_alpha numeric the transparency of gap background colour, default is 1. #' @param bg_line_width numeric the line width of background point layer, #' default is \code{0.3}. #' @param gap_line_width numeric the line width of gap between the background and #' top point point layer, default is \code{.1}. #' @param pointsize numeric the size of point, default is NULL, will use the #' internal size aesthetics of \code{geom_bgpoint} #' @param ... Other arguments passed on to \code{\link[ggplot2]{layer}}. #' @details #' \itemize{ #' \item \code{colour} the colour of point, default is \code{black}. #' \item \code{bg_colour} the colour of background point, default is \code{NA}. #' \item \code{alpha} the transparency of colour, default is 1. #' \item \code{subset} subset the data frame which meet conditions to display. #' } #' @importFrom rlang list2 #' @author Shuangbin Xu #' @export #' @examples ##' library(ggplot2) ##' ggplot(iris, ##' aes(x= Sepal.Length, y = Petal.Width, color=Species, bg_colour=Species) ##' ) + ##' geom_bgpoint(pointsize=4, gap_line_width = .1, bg_line_width = .3) geom_bgpoint <- function( mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, gap_colour = 'white', gap_alpha = 1, bg_line_width = .3, gap_line_width = .1, pointsize = NULL ){ layer( data = data, mapping = mapping, stat = stat, geom = GeomBgpoint, position = position, show.legend = show.legend, inherit.aes = inherit.aes, params = list2( na.rm = na.rm, gap_colour = gap_colour, gap_alpha = gap_alpha, bg_line_width = bg_line_width, gap_line_width = gap_line_width, pointsize = pointsize, ... ) ) } #' @title geom_scattermore2 #' @description #' this add the background colour for the \code{\link[scattermore]{geom_scattermore}} #' @eval rd_aesthetics("geom", "scattermore2") #' @inheritParams ggplot2::layer #' @param na.rm If `FALSE`, the default, missing values are removed with #' a warning. If `TRUE`, missing values are silently removed. #' @param interpolate A logical value indicating whether to linearly interpolate #' the image (the alternative is to use nearest-neighbour interpolation, #' which gives a more blocky result). Default \code{FALSE}, #' passed to \code{\link[grid]{rasterGrob}}. #' @param pointsize Radius of rasterized point. Use ‘0’ for single pixels (fastest). #' @param pixels Vector with X and Y resolution of the raster, default \code{c(512,512)}. #' @param gap_colour colour of gap background between the bottom background #' and top point point layer, default is \code{white}. #' @param gap_alpha numeric the transparency of gap background colour, default is 1. #' @param bg_line_width numeric the line width of background point layer, #' default is \code{0.3}. #' @param gap_line_width numeric the line width of gap between the background and #' top point point layer, default is \code{.1}. #' @param ... Other arguments passed on to \code{\link[ggplot2]{layer}}. #' @details #' \itemize{ #' \item \code{colour} the colour of point, default is \code{black}. #' \item \code{bg_colour} the colour of background point, default is \code{NA}. #' \item \code{alpha} the transparency of colour, default is 1. #' \item \code{subset} subset the data frame which meet conditions to display. #' } #' @return polygonal point layer #' @importFrom ggplot2 layer #' @author Shuangbin Xu #' @export #' @examples ##' library(ggplot2) ##' ggplot(iris, ##' aes(x= Sepal.Length, y = Petal.Width, color=Species, bg_colour=Species) ##' ) + ##' geom_scattermore2(pointsize=4, gap_line_width = .1, bg_line_width = .3) geom_scattermore2 <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", ..., na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, interpolate = FALSE, pointsize = 0, pixels = c(512, 512), gap_colour = 'white', gap_alpha = 1, bg_line_width = .3, gap_line_width = .1){ ggplot2::layer( data = data, mapping = mapping, stat = stat, position = position, geom = GeomScattermore2, show.legend = show.legend, inherit.aes = inherit.aes, params = list2( na.rm = na.rm, interpolate = interpolate, pointsize = pointsize, pixels = pixels, gap_colour = gap_colour, gap_alpha = gap_alpha, bg_line_width = bg_line_width, gap_line_width = gap_line_width, ... ) ) } #' @importFrom scattermore scattermore GeomScattermore2 <- ggplot2::ggproto("GeomScattermore2", ggplot2::Geom, required_aes = c("x", "y"), non_missing_aes = c("alpha", "colour"), optional_aes = c("subset"), default_aes = ggplot2::aes( shape = 19, colour = "black", size = 1.5, fill = NA, alpha = 1, stroke = 0.5, bg_colour = NA ), setup_data = function(data, params){ if (is.null(data$subset)) return(data) data[which(data$subset),] }, draw_panel = function(data, pp, coord, pointsize = 0, interpolate = FALSE, na.rm = FALSE, pixels = c(512, 512), gap_colour = 'white', gap_alpha = 1, bg_line_width = .3, gap_line_width = .1){ coords <- coord$transform(data, pp) upperimage <- scattermore(cbind(coords$x, coords$y), rgba = grDevices::col2rgb(alpha = TRUE, scales::alpha(coords$colour, coords$alpha)), cex = pointsize, xlim = c(0, 1), ylim = c(0, 1), size = pixels) if (!all(is.null(coords$bg_colour)) && !all(is.na(coords$bg_colour))){ tmpsize <- sqrt(pointsize) gapsize <- (tmpsize + tmpsize * gap_line_width * 2)^2 bgsize <- gapsize + (sqrt(bg_line_width) + tmpsize * bg_line_width * 2) ^2 bgimage <- scattermore(cbind(coords$x, coords$y), rgba = grDevices::col2rgb(alpha = TRUE, scales::alpha(coords$bg_colour, 1)), cex = bgsize, xlim = c(0, 1), ylim = c(0, 1), size = pixels) gapimage <- scattermore(cbind(coords$x, coords$y), rgba = grDevices::col2rgb(alpha = TRUE, scales::alpha(gap_colour, gap_alpha)), cex = gapsize, xlim = c(0, 1), ylim = c(0, 1), size = pixels) }else{ bgimage <- gapimage <- NULL } ggplot2:::ggname( "geom_scattermore2", crasterGrob( upperimage, bgimage, gapimage, 0, 0, 1, 1, default.units = "native", just = c("left", "bottom"), interpolate = interpolate ) ) }, draw_key = draw_key_bgpoint ) #' @importFrom ggplot2 translate_shape_string draw_key_point GeomBgpoint <- ggplot2::ggproto("GeomBgpoint", ggplot2::Geom, required_aes = c("x", "y"), non_missing_aes = c("alpha", "colour"), optional_aes = c("subset"), default_aes = ggplot2::aes( shape = 19, colour = "black", size = 1.5, fill = NA, alpha = 1, stroke = 0.5, bg_colour = NA ), setup_data = function(data, params){ if (is.null(data$subset)) return(data) data[which(data$subset),] }, draw_panel = function(self, data, panel_params, coord, na.rm = FALSE, gap_colour = 'white', gap_alpha = 1, bg_line_width = .3, gap_line_width = .1, pointsize = NULL ){ if (is.character(data$shape)) { data$shape <- translate_shape_string(data$shape) } coords <- coord$transform(data, panel_params) stroke_size <- coords$stroke stroke_size[is.na(stroke_size)] <- 0 if (is.null(pointsize)){ pointsize <- coords$size * .pt + stroke_size * .stroke / 2 }else{ pointsize <- rep(pointsize, nrow(coords)) * .pt + stroke_size * .stroke/2 } ggname("geom_bgpoint", cpointsGrob( coords$x, coords$y, pch = coords$shape, bg_line_width = bg_line_width, gap_line_width = gap_line_width, bg_colour = coords$bg_colour, gap_colour = alpha(gap_colour, gap_alpha), gp = gpar( col = alpha(coords$colour, coords$alpha), fill = fill_alpha(coords$fill, coords$alpha), fontsize = pointsize, lwd = coords$stroke * .stroke / 2 ) ) ) }, draw_key = draw_key_bgpoint ) #' @importFrom grid grobName ggname <- function (prefix, grob){ grob$name <- grobName(grob, prefix) grob }