Preliminary legend merging code

NEWS

@@ -1,6 +1,8 @@
 ggplot 0.6
 ----------------------------------------
-
+
+  * preliminary legend merging code:
+     * consequence: legend type no longer specified in scale (e.g. size, identity, manual), but derived from geoms used
   * fix scale adjustment bug in geom_density
   * new geom_rug to add marginal rug plots
   * all discrete scales now have labels argument which you can use to override the factor levels

R/geom-.r

@@ -16,6 +16,8 @@ Geom <- proto(TopLevel, expr={
   default_aes <- function(.) {}
   default_pos <- function(.) PositionIdentity
 
+  guide_geom <- function(.) "point"
+
   draw <- function(...) {}
   draw_groups <- function(., data, scales, coordinates, ...) {
     if (is.null(data) || nrow(data) == 0) return()

R/geom-path-.r

@@ -59,6 +59,7 @@ GeomPath <- proto(Geom, {
   required_aes <- c("x", "y")
   default_aes <- function(.) aes(colour="black", size=1, linetype=1)
   icon <- function(.) linesGrob(c(0.2, 0.4, 0.8, 0.6, 0.5), c(0.2, 0.7, 0.4, 0.1, 0.5))
+  guide_geom <- function(.) "path"
 
   seealso <- list(
     geom_line = "Functional (ordered) lines", 

R/geom-ribbon-.r

@@ -6,8 +6,10 @@ GeomRibbon <- proto(GeomInterval, {
     if (!"y" %in% scales$input()) {
       scales$add(ScaleContinuous$new(variable="y"))  
     }
+
     y <- scales$get_scales("y")
     y$train(data$min)
+    y$train(data$y)
     y$train(data$max)
   }
 

R/geom-tile.r

@@ -70,6 +70,8 @@ GeomTile <- proto(Geom, {
   default_stat <- function(.) StatIdentity
   default_aes <- function(.) aes(fill="grey50", colour=NA, size=1, width = resolution(x), height = resolution(y), size=1, linetype=1)
   required_aes <- c("x", "y")
+  guide_geom <- function(.) "tile"
+
 
   examples <- function(.) {
     # Generate data

R/guides-legend.r

@@ -0,0 +1,77 @@
+gglegends <- function(legends, usage) {
+  # Need to collapse legends describing same values into single data.frame
+  # - first group by name
+  names <- unname(unlist(lapply(legends, "[", "name")))
+  keys <- lapply(legends, "[[", "display")
+  variables <- split(keys, names)
+
+  # - then merge data.frames
+  keys_merged <- unname(lapply(variables, merge_legends))
+  legends_merged <- mapply(function(name, keys) list(name = name, display=keys), unique(names), keys_merged, SIMPLIFY = FALSE, USE.NAMES = FALSE)  
+
+  lapply(legends_merged, gglegend, usage=usage)
+}
+
+merge_legends <- function(legends) {
+  n <- length(legends)
+  if (n < 2) return(legends[[1]])
+
+  all <- legends[[1]]
+  for(i in 2:n) 
+    all <- merge(all, legends[[i]], by="label", sort="false")
+  all
+}
+
+gglegend <- function(legend, usage=usage) {
+  display <- legend$display
+
+  aesthetics <- setdiff(names(legend$display), "label")
+
+  legend_f <- function(x) {
+    geom <- Geom$find(x)
+    function(data) geom$draw_legend(data)
+  }
+  grobs <- lapply(unique(unlist(usage[aesthetics])), legend_f)
+
+  title <- ggname("title", textGrob(legend$name, x = 0, y = 0.5, just = c("left", "centre"), 
+    gp=gpar(fontface="bold")
+  ))
+
+  nkeys <- nrow(display)
+  hgap <- vgap <- unit(0.3, "lines")
+
+  label.heights <- do.call("unit.c", lapply(display$label, function(x) stringHeight(as.expression(x))))
+  label.widths  <- do.call("unit.c", lapply(display$label, function(x) stringWidth(as.expression(x))))
+
+  widths <- unit.c(
+    unit(1.4, "lines"), 
+    hgap, 
+    max(unit.c(unit(1, "grobwidth", title) - unit(1.4, "lines") - 2 * hgap), label.widths),
+    hgap
+  )
+
+  heights <- unit.c(
+    unit(1, "grobheight", title) + 2 * vgap, 
+    unit.pmax(unit(1.4, "lines"), vgap + label.heights)
+  )  
+
+  # Layout the legend table
+  legend.layout <- grid.layout(nkeys + 1, 4, widths = widths, heights = heights, just=c("left","top"))
+  fg <- ggname("legend", frameGrob(layout = legend.layout))
+  #fg <- placeGrob(fg, rectGrob(gp=gpar(fill="NA", col="NA", name="legend-background")))
+
+  numeric_labels <- all(sapply(display$label, is.language)) || suppressWarnings(all(!is.na(sapply(display$label, "as.numeric"))))
+  valign <- if(numeric_labels) "right" else "left"
+  vpos   <- if(numeric_labels) 1 else 0
+
+  fg <- placeGrob(fg, title, col=1:2, row=1)
+  for (i in 1:nkeys) {
+    df <- as.list(display[i,, drop=FALSE])
+    for(grob in grobs) {
+      fg <- placeGrob(fg, ggname("key", grob(df)), col = 1, row = i+1)      
+    }
+    fg <- placeGrob(fg, ggname("label", textGrob(display$label[[i]], x = vpos, y = 0.5, just = c(valign, "centre"))), col = 3, row = i+1)
+  }
+
+  fg
+}

R/guides.r

@@ -73,8 +73,8 @@ guides_basic <- function(plot, scales, coordinates) {
 # @keyword hplot 
 # @value frameGrob, or NULL if no legends
 # @keyword internal
-legends <- function(scales, horizontal = FALSE) {
-  legs <- scales$guide_legend()
+legends <- function(scales, scale_usage, horizontal = FALSE) {
+  legs <- scales$guide_legend(scale_usage)
 
   n <- length(legs)
   if (n == 0) return()

R/plot-surrounds.r

@@ -24,7 +24,8 @@ prettyplot <- function(plot, plotgrob, scales=plot$scales, cs=plot$coordinates)
   horiz <- any(c("top", "bottom") %in% position)
   vert <-  any(c("left", "right") %in% position)
 
-  legend <- if (position != "none") legends(scales, horiz) else NULL
+
+  legend <- if (position != "none") legends(scales, scale_usage(plot), horiz) else NULL
   if (is.null(legend)) position <- "none"
 
   gp <- gpar(fill=plot$background.fill, col=plot$background.colour)
@@ -102,3 +103,16 @@ prettyplot <- function(plot, plotgrob, scales=plot$scales, cs=plot$coordinates)
 
   lf
 }
+
+scale_usage <- function(plot) {
+  aesthetics <- lapply(plot$layers, function(p) c(names(p$aesthetics), names(plot$defaults)))
+  names(aesthetics) <- sapply(plot$layers, function(p) p$geom$guide_geom())
+
+  lapply(invert(aesthetics), unique)
+}
+
+invert <- function(L) {
+  t1 <- unlist(L)
+  names(t1) <- rep(names(L), lapply(L, length))
+  tapply(names(t1), t1, c)
+}

R/scale-.r

@@ -104,8 +104,6 @@ Scale <- proto(TopLevel, expr={
     if (newline) cat("\n") 
   }
 
-  guide_legend_geom <- function(.) GeomPoint
-
   html_returns <- function(.) {
     ps(
       "<h2>Returns</h2>\n",
@@ -114,60 +112,20 @@ Scale <- proto(TopLevel, expr={
   }
   # Guides
   # ---------------------------------------------
-
-  guide_legend <- function(.) {
-    if (identical(., Scale)) return(NULL)
-    if (!.$legend) return(NULL)
-
-    reverse <- rev # if (.$.reverse) force else rev
-    labels <- reverse(.$labels())
-    breaks <- reverse(.$rbreaks())
-
-    if (is.null(breaks)) return(NULL)
-    grob <- function(data) .$guide_legend_geom()$draw_legend(data)
-
-    title <- ggname("title", textGrob(.$name, x = 0, y = 0.5, just = c("left", "centre"), 
-      gp=gpar(fontface="bold")
-    ))
-
-    nkeys <- length(labels)
-    hgap <- vgap <- unit(0.3, "lines")
-
-    values <- data.frame(breaks)
-    names(values) <- .$output()
+  legend_desc <- function(.) {
+    if (identical(., Scale) || !.$legend) return()
 
-    label.heights <- do.call("unit.c", lapply(labels, function(x) stringHeight(as.expression(x))))
-    label.widths <- do.call("unit.c", lapply(labels, function(x) stringWidth(as.expression(x))))
+    breaks <- .$rbreaks()
+    if (is.null(breaks)) return()
 
-    widths <- unit.c(
-      unit(1.4, "lines"), 
-      hgap, 
-      max(unit.c(unit(1, "grobwidth", title) - unit(1.4, "lines") - 2 * hgap), label.widths),
-      hgap
+    df <- data.frame(breaks, stringsAsFactors = FALSE)
+    names(df) <- .$output()
+    df$label <- .$labels()
+    list(
+      name = .$name,
+      aesthetic = .$output(),
+      display = df
     )
-
-    heights <- unit.c(
-      unit(1, "grobheight", title) + 2 * vgap, 
-      unit.pmax(unit(1.4, "lines"), vgap + label.heights)
-    )  
-
-    # Make a table
-    legend.layout <- grid.layout(nkeys + 1, 4, widths = widths, heights = heights, just=c("left","top"))
-    fg <- ggname(.$my_name(), frameGrob(layout = legend.layout))
-    #fg <- placeGrob(fg, rectGrob(gp=gpar(fill="NA", col="NA", name="legend-background")))
-
-    numeric_labels <- all(sapply(labels, is.language)) || suppressWarnings(all(!is.na(sapply(labels, "as.numeric"))))
-    valign <- if(numeric_labels) "right" else "left"
-    vpos   <- if(numeric_labels) 1 else 0
-
-    fg <- placeGrob(fg, title, col=1:2, row=1)
-    for (i in 1:nkeys) {
-      df <- as.list(values[i,, drop=FALSE])
-      fg <- placeGrob(fg, ggname("key", grob(df)), col = 1, row = i+1)
-      fg <- placeGrob(fg, ggname("label", textGrob(labels[[i]], x = vpos, y = 0.5, just = c(valign, "centre"))), col = 3, row = i+1)
-    }
-
-    fg
   }
 
   call <- function(.) {    

R/scale-continuous-colour.r

@@ -18,7 +18,6 @@ ScaleGradient <- proto(ScaleContinuous, expr={
   }
 
   rbreaks <- function(.) .$map(.$breaks())
-  guide_legend_geom <- function(.) GeomTile
   common <- c("colour", "fill")
 
   # Documetation -----------------------------------------------
@@ -111,7 +110,6 @@ ScaleGradient2 <- proto(ScaleContinuous, expr={
   }
 
   rbreaks <- function(.) .$map(.$breaks())
-  guide_legend_geom <- function(.) GeomTile
 
   objname <-"gradient2"
   common <- c("colour", "fill")

R/scale-discrete-colour.r

@@ -2,17 +2,23 @@ ScaleColour <- proto(ScaleDiscrete, expr={
   common <- c("colour", "fill")
   objname <- "colour"
   doc <- FALSE
-  guide_legend_geom <- function(.) GeomTile
 })
 
 ScaleHue <- proto(ScaleColour, expr={
-  new <- function(., name=NULL, h=c(0,360), l=65, c=100, alpha=1, labels=NULL, variable) {
-    .$proto(name=name, h=h, l=l, c=c, alpha=alpha, .input=variable, .output=variable, .lables = labels)
+  new <- function(., name=NULL, h=c(0,360), l=65, c=100, alpha=1, labels=NULL, h.start = 0, direction = 1,  variable) {
+    .$proto(name=name, h=h, l=l, c=c, alpha=alpha, .input=variable, .output=variable, .labels = labels, direction = direction, start  = h.start)
   }
 
   breaks <- function(.) {
+    rotate <- function(x) (x + .$start) %% 360 * .$direction
+
     n <- length(.$domain())
-    grDevices::hcl(seq(.$h[1], .$h[2], length = n+1), c=.$c, l=.$l, alpha=.$alpha)[-(n+1)]
+    grDevices::hcl(
+      h = rotate(seq(.$h[1], .$h[2], length = n+1)), 
+      c =.$c, 
+      l =.$l, 
+      alpha=.$alpha
+    )[-(n+1)]
   }
   max_levels <- function(.) Inf
 
@@ -68,7 +74,7 @@ ScaleBrewer <- proto(ScaleColour, expr={
   doc <- TRUE
 
   new <- function(., name=NULL, palette=1, type="qual", alpha=1, reverse = FALSE, labels=NULL, variable) {
-    .$proto(name=name, palette=palette, type=type, .input=variable, .output=variable, .alpha=alpha, .reverse = reverse, .lables = labels)
+    .$proto(name=name, palette=palette, type=type, .input=variable, .output=variable, .alpha=alpha, .reverse = reverse, .labels = labels)
   }
 
   breaks <- function(.) {

R/scale-identity.r

@@ -1,8 +1,8 @@
 
 ScaleIdentity <- proto(ScaleDiscrete, {  
   common <- c("colour","fill","size","shape","linetype")
-  new <- function(., name=NULL, breaks=NULL, labels=NULL, guide="point", variable="x") {
-    .$proto(name=name, .breaks=breaks, .labels=labels, .guide=guide, .input=variable, .output=variable)
+  new <- function(., name=NULL, breaks=NULL, labels=NULL, variable="x") {
+    .$proto(name=name, .breaks=breaks, .labels=labels, .input=variable, .output=variable)
   }
 
   guides.manual <- function(scale, ...) {
@@ -20,8 +20,6 @@ ScaleIdentity <- proto(ScaleDiscrete, {
   breaks <- function(.) .$.breaks
   labels <- function(.) .$.labels
 
-  guide_legend_geom <- function(.) Geom$find(.$.guide)
-
   guide_legend <- function(.) {
     if (is.null(.$.labels)) return()
     .super$guide_legend(.)

R/scale-linetype.r

@@ -4,7 +4,6 @@ ScaleLinetype <- proto(ScaleDiscrete, expr={
 
   frange <- function(.) (1:4)[1:length(.$domain())]
   max_levels <- function(.) 4
-  guide_legend_geom <- function(.) GeomPath
 
   # Documetation -----------------------------------------------
 

R/scale-manual.r

@@ -2,8 +2,8 @@ ScaleManual <- proto(ScaleDiscrete, {
   common <- c("colour","fill","size","shape","linetype")
   .values <- c()
 
-  new <- function(., name=NULL, values=NULL, guide="point", variable="x") {
-    .$proto(name=name, .values=values, .guide=guide, .input=variable, .output=variable)
+  new <- function(., name=NULL, values=NULL, variable="x") {
+    .$proto(name=name, .values=values, .input=variable, .output=variable)
   }
 
   map <- function(., values) {
@@ -20,12 +20,6 @@ ScaleManual <- proto(ScaleDiscrete, {
   breaks <- function(.) .$.values
   labels <- function(.) if (.$has_names()) names(.$breaks()) else .$.domain
 
-  guide_legend_geom <- function(.) Geom$find(.$.guide)
-
-  guide_legend <- function(.) {
-    .super$guide_legend(.)
-  }
-
   # Documetation -----------------------------------------------
 
   objname <- "manual"

R/scale-shape.r

@@ -16,7 +16,6 @@ ScaleShape <- proto(ScaleDiscrete, expr={
   }
 
   max_levels <- function(.) 6
-  guide_legend_geom <- function(.) GeomPoint
 
   # Documetation -----------------------------------------------
   objname <- "shape"

R/scale-size.r

@@ -2,12 +2,10 @@ ScaleSize <- proto(ScaleContinuous, expr={
   common <- NULL
   .input <- .output  <- "size"
 
-  new <- function(., name=NULL, to=c(1, 5), guide="point") {
-    .$proto(name=name, .range=to, .guide=guide)
+  new <- function(., name=NULL, to=c(1, 5)) {
+    .$proto(name=name, .range=to)
   }
 
-  guide_legend_geom <- function(.) Geom$find(.$.guide)
-
   objname <- "size"
   desc <- "Size scale for continuous variable"
 
@@ -48,5 +46,4 @@ ScaleSizeDiscrete <- proto(ScaleDiscrete, expr={
   doc <- FALSE
 
   max_levels <- function(.) Inf
-  guide_legend_geom <- function(.) GeomPoint
 }) 

R/scales-.r

@@ -52,10 +52,9 @@ Scales <- proto(Scale, expr={
     sapply(.$.scales, function(scale) scale$input())
   }
 
-  guide_legend <- function(.) {
-    legs <- compact(lapply(.$.scales, function(x) x$guide_legend()))
-    legs[sapply(legs, length) == 0] <- NULL
-    legs
+  guide_legend <- function(., usage) {
+    legends <- compact(lapply(.$.scales, function(x) x$legend_desc()))
+    gglegends(legends, usage)
   }
 
   # Train scale from a data frame