add bg point layer vector

ronfinn · Jun 17, 2024 · 0bc813a · 0bc813a
1 parent 8682681
commit 0bc813a
Show file tree

Hide file tree

Showing 6 changed files with 318 additions and 34 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -8,7 +8,8 @@ S3method(ggplot_add,sc_dim_geom_label)
 S3method(ggplot_add,sc_geom_annot)
 export("%<+%")
 export(aes)
-export(draw_key_scattermore2)
+export(draw_key_bgpoint)
+export(geom_bgpoint)
 export(geom_scattermore2)
 export(sc_dim)
 export(sc_dim_count)
@@ -60,6 +61,7 @@ importFrom(ggplot2,element_blank)
 importFrom(ggplot2,element_text)
 importFrom(ggplot2,facet_grid)
 importFrom(ggplot2,facet_wrap)
+importFrom(ggplot2,fill_alpha)
 importFrom(ggplot2,geom_blank)
 importFrom(ggplot2,geom_col)
 importFrom(ggplot2,geom_point)
@@ -84,6 +86,7 @@ importFrom(ggplot2,stat_ellipse)
 importFrom(ggplot2,theme)
 importFrom(ggplot2,theme_bw)
 importFrom(ggplot2,theme_minimal)
+importFrom(ggplot2,translate_shape_string)
 importFrom(ggplot2,waiver)
 importFrom(ggplot2,xlab)
 importFrom(ggplot2,ylab)
@@ -102,6 +105,7 @@ importFrom(grid,unit)
 importFrom(methods,as)
 importFrom(methods,setMethod)
 importFrom(rlang,.data)
+importFrom(rlang,list2)
 importFrom(scales,alpha)
 importFrom(scales,pal_identity)
 importFrom(scattermore,geom_scattermore)

diff --git a/R/draw_key.R b/R/draw_key.R
@@ -8,24 +8,36 @@
 #' @param params A list of additional parameters supplied to the geom.
 #' @param size Width and height of key in mm.
 #' @return A grid grob.
-#' @name draw_key_scattermore2
+#' @name draw_key_bgpoint
 #' @export
 #' @importFrom scales alpha
 #' @importFrom ggplot2 draw_key_point
 #' @importFrom grid grobTree pointsGrob
