geom_cloud.r

library(dplyr)

library(ggplot2)
library(grid)

geom_cloud <- function(mapping = NULL, data = NULL, ...,
											 na.rm = FALSE, 
											 steps = 5, se_mult=1, max_alpha=1,
											 inherit.aes = TRUE) {

  layer(
    data = data,
    mapping = mapping,
    stat = "identity",
    geom = GeomCloud,
    position = "identity",
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
			steps = steps,
			se_mult = se_mult,
			max_alpha = max_alpha,
      ...
    )
  )
}

# get points equally spaced in density 
equal_ses <- function(steps) {
	xend <- c(0,4)
	endpnts <- dnorm(xend)
# perhaps use ppoints instead?
	deql <- seq(from=endpnts[1],to=endpnts[2],length.out=steps+1)
	davg <- (deql[-1] + deql[-length(deql)])/2
# invert
	xeql <- unlist(lapply(davg,function(d) {
					 uniroot(f=function(x) { dnorm(x) - d },interval=xend)$root
	}))
	xeql
}

GeomCloud <- ggproto("GeomCloud", Geom,
  required_aes = c("x", "y", "ymin", "ymax"),
  non_missing_aes = c("fill"),
  default_aes = aes(
    colour = NA, fill = NA, alpha = 1, size=1, linetype=1
  ),
	setup_data = function(data,params) {
		ses <- equal_ses(params$steps)
		data$up_se <- (1/params$se_mult) * (data$ymax - data$y)
		data$dn_se <- (1/params$se_mult) * (data$y - data$ymin)
		data$alpha <- params$max_alpha / params$steps
		# a trick to get positions ok: puff up the ymax and ymin for now
		maxse <- max(ses)
		data$ymax  <- data$y + maxse * data$up_se
		data$ymin  <- data$y - maxse * data$dn_se
		data
	},
  draw_group = function(data, panel_scales, coord,
												na.rm = FALSE,
												steps = 5, se_mult=1, max_alpha=1) {

		# 2FIX: use the coordinate transform? or just forget it?
		ses <- equal_ses(steps)
		grobs <- Map(function(myse) {
									 this_data <- data
									 this_data$ymax <- this_data$y + myse * this_data$up_se
									 this_data$ymin <- this_data$y - myse * this_data$dn_se
									 ggplot2::GeomRibbon$draw_group(this_data, panel_scales, coord, na.rm=na.rm)
												},ses)
		do.call("gList",grobs)
  },
	draw_key = draw_key_polygon
)


library(dplyr)

nobs <- 1000

set.seed(2134)
mydat <- data.frame(grp=sample(c(0,1),nobs,replace=TRUE),
										colfac=sample(letters[1:2],nobs,replace=TRUE),
										rowfac=sample(letters[10 + (1:2)],nobs,replace=TRUE)) %>%
	mutate(x=seq(0,1,length.out=nobs) + 0.33 * grp) %>%
	mutate(y=0.25*rnorm(nobs) + 2*grp) %>%
	mutate(grp=factor(grp)) %>%
	mutate(se=runif(nobs,min=1,max=1.1) * sqrt(x)) %>%
	mutate(ymin=y-se,ymax=y+se)

ph <- mydat %>%
	ggplot(aes(x=x,y=y,ymin=ymin,ymax=ymax,color=grp)) + 
	facet_grid(rowfac ~ colfac) +
	geom_line() + 
	geom_errorbar() +
	labs(title='with errorbar')
#print(ph)

ph <- mydat %>%
	ggplot(aes(x=x,y=y,ymin=ymin,ymax=ymax,color=grp,fill=grp)) + 
	facet_grid(rowfac ~ colfac) +
	geom_line() + 
	geom_cloud(aes(fill=grp),steps=12,color=NA) + 
	geom_errorbar() +
	labs(title='with errorbar')
print(ph)

ph <- mydat %>%
	ggplot(aes(x=x,y=y,ymin=ymin,ymax=ymax,color=grp,fill=grp)) + 
	facet_grid(rowfac ~ colfac) +
	geom_line() + 
	geom_cloud(aes(fill=grp),steps=15,max_alpha=0.5,color=NA) + 
	geom_errorbar() +
	labs(title='with errorbar')
#print(ph)

# do transforms work? not sure...
offs <- 2
ph <- mydat %>%
	mutate(y=y+offs,ymin=ymin+offs,ymax=ymax+offs) %>%
	ggplot(aes(x=x,y=y,ymin=ymin,ymax=ymax,color=grp,fill=grp)) + 
	facet_grid(rowfac ~ colfac) +
	scale_y_sqrt() + 
	geom_line() + 
	geom_cloud(aes(fill=grp),steps=15,max_alpha=0.75,color=NA) + 
	geom_errorbar() +
	labs(title='with errorbar')
print(ph)
# source('~/cloud.r')