.

ChangeLog

@@ -0,0 +1,6 @@
+Version 0.13.0 (2024-09-024)
+    * Add 'mode' parameter to 'relx' and 'rely'.
+    * Suggest 'qs2' instead of 'qs'
+    * Add 'light_cool_colors' theme
+Version 0.12.0 (2023-04-06)
+    * Initial tracking

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: glow
 Title: Make Plots that Glow
-Version: 0.12.0
-Date: 2023-4-6
+Version: 0.13.0
+Date: 2024-09-24
 Authors@R: c(
     person("Travers", "Ching", email = "[email protected]", role = c("aut", "cre", "cph"))
 	)
@@ -17,8 +17,8 @@ Imports:
 Depends:
     ggplot2
 Suggests:
-    knitr, rmarkdown, viridisLite, magick, EBImage, qs
+    knitr, rmarkdown, viridisLite, magick, EBImage, qs2
 VignetteBuilder: knitr
-RoxygenNote: 7.1.2
+RoxygenNote: 7.3.2
 URL: https://github.com/traversc/glow
 BugReports: https://github.com/traversc/glow/issues

NAMESPACE

@@ -7,6 +7,7 @@ importFrom(grDevices, col2rgb, rgb, colorRampPalette, rainbow)
 useDynLib(glow, .registration=TRUE)
 export("theme_night",
        "light_heat_colors",
+       "light_cool_colors",
        "additive_alpha",
        "GlowMapper",
        "GlowMapper4",

R/glow_functions.r → R/glow_pkg_functions.R

@@ -18,6 +18,10 @@ light_heat_colors <- function(...) {
   colorRampPalette(c("red", "darkorange2", "darkgoldenrod1", "gold1", "yellow2"))(...)
 }
 
+light_cool_colors <- function(...) {
+  colorRampPalette(c("#1133AA", "#CCFFFF"))(...)
+}
+
 additive_alpha <- function(colors) {
   s <- seq(2, length(colors))
   x <- t(col2rgb(colors, alpha=F))/255
@@ -44,14 +48,42 @@ map_colors <- function(colors, x, min_limit=NULL, max_limit=NULL) {
   colors[findInterval(x, seq(min_limit, max_limit, length.out = length(colors) + 1), all.inside = TRUE)]
 }
 
-relx <- function(r) {
-  structure(r, class = "relx")
+relx <- function(r, mode = "data") {
+  structure(r, class = "relx", mode = mode)
 }
 
-rely <- function(r) {
-  structure(r, class = "rely")
+rely <- function(r, mode = "data") {
+  structure(r, class = "rely", mode = mode)
 }
 
+# internal helper function
+calculate_radius <- function(radius, xdiff, ydiff, self) {
+    plot_x_diff <- self$xmax - self$xmin
+    plot_y_diff <- self$ymax - self$ymin
+    if(inherits(radius, "relx")) {
+      rel_mode <- attr(radius, "mode")
+      attributes(radius) <- NULL
+      if(rel_mode == "data") {
+        radius <- xdiff * radius / self$x_aspect_ratio
+      } else if(rel_mode == "plot") {
+        radius <- plot_x_diff * radius / self$x_aspect_ratio
+      } else {
+        stop("relx mode must be 'data' or 'plot'")
+      }
+    } else if(inherits(radius, "rely")) {
+      rel_mode <- attr(radius, "mode")
+      attributes(radius) <- NULL
+      if(rel_mode == "data") {
+        radius <- ydiff * radius / self$y_aspect_ratio
+      } else if(rel_mode == "plot") {
+        radius <- plot_y_diff * radius / self$y_aspect_ratio
+      } else {
+        stop("rely mode must be 'data' or 'plot'")
+      }
+    } else {
+      radius
+    }
+}
 
 # GlowMapper ###################################
 GlowMapper <- R6Class("GlowMapper", list(
@@ -115,16 +147,7 @@ GlowMapper <- R6Class("GlowMapper", list(
     self$x_aspect_ratio <- max(xincrement / yincrement,1)
     self$y_aspect_ratio <- max(yincrement / xincrement,1)
 
-    if(inherits(radius, "relx")) {
-      class(radius) <- NULL
-      radius <- xdiff * radius / self$x_aspect_ratio
-    } else if(inherits(radius, "rely")) {
-      class(radius) <- NULL
-      radius <- ydiff * radius / self$y_aspect_ratio
-    } else {
-      # nothing
-    }
-    class(radius) <- NULL
+    radius <- calculate_radius(radius, xdiff, ydiff, self)
 
     self$plot_data <- data.frame(x, y, intensity, radius, distance_exponent)
 
@@ -275,17 +298,7 @@ GlowMapper4 <- R6Class("GlowMapper4", list(
     self$x_aspect_ratio <- max(xincrement / yincrement,1)
     self$y_aspect_ratio <- max(yincrement / xincrement,1)
 
-
-    if(inherits(radius, "relx")) {
-      class(radius) <- NULL
-      radius <- xdiff * radius / self$x_aspect_ratio
-    } else if(inherits(radius, "rely")) {
-      class(radius) <- NULL
-      radius <- ydiff * radius / self$y_aspect_ratio
-    } else {
-      # nothing
-    }
-    class(radius) <- NULL
+    radius <- calculate_radius(radius, xdiff, ydiff, self)
 
     self$plot_data <- data.frame(x, y, r,g,b, radius, distance_exponent)
 
@@ -460,16 +473,7 @@ LightMapper <- R6Class("LightMapper", list(
     self$x_aspect_ratio <- max(xincrement / yincrement,1)
     self$y_aspect_ratio <- max(yincrement / xincrement,1)
 
-    if(inherits(radius, "relx")) {
-      class(radius) <- NULL
-      radius <- xdiff * radius / self$x_aspect_ratio
-    } else if(inherits(radius, "rely")) {
-      class(radius) <- NULL
-      radius <- ydiff * radius / self$y_aspect_ratio
-    } else {
-      # nothing
-    }
-    class(radius) <- NULL
+    radius <- calculate_radius(radius, xdiff, ydiff, self)
 
     self$plot_data <- data.frame(x, y, intensity, radius, falloff_exponent, distance_exponent)
 
@@ -615,16 +619,7 @@ LightMapper4 <- R6Class("GlowMapper4", list(
     self$x_aspect_ratio <- max(xincrement / yincrement,1)
     self$y_aspect_ratio <- max(yincrement / xincrement,1)
 
-    if(inherits(radius, "relx")) {
-      class(radius) <- NULL
-      radius <- xdiff * radius / self$x_aspect_ratio
-    } else if(inherits(radius, "rely")) {
-      class(radius) <- NULL
-      radius <- ydiff * radius / self$y_aspect_ratio
-    } else {
-      # nothing
-    }
-    class(radius) <- NULL
+    radius <- calculate_radius(radius, xdiff, ydiff, self)
 
     self$plot_data <- data.frame(x, y, r,g,b, radius, distance_exponent, falloff_exponent)
 

R/zz_help_files.R

@@ -35,6 +35,25 @@ NULL
 #' @name light_heat_colors
 NULL
 
+# light_cool_colors ###################################################
+
+#' light_cool_colors
+#' 
+#' A light color palette.
+#' 
+#' @usage light_cool_colors(...)
+#' @param ... Arguments passed to the function returned by `colorRampPalette`
+#' @return A light color palette function
+#' @details A simple light color palette gradient from dark blue to light blue 
+#' intended for a heatmap with a white or light color background. 
+#'  
+#'  Equivalent to `colorRampPalette(c("#1133AA", "#CCFFFF"))(...)`.
+#' @examples
+#' light_colors <- light_cool_colors(144)
+#' plot(1:144, 1:144, col = light_colors, pch = 19)
+#' @name light_cool_colors
+NULL
+
 # circular_palette ###################################################
 
 #' circular_palette
@@ -94,9 +113,11 @@ NULL
 #' 
 #' Helper functions for specifying the `radius` parameter in `GlowMapper$map` and similar. 
 #' 
-#' @usage relx(r)
-#' @aliases relx
-#' @param r Radius of point data relative to X or Y range of the plot, a value between 0 and 1. 
+#' @usage relx(r, mode = "data")
+#' @usage rely(r, mode = "data")
+#' @param r Radius of point data relative to X or Y range of the plot, a value between 0 and 1.
+#' @param mode One of "data" (default) or "plot". Whether to use a radius relative to the extent 
+#' of the data range or the plot range (which could have been adjusted manually).
 #' @return A class structure for input to `GlowMapper$map`
 #' @details 
 #' Helper functions for specifying the `radius` parameter relative to the range of the plot as a proportion. 
@@ -126,7 +147,10 @@ NULL
 #' @name relxy
 NULL
 
-#' @usage rely(r)
+#' @aliases relx
+#' @name relxy
+NULL
+
 #' @aliases rely
 #' @name relxy
 NULL

README.md

@@ -95,7 +95,7 @@ ggplot() +
 ![](vignettes/diamonds_vignette_dark.png "diamonds_vignette_dark.png")
 
 ``` r
-# light color theme
+# light "heat" color theme
 light_colors <- light_heat_colors(144)
 ggplot() + 
   geom_raster(data = pd, aes(x = pd$x, y = pd$y, fill = pd$value), show.legend = FALSE) +
@@ -107,6 +107,19 @@ ggplot() +
 
 ![](vignettes/diamonds_vignette_light.png "diamonds_vignette_light.png")
 
+``` r
+# light "cool" color theme
+light_colors <- light_cool_colors(144)
+ggplot() + 
+  geom_raster(data = pd, aes(x = pd$x, y = pd$y, fill = pd$value), show.legend = FALSE) +
+  scale_fill_gradientn(colors = additive_alpha(light_colors)) +
+  coord_fixed(gm$aspect(), xlim = gm$xlim(), ylim = gm$ylim()) + 
+  labs(x = "carat", y = "price") + 
+  theme_bw(base_size = 14)
+```
+
+![](vignettes/diamonds_vignette_cool.png "diamonds_vignette_cool.png")
+
 ### Writing a raster image directly
 
 Instead of using ggplot, you can also output a raster image directly

inst/examples/examples.R

@@ -13,7 +13,7 @@
 
 library(dplyr)
 library(data.table)
-library(qs)
+library(qs2)
 
 library(glow)
 library(ggplot2)
@@ -59,7 +59,7 @@ output_width = 1920*4
 output_height = 1080*4
 outfile <- "plots/GAIA_galaxy_pseudocolor.png"
 
-stars <- qread("plot_data/gaia_stars.qs")
+stars <- qs_read("plot_data/gaia_stars.qs2")
 
 # Transform to galactic coordinates
 # https://gea.esac.esa.int/archive/documentation/GDR2/Data_processing/chap_cu3ast/sec_cu3ast_intro/ssec_cu3ast_intro_tansforms.html
@@ -116,7 +116,7 @@ writeImage(img, "plots/GAIA_galaxy_pseudocolor.png")
 
 outfile <- "plots/US_coronavirus_2021.png"
 
-cov_cases <- qread("plot_data/covid_confirmed_usafacts.qs")
+cov_cases <- qs_read("plot_data/covid_confirmed_usafacts.qs2")
 centroids <- cov_cases$centroids
 state <- cov_cases$state
 county <- cov_cases$county
@@ -280,9 +280,23 @@ outfile <- "plots/diamonds_vignette_light.png"
 ggsave(g, file=outfile, width=10, height=4, dpi=96)
 trim_image(outfile, "white")
 
+# light color theme with cool colors
+light_colors <- colorRampPalette(c("#1133AA", "#CCFFFF"))(144)
+g <- ggplot() + 
+  geom_raster(data = pd, aes(x = pd$x, y = pd$y, fill = pd$value), show.legend = F) +
+  scale_fill_gradientn(colors = additive_alpha(light_colors)) +
+  coord_fixed(gm$aspect(), xlim = gm$xlim(), ylim = gm$ylim()) + 
+  labs(x = "carat", y = "price") + 
+  theme_bw(base_size = 14)
+
+outfile <- "plots/diamonds_vignette_cool.png"
+ggsave(g, file=outfile, width=10, height=4, dpi=96)
+trim_image(outfile, "white")
+
+
 # Volcano ##########################################
 
-DMPs <- qread("plot_data/methylation_data.qs")
+DMPs <- qs_read("plot_data/methylation_data.qs2")
 
 adj_pval_threshold <- DMPs %>% filter(adj.P.Val < 0.05) %>%
   pull(P.Value) %>% max
@@ -308,7 +322,7 @@ trim_image(outfile,  "white")
 # https://www.r-bloggers.com/visualize-large-data-sets-with-the-bigvis-package/
 ## wget https://packages.revolutionanalytics.com/datasets/AirOnTime87to12/AirOnTimeCSV.zip .
 
-air <- qread("plot_data/AirOnTime.qs", nthreads=nt)
+air <- qs_read("plot_data/AirOnTime.qs2", nthreads=nt)
 
 temp <- rbindlist(air)
 qlo1 <- temp$ARR_DELAY %>% quantile(0.0025)

inst/examples/examples_parse_data.R

@@ -4,7 +4,7 @@ library(glow)
 library(dplyr)
 library(data.table)
 library(arrow)
-library(qs)
+library(qs2)
 library(stringr)
 
 # COVID example
@@ -41,7 +41,7 @@ stars <- lapply(files, function(f) {
 stars2 <- stars[complete.cases(stars),]
 stars2 <- stars2 %>% arrange_all
 
-qsave(stars2, "plot_data/gaia_stars.qs", preset = "custom", algorithm = "zstd", compress_level = 22, nthreads = 8)
+qs_save(stars2, "plot_data/gaia_stars.qs2", preset = "custom", algorithm = "zstd", compress_level = 22, nthreads = 8)
 
 
 # COVID #######################################################################
@@ -61,7 +61,7 @@ centroids <- left_join(centroids, cov_cases, by = c("name", "state_abbr"))
 centroids$total[is.na(centroids$total)] <- 0
 centroids <- filter(centroids, total > 0)
 
-qsave(list(centroids=centroids, county=county, state=state), "plot_data/covid_confirmed_usafacts.qs", preset = "custom", algorithm = "zstd", compress_level = 22)
+qs_save(list(centroids=centroids, county=county, state=state), "plot_data/covid_confirmed_usafacts.qs2", preset = "custom", algorithm = "zstd", compress_level = 22)
 
 
 # Volcano ##########################################
@@ -102,7 +102,7 @@ DMPs <- topTable(fit2, num=Inf, coef=1, genelist=ann450kSub)
 DMPs <- DMPs %>% dplyr::select(logFC, P.Value, adj.P.Val)
 rownames(DMPs) <- NULL
 
-qsave(DMPs, file = "plot_data/methylation_data.qs", preset = "custom", algorithm = "zstd", compress_level = 22)
+qs_save(DMPs, file = "plot_data/methylation_data.qs2", preset = "custom", algorithm = "zstd", compress_level = 22)
 
 # Airline ######################################################################
 # https://www.r-bloggers.com/visualize-large-data-sets-with-the-bigvis-package/
@@ -119,7 +119,7 @@ air <- lapply(1:length(files), function(i) {
     filter(complete.cases(.))
   return(z)
 })
-qsave(air, file="plot_data/AirOnTime.qs", preset = "custom", algorithm = "zstd", compress_level = 22, nthreads=nt)
+qs_save(air, file="plot_data/AirOnTime.qs2", preset = "custom", algorithm = "zstd", compress_level = 22, nthreads=nt)
 
 # GPS traces ######################################################################
 # https://planet.osm.org/gps/
@@ -130,6 +130,6 @@ system(sprintf("unxz %s/simple-gps-points-120312.txt.xz", tempdir))
 gps <- data.table::fread(sprintf("%s/simple-gps-points-120312.txt", tempdir), header=FALSE, data.table=FALSE)
 gps <- list(latitude = gps[[1]], longitude = gps[[2]]) # Long dataframes not supported in R as of 4.2.3
 
-qsave(gps, file="plot_data/simple-gps-points.qs", preset = "custom", algorithm = "zstd", compress_level = 22, nthreads=nt)
+qs_save(gps, file="plot_data/simple-gps-points.qs2", preset = "custom", algorithm = "zstd", compress_level = 22, nthreads=nt)
 
 

inst/examples/gps_example.R

@@ -1,4 +1,4 @@
-library(qs)
+library(qs2)
 library(glow)
 library(EBImage)
 
@@ -10,7 +10,7 @@ output_height = 1080*4
 radius <- 0.2 # Increase this value if plotting fewer points
 intensity <- 0.6 # Increase this value if plotting fewer points
 
-gps <- qread("plot_data/simple-gps-points.qs", nthreads=32)
+gps <- qs_read("plot_data/simple-gps-points.qs2", nthreads=32)
 
 length(gps$latitude) # 2770233904