-draw_key_scattermore2 <- function(data, params, size){
-    pointkey <- draw_key_point(data, params, size)
-    if (is.null(data$bg_colour)){
-        return (pointkey)
-    }
-    
-    stroke_size <- data$stroke %||% 0.5
-    stroke_size[is.na(stroke_size)] <- 0
+#' @importFrom ggplot2 fill_alpha
+#' @export
+draw_key_bgpoint <- function(data, params, size){
+  if (is.null(data$shape)) {
+    data$shape <- 19
+  } else if (is.character(data$shape)) {
+    data$shape <- translate_shape_string(data$shape)
+  }
 
-    gp <- gpar(col = data$bg_colour, 
-               fontsize = (data$size %||% 1.5) * .pt + stroke_size * .stroke / 2,
-               lwd = (data$stroke %||% 0.5) * 4)
-    grobTree(pointkey, pointsGrob(0.5, 0.5, pch = 21, gp = gp))
+  # NULL means the default stroke size, and NA means no stroke.
+  stroke_size <- data$stroke %||% 0.5
+  stroke_size[is.na(stroke_size)] <- 0
+  cpointsGrob(0.5, 0.5,
+    pch = data$shape,
+    bg_colour = data$bg_colour,
+    gap_colour = alpha(params$gap_colour %||% "black", params$gap_alpha),
+    bg_line_width = params$bg_line_width,
+    gap_line_width = params$gap_line_width,
+    gp = gpar(
+      col = alpha(data$colour %||% "black", data$alpha),
+      fill = fill_alpha(data$fill %||% "black", data$alpha),
+      fontsize = (data$size %||% 1.5) * .pt + stroke_size * .stroke / 2,
+      lwd = stroke_size * .stroke / 2
+    )
+  )    
 }
 
 .pt <- 2.845276

diff --git a/R/pointsGrob2.R b/R/pointsGrob2.R
@@ -52,36 +52,35 @@ grid.craster <- function (image, bg.image, gap.image, x = unit(0.5, "npc"),
 ##' @importFrom grid pointsGrob
 cpointsGrob <- function(x = stats::runif(10), y = stats::runif(10), pch = 1,
     size = unit(1, "char"), bg_line_width = .3, gap_line_width = .1,
-    bg_colour = "black", gap.colour = 'white', default.units = "native",
+    bg_colour = "black", gap_colour = 'white', default.units = "native",
     name = NULL, gp = gpar(), vp = NULL){
 
     upperPointGrob <- pointsGrob(x = x, y = y, pch = pch, size = size,
                                 default.units = default.units, name = name,
                                 gp = gp, vp = vp)
 
-    if (is.null(bg_colour)){
+    if (is.null(bg_colour) || all(is.na(bg_colour))){
         return(upperPointGrob)
     }
 
-    gp.bg <- gp
-    gp.gap <- gp
+    gp_bg <- gp
+    gp_gap <- gp
 
-    gp.bg$col <- bg_colour
-    gp.gap$col <- gap.colour
-
-    gp$fontsize
+    gp_bg$col <- bg_colour
+    gp_gap$col <- gap_colour
 
     tmpsize <- sqrt(gp$fontsize)
-    gp.gap$fontsize <- (tmpsize + tmpsize * gap_line_width * 2)^2
-    gp.bg$fontsize <- gp.gap$fontsize + (sqrt(bg_line_width) + tmpsize * bg_line_width * 2) ^2
-
+    gp_gap_size <- (tmpsize + tmpsize * gap_line_width * 2)^2
+    gp_bg_size <- gp_gap_size + (sqrt(bg_line_width) + tmpsize * bg_line_width * 2) ^2
+    gp_gap$fontsize <- gp_gap_size
+    gp_bg$fontsize <- gp_bg_size
     gapPointGrob <- pointsGrob(x = x, y = y, pch = pch, size = size,
                               default.units = default.units, name = name,
-                              gp = gp.gap, vp = vp)
+                              gp = gp_gap, vp = vp)
 
     bgPointGrob <- pointsGrob(x = x, y = y, pch = pch, size = size,
                              default.units = default.units, name = name,
-                             gp = gp.bg, vp = vp)
+                             gp = gp_bg, vp = vp)
 
     grobs <- gList(bgPointGrob, gapPointGrob, upperPointGrob)
     gTree(children = grobs)
@@ -90,11 +89,11 @@ cpointsGrob <- function(x = stats::runif(10), y = stats::runif(10), pch = 1,
 ##' @importFrom grid grid.draw
 grid.cpoints <- function(x = stats::runif(10), y = stats::runif(10), pch = 1,
     size = unit(1, "char"), bg_line_width = .3, gap_line_width = .1,
-    bg_colour = "black", gap.colour = 'white', default.units = "native",
+    bg_colour = "black", gap_colour = 'white', default.units = "native",
     name = NULL, gp = gpar(), draw = TRUE, vp = NULL){
     pg <- cpointsGrob(x = x, y = y, pch = pch, size = size, bg_line_width = bg_line_width,
                       gap_line_width = gap_line_width, bg_colour = bg_colour,
-                      gap.colour = gap.colour, default.units = default.units, name = name,
+                      gap_colour = gap_colour, default.units = default.units, name = name,
                       gp = gp, vp = vp)
     if (draw) grid.draw(pg)
     invisible(pg)

diff --git a/R/sc-geom-point.R b/R/sc-geom-point.R
@@ -21,6 +21,76 @@ sc_geom_point <- function(mapping=NULL, ...){
     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}} 
@@ -71,7 +141,7 @@ geom_scattermore2 <- function(mapping = NULL, data = NULL, stat = "identity", po
     geom = GeomScattermore2,
     show.legend = show.legend,
     inherit.aes = inherit.aes,
-    params = list(
+    params = list2(
       na.rm = na.rm,
       interpolate = interpolate,
       pointsize = pointsize,
@@ -150,11 +220,71 @@ GeomScattermore2 <- ggplot2::ggproto("GeomScattermore2", ggplot2::Geom,
       )
     )
   },
-  draw_key = draw_key_scattermore2
+  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
 }
+
+
diff --git a/man/draw_key_scattermore2.Rd → man/draw_key_bgpoint.Rd b/man/draw_key_scattermore2.Rd → man/draw_key_bgpoint.Rd