Position cleanup

  * dodge works again
  * stack, dodge and fill all use same base function
  * jitter uses width and height arguments to match others (and future)

NEWS

@@ -1,6 +1,7 @@
 ggplot2 0.6.1  (2008-XX-XX)
 ----------------------------------------
 
+  * Arguments to geom_jitter changed to height and width to match other position adjustments
   * Fixed bug in remove_missing function will resulted incorrect calculations of some statistics when missing values were present
   * geom_boxplot: previously was not displaying outliers if only one present
   * show outlier if only one present

R/position-.r

@@ -7,7 +7,11 @@ Position <- proto(TopLevel, expr = {
 
   class <- function(.) "position"
 
-  new <- function(.) .$proto()
+  width <- NULL
+  height <- NULL
+  new <- function(., width = NULL, height = NULL) {
+    .$proto(width = width, height = NULL)
+  }
 
   parameters <- function(.) {
     params <- formals(get("new", .))

R/position-collide.r

@@ -0,0 +1,59 @@
+collide <- function(data, width = NULL, name, strategy) {
+
+  # Determine width
+  if (!is.null(width)) {
+    # Width set manually
+    width <- .$width
+    data <- within(data, {
+      xmin <- x - width / 2
+      xmax <- x + width / 2
+    })
+  } else {
+    # Width determined from data, must be floating point constant 
+    widths <- unique(with(data, xmax - xmin))
+    if (length(widths) > 1 && sd(widths) > 1e-6) {
+      stop(name, " requires constant width", call. = FALSE)
+    }
+    width <- widths[1]
+  }
+
+  # Check for overlap
+  intervals <- as.numeric(t(unique(data[c("xmin", "xmax")])))
+  if (any(diff(intervals) < -1e-6)) {
+    stop(name, " requires non-overlapping x intervals", call. = FALSE)
+    # This is where the algorithm from [L. Wilkinson. Dot plots. 
+    # The American Statistician, 1999.] should be used
+  }
+
+  ddply(data, .(xmin), function(df) strategy(df, width = width))
+}
+
+# Assumes that each set has the same horizontal position
+stack <- function(df, width) {
+  n <- nrow(df) + 1
+  y <- with(df, ifelse(is.na(y), 0, y))
+  heights <- c(0, cumsum(y))
+
+  within(df, {
+    ymin <- heights[-n]
+    ymax <- heights[-1]
+  })
+}
+
+fill <- function(df, width) {
+  within(stack(df, width), {
+    ymin <- ymin / max(ymax)
+    ymax <- ymax / max(ymax)
+  })
+}
+
+# Assumes that each set has the same horizontal position
+dodge <- function(df, width) {
+  n <- nrow(df)
+
+  within(df, {
+    xmin <- xmin + width / n * seq_len(n)
+    xmax <- xmin + width / n
+  })
+}
+

R/position-dodge.r

@@ -1,26 +1,9 @@
 PositionDodge <- proto(Position, {
-
-  width <- NULL
-  new <- function(., width=NULL) {
-    .$proto(width=width)
-  }
-
   adjust <- function(., data, scales) {
     if (nrow(data) == 0) return()
     check_required_aesthetics("x", names(data), "position_dodge")
 
-    if (is.null(data$width)) data$width <- resolution(data$x) * 0.9
-    maxwidth <- if (!is.null(.$width))  .$width else max(data$width)
-    maxn <- max(tapply(data$x, data$x, length))
-    dodge <- function(data) {
-      transform(data, 
-        x = x + (1:nrow(data) - (maxn + 1) / 2) * (maxwidth/maxn) ,
-        width = width / maxn
-      )
-    }
-
-    xs <- split(data, data$x)
-    do.call("rbind.fill", lapply(xs, dodge))
+    collide(data, .$width, .$my_name(), dodge)
   }  
 
   objname <- "dodge"
@@ -39,10 +22,12 @@ PositionDodge <- proto(Position, {
     p <- qplot(x, y, data=df, position="dodge", geom="bar", stat="identity")
     p 
     p + geom_linerange(aes(ymin= y - 1, ymax = y+1), position="dodge")
+
     # Dodging things with different widths is tricky
     p + geom_errorbar(aes(ymin= y - 1, ymax = y+1), width=0.2, position="dodge")
     # You can specify the width to use for dodging (instead of the actual
     # width of the object) as follows
     p + geom_errorbar(aes(ymin= y - 1, ymax = y+1, width=0.2), position=position_dodge(width=0.90))
   }
 })
+

R/position-fill.r

@@ -0,0 +1,37 @@
+PositionFill <- proto(Position, {
+  adjust <- function(., data, scales) {
+    if (is.null(data)) return() 
+
+    y <- scales$get_scales("y")
+    y$limits <- c(0, 1)
+
+    check_required_aesthetics(c("x", "ymax"), names(data), "position_fill")
+    if (!all(data$ymin == 0)) warning("Filling not well defined when ymin != 0")
+    collide(data, .$width, .$my_name(), fill)
+  }  
+
+  objname <- "fill"
+  desc <- "Stack overlapping objects on top of one another, and standardise have equal height"
+
+  icon <- function(.) {
+    y <- c(0.5, 0.8)
+    rectGrob(0.5, c(0.625, 1), width=0.4, height=c(0.625, 0.375), gp=gpar(col="grey60", fill=c("#804070", "#668040")), vjust=1)
+  }
+
+
+  examples <- function(.) {
+    # See ?geom_bar and ?geom_area for more examples
+    ggplot(mtcars, aes(x=factor(cyl), fill=factor(vs))) + geom_bar(position="fill")
+
+    cde <- geom_histogram(position="fill", binwidth = 500)
+
+    ggplot(diamonds, aes(x=price)) + cde
+    ggplot(diamonds, aes(x=price, fill=cut)) + cde
+    ggplot(diamonds, aes(x=price, fill=clarity)) + cde
+    ggplot(diamonds, aes(x=price, fill=color)) + cde
+  }
+
+
+})
+
+

R/position-jitter.r

@@ -1,24 +1,17 @@
 PositionJitter <- proto(Position, {
-
-  xjitter <- NULL
-  yjitter <- NULL
-  new <- function(., xjitter=NULL, yjitter=NULL) {
-    .$proto(xjitter=xjitter, yjitter=yjitter)
-  }
-
   adjust <- function(., data, scales) {
     check_required_aesthetics(c("x", "y"), names(data), "position_jitter")
 
-    if (is.null(.$xjitter)) .$xjitter <- resolution(data$x) * 0.40
-    if (is.null(.$yjitter)) .$yjitter <- resolution(data$y) * 0.40
+    if (is.null(.$width)) .$width <- resolution(data$x) * 0.40
+    if (is.null(.$height)) .$height <- resolution(data$y) * 0.40
 
     trans_x <- NULL
     trans_y <- NULL
-    if(.$xjitter > 0) {
-      trans_x <- function(x) jitter(x, amount = .$xjitter)
+    if(.$width > 0) {
+      trans_x <- function(x) jitter(x, amount = .$width)
     }
-    if(.$yjitter > 0) {
-      trans_y <- function(x) jitter(x, amount = .$yjitter)
+    if(.$height > 0) {
+      trans_y <- function(x) jitter(x, amount = .$height)
     }
 
     transform_position(data, trans_x, trans_y)
@@ -37,13 +30,8 @@ PositionJitter <- proto(Position, {
     qplot(am, vs, data=mtcars)
     qplot(am, vs, data=mtcars, position="jitter")
     # Control amount of jittering by calling position_jitter
-    qplot(am, vs, data=mtcars, position=position_jitter(x=10, y=0))
-    qplot(am, vs, data=mtcars, position=position_jitter(x=0.5, y=0.5))
-
-    # See lots of actually useful examples at geom_jitter
-    # You can, however, jitter any geom, however little sense it might make
-    qplot(cut, clarity, data=diamonds, geom="blank", group=1) + geom_path()
-    qplot(cut, clarity, data=diamonds, geom="blank", group=1) + geom_path(position="jitter")
+    qplot(am, vs, data=mtcars, position=position_jitter(w=10, h=0))
+    qplot(am, vs, data=mtcars, position=position_jitter(w=0.5, h=0.5))
   }
 
 })

R/position-stack.r

@@ -1,30 +1,12 @@
 PositionStack <- proto(Position, {
-  rescale <- FALSE
 
   adjust <- function(., data, scales) {
     if (is.null(data)) return() 
 
-    check_required_aesthetics(c("x", "y"), names(data), "position_stack")
+    check_required_aesthetics(c("x", "ymax"), names(data), "position_stack")
     if (!all(data$ymin == 0)) warning("Stacking not well defined when ymin != 0")
-
-    adjust <- function(data) {
-      data <- data[order(data$x), ]
-
-      y <- with(data, ifelse(is.na(y), 0, y))
-      heights <- c(0, cumsum(y))
-      if (.$rescale) heights <- rescale(heights, c(0,1))
-      transform(data, 
-        ymin = heights[-length(heights)],
-        ymax = heights[-1],
-        y = heights[-1]
-      )
-    }
-
-    xs <- split(data, data$x)
-    data <- do.call("rbind", lapply(xs, adjust))
-
-    data
-  }
+    collide(data, .$width, .$my_name(), stack)
+  }  
 
   objname <- "stack"
   desc <- "Stack overlapping objects on top of one another"
@@ -36,31 +18,7 @@ PositionStack <- proto(Position, {
     # See ?geom_bar and ?geom_area for more examples
     ggplot(mtcars, aes(x=factor(cyl), fill=factor(vs))) + geom_bar()
 
-    ggplot(diamonds, aes(x=price)) + geom_bar()
-    ggplot(diamonds, aes(x=price, fill=cut)) + geom_bar()
-  }
-})
-
-PositionFill <- proto(PositionStack, {
-  rescale <- TRUE
-  objname = "fill"
-  desc <- "Stack overlapping objects on top of one another, and standardise have equal height"
-
-  icon <- function(.) {
-    y <- c(0.5, 0.8)
-    rectGrob(0.5, c(0.625, 1), width=0.4, height=c(0.625, 0.375), gp=gpar(col="grey60", fill=c("#804070", "#668040")), vjust=1)
-  }
-
-
-  examples <- function(.) {
-    # See ?geom_bar and ?geom_area for more examples
-    ggplot(mtcars, aes(x=factor(cyl), fill=factor(vs))) + geom_bar(position="fill")
-
-    ggplot(diamonds, aes(x=price)) + geom_bar(position="fill")
-    ggplot(diamonds, aes(x=price, fill=cut)) + geom_bar(position="fill")
-    ggplot(diamonds, aes(x=price, fill=clarity)) + geom_bar(position="fill")
-    ggplot(diamonds, aes(x=price, fill=color)) + geom_bar(position="fill")
+    ggplot(diamonds, aes(x=price)) + geom_histogram(binwidth=500)
+    ggplot(diamonds, aes(x=price, fill=cut)) + geom_histogram(binwidth=500)
   }
-
-
 })