まえの日記ではimage_text関数をかきました。
でも、本当はもっとひどいスパゲティーコードで、ひどい関数でした…というお話。
でも、相関係数のマトリクスや、数値を視覚化するときに便利にしていたな〜
image2 <- function(dat, dimname=dimnames(dat), log=FALSE, digits=2, zlim=c("fit","center"), lower=TRUE, text.plot=TRUE, text.cex=1, text.col="grey50", thres=c(0,.9), thres.col=c("red", "blue"), xlab=TRUE, ylab=TRUE, grid=FALSE, grid.v=FALSE, grid.h=FALSE, grid.divide=FALSE, rot=c(-45,-45), colbar=TRUE, col="bw", ...){ if(!is.matrix(dat)) dat <- as.matrix(dat) x <- dat dimnames(x) <- dimname # マトリクスの並べ替え if(log) x <- log2(x) if(zlim[1] == "center"){ zlim <- ceiling(max(abs(x), na.rm=TRUE)*10)/10 zlim <- c((-1)*zlim, zlim) }else{ zlim <- range(x, na.rm=TRUE, finite=TRUE) zlim <- c(floor(zlim[1]*10)/10, ceiling(zlim[2]*10)/10) } if(is.numeric(digits)) x <- round(x,digits=digits) if(lower) x[upper.tri(x)] <- NA #x <- t(x[nrow(x):1,ncol(x):1])[ncol(x):1,] # 文字の色を決める y <- x y[!is.na(y)] <- text.col if(!is.na(thres[1])) y[x < thres[1] & !is.na(x)] <- thres.col[1] if(!is.na(thres[2])) y[x > thres[2] & !is.na(x)] <- thres.col[2] text.col <- y if(all(text.plot)) labels <- x labels[is.na(labels)] <- "" # カラーコードを決める if(any(c("ryg","gyr","gbr","rbg","gwr","rwg","bwr","rwb","bw","wb","gw","wg","rw","rainbow")%in%col)) col <- col.seq(col) # image関数かimage.plot関数か if(colbar){ par(mai=c(1,1,.8,0)) library("fields") image.plot(t(x[nrow(x):1,ncol(x):1])[ncol(x):1,], nlevel=40, zlim=zlim , legend.shrink=1, col=col, axes=FALSE, horizontal=FALSE, ...) detach("package:fields") }else{ par(mai=c(1,1,.8,1)) image(t(x[nrow(x):1,ncol(x):1])[ncol(x):1,], zlim=zlim, col=col, axes=FALSE, ...) } # 値を入れる at_v <- 1/(2*(ncol(x)-1)) at_v <- seq(0,1+2*at_v,by=at_v)-at_v at_h <- 1/(2*(nrow(x)-1)) at_h <- seq(0,1+2*at_h,by=at_h)-at_h xy <- do.call("rbind",lapply(at_v[seq(2,length(at_v),by=2)] ,function(x,y) cbind(x,y),y=rev(at_h[seq(2,length(at_h),by=2)]))) if(text.plot){ text(xy, labels=labels, col=text.col, cex=text.cex) } # グリッドを入れる if(grid) abline(v=at_v[seq(3,length(at_v)-1,by=2)],h=at_h[seq(3,length(at_h)-1,by=2)],col=8) if(grid.v) abline(v=at_v[seq(3,length(at_v)-1,by=2)],col=8) if(grid.h) abline(h=at_h[seq(3,length(at_h)-1,by=2)],col=8) if(is.list(grid.divide)) abline(v=at_v[seq(3,length(at_v)-1,by=2)][grid.divide[[1]]] ,h=rev(at_h[seq(3,length(at_h)-1,by=2)])[grid.divide[[2]]],col="blue3") box() # 軸に名前を入れる gridtext(label=colnames(x),at=at_v[seq(2,length(at_v)-1,by=2)],side=1,rot=-90) gridtext(label=rev(rownames(x)),at=at_h[seq(2,length(at_h)-1,by=2)],side=2,rot=0,just="right") }
こんな関数でした。
で、実際に使ってみると、こんな絵が描けます。
dat <- matrix(1:18+rnorm(18),ncol=9,nrow=10,dimnames=list(1:10,paste("colname",1:9))) jpeg("image2-1.jpg") image2(dat,grid.h=TRUE,lower=FALSE,thres=c(2,15),thres.col=c("cyan","magenta")) dev.off() jpeg("image2-2.jpg") image2(cor(dat),grid=TRUE,grid.divide=list(c(1,3,5),c(2,6)),main="Correlation") dev.off()
で、こんな感じ。
引数が多くて、ifコードもひどい。見苦しい限りです。
今から振り返ると、コードを書き直すのも億劫になるひどいコードです。
