Preserve empty levels and factor ordering unlesss explicitly specifie…

…d otherwise
gsk3 · Feb 28, 2009 · b7b837f · b7b837f
1 parent 0c98379
commit b7b837f
Show file tree

Hide file tree

Showing 11 changed files with 23 additions and 22 deletions.
diff --git a/NEWS b/NEWS
@@ -8,4 +8,5 @@ ggplot2 0.8.3  (2008-XX-XX)
 * stat_summary: now warns when dropping records with missing values
 * scale_manual: breaks and limits 
 * scale_discrete: factor levels no longer mistakenly reordered
-* American spelling of color accepted in more places
+* American spelling of color accepted in more places
+* scale_discrete: empty factor levels will be preserved, unless drop = TRUE
diff --git a/R/facet-grid-.r b/R/facet-grid-.r
@@ -202,10 +202,10 @@ FacetGrid <- proto(Facet, {
 
     lapply(data, function(l) {
       for(i in seq_along(.$scales$x)) {
-        lapply(l[, i], .$scales$x[[i]]$train_df)
+        lapply(l[, i], .$scales$x[[i]]$train_df, drop = .$free$x)
       }
       for(i in seq_along(.$scales$y)) {
-        lapply(l[i, ], .$scales$y[[i]]$train_df)
+        lapply(l[i, ], .$scales$y[[i]]$train_df, drop = .$free$y)
       }
     })
   }

diff --git a/R/facet-wrap.r b/R/facet-wrap.r
@@ -173,10 +173,10 @@ FacetWrap <- proto(Facet, {
 
     lapply(data, function(l) {
       for(i in seq_along(.$scales$x)) {
-        .$scales$x[[i]]$train_df(l[[1, i]])
+        .$scales$x[[i]]$train_df(l[[1, i]], fr$x)
       }
       for(i in seq_along(.$scales$y)) {
-        .$scales$y[[i]]$train_df(l[[1, i]])
+        .$scales$y[[i]]$train_df(l[[1, i]], fr$y)
       }
     })
   }

diff --git a/R/scale-.r b/R/scale-.r
@@ -59,12 +59,12 @@ Scale <- proto(TopLevel, expr={
   }
 
   # Train scale from a data frame
-  train_df <- function(., df) {
+  train_df <- function(., df, drop = FALSE) {
     # Don't train if limits have already been set
     if (!is.null(.$limits)) return()
 
     input <- .$input_aesthetics(df)
-    l_ply(input, function(var) .$train(df[[var]]))
+    l_ply(input, function(var) .$train(df[[var]], drop))
   }
 
   # Map values from a data.frame.   Returns data.frame

diff --git a/R/scale-continuous-.r b/R/scale-continuous-.r
@@ -43,7 +43,8 @@ ScaleContinuous <- proto(Scale, funEnvir = globalenv(), {
     df
   }
 
-  train <- function(., x) {
+  train <- function(., x, drop = FALSE) {
+    if (!is.null(.$limits)) return()
     if (is.null(x)) return()
     if (!is.numeric(x)) {
       stop(
@@ -52,7 +53,6 @@ ScaleContinuous <- proto(Scale, funEnvir = globalenv(), {
       )
     }
     if (all(is.na(x))) return()
-
     .$.domain <- range(x, .$.domain, na.rm=TRUE, finite=TRUE)
   }
 

diff --git a/R/scale-date.r b/R/scale-date.r
@@ -24,7 +24,7 @@ ScaleDate <- proto(ScaleContinuous,{
     .$proto(.input=variable, .output=variable, major_seq=major, minor_seq=minor, format=format, name=name, .tr=trans, limits = limits)
   }
 
-  train <- function(., values) {
+  train <- function(., values, drop = FALSE) {
     .$.domain <- range(c(values, .$.domain), na.rm=TRUE)
   }
 

diff --git a/R/scale-discrete-.r b/R/scale-discrete-.r
@@ -7,8 +7,8 @@ ScaleDiscrete <- proto(Scale, expr={
 
   discrete <- function(.) TRUE
 
-  new <- function(., name=NULL, variable=.$.input, expand = c(0.05, 0.55), limits = NULL, breaks = NULL, labels = NULL, formatter = identity) {
-    .$proto(name=name, .input=variable, .output=variable, .expand = expand, .labels = labels, limits = limits, breaks = breaks, formatter = formatter)
+  new <- function(., name=NULL, variable=.$.input, expand = c(0.05, 0.55), limits = NULL, breaks = NULL, labels = NULL, formatter = identity, drop = FALSE) {
+    .$proto(name=name, .input=variable, .output=variable, .expand = expand, .labels = labels, limits = limits, breaks = breaks, formatter = formatter, drop = drop)
   }
 
   # Range -------------------
@@ -39,19 +39,19 @@ ScaleDiscrete <- proto(Scale, expr={
 
   # Override default behaviour: we do need to train, even if limits
   # have been set
-  train_df <- function(., df) {
+  train_df <- function(., df, drop = FALSE) {
     input <- .$input_aesthetics(df)
-    l_ply(input, function(var) .$train(df[[var]]))
+    l_ply(input, function(var) .$train(df[[var]], drop))
   }
 
-  train <- function(., x) {
+  train <- function(., x, drop = .$drop) {
     if (is.null(x)) return()
     if (!plyr::is.discrete(x)) {
       stop("Continuous variable (", .$name , ") supplied to discrete ",
        .$my_name(), ".", call. = FALSE) 
     }
 
-    .$.domain <- discrete_range(.$.domain, x)
+    .$.domain <- discrete_range(.$.domain, x, drop = drop)
   }
 
   check_domain <- function(.) {

diff --git a/R/scale-discrete-position.r b/R/scale-discrete-position.r
@@ -16,9 +16,9 @@ ScaleDiscretePosition <- proto(ScaleDiscrete, {
 
   cont_domain <- c(NA, NA)
 
-  train <- function(., x) {
+  train <- function(., x, drop = .$drop) {
     if (plyr::is.discrete(x)) {
-      .$.domain <- discrete_range(.$.domain, x)
+      .$.domain <- discrete_range(.$.domain, x, drop = drop)
     } else {
       .$cont_domain <- range(.$cont_domain, x, na.rm = TRUE)
     }

diff --git a/R/scale-identity.r b/R/scale-identity.r
@@ -5,7 +5,7 @@ ScaleIdentity <- proto(ScaleDiscrete, {
     .$proto(name=name, breaks=breaks, .labels=labels, .input=variable, .output=variable, formatter = formatter)
   }
 
-  train <- function(., data) {
+  train <- function(., data, drop = FALSE) {
     .$breaks <- union(.$breaks, unique(data))
   }
   trained <- function(.) !is.null(.$.labels)  

diff --git a/R/scales-.r b/R/scales-.r
@@ -96,11 +96,11 @@ Scales <- proto(Scale, expr={
   }
 
   # Train scale from a data frame
-  train_df <- function(., df) {
+  train_df <- function(., df, drop = FALSE) {
     if (is.null(df)) return()
 
     lapply(.$.scales, function(scale) {
-      scale$train_df(df)
+      scale$train_df(df, drop)
     })
   }
 

diff --git a/R/utilities-discrete.r b/R/utilities-discrete.r
@@ -2,7 +2,7 @@
 # This is the equivalent of range for discrete variables 
 # 
 # @keywords internal
-discrete_range <- function(..., drop = TRUE) {
+discrete_range <- function(..., drop = FALSE) {
   pieces <- list(...)
 
   clevels <- function(x) {