New annotation function, plus changes to support it.

gsk3 · Mar 6, 2009 · 376fb86 · 376fb86
1 parent 0ca93fd
commit 376fb86
Show file tree

Hide file tree

Showing 20 changed files with 48 additions and 41 deletions.
diff --git a/NEWS b/NEWS
@@ -22,4 +22,5 @@ ggplot2 0.8.3  (2008-XX-XX)
 * facet_wrap: corrected labelling when facetting by multiple variables (thank to Charlotte Wickham for a clear test case)
 * facet_wrap: add drop argument to control whether or not panels for non-existent combinations of facetting variables should be dropped or not.  Defaults to TRUE
 * facet_wrap: in general, is much better at dealing with empty factor levels, and varying levels across layers
-* facet_grid: gains as.table argument to control direction of horizontal facets
+* facet_grid: gains as.table argument to control direction of horizontal facets
+* annotate: new annotate function to make it easier to add annotations to plots
diff --git a/R/annotation.r b/R/annotation.r
@@ -0,0 +1,9 @@
+# annotate("text", x = 0, y = 0, label = "title")
+annotate <- function(geom, x, y, ...) {
+  layer(
+    geom = geom, geom_params = list(...), 
+    stat = "identity", 
+    inherit.aes = FALSE,
+    data = data.frame(x, y), mapping = aes(x, y)
+  )
+}
diff --git a/R/facet-grid-.r b/R/facet-grid-.r
@@ -32,6 +32,7 @@ FacetGrid <- proto(Facet, {
   stamp_data <- function(., data) {
     data <- add_missing_levels(data, .$facet_levels)
     data <- lapply(data, function(df) {
+      if (empty(df)) return(force_matrix(data.frame()))
       df <- stamp(add_group(df), .$facets, force, 
         margins=.$margins, fill = list(NULL), add.missing = TRUE)
       force_matrix(df)

diff --git a/R/fortify.r b/R/fortify.r
@@ -4,3 +4,9 @@
 # @seealso \code{\link{fortify.lm}}
 fortify <- function(model, data, ...) UseMethod("fortify")
 
+fortify.data.frame <- function(model, data, ...) model
+fortify.NULL <- function(model, data, ...) data.frame()
+fortify.default <- function(model, data, ...) {
+
+  stop("ggplot2 doesn't know how to deal with data of class ", class(model), call. = FALSE)
+}
diff --git a/R/geom-.r b/R/geom-.r
@@ -20,7 +20,8 @@ Geom <- proto(TopLevel, expr={
 
   draw <- function(...) {}
   draw_groups <- function(., data, scales, coordinates, ...) {
-    if (is.null(data) || nrow(data) == 0) return()
+    if (empty(data)) return(nullGrob())
+
     groups <- split(data, factor(data$order))
     grobs <- lapply(groups, function(group) .$draw(group, scales, coordinates, ...))
 

diff --git a/R/geom-point-.r b/R/geom-point-.r
@@ -3,7 +3,7 @@ GeomPoint <- proto(Geom, {
   draw <- function(., data, scales, coordinates, na.rm = FALSE, ...) {    
     data <- remove_missing(data, na.rm, 
       c("x", "y", "size", "shape"), name = "geom_point")
-    if (nrow(data) == 0) return(nullGrob())
+    if (empty(data)) return(nullGrob())
 
 
     with(coordinates$transform(data, scales), 

diff --git a/R/layer.r b/R/layer.r
@@ -25,7 +25,7 @@ Layer <- proto(expr = {
 
     if (is.null(geom) && is.null(stat)) stop("Need at least one of stat and geom")
 
-    if (!is.null(data) && !is.data.frame(data)) stop("Data needs to be a data.frame")
+    data <- fortify(data)
     if (!is.null(mapping) && !inherits(mapping, "uneval")) stop("Mapping should be a list of unevaluated mappings created by aes or aes_string")
 
     if (is.character(geom)) geom <- Geom$find(geom)
@@ -111,7 +111,6 @@ Layer <- proto(expr = {
   #
   make_aesthetics <- function(., plot) {
     data <- nulldefault(.$data, plot$data)
-    if (is.null(data)) stop("No data for layer", call.=FALSE)
 
     # For certain geoms, it is useful to be able to ignore the default
     # aesthetics and only use those set in the layer
@@ -138,7 +137,7 @@ Layer <- proto(expr = {
   }
 
   calc_statistic <- function(., data, scales) {
-    if (is.null(data) || nrow(data) == 0) return(data.frame())
+    if (empty(data)) return(data.frame())
 
     check_required_aesthetics(.$stat$required_aes, 
       c(names(data), names(.$stat_params)), 
@@ -168,7 +167,7 @@ Layer <- proto(expr = {
   }
 
   map_statistic <- function(., data, plot) {
-    if (is.null(data) || length(data) == 0 || nrow(data) == 0) return()
+    if (empty(data)) return(data.frame())
 
     aesthetics <- defaults(.$mapping, 
       defaults(plot$mapping, .$stat$default_aes()))
@@ -188,13 +187,10 @@ Layer <- proto(expr = {
   }
 
   reparameterise <- function(., data) {
-    if (is.null(data)) stop("No data to plot", call. = FALSE)
     gg_apply(data, function(df) {
-      if (!is.null(df)) {
-        .$geom$reparameterise(df, .$geom_params) 
-      } else {
-        data.frame()
-      }
+      if (empty(df)) return(data.frame())
+
+      .$geom$reparameterise(df, .$geom_params) 
     })
   }
 
@@ -205,11 +201,12 @@ Layer <- proto(expr = {
   }
 
   make_grob <- function(., data, scales, cs) {
-    if (is.null(data) || nrow(data) == 0) return(nullGrob())
     data <- .$use_defaults(data)
+    if (empty(data)) return(nullGrob())
 
     check_required_aesthetics(.$geom$required_aes, c(names(data), names(.$geom_params)), paste("geom_", .$geom$objname, sep=""))
 
+    if (is.null(data$group)) data$group <- 1
     if (is.null(data$order)) data$order <- data$group
     data <- data[order(data$order), ]
 
@@ -274,11 +271,7 @@ layer <- Layer$new
 # @keyword hplot
 # @keyword internal
 calc_aesthetics <- function(plot, data = plot$data, aesthetics, env = plot$plot_env) {
-  if (is.null(data)) data <- plot$data
-
-  if (!is.data.frame(data)) {
-    data <- fortify(data)
-  }
+  if (empty(data)) data <- plot$data
 
   eval.each <- function(dots) 
     compact(lapply(dots, function(x.) eval(x., data, env)))

diff --git a/R/plot-build.r b/R/plot-build.r
@@ -30,7 +30,7 @@ ggplot_build <- function(plot) {
 
   # Apply and map statistics, then reparameterise geoms that need it
   data <- facet$calc_statistics(data, layers)
-  data <- dlapply(function(d, p) p$map_statistics(d, plot))  
+  data <- dlapply(function(d, p) p$map_statistics(d, plot)) 
   data <- dlapply(function(d, p) p$reparameterise(d))
 
   # Adjust position

diff --git a/R/plot.r b/R/plot.r
@@ -7,11 +7,7 @@
 ggplot <- function(data = NULL, ...) UseMethod("ggplot")
 
 ggplot.default <- function(data = NULL, mapping = aes(), ...) {
-  if (is.null(data)) {
-    ggplot.data.frame(data, mapping, ...)
-  } else {
-    ggplot.data.frame(fortify(data), mapping, ...)
-  }
+  ggplot.data.frame(fortify(data), mapping, ...)
 }
 
 # Create a new plot
@@ -26,11 +22,6 @@ ggplot.default <- function(data = NULL, mapping = aes(), ...) {
 ggplot.data.frame <- function(data, mapping=aes(), ..., environment = globalenv()) {
   if (!missing(mapping) && !inherits(mapping, "uneval")) stop("Mapping should be created with aes or aes_string")
 
-  # if (!is.null(data)) {
-  #   if (ncol(data) == 0) stop("data has no columns")
-  #   if (nrow(data) == 0) stop("data has no rows")    
-  # }
-
   p <- structure(list(
     data = data, 
     layers = list(),

diff --git a/R/position-dodge.r b/R/position-dodge.r
@@ -1,6 +1,6 @@
 PositionDodge <- proto(Position, {
   adjust <- function(., data, scales) {
-    if (nrow(data) == 0) return(data.frame())
+    if (empty(data)) return(data.frame())
     check_required_aesthetics("x", names(data), "position_dodge")
 
     collide(data, .$width, .$my_name(), pos_dodge, check.width = FALSE)

diff --git a/R/position-fill.r b/R/position-fill.r
@@ -1,6 +1,6 @@
 PositionFill <- proto(Position, {
   adjust <- function(., data, scales) {
-    if (nrow(data) == 0) return(data.frame())
+    if (empty(data)) return(data.frame())
 
     y <- scales$get_scales("y")
     y$limits <- c(0, 1)

diff --git a/R/position-jitter.r b/R/position-jitter.r
@@ -1,7 +1,7 @@
 PositionJitter <- proto(Position, {
 
   adjust <- function(., data, scales) {
-    if (nrow(data) == 0) return(data.frame())
+    if (empty(data)) return(data.frame())
     check_required_aesthetics(c("x", "y"), names(data), "position_jitter")
 
     if (is.null(.$width)) .$width <- resolution(data$x) * 0.4

diff --git a/R/position-stack.r b/R/position-stack.r
@@ -1,7 +1,7 @@
 PositionStack <- proto(Position, {
 
   adjust <- function(., data, scales) {
-    if (nrow(data) == 0) return(data.frame()) 
+    if (empty(data)) return(data.frame())
 
     check_required_aesthetics(c("x", "ymax"), names(data), "position_stack")
     if (!all(data$ymin == 0)) warning("Stacking not well defined when ymin != 0")

diff --git a/R/scale-.r b/R/scale-.r
@@ -60,7 +60,7 @@ Scale <- proto(TopLevel, expr={
 
   # Train scale from a data frame
   train_df <- function(., df, drop = FALSE) {
-    if (is.null(df) || nrow(df) == 0) return() 
+    if (empty(df)) return() 
     # Don't train if limits have already been set
     if (!is.null(.$limits)) return()
 

diff --git a/R/scale-continuous-.r b/R/scale-continuous-.r
@@ -28,6 +28,7 @@ ScaleContinuous <- proto(Scale, funEnvir = globalenv(), {
 
   # Transform each 
   transform_df <- function(., df) {
+    if (empty(df)) return(data.frame())
     input <- .$input()
     output <- .$output()
 

diff --git a/R/scale-discrete-.r b/R/scale-discrete-.r
@@ -40,7 +40,7 @@ ScaleDiscrete <- proto(Scale, expr={
   # Override default behaviour: we do need to train, even if limits
   # have been set
   train_df <- function(., df, drop = FALSE) {
-    if (is.null(df) || nrow(df) == 0) return() 
+    if (empty(df)) return() 
 
     input <- .$input_aesthetics(df)
     l_ply(input, function(var) .$train(df[[var]], drop))

diff --git a/R/scales-.r b/R/scales-.r
@@ -97,7 +97,7 @@ Scales <- proto(Scale, expr={
 
   # Train scale from a data frame
   train_df <- function(., df, drop = FALSE) {
-    if (is.null(df) || nrow(df) == 0) return() 
+    if (empty(df)) return() 
 
     lapply(.$.scales, function(scale) {
       scale$train_df(df, drop)
@@ -123,7 +123,7 @@ Scales <- proto(Scale, expr={
   # Transform values to cardinal representation
   transform_df <- function(., df) {
     if (length(.$.scales) == 0) return(df)
-    if (is.null(df) || nrow(df) == 0) return(df)
+    if (empty(df)) return(data.frame())
     transformed <- compact(lapply(.$.scales, function(scale) {
       scale$transform_df(df)
     }))
@@ -138,7 +138,7 @@ Scales <- proto(Scale, expr={
   # scales are always available for modification.   The type of a scale is
   # fixed by the first use in a layer.
   add_defaults <- function(., data, aesthetics, env) {
-    if (is.null(data) || is.null(aesthetics)) return()
+    if (is.null(aesthetics)) return()
     names(aesthetics) <- laply(names(aesthetics), aes_to_scale)
 
     new_aesthetics <- setdiff(names(aesthetics), .$input())

diff --git a/R/stat-.r b/R/stat-.r
@@ -11,7 +11,7 @@ Stat <- proto(TopLevel, expr={
   calculate <- function(., data, scales, ...) {}
 
   calculate_groups <- function(., data, scales, ...) {
-    if (is.null(data) || nrow(data) == 0) return(data.frame())
+    if (empty(data)) return(data.frame())
 
     force(data)
     force(scales)

diff --git a/R/utilities-layer.r b/R/utilities-layer.r
@@ -19,7 +19,7 @@ is.integeric <- function(x) all(floor(x) == x)
 # @value data.frame with group variable
 # @keyword internal
 add_group <- function(data) {
-  if (nrow(data) == 0) return(data)
+  if (empty(data)) return(nullGrob())
 
   if (is.null(data$group)) {
     cat <- sapply(data[setdiff(names(data), "label")], plyr::is.discrete)

diff --git a/R/utilities.r b/R/utilities.r
@@ -158,4 +158,8 @@ invert <- function(L) {
 # @keywords internal
 "%inside%" <- function(x, interval) {
   x >= interval[1] & x <= interval[2]
+}
+
+empty <- function(df) {
+  (is.null(df) || nrow(df) == 0 || ncol(df) == 0)
 }