Last active
October 25, 2024 02:20
-
-
Save eliocamp/eabafab2825779b88905954d84c82b32 to your computer and use it in GitHub Desktop.
A way to add multiple color or fill scales to a ggplot2 plot
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # All this is implemented (plus bugfixes!) in the ggnewscale package: | |
| # https://github.com/eliocamp/ggnewscale | |
| # If you have any issues, I prefer it if you send them as issues here: | |
| # https://github.com/eliocamp/ggnewscale/issues | |
| #' Allows to add another scale | |
| #' | |
| #' @param new_aes character with the aesthetic for which new scales will be | |
| #' created | |
| #' | |
| new_scale <- function(new_aes) { | |
| structure(ggplot2::standardise_aes_names(new_aes), class = "new_aes") | |
| } | |
| #' Convenient functions | |
| new_scale_fill <- function() { | |
| new_scale("fill") | |
| } | |
| new_scale_color <- function() { | |
| new_scale("colour") | |
| } | |
| new_scale_colour <- function() { | |
| new_scale("colour") | |
| } | |
| #' Special behaviour of the "+" for adding a `new_aes` object | |
| #' It changes the name of the aesthethic for the previous layers, appending | |
| #' "_new" to them. | |
| ggplot_add.new_aes <- function(object, plot, object_name) { | |
| plot$layers <- lapply(plot$layers, bump_aes, new_aes = object) | |
| plot$scales$scales <- lapply(plot$scales$scales, bump_aes, new_aes = object) | |
| plot$labels <- bump_aes(plot$labels, new_aes = object) | |
| plot | |
| } | |
| bump_aes <- function(layer, new_aes) { | |
| UseMethod("bump_aes") | |
| } | |
| bump_aes.Scale <- function(layer, new_aes) { | |
| old_aes <- layer$aesthetics[remove_new(layer$aesthetics) %in% new_aes] | |
| new_aes <- paste0(old_aes, "_new") | |
| layer$aesthetics[layer$aesthetics %in% old_aes] <- new_aes | |
| if (is.character(layer$guide)) { | |
| layer$guide <- match.fun(paste("guide_", layer$guide, sep = ""))() | |
| } | |
| layer$guide$available_aes[layer$guide$available_aes %in% old_aes] <- new_aes | |
| layer | |
| } | |
| bump_aes.Layer <- function(layer, new_aes) { | |
| original_aes <- new_aes | |
| old_aes <- names(layer$mapping)[remove_new(names(layer$mapping)) %in% new_aes] | |
| new_aes <- paste0(old_aes, "_new") | |
| old_geom <- layer$geom | |
| old_setup <- old_geom$handle_na | |
| new_setup <- function(self, data, params) { | |
| colnames(data)[colnames(data) %in% new_aes] <- original_aes | |
| old_setup(data, params) | |
| } | |
| new_geom <- ggplot2::ggproto(paste0("New", class(old_geom)[1]), old_geom, | |
| handle_na = new_setup) | |
| new_geom$default_aes <- change_name(new_geom$default_aes, old_aes, new_aes) | |
| new_geom$non_missing_aes <- change_name(new_geom$non_missing_aes, old_aes, new_aes) | |
| new_geom$required_aes <- change_name(new_geom$required_aes, old_aes, new_aes) | |
| new_geom$optional_aes <- change_name(new_geom$optional_aes, old_aes, new_aes) | |
| layer$geom <- new_geom | |
| old_stat <- layer$stat | |
| old_setup2 <- old_stat$handle_na | |
| new_setup <- function(self, data, params) { | |
| colnames(data)[colnames(data) %in% new_aes] <- original_aes | |
| old_setup2(data, params) | |
| } | |
| new_stat <- ggplot2::ggproto(paste0("New", class(old_stat)[1]), old_stat, | |
| handle_na = new_setup) | |
| new_stat$default_aes <- change_name(new_stat$default_aes, old_aes, new_aes) | |
| new_stat$non_missing_aes <- change_name(new_stat$non_missing_aes, old_aes, new_aes) | |
| new_stat$required_aes <- change_name(new_stat$required_aes, old_aes, new_aes) | |
| new_stat$optional_aes <- change_name(new_stat$optional_aes, old_aes, new_aes) | |
| layer$stat <- new_stat | |
| layer$mapping <- change_name(layer$mapping, old_aes, new_aes) | |
| layer | |
| } | |
| bump_aes.list <- function(layer, new_aes) { | |
| old_aes <- names(layer)[remove_new(names(layer)) %in% new_aes] | |
| new_aes <- paste0(old_aes, "_new") | |
| names(layer)[names(layer) %in% old_aes] <- new_aes | |
| layer | |
| } | |
| change_name <- function(list, old, new) { | |
| UseMethod("change_name") | |
| } | |
| change_name.character <- function(list, old, new) { | |
| list[list %in% old] <- new | |
| list | |
| } | |
| change_name.default <- function(list, old, new) { | |
| nam <- names(list) | |
| nam[nam %in% old] <- new | |
| names(list) <- nam | |
| list | |
| } | |
| change_name.NULL <- function(list, old, new) { | |
| NULL | |
| } | |
| remove_new <- function(aes) { | |
| stringi::stri_replace_all(aes, "", regex = "(_new)*") | |
| } | |
| # Example | |
| library(ggplot2) | |
| vd <- reshape2::melt(volcano) | |
| names(vd) <- c("x", "y", "z") | |
| # point measurements of something (abund) at a few locations | |
| d <- data.frame(x=runif(30, 1, 80), y = runif(30, 1, 60), abund=rnorm(30)) | |
| ggplot(mapping = aes(x, y)) + | |
| geom_contour(aes(z = z, color = ..level..), data = vd) + | |
| scale_color_viridis_c(option = "D") + | |
| new_scale_color() + # geoms below can use another color scale! | |
| geom_point(data = d, size = 3, aes(color = abund)) + | |
| scale_color_viridis_c(option = "A") |
Author
Ah, yes. In that case, then geom_point(aes(..., fill = group2), shape = 21, color = "black") should do the trick.
Ok, now I fixed it with new_scale_fill() and including the scale_shape_manual (21) and scale_fill_manual(white and black)
Thank you so much!!
Thank you! this is awesome!
That was super helpful Dr. Campitelli
I have just used it.
One problem that I am dealing, I am not able to modify the order of labels in the legend. Do you have any advice on it? Thank you!
Author
Please, Dr. Campitelli lives in Bariloche. Calle me Elio 😆 (also, I'm not a doctor nor have a PhD -yet)
To control de order of legends you need to put something like scale_color_continuous(guide = guide_legend(order = 1)). So, inside each scale definition, you set the guide parameter and then the order of each guide.
it worked! thank you a lot
Awesome! Thanks.
With current ggplot2, at least in your example above, remove_new() as no effect as there is never an aes with new in it.
So I don't know if you still need it for other cases, but if you do, perhaps removing the dependence to stringi could be good.
Perhaps this would do the job:
remove_new <- function(aes) {
gsub(pattern = "(_new)*", replacement = "", x = aes)
}
but double check since I cannot test it.
This solved my problem after days of trying. Thank you!
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Thank you so much for your help!! Yes, I would like to use fill aesthetic with points because it's difficult to see the white dots on the grey background. So I would like to fill balck and white but with the contour black..