Update example with origin and legend

table.shingle.R

table.shingle<-function(..., as.data.frame=F) {
	dots<-list(...)
	stopifnot(all(sapply(dots, class) %in% c("shingle","factor")))
	stopifnot(length(unique(sapply(dots, length)))==1)
	dims<-sapply(dots, nlevels)
	varnames<-tail(lapply(match.call(), deparse),-1)
	varnames["as.data.frame"] <- NULL
	res<-array(0, dims, `names<-`(lapply(dots, function(x) as.vector(sapply(levels(x), paste, collapse=":"))), varnames))
	isinlevel<-function(z, ints) {
		if(is.factor(z)) {
			as.numeric(z)
		} else {
			which(sapply(ints, function(y) {y[1]<=z & z<=y[2]}))
		}
	}
	for(i in seq_along(dots[[1]])) {
		dx<-vector("list", length(dots))
		for(h in seq_along(dots)) {
			dx[[h]]<-isinlevel(dots[[h]][i], levels(dots[[h]]))
		}
		idx<-as.matrix(do.call("expand.grid", dx))
		res[idx]<-res[idx]+1
	}
	res<-as.table(res)
	if(as.data.frame) {
		#attempts to preserve the shingles
		shingleunoverlap<-function(x) {
			n<-nlevels(x)*2
			ints<-do.call(rbind, levels(x))
			return((ints[c(1, seq(n/2+1, n-1))] +  ints[c(seq(2, n/2),n)])/2);
		}
		res<-base::as.data.frame(res)
		for(i in seq_along(dots)) {
			if(class(dots[[i]])=="shingle") {
				nvals<-shingleunoverlap(dots[[i]])[as.numeric(res[[i]])]
				res[[i]]<-nvals
				attr(res[[i]], "levels")<-attr(dots[[i]], "levels")
				attr(res[[i]], "class")<-"shingle"
			}
		}
	}
	res;
}

test.table.shingle.R

require(lattice)

x<-equal.count(rnorm(50))
y<-factor(sample(c("M","F"), 50, replace=T))
z<-equal.count(rnorm(50))

a<-table.shingle(x,y,z);a
b<-table.shingle(x,y,z, as.data.frame=T);b

useOuterStrips(barchart(~Freq|x+z,b, groups=y, origin=0, auto.key=TRUE))