Permalink
Browse files

Added Wilkinson-style dot plot.

  • Loading branch information...
1 parent 2e9ce70 commit 1457979c53b1c9282e328159cdca014a8f56a81c @wch wch committed Dec 9, 2011
Showing with 397 additions and 0 deletions.
  1. +3 −0 DESCRIPTION
  2. +3 −0 NAMESPACE
  3. +134 −0 R/geom-dotplot.r
  4. +73 −0 R/grob-dotcluster.r
  5. +184 −0 R/stat-bindot.r
View
@@ -74,6 +74,7 @@ Collate:
'geom-boxplot.r'
'geom-crossbar.r'
'geom-defaults.r'
+ 'geom-dotplot.r'
'geom-error.r'
'geom-errorh.r'
'geom-freqpoly.r'
@@ -103,6 +104,7 @@ Collate:
'geom-vline.r'
'ggplot2.r'
'grob-absolute.r'
+ 'grob-dotcluster.r'
'grob-null.r'
'guide-colorbar.r'
'guide-legend.r'
@@ -157,6 +159,7 @@ Collate:
'stat-contour.r'
'stat-density-2d.r'
'stat-density.r'
+ 'stat-bindot.r'
'stat-function.r'
'stat-identity.r'
'stat-qq.r'
View
@@ -34,6 +34,7 @@ export(geom_contour)
export(geom_crossbar)
export(geom_density)
export(geom_density2d)
+export(geom_dotplot)
export(geom_errorbar)
export(geom_errorbarh)
export(geom_freqpoly)
@@ -164,6 +165,7 @@ export(stat_aggr2d)
export(stat_aggrhex)
export(stat_bin)
export(stat_bin2d)
+export(stat_bindot)
export(stat_binhex)
export(stat_boxplot)
export(stat_contour)
@@ -241,6 +243,7 @@ S3method(cweave,list)
S3method(cweave,matrix)
S3method(dim,gtable)
S3method(drawDetails,zeroGrob)
+S3method(drawDetails,dotclustergrob)
S3method(facet_map_layout,grid)
S3method(facet_map_layout,null)
S3method(facet_map_layout,wrap)
View
@@ -0,0 +1,134 @@
+#' Dot plot
+#'
+geom_dotplot <- function (mapping = NULL, data = NULL, stat = "bindot", position = "identity",
+na.rm = FALSE, just = 0, binaxis = "x", binstataxis = "x", stackdir = "up", ...) {
+ GeomDotplot$new(mapping = mapping, data = data, stat = stat, position = position,
+ na.rm = na.rm, just = just, binaxis = binaxis, binstataxis = binstataxis, stackdir = stackdir, ...)
+}
+
+# TODO:
+# Get rid of binstataxis parameter - use only binaxis
+# Vertically align points either on grid, or physically touch
+# Bin overlap
+# Stack overlap
+# Add dot density algorithm
+# xmin, xmax bounding box
+# Set y range without using coord
+# Better way of setting baseline
+# Legends when used with violin
+
+GeomDotplot <- proto(Geom, {
+ objname <- "dotplot"
+
+# Is draw_groups needed?
+# draw_groups <- function(., ...) .$draw(...)
+
+ reparameterise <- function(., df, params) {
+ df$width <- df$width %||%
+ params$width %||% (resolution(df$x, FALSE) * 0.9)
+
+ if (params$binaxis=="x") {
+ # Fill the bins: at a given x, if count=3, make 3 entries at that x, with y=1,2,3
+ df <- ddply(df, .(x, group), function(xx) {
+ if(xx$count==0) return(NULL)
+ xx[1:xx$count, ] <- xx[1, ] # replicate the row count times
+ xx$countidx <- 1:(xx$count[1])
+ xx
+ })
+
+ # ymin, ymax, xmin, and xmax define the bounding rectangle for each group
+ # But not really.
+ # This is not the same as for y! fix me!
+ df <- ddply(df, .(group), transform,
+ ymin = min(y),
+ ymax = max(y),
+ xmin = min(x),
+ xmax = max(x))
+
+ } else if (params$binaxis=="y") {
+ df <- ddply(df, .(y, group), function(xx) {
+ if(xx$count==0) return(NULL)
+ xx[1:xx$count, ] <- xx[1, ] # replicate the row count times
+ xx$countidx <- 1:(xx$count[1])
+ xx
+ })
+
+ # ymin, ymax, xmin, and xmax define the bounding rectangle for each group
+ # But not really.
+ df <- ddply(df, .(group), transform,
+ ymin = min(y),
+ ymax = max(y),
+ xmin = x - width / 2,
+ xmax = x + width / 2)
+ }
+
+ df
+ }
+
+
+ draw <- function(., data, scales, coordinates, na.rm = FALSE, just = 0, binaxis = "x", stackdir = "up", ...) {
+ data <- remove_missing(data, na.rm,
+ c("x", "y", "size", "shape"), name = "geom_dotplot")
+ if (empty(data)) return(zeroGrob())
+
+
+ # Transform the data to the new coordinates
+ tdata <- coord_transform(coordinates, data, scales)
+
+
+ # Is there a better way of generalizing over x and y?
+ if (binaxis=="x") {
+ dotwidthnpc <- tdata$binwidth[1] / (max(scales$x.range) - min(scales$x.range))
+ # This isn't necessarily a reliable way to get the baseline...
+ stackbaselinenpc <- min(tdata$y)
+
+ binpositions <- tdata$x
+
+ } else if (binaxis=="y") {
+
+ dotwidthnpc <- tdata$binwidth[1] / (max(scales$y.range) - min(scales$y.range))
+ stackbaselinenpc <- min(tdata$x)
+ binpositions <- tdata$y
+ }
+
+ ggname(.$my_name(),
+ grobTree(
+ dotclusterGrob(binaxis, binpositions, bincounts=tdata$countidx, bintotals=tdata$count,
+ baseline=stackbaselinenpc,
+ binwidth=dotwidthnpc, heightratio=1,
+ stackdir=stackdir,
+ just=just,
+ default.units="npc",
+ gp=gpar(col=alpha(tdata$colour, tdata$alpha),
+ fill=alpha(tdata$fill, tdata$alpha))))
+ )
+
+ }
+
+ draw_legend <- function(., data, ...) {
+ # If fill is set, ensure that you can actually see it
+ if (!is.null(data$fill) && !all(is.na(data$fill)) && data$shape == 16) {
+ data$shape <- 21
+ }
+ data <- aesdefaults(data, .$default_aes(), list(...))
+
+ with(data,
+ pointsGrob(0.5, 0.5, size=unit(size, "mm"), pch=shape,
+ gp=gpar(
+ col=alpha(colour, alpha),
+ fill=alpha(fill, alpha),
+ fontsize = size * .pt)
+ )
+ )
+ }
+
+ icon <- function(.) {
+ pos <- seq(0.1, 0.9, length=6)
+ pointsGrob(x=pos, y=pos, pch=19, gp=gpar(col="black", cex=0.5), default.units="npc")
+ }
+
+ default_stat <- function(.) StatBindot
+ required_aes <- c("x", "y")
+ default_aes <- function(.) aes(y=..count.., shape=16, colour=NA, size=2, fill = "black", alpha = 1)
+
+})
View
@@ -0,0 +1,73 @@
+dotclusterGrob <- function (
+ binaxis = "x",
+ binpositions = unit(0.5, "npc"),
+ bincounts = 0,
+ bintotals = 0,
+ baseline = unit(0.5, "npc"),
+ binwidth = unit(1, "npc"), heightratio = 1,
+ stackdir = "up",
+ just = NULL, default.units = "npc", name = NULL, gp = gpar(),
+ vp = NULL)
+{
+ if (!is.unit(binpositions))
+ x <- unit(binpositions, default.units)
+ if (!is.unit(baseline))
+ baseline <- unit(baseline, default.units)
+ if (!is.unit(binwidth))
+ binwidth <- unit(binwidth, default.units)
+
+ grob(binaxis = binaxis, binpositions = binpositions, bincounts = bincounts, bintotals = bintotals,
+ baseline = baseline,
+ binwidth = binwidth, heightratio = heightratio,
+ stackdir = stackdir, just = just,
+ name = name, gp = gp, vp = vp,
+ cl = "dotclustergrob")
+}
+
+drawDetails.dotclustergrob <- function(x, recording=TRUE) {
+
+ # There's a binning axis and a stacking axis. If the binning axis is x, then the
+ # stacking axis is y, and vice versa.
+ if(x$binaxis == "x") {
+ convert_binaxis <- convertX
+ convert_stackaxis <- convertY
+ } else if (x$binaxis == "y") {
+ convert_binaxis <- convertY
+ convert_stackaxis <- convertX
+ }
+
+ # Some of these conversions are necessary to do arithmetic on the units
+ binwidthmm <- convert_binaxis(x$binwidth, "mm", valueOnly=TRUE)
+ binwidthnpc <- convert_binaxis(x$binwidth, "npc", valueOnly=TRUE)
+ binheightmm <- binwidthmm
+ binheightnpc <- convert_stackaxis(unit(binheightmm,"mm"), "npc", valueOnly=TRUE)
+
+ baselinenpc <- convert_binaxis(x$baseline, "npc", valueOnly=TRUE)
+
+ # Do stacking
+ if (x$stackdir == "up")
+ stackpos <- (x$bincounts-0.5-x$just) * binheightnpc + baselinenpc
+ else if (x$stackdir == "down")
+ stackpos <- (-x$bincounts+1.5-x$just) * binheightnpc + baselinenpc
+ else if (x$stackdir == "center")
+ stackpos <- (x$bincounts-(x$bintotals/2)-x$just) * binheightnpc + baselinenpc
+ else if (x$stackdir == "centerwhole")
+ stackpos <- ceiling((x$bincounts-(x$bintotals/2)-x$just)) * binheightnpc + baselinenpc
+ else if (x$stackdir == "centerwholedown")
+ stackpos <- floor ((x$bincounts-(x$bintotals/2)-x$just)) * binheightnpc + baselinenpc
+
+
+ if(x$binaxis == "x") {
+ xpos <- x$binpositions
+ ypos <- stackpos
+ } else if(x$binaxis == "y") {
+ xpos <- stackpos
+ ypos <- x$binpositions
+ }
+
+ grid.draw(
+ circleGrob(x=xpos, y=ypos,
+ r=unit(binwidthmm/2, "mm"), # Need absolute measurement because if you use npc coordinates, r is relative to the smaller direction of x and y
+ name=x$name, gp=x$gp, vp=x$vp),
+ )
+}
Oops, something went wrong.

0 comments on commit 1457979

Please sign in to comment.