Last active
August 29, 2015 14:12
-
-
Save annoporci/f0c355fcd5ab4462a424 to your computer and use it in GitHub Desktop.
This file contains 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
| # swap_grobs() | |
| # a function to swap parts of the grobs between two very similar plot objects | |
| # Data | |
| df <- structure(list(Year = c(1950, 2013, 1950, 2013), Country = structure(c(1L, | |
| 1L, 2L, 2L), .Label = c("France", "United States"), class = "factor"), | |
| Category = c("Hourly minimum wage", "Hourly minimum wage", | |
| "Hourly minimum wage", "Hourly minimum wage"), value = c(2.14, | |
| 9.43, 3.84, 7.25), variable = c("France (2013 euros)", | |
| "France (2013 euros)", "United States (2013 dollars)", "United States (2013 dollars)" | |
| ), Unit = c("2013 euros", "2013 euros", "2013 dollars", "2013 dollars" | |
| )), .Names = c("Year", "Country", "Category", "value", "variable", | |
| "Unit"), row.names = c(NA, 4L), class = "data.frame") | |
| # Libraries | |
| library(ggplot2) | |
| library(grid) | |
| library(gtable) | |
| library(plyr) # function rename | |
| library(scales) # function alpha | |
| # Colorful plots | |
| p1 <- ggplot(data = df, aes(x = Year, y = value, group = variable, colour = variable, shape = variable)) + | |
| geom_line(size = 3) + | |
| geom_point(size = 10) + | |
| theme(panel.grid.major = element_line(size = 1, colour = "green"), | |
| panel.grid.minor = element_line(size = 1, colour = "green", linetype = "dotted")) + | |
| theme(axis.ticks = element_line(size = 20, colour = "green")) + | |
| theme(text = element_text(size = 20, colour = "green")) + | |
| theme(axis.text = element_text(size = 20, colour = "green")) + | |
| scale_colour_manual(values = c("turquoise", "darkgreen")) + | |
| xlab("xlab from plot 1") + | |
| ylab("ylab from plot 1") + | |
| ggtitle("title from plot 1") + | |
| scale_x_continuous(breaks = seq(1950, 2020, by = 10)) + | |
| scale_y_continuous(breaks = seq(0, 10, by = 2)) + | |
| theme(panel.background = element_rect(fill = alpha("aquamarine", .05))) + | |
| theme(panel.border = element_rect(fill = NA, colour = "darkgreen", size = 6)) + | |
| guides(colour = "legend", shape = "legend", guide_legend(title = "legend for plot 1", legend.position = c(.75, .25))) | |
| p2 <- ggplot(data = df, aes(x = Year, y = value, group = variable, colour = variable, shape = variable)) + | |
| geom_line(size = 3) + | |
| geom_point(size = 10) + | |
| theme(panel.grid.major = element_line(size = 1, colour = "red"), | |
| panel.grid.minor = element_line(size = 1, colour = "red", linetype = "dotted")) + | |
| theme(axis.ticks = element_line(size = 20, colour = "red")) + | |
| theme(text = element_text(size = 20, colour = "red")) + | |
| theme(axis.text = element_text(size = 20, colour = "red")) + | |
| scale_colour_manual(values = c("darkorange", "violet")) + | |
| xlab("xlab from plot 2") + | |
| ylab("ylab from plot 2") + | |
| ggtitle("title from plot 2") + | |
| scale_x_continuous(breaks = seq(1960, 2020, by = 20)) + | |
| scale_y_continuous(breaks = seq(0, 10, by = 1)) + | |
| theme(panel.background = element_rect(fill = alpha("lightpink", .05))) + | |
| theme(panel.border = element_rect(fill = NA, colour = "darkred", size = 6)) + | |
| guides(colour = "legend", shape = "legend", guide_legend(title = "legend for plot 2", legend.position = c(.25, .75))) | |
| ######################################################################### | |
| ### function swap_grobs | |
| swap_grobs <- function(from, to, what) { | |
| ### description | |
| ## access the grobs of 2 plots and swaps elements | |
| ## currently supports: panel, background, border, left axis, bottom axis, | |
| ## left labels, bottom labels, plot title, data points, data lines, legend | |
| ## to be extended to deal with vertical/horizontal gridlines separately | |
| ## and maybe to separate ticks from labels | |
| ### package dependencies | |
| require(ggplot2) | |
| require(grid) | |
| require(gtable) | |
| require(plyr) | |
| ### argument processing | |
| # make shorter names | |
| g1 <- from | |
| g2 <- to | |
| # (1) define first level grobs | |
| # treat axis-l and axis-b separately (see below) | |
| ## g1[["layout"]]$name | |
| ## [1] "background" "axis-l" "spacer" "panel" | |
| ## [5] "axis-b" "xlab" "ylab" "title" | |
| args_list_1 <- c("background", "spacer", "panel", "xlab", "ylab", | |
| "title", "guide-box") | |
| # (2) define second level grobs / panel | |
| ## names(g1[["grobs"]][[which(g1[["layout"]][, "name"] == | |
| ## "panel")]][["children"]]) | |
| ## [1] "grill.gTree.1309" "GRID.polyline.1294" | |
| ## [3] "geom_point.points.1296" "panel.border.zeroGrob.1297" | |
| args_list_2 <- c("grill.gTree", "GRID.polyline", | |
| "geom_points.points", "panel.border") | |
| # (3) define second level grobs / axis-b and axis-l | |
| # to get to the axis line and labels for axis-l and axis-b, go deeper: | |
| # use the axis-l and axis-b names but treat these cases separately | |
| # make a swap at the level of the children | |
| # explore second level grobs / axis-l + axis-b | |
| ## names(g2$grobs[[which(g2$layout$name == | |
| ## "axis-l")]]$children[["axis"]]) | |
| ## [1] "grobs" "layout" "widths" "heights" "respect" | |
| ## [6] "rownames" "colnames" "name" "gp" "vp" | |
| ## names(g2$grobs[[which(g2$layout$name == "axis-l")]]$children) | |
| ## [1] "axis.line.y.zeroGrob.2379" "axis" | |
| args_list_3 <- c("axis-l", "axis-b") | |
| # (4) define second level grobs / grill | |
| # to get the horizontal and vertical gridlines separately, go deeper: | |
| # PROBLEM: DOES NOT WORK, to be investigated | |
| ## Warning message: | |
| ## In g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| ## "panel")]][["children"]][grepl("grill", : | |
| ## number of items to replace is not a multiple of replacement length | |
| ## | |
| ## g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| ## "panel")]][["children"]][grepl("grill", | |
| ## names(g1[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| ## "panel")]][["children"]]))]$grill$children | |
| ## (rect[panel.background.rect.3414], | |
| ## polyline[panel.grid.minor.y.polyline.3416], | |
| ## polyline[panel.grid.minor.x.polyline.3418], | |
| ## polyline[panel.grid.major.y.polyline.3420], | |
| ## polyline[panel.grid.major.x.polyline.3422]) | |
| args_list_4 <- c("panel.grid.major.x", "panel.grid.major.y", | |
| "panel.grid.minor.x", "panel.grid.minor.y") | |
| # define mapping from user-level synonyms to valid names | |
| rename_args_list <- c( | |
| # plot title | |
| "plot.title" = "title", | |
| # left axis (including labels and ticks) | |
| "axis.left" = "axis-l", | |
| "axis.y" = "axis-l", | |
| # bottom axis (including labels and ticks) | |
| "axis.bottom" = "axis-b", | |
| "axis.x" = "axis-b", | |
| # axis titles | |
| "axis.title.x" = "xlab", | |
| "axis.title.y" = "ylab", | |
| # axis tickmarks: To Do... maybe some day! | |
| "axis.ticks.x" = "", | |
| "axis.ticks.y" = "", | |
| # gridlines (including major & minor, x & y) | |
| "grill" = "grill.gTree", | |
| "gridlines" = "grill.gTree", | |
| "panel.grid" = "grill.gTree", | |
| # horizontal & vertical gridlines: | |
| "grid.major.x" = "panel.grid.major.x", | |
| "grid.major.y" = "panel.grid.major.y", | |
| "grid.minor.x" = "panel.grid.minor.x", | |
| "grid.minor.y" = "panel.grid.minor.y", | |
| # data geom_line | |
| "polyline" = "GRID.polyline", | |
| "geom_line" = "GRID.polyline", | |
| "lines" = "GRID.polyline", | |
| # data geom_points | |
| "points" = "geom_points.points", | |
| "geom_points" = "geom_points.points", | |
| # panel border | |
| "border" = "panel.border", | |
| # legend | |
| "legend" = "guide-box", | |
| "guides" = "guide-box" | |
| ) | |
| # make list of accepted synonyms from mapping | |
| args_list_synonyms <- names(rename_args_list) | |
| # make full list of arguments, all levels, including synonyms | |
| args_list <- c(args_list_1, args_list_2, args_list_3, args_list_4, args_list_synonyms) | |
| # rename synonyms to 'under the hood' gtable name | |
| rename_args <- function(x) { | |
| names(x) <- x | |
| full <- match(names(x), args_list) | |
| names(x)[!is.na(full)] <- args_list[full[!is.na(full)]] | |
| plyr::rename(x, rename_args_list, warn_missing = FALSE) | |
| } | |
| # make a valid name from user input | |
| what <- rename_args(what) | |
| ### Define replacements at first and second level | |
| # Replace 1 element of g2 grob with corresponding element of g1 grob | |
| # first level of nesting | |
| if (names(what) %in% args_list_1) { | |
| g2[["grobs"]][grepl(what, g2[["grobs"]])] <- | |
| g1[["grobs"]][grepl(what, g1[["grobs"]])] | |
| level <- 1 # debug | |
| } | |
| # second level of nesting | |
| else if (names(what) %in% args_list_2) { | |
| g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| "panel")]][["children"]][grepl(what, | |
| names(g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| "panel")]][["children"]]))] <- | |
| g1[["grobs"]][[which(g1[["layout"]][, "name"] == | |
| "panel")]][["children"]][grepl(what, | |
| names(g1[["grobs"]][[which(g1[["layout"]][, "name"] == | |
| "panel")]][["children"]]))] | |
| level <- 2 # debug | |
| } | |
| # second level of nesting / axis-l + axis-b children | |
| else if (names(what) %in% args_list_3) { | |
| g2$grobs[[which(g2$layout$name == what)]]$children[["axis"]] <- | |
| g1$grobs[[which(g1$layout$name == what)]]$children[["axis"]] | |
| level <- 3 # debug | |
| } | |
| # second level of nesting / panel.grid.major.x, .y, .minor, etc. | |
| else if (names(what) %in% args_list_4) { | |
| g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| "panel")]][["children"]][grepl("grill", | |
| names(g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| "panel")]][["children"]]))]$grill$children[grepl(what, | |
| names(g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| "panel")]][["children"]][grepl("grill", | |
| names(g2[["grobs"]][[which(g2[["layout"]][, "name"] == | |
| "panel")]][["children"]]))]$grill$children))] <- | |
| g1[["grobs"]][[which(g1[["layout"]][, "name"] == | |
| "panel")]][["children"]][grepl("grill", | |
| names(g1[["grobs"]][[which(g1[["layout"]][, "name"] == | |
| "panel")]][["children"]]))]$grill$children[grepl(what, | |
| names(g1[["grobs"]][[which(g1[["layout"]][, "name"] == | |
| "panel")]][["children"]][grepl("grill", | |
| names(g1[["grobs"]][[which(g1[["layout"]][, "name"] == | |
| "panel")]][["children"]]))]$grill$children))] | |
| level <- 4 # debug | |
| } | |
| # return(paste("swapping", what, "in level", level)) # debug | |
| return(g2) | |
| } | |
| ####################################################################### | |
| ### Explore the grobs with function swap_grobs | |
| g1 <- ggplot_gtable(ggplot_build(p1)) | |
| g2 <- ggplot_gtable(ggplot_build(p2)) | |
| # Test the following possibilities (and a few more): | |
| ## "background", "panel", "panel.border", "guides" | |
| ## "xlab", "ylab", "title" | |
| ## "axis.x", "axis.y", | |
| ## "gridlines", "geom_points", "geom_line" | |
| # define a convenient shortcut | |
| grid.show <- function(x) { grid.newpage(); grid.draw(x) } | |
| grid.show(swap_grobs(from = g1, to = g2, what = "grill")) | |
| grid.show(swap_grobs(g1, g2, "background")) | |
| grid.show(swap_grobs(g1, g2, "panel")) | |
| # [don't know what spacer is!] | |
| grid.show(swap_grobs(g1, g2, "spacer")) | |
| grid.show(swap_grobs(g1, g2, "axis-l")) | |
| grid.show(swap_grobs(g1, g2, "axis-b")) | |
| grid.show(swap_grobs(g1, g2, "xlab")) | |
| grid.show(swap_grobs(g1, g2, "ylab")) | |
| grid.show(swap_grobs(g1, g2, "title")) | |
| grid.show(swap_grobs(g1, g2, "grill")) | |
| grid.show(swap_grobs(g1, g2, "panel.border")) | |
| grid.show(swap_grobs(g1, g2, "panel.grid.major.x")) | |
| grid.show(swap_grobs(g1, g2, "panel.grid.minor.y")) | |
function swap_grobs() can swap the following:
## "background", "panel", "panel.border", "guides"
## "xlab", "ylab", "title"
## "axis.x", "axis.y",
## "gridlines", "geom_points", "geom_line"
but it fails with this:
grid.show(swap_grobs(g1, g2, "panel.grid.major.x"))
Warning message:
In g2[["grobs"]][[which(g2[["layout"]][, "name"] == "panel")]][["children"]][grepl("grill", :
number of items to replace is not a multiple of replacement length
To be continued (maybe)...
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
This is preliminary, exploratory and completely stupid.