grp.plot <- function(data, panel.x = 1, panel.y = NULL, panel.function, panel.axes = "lb", panel.axes.cex = 0.7, ..., grp.xy = NULL, vars.to.factors = TRUE, panel.reverse.y = FALSE, panel.space.factor = 0.1, panel.prop.to.size = c(FALSE, FALSE), panel.margin = 0.05, panel.frame = TRUE, panel.adjust = c(0.5, 0.5), main, horizontal = FALSE, probability = TRUE, lab.side = c("bl", "br", "tl", "tr")[1], lab.parallel = c(TRUE, TRUE), lab.cex = 1, lab.boxes = 2, lab.color = c("#CCCCCC", "white"), lab.type = c("expanded", "compact")[2], lab.n.max = 16, packer = c("boxplot", "hist", "xy.plot", "free")[1], verbose = !TRUE){ if(verbose) print("grp.plot starts") grp.pic <- paste(collapse = "", c("0 ~ 0 |", paste(c(panel.x, panel.y), collapse = "+") ) ) pic.plot.result <- do.call("pic.plot", list(data, grp.xy = grp.xy, vars.to.factors = vars.to.factors, grp.pic = grp.pic, panel.reverse.y = panel.reverse.y, panel.space.factor = panel.space.factor, panel.prop.to.size = panel.prop.to.size, panel.margin = panel.margin, panel.frame = panel.frame, panel.adjust = panel.adjust, lab.side = lab.side, lab.parallel = lab.parallel, lab.cex = lab.cex, lab.boxes = lab.boxes, lab.color = lab.color, lab.type = lab.type, lab.n.max = lab.n.max, main = if(!missing(main)) main else "grp.plot of data", packer = c("relax"), verbose = verbose)) jobs <- pic.plot.result$jobs data.mat <- pic.plot.result$data.mat newpar <- pic.plot.result$newpar colnames(data.mat) <- make.names(colnames(data.mat)) # print("in grp.plot"); print(data.mat[1:3,]) if(packer == "xy.plot" && is.null(panel.y)) panel.y <- panel.x if(packer == "xy.plot" && missing(panel.function)){ panel.function <- function() points(dm[,panel.x], dm[,panel.y]) } if(!missing(panel.function)){ # environment(panel.function) <- environment() # alt panel.env <- attach(what = NULL) if(exists("panel.x")) assign("panel.x", panel.x, env = panel.env) if(exists("panel.y")) assign("panel.y", panel.y, env = panel.env) assign("data.mat", data.mat, env = panel.env) assign("jobs", jobs, env = panel.env) environment(panel.function) <- panel.env } opa <- par(no.readonly = TRUE); par(newpar) size.usr.to.mm <- function(size, horizontal = TRUE){ # use to mm usr <- par()$usr; usr <- usr[(3:4) - 2 * horizontal]; pin <- par()$pin mm <- size / (usr[2]-usr[1]) * pin[2 - horizontal] * 25.4 } new.mai <- rbind(size.usr.to.mm(jobs[,3] - newpar$usr[3], horizontal = FALSE), size.usr.to.mm(jobs[,1] - newpar$usr[1]), - size.usr.to.mm(jobs[,4] - newpar$usr[4], horizontal = FALSE), - size.usr.to.mm(jobs[,2] - newpar$usr[2])) / 25.4 + newpar$mai # focus first panel par(mai = new.mai[,1], new = TRUE ) if(packer == "xy.plot"){ par(mai = new.mai[,1], new = TRUE) if(is.factor(data.mat[, panel.x])) data.mat[, panel.x] <- as.numeric(as.character(data.mat[, panel.x])) if(is.factor(data.mat[, panel.y])) data.mat[, panel.y] <- as.numeric(as.character(data.mat[, panel.y])) plot(data.mat[, panel.x], data.mat[, panel.y], col = 0, main="", xlab="", ylab="",axes=FALSE, type="n") usr <- par()$usr xy.names <- c(panel.x, panel.y) if( is.numeric(xy.names) ) xy.names <- colnames(data.mat)[xy.names] } if(packer == "boxplot"){ if(is.factor(data.mat[, panel.x])) data.mat[, panel.x] <- as.numeric(as.character(data.mat[, panel.x])) usr <- c(.5,1.5, range(data.mat[,panel.x])) # if(missing(horizontal) && horizontal) usr <- usr[c(3:4, 1:2)] # else horizontal <- FALSE xy.names <- c(panel.x) if( is.numeric(xy.names) ) xy.names <- colnames(data.mat)[xy.names] } if(packer == "hist"){ if(is.factor(data.mat[, panel.x])) data.mat[, panel.x] <- as.numeric(as.character(data.mat[, panel.x])) breaks <- hist(data.mat[,panel.x], plot = FALSE)$breaks usr <- c(range(data.mat[,panel.x]), 0, -Inf) for(j in seq(dim(jobs)[1])){ dm <- data.mat[ data.mat[,"job.no"] == jobs[j,5], , drop = FALSE ] res <- hist(dm[, panel.x], plot = FALSE, breaks = breaks) h <- max(res$counts)/diff(breaks[1:2]) / sum(res$counts) usr[4] <- pmax(usr[4], h) } xy.names <- c(panel.x) if( is.numeric(xy.names) ) xy.names <- colnames(data.mat)[xy.names] } for(j in seq(dim(jobs)[1])){ par(mai = new.mai[,j], new = TRUE) dm <- data.mat[ data.mat[,"job.no"] == jobs[j,5], , drop = FALSE ] if(!missing(panel.function)){ assign("dm", dm, env = panel.env) # print("HALLO"); print(dm[1:3,]) } if(packer == "xy.plot"){ plot(dm[,panel.x], dm[,panel.y], xlim = usr[1:2], ylim = usr[3:4], xlab="", ylab="",axes=FALSE, type = "n", ...) if( !is.null(panel.axes) ){ panel.axes <- unlist(strsplit(panel.axes, "")) if("l" %in% panel.axes ){ if( jobs[j,1] == min(jobs[,1] ) ) { axis(2,cex.axis = panel.axes.cex, padj=1.5) axis(2,at = usr[4], labels = xy.names[2], cex.axis = panel.axes.cex, hadj = 1, padj = -0.5, tick = FALSE) } } if("r" %in% panel.axes ){ if( jobs[j,2] == max(jobs[,2] ) ) { axis(4,cex.axis = panel.axes.cex, padj=-1.5) axis(4,at = usr[4], labels = xy.names[2], cex.axis = panel.axes.cex, hadj = 1, padj = 0, tick = FALSE) } } if("t" %in% panel.axes ){ if( jobs[j,4] == max(jobs[,4] ) ) { axis(3,cex.axis = panel.axes.cex, padj=1.5) axis(3,at = usr[2], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = -0.5, tick = FALSE) } } if("b" %in% panel.axes ){ if( jobs[j,3] == min(jobs[,3] ) ) { axis(1,cex.axis = panel.axes.cex, padj=-1.5) axis(1,at = usr[2], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = 0, tick = FALSE) } } } } if(packer == "boxplot"){ boxplot(dm[,panel.x], type ="n", horizontal = horizontal, xlim = usr[1:2], ylim = usr[3:4], axes=FALSE, ...) ### mosaicplot(HairEyeColor) if( !is.null(panel.axes) ){ panel.axes <- unlist(strsplit(panel.axes, "")) if("b" %in% panel.axes && horizontal){ if( jobs[j,3] == min(jobs[,3] ) ) { axis(1,cex.axis = panel.axes.cex, padj=-1.5) axis(1,at = usr[2], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = 0, tick = FALSE) } } if("l" %in% panel.axes && !horizontal){ if( jobs[j,1] == min(jobs[,1] ) ) { axis(2,cex.axis = panel.axes.cex, padj=1.5) axis(2,at = usr[4], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = -0.5, tick = FALSE) } } if("t" %in% panel.axes && horizontal){ if( jobs[j,4] == max(jobs[,4] ) ) { axis(3,cex.axis = panel.axes.cex, padj=1.5) axis(3,at = usr[2], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = -0.5, tick = FALSE) } } if("r" %in% panel.axes && !horizontal){ if( jobs[j,2] == max(jobs[,2] ) ) { axis(4,cex.axis = panel.axes.cex, padj=-1.5) axis(4,at = usr[4], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = 0, tick = FALSE) } } } } if(packer == "hist"){ hist(dm[ ,panel.x], probability = probability, col = "red", main = "", breaks = breaks, xlim = usr[1:2], ylim = usr[3:4], axes = FALSE, xlab = "", ylab = "", ...) if( !is.null(panel.axes) ){ panel.axes <- unlist(strsplit(panel.axes, "")) if("b" %in% panel.axes){ if( jobs[j,3] == min(jobs[,3] ) ) { axis(1,cex.axis = panel.axes.cex, padj=-1.5) axis(1,at = usr[2], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = 0, tick = FALSE) } } if("l" %in% panel.axes){ if( jobs[j,1] == min(jobs[,1] ) ) { axis(2,cex.axis = panel.axes.cex, padj=1.5) axis(2,at = usr[4], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = -0.5, tick = FALSE) } } if("t" %in% panel.axes){ if( jobs[j,4] == max(jobs[,4] ) ) { axis(3,cex.axis = panel.axes.cex, padj=1.5) axis(3,at = usr[2], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = -0.5, tick = FALSE) } } if("r" %in% panel.axes){ if( jobs[j,2] == max(jobs[,2] ) ) { axis(4,cex.axis = panel.axes.cex, padj=-1.5) axis(4,at = usr[4], labels = xy.names[1], cex.axis = panel.axes.cex, hadj = 1, padj = 0, tick = FALSE) } } } } box() if(!missing(panel.function)){ attach.ok <- try( attach(dm)); ok <- try(panel.function()) if(class(attach.ok) != "try-error") detach(dm) if(class(ok) == "try-error") cat("Error: user panel.function failed\n") } } if(!missing(panel.function)){ if("NULL" %in% search()) detach("NULL") } par(opa) }