# The MIT License # Copyright (c) 2007 The GGobi Foundation # http://www.ggobi.org/book/code-license.txt # For generating ellipses # Utility functions f.vc.ellipse <- function(vc, xm, n=500) { p<-ncol(vc) x<-f.gen.sphere(n,p) evc<-eigen(vc) vc2<-(evc$vectors)%*%diag(sqrt(evc$values))%*%t(evc$vectors) x<-x%*%vc2 x + matrix(rep(xm, each=n),ncol=p) } f.gen.sphere<-function(n=100,p=5) { x<-matrix(rnorm(n*p),ncol=p) xnew<-t(apply(x,1,f.norm.vec)) xnew } f.norm.vec<-function(x) { x<-x/f.norm(x) x } f.norm<-function(x) { sqrt(sum(x^2)) } # For multivariate normal f.gen.mvn<-function(n=100,p=5,mn=rep(0,p),vc=diag(rep(1,p))) { x<-matrix(rnorm(n*p),ncol=p) ev<-eigen(vc) vcsqrt<-diag(sqrt(ev$values))%*%t(ev$vectors) x<-x%*%vcsqrt x<-x+matrix(rep(mn,n),ncol=p,byrow=T) return(x) } f.mv.dist<-function(x){ n<-dim(x)[1] p<-dim(x)[2] mn<-apply(x,2,mean) vc<-var(x) ev<-eigen(vc) vcinv<-ev$vectors%*%diag(1/ev$values)%*%t(ev$vectors) x<-x-matrix(rep(mn,n),ncol=p,byrow=T) dx<-NULL for (i in 1:n) dx<-c(dx,x[i,]%*%vcinv%*%as.matrix(x[i,])) return(dx) } f.mv.distQQ<-function(x){ n<-dim(x)[1] p<-dim(x)[2] mn<-apply(x,2,mean) vc<-var(x) ev<-eigen(vc) vcinv<-ev$vectors%*%diag(1/ev$values)%*%t(ev$vectors) x<-x-matrix(rep(mn,n),ncol=p,byrow=T) dx<-NULL for (i in 1:n) dx<-c(dx,x[i,]%*%vcinv%*%as.matrix(x[i,])) par(pty="s") qqplot(dx,qchisq(((1:n)-0.5)/n,p),ylab="Chisq quantiles",pch=16,main="") lines(c(0:round(max(dx))),c(0:round(max(dx))),col="gray80") } # LDA f.var.ellipse<-function(x,n=100){ xm<-apply(x,2,mean) p<-dim(x)[2] xn<-dim(x)[1] xv<-var(x) ev<-eigen(xv) sph<-matrix(rnorm(n*p),ncol=p) cntr<-t(apply(sph,1,f.norm.vec)) cntr<-cntr%*%diag(sqrt(ev$values))%*%t(ev$vectors) cntr<-cntr+matrix(rep(xm,n),nrow=n,byrow=T) return(cntr) } # SOM routines f.ggobi.som <- function(x,x.som) { xmx<-jitter(x.som$visual$x,factor=2) xmy<-jitter(x.som$visual$y,factor=2) ncols<-ncol(x) x.ggobi<-cbind(x,xmx,xmy) dimnames(x.ggobi)[[2]][ncols+1]<-"Map 1" dimnames(x.ggobi)[[2]][ncols+2]<-"Map 2" x.grid<-cbind(x.som$code,x.som$code.sum[,1:2]) dimnames(x.grid)[[2]]<-dimnames(x.ggobi)[[2]] x.clust<-rbind(x.ggobi,x.grid) } f.ggobi.som.net <- function(x.som) { x.net<-NULL for (i in 1:x.som$xdim) { for (j in 1:x.som$ydim) { if (j\n\n",file=filename) cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) cat(sep="",dat1.description,"\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) p1<-ncol(dat1) n1<-nrow(dat1) cat(p1,n1,"\n") var.name1<-colnames(dat1) if (is.null(var.name1)) for (i in 1:p1) var.name1<-c(var.name1,paste("Var ",i)) cat(sep="","\n",file=filename,append=T) for (i in 1:p1) { if (is.factor(dat1[,i])) { l1<-length(levels(dat1[,i])) cat(sep=""," \n",file=filename,append=T) cat(" \n",sep="",file=filename,append=T) for (j in 1:l1) cat(" ",levels(dat1[,i])[j],"\n", sep="",file=filename,append=T) cat(" \n",file=filename,append=T) cat(" \n",file=filename,append=T) } else if (i%in%catvars1) { cat(sep=""," \n",file=filename,append=T) } else { cat(sep=""," \n", file=filename,append=T) } } cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) row.name1<-rownames(dat1) if (is.null(row.name1)) row.name1<-c(1:n1) if (is.null(dat1.id)) dat1.id<-c(1:n1) if (length(dat1.colors)!=n1) { if (!is.null(dat1.colors)) cat("Length of data 1 colors vector is not the same as the number of rows.\n") dat1.colors<-rep(default.color,n1) } if (length(dat1.glyphs)!=n1) { if (!is.null(dat1.glyphs)) cat("Length of data 1 glyphs vector is not the same as the number of rows.\n") dat1.glyphs<-rep(default.glyph,n1) } for(i in 1:n1) { cat(sep="","\n",file=filename,append=T) for (j in 1:p1) cat(dat1[i,j]," ",file=filename,append=T) cat(sep="","\n\n",file=filename,append=T) } cat(sep="","\n\n",file=filename,append=T) if (data.num>1) { # 2nd data p2<-ncol(dat2) n2<-nrow(dat2) var.name2<-colnames(dat2) if (is.null(var.name2)) for (i in 1:p1) var.name2<-c(var.name2,paste("Var ",i)) cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) cat(sep="",dat2.description,"\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) for (i in 1:p2) { if (i%in%catvars2) { cat(sep="","\n",file=filename,append=T) } else cat(sep="","\n", file=filename,append=T) } cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) row.name2<-rownames(dat2) if (is.null(row.name2)) row.name2<-c(1:n2) if (is.null(dat2.id)) dat2.id<-c(1:n2) if (length(dat2.colors)\n",file=filename,append=T) cat(sep=" ",dat2[i,],"\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) } cat(sep="","\n\n",file=filename,append=T) } else { for(i in 1:n2) { cat(sep="","\n",file=filename,append=T) cat(sep=" ",dat2[i,],"\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) } cat(sep="","\n\n",file=filename,append=T) } } if (data.num>2) { # 3rd data p3<-ncol(dat3) n3<-nrow(dat3) var.name3<-colnames(dat3) if (is.null(var.name3)) for (i in 1:p1) var.name3<-c(var.name3,paste("Var ",i)) cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) cat(sep="",dat3.description,"\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) for (i in 1:p3) { if (i%in%catvars3) { cat(sep="","\n",file=filename,append=T) } else cat(sep="","\n", file=filename,append=T) } cat(sep="","\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) row.name3<-rownames(dat3) if (is.null(row.name3)) row.name3<-c(1:n3) if (length(dat3.colors)!=n1) { if (!is.null(dat3.colors)) cat("Length of data 3 colors vector is not the same as the number of rows.\n") dat3.colors<-rep(default.color,n3) } if (length(dat3.glyphs)!=n3) { if (!is.null(dat3.glyphs)) cat("Length of data 3 glyphs vector is not the same as the number of rows.\n") dat3.glyphs<-rep(default.glyph,n3) } for(i in 1:n3) { cat(sep=""," ",file=filename,append=T) cat(sep="","color=\"",dat3.colors[i],"\" ",file=filename,append=T) cat(sep="","glyph=\"",dat3.glyphs[i],"\"",file=filename,append=T) cat(sep="",">\n",file=filename,append=T) cat(sep=" ",dat3[i,],"\n",file=filename,append=T) cat(sep="","\n",file=filename,append=T) } cat(sep="","\n\n",file=filename,append=T) } # wrap-up file cat(sep="","",file=filename,append=T) }