# Routines for comparing distributions # Tom Minka 1/28/02 jitter <- function(x) x + runif(length(x), -0.4, 0.4) sapply <- function(X, FUN, ..., simplify = T) { if(is.character(FUN)) FUN <- get(FUN, mode = "function") else if(mode(FUN) != "function") { farg <- substitute(FUN) if(mode(farg) == "name") FUN <- get(farg, mode = "function") else stop(paste("\"", farg, "\" is not a function", sep = "")) } answer <- lapply(X, FUN, ...) if(simplify && length(answer) && length(common.len <- unique(unlist(lapply(answer, length)))) == 1) { if(common.len == 1) unlist(answer, recursive = F) else if(common.len > 1) array(unlist(answer, recursive = F), c( common.len, length(X)), list(names(X[[1]]), names(answer))) else answer } else answer } # only needed on PC if(T) trellis.device(color=F) as.data.frame.table <- function (x) { data.frame(do.call("expand.grid", dimnames(x)), Freq = c(x)) } ########################################################################################## cut.quantile <- function(x,n=4) { if(length(x) == 0) stop("input vector is empty") x[is.na(x)] <- 0 b <- quantile(x,probs=seq(0,1,len=n)) if(n == 4) labels <- c("low","med","high") else labels <- NULL cut(x,b,include=T,labels=labels) } dotplot.superpose <- function(m,xlab="") { f <- as.data.frame.table(m) n <- length(levels(f$Var1)) dotplot(Var2~Freq,f,groups=Var1,xlab=xlab, panel = function(x, y, subscripts, groups, ...) { dot.line <- trellis.par.get("dot.line") panel.abline(h = y, col = dot.line$col, lty = dot.line$lty, lwd = dot.line$lwd) panel.superpose(x, y, subscripts, groups, ...) }, key = list(points = Rows(trellis.par.get("superpose.symbol"), 1:n), text = list(levels(f$Var1)), columns = n) ) }