[R] RAM usage
Vaidotas Zemlys
mpiktas at delfi.lt
Fri Oct 18 14:21:19 CEST 2002
Hi,
> You'll need to post the code for anyone to be able to help. There are
> many ways to do the same thing, some hugely more efficient than
> others.
>
Ok, here it is:
#main function
rptree <-
function(X,y,depth=3,count=10) {
X <- as.matrix(X)
y <- as.vector(y)
m <- dim(X)[1]
n <- dim(X)[2]
if(!identical(m,length(y))) {
stop("Nesutampa dimensijos")
}
cnames <- colnames(X)
tree <- list()
snames <- list()
node <- node.div(X,y,count=count,sep="",col.names=cnames)
l <- node$l
paths <- node$paths
rownames(l) <- node$snames -> rownames(paths)
tree[[1]] <- list(subsets=l,paths=paths)
snames[[1]] <- node$snames
if(depth>1) {
for(i in 2:depth) {
nl <- dim(tree[[i-1]]$subsets)[1]
off <-0
l <- logical();
paths <- numeric();
l.snames <- character();
for(j in 1:nl) {
subs <- tree[[i-1]]$subsets[j,]
node <- node.div(X[subs,],y[subs],count=count,name=snames[[i-1]][j],col.names=cnames)
if(node$bonferoni>0) {
nnl <- dim(node$l)[1]
subss <- matrix(rep(subs,nnl),nrow=nnl,byrow=TRUE)
subss[subss] <- node$l
l <- rbind(l,subss)
paths <- rbind(paths,cbind(matrix(rep(tree[[i-1]]$paths[j,],nnl),nrow=nnl,byrow=TRUE), node$paths))
l.snames[off+1:nnl] <- node$snames
off <- off + nnl
}
}
rownames(l) <- l.snames -> rownames(paths)
tree[[i]] <- list(subsets=l,paths=paths)
snames[[i]] <- l.snames
}
}
names(tree) <- paste("lv",1:depth,sep="")
tree$X <- X
tree$y <- y
attributes(tree)$class <- "rptree"
tree
}
#function node.div used in main function rptree
node.div <-
function(X,y,count=10,name="subset",sep=".",col.names=NULL) {
m <- dim(X)[1]
n <- dim(X)[2]
SZZ=sum(y^2)
SZ=sum(y)
t <- rep(0,n)
for(i in 1:n) {
n1_length(X[X[,i]==0,i])
if((n1>10) && (n1<(m-10))) {
if(min(c(n1,m-n1)==n1)) {
SX <- sum(y[X[,i]==0])
SXX <- sum(y[X[,i]==0]^2)
n2 <- m-n1
}
else {
SX <- sum(y[X[,i]>0])
SXX <- sum(y[X[,i]>0]^2)
n2 <- n1
n1 <- m-n1
}
SY <- SZ-SX;
SYY <- SZZ-SXX;
SSX <- SXX-(1/n1)*(SX)^2
SSY <- SYY-(1/n2)*(SY)^2
v <- (SSX+SSY)/(m-2)
stderr <- sqrt(v*(1/n1+1/n2))
t[i] <- abs(SX/n1-SY/n2)/stderr
}
}
#t <- t[t>0]
bonf <- length(t[t>0])
ind <- rep(0,count)
if(bonf>1) {
st <- sort(t,decreasing=TRUE,index.return=TRUE)
j <- 1
jj <- 1
ind[1] <- st$ix[1]
q.value <- qt(0.975,m-2)
while((j<count) && (st$x[jj+1]>q.value) && (j<n)) {
max.cor <- max(abs(cor(X[,c(ind,st$ix[jj+1])])[j+1,1:j]))
if(max.cor<0.9) {
j <- j + 1
jj <- jj + 1
ind[j]_st$ix[jj]
}
else {
jj <- jj + 1
}
}
}
else {
if(bonf==1) {
ind[1]_(1:n)[t>0]
}
}
ind <- ind[ind>0]
ni <- length(ind)
if(ni>0) {
l_X[,ind]>0
l <- t(matrix(c(l,!l),nrow=m))
paths <- cbind(rep(ind,2),rep(c(1,0),each=ni))
if(identical(col.names,NULL)) {
snames <- paste(name,paste(rep(ind,2),rep(c(1,0),each=ni),sep="@"),sep=sep)
}
else {
snames <- paste(name,paste(rep(col.names[ind],2),rep(c(1,0),each=ni),sep="@"),sep=sep)
}
list(l=l,paths=paths,snames=snames,bonferoni=bonf)
}
else {
list(bonferoni=bonf)
}
}
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-help mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !) To: r-help-request at stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
More information about the R-help
mailing list