Create geom_rect

  * move common code out of geom_bar and geom_tile
  * clarify role of reparameterise
  * make zero in resolution optional

Author: hadley

R/geom-bar-.r

@@ -4,39 +4,19 @@ GeomBar <- proto(Geom, {
   default_pos <- function(.) PositionStack
   default_aes <- function(.) aes(colour=NA, fill="grey60", size=1, linetype=1, width = resolution(x) * 0.9)
 
-  required_aes <- c("x")
+  required_aes <- c("x", "width")
 
   reparameterise <- function(., df) {
+    if (is.null(df$width)) df$width <- resolution(df$x, FALSE) * 0.9
+    
     transform(df,
-      ymin = 0,
-      ymax = y,
-      xmin = x - width / 2, 
-      xmax = x + width / 2,
-      width = NULL
+      ymin = 0, ymax = y,
+      xmin = x - width / 2, xmax = x + width / 2, width = NULL
     )
   }
 
   draw <- function(., data, scales, coordinates, ...) {
-    if (coordinates$muncher()) {
-      data <- transform(data, top=max, bottom=min, left=x - width/2, right=x + width/2)
-      ggname("bar",gTree(children=do.call("gList", lapply(1:nrow(data), function(i) {
-        data <- data[i, ]
-        df <- cbind(with(data, rbind(
-          cbind(y=top, x=left),
-          cbind(y=top, x=right),
-          cbind(y=bottom, x=right),
-          cbind(y=bottom, x=left),
-          cbind(y=top, x=left)
-        )), data[rep(1,5), setdiff(names(.$default_aes()), c("min","max"))])
-        GeomPolygon$draw(df, scales, coordinates)
-      }))))
-    } else {
-    with(coordinates$transform(data), 
-      ggname(.$my_name(), rectGrob(xmin, ymax, width=xmax-xmin, height=ymax-ymin, default.units="native", just=c("left", "top"), 
-      gp=gpar(col=colour, fill=fill, lwd=size * .pt, lty=linetype, lineend="butt"))
-    ))
-    }
-    
+    GeomRect$draw(data, scales, coordinates, ...)
   }
 
   # Documentation -----------------------------------------------

R/geom-rect.r

@@ -0,0 +1,62 @@
+GeomRect <- proto(Geom, {
+  
+  default_stat <- function(.) StatIdentity
+  default_pos <- function(.) PositionIdentity
+  default_aes <- function(.) aes(colour=NA, fill="grey60", size=1, linetype=1)
+  
+  required_aes <- c("xmin", "xmax", "ymin", "ymax")
+
+  draw <- function(., data, scales, coordinates, ...) {
+    if (coordinates$muncher()) {
+      aesthetics <- setdiff(names(data), c("xmin","xmax", "ymin", "ymax"))
+      
+      polys <- alply(data, 1, function(row) {
+        poly <- with(row[i, ], rect_to_poly(xmin, xmax, ymin, ymax))
+        aes <- row[rep(1,5), aesthetics]
+      
+        GeomPolygon$draw(cbind(poly, aesthetics), scales, coordinates)
+      })
+      
+      ggname("bar",do.call("grobTree", polys))
+    } else {
+      with(coordinates$transform(data), 
+        ggname(.$my_name(), rectGrob(
+          xmin, ymax, 
+          width = xmax - xmin, height = ymax - ymin, 
+          default.units = "native", just = c("left", "top"), 
+          gp=gpar(
+            col=colour, fill=fill, 
+            lwd=size * .pt, lty=linetype, lineend="butt"
+          )
+        ))
+      )
+    }
+    
+  }
+  
+  # Documentation -----------------------------------------------
+  objname <- "rect"
+  desc <- "2d rectangles"
+  guide_geom <- function(.) "tile"
+  
+  icon <- function(.) {
+    rectGrob(c(0.3, 0.7), c(0.4, 0.8), height=c(0.4, 0.8), width=0.3, vjust=1, gp=gpar(fill="grey60", col=NA))
+  }
+  
+  examples <- function(.) {
+    df <- data.frame(
+      x = sample(10, 20, replace = TRUE),
+      y = sample(10, 20, replace = TRUE)
+    )
+    ggplot(df, aes(xmin = x, xmax = x + 1, ymin = y, ymax = y + 2)) +
+    geom_rect()
+  }  
+
+})
+
+rect_to_poly <- function(xmin, xmax, ymin, ymax) {
+  data.frame(
+    y = c(ymax, ymax, ymin, ymin, ymax),
+    x = c(xmin, xmax, xmax, xmin, xmin)
+  )
+}

R/geom-tile.r

@@ -1,42 +1,21 @@
 GeomTile <- proto(Geom, {
-  draw_groups <- function(., ...) .$draw(...)
-  draw <- function(., data,  scales, coordinates, ...) {
-    if (nrow(data) == 1) return(NULL)
-    data$colour[is.na(data$colour)] <- data$fill[is.na(data$colour)]
-    
-    data <- transform(data, 
-      xmin = x - width/2, 
-      xmax = x + width/2,
-      ymin = y - height/2,
-      ymax = y + height/2
-    )
-    if (coordinates$muncher()) {
-      data <- transform(data, top=y + height/2, bottom= y - height/2, left=x - width/2, right=x + width/2)
-      ggname(.$my_name(), gTree(children=do.call("gList", lapply(1:nrow(data), function(i) {
-        data <- data[i, ]
-        df <- cbind(with(data, rbind(
-          cbind(y = top, x=left),
-          cbind(y = top, x=right),
-          cbind(y = bottom, x=right),
-          cbind(y = bottom, x=left)
-        )), data[rep(1,4), names(.$default_aes())])
-        GeomPolygon$draw(df, scales, coordinates)
-      }))))
-    } else {  
-    with(coordinates$transform(data),
-      ggname(.$my_name(), rectGrob(
-        xmin, ymax, 
-        width=(xmax-xmin) * size, height=(ymax-ymin) * size, 
-        default.units="native", just=c("left","top"), 
-        gp=gpar(col=colour, fill=fill))
-      )
+  reparameterise <- function(., df) {
+    if (is.null(df$width)) df$width <- resolution(df$x, FALSE)
+    if (is.null(df$height)) df$height <- resolution(df$y, FALSE)
+
+    transform(df, 
+      xmin = x - width/2,  xmax = x + width/2, width = NULL,
+      ymin = y - height/2,  ymax = y + height/2, height = NULL 
     )
-    }
+  }
+
+  draw_groups <- function(., data,  scales, coordinates, ...) {
+    data$colour[is.na(data$colour)] <- data$fill[is.na(data$colour)]
+    GeomRect$draw(data, scales, coordinates, ...)
   }
 
   draw_legend <- function(., data, ...)  {
     data <- aesdefaults(data, .$default_aes(), list(...))
-
     rectGrob(gp=gpar(col=NA, fill=data$fill))
   }  
 
@@ -50,7 +29,7 @@ GeomTile <- proto(Geom, {
   }
 
   default_stat <- function(.) StatIdentity
-  default_aes <- function(.) aes(fill="grey50", colour=NA, width = resolution(x), height = resolution(y), size=1, linetype=1)
+  default_aes <- function(.) aes(fill="grey50", colour=NA, width = resolution(x), height = resolution(y), size=0.1, linetype=1)
   required_aes <- c("x", "y")
   guide_geom <- function(.) "tile"
 

R/utilities-geoms.r

@@ -7,8 +7,12 @@
 # @arguments numeric vector
 # @keyword hplot
 # @keyword internal 
-resolution <- function(x) {
-  un <- unique(c(0, as.numeric(x)))
+resolution <- function(x, zero = TRUE) {
+  if (zero) {
+    un <- unique(c(0, as.numeric(x)))    
+  } else {
+    un <- unique(as.numeric(x))
+  }
 
   if (length(un) == 1) return(1)
   min(diff(sort(un)))

R/xxx.r

@@ -25,6 +25,7 @@ geom_point <- GeomPoint$build_accessor()
 geom_pointrange <- GeomPointrange$build_accessor()
 geom_polygon <- GeomPolygon$build_accessor()
 geom_quantile <- GeomQuantile$build_accessor()
+geom_rect <- GeomRect$build_accessor()
 geom_ribbon <- GeomRibbon$build_accessor()
 geom_rug <- GeomRug$build_accessor()
 geom_segment <- GeomSegment$build_accessor()