#### fixed bug in patternmarkers

Genevieve Stein-O'Brien authored on 17/04/2018 20:14:30
Showing 1 changed files

 ... ... `@@ -23,66 +23,56 @@ threshold="all", lp=NA, full=FALSE)` 23 23 ` ` 24 24 ` # find the A with the highest magnitude` 25 25 ` Arowmax <- t(apply(Amatrix, 1, function(x) x/max(x)))` 26 `- #Arowmax <- t(apply(Amatrix, 1, function(x){ ` 27 `- # if (mean(x) == 0){ return(rep(0, times=length(x))) }` 28 `- # else { return(x/max(x)) }` 29 `- #})) ## this prevents NA values from creeping due to rows with zero means` 30 `-` 31 `- pmax<-apply(Amatrix, 1, max)` 26 `+ ` 32 27 ` # determine which genes are most associated with each pattern` 28 `+ sstat<-matrix(NA, nrow=nrow(Amatrix), ncol=ncol(Amatrix),dimnames=dimnames(Amatrix))` 33 29 ` ssranks<-matrix(NA, nrow=nrow(Amatrix), ncol=ncol(Amatrix),dimnames=dimnames(Amatrix))#list()` 34 30 ` ssgenes<-matrix(NA, nrow=nrow(Amatrix), ncol=ncol(Amatrix),dimnames=NULL)` 35 31 ` nP=dim(Amatrix)[2]` 36 32 ` if(!is.na(lp))` 37 33 ` {` 38 `- if(length(lp)!=dim(Amatrix)[2])` 39 `- {` 34 `+ if(length(lp)!=dim(Amatrix)[2]){` 40 35 ` warning("lp length must equal the number of columns of the Amatrix")` 41 36 ` }` 42 `- for (i in 1:nP)` 43 `- {` 44 `- sstat <- apply(Arowmax, 1, function(x) sqrt(t(x-lp)%*%(x-lp)))` 45 `- ssranks[order(sstat),i] <- 1:length(sstat)` 46 `- ssgenes[,i]<-names(sort(sstat,decreasing=FALSE,na.last=TRUE))` 37 `+ for (i in 1:nP){` 38 `+ sstat[,i] <- apply(Arowmax, 1, function(x) sqrt(t(x-lp)%*%(x-lp)))` 39 `+ ssranks[order(sstat[,i]),i] <- 1:dim(sstat)[1]` 40 `+ ssgenes[,i]<-names(sort(sstat[,i],decreasing=FALSE,na.last=TRUE))` 47 41 ` }` 48 42 ` }` 49 43 ` else` 50 44 ` {` 51 `- for(i in 1:nP)` 52 `- {` 45 `+ for(i in 1:nP){` 53 46 ` lp <- rep(0,dim(Amatrix)[2])` 54 47 ` lp[i] <- 1` 55 `- sstat <- apply(Arowmax, 1, function(x) sqrt(t(x-lp)%*%(x-lp)))` 56 `- ssranks[order(sstat),i] <- 1:length(sstat)` 57 `- ssgenes[,i]<-names(sort(sstat,decreasing=FALSE,na.last=TRUE))` 48 `+ sstat[,i] <- unlist(apply(Arowmax, 1, function(x) sqrt(t(x-lp)%*%(x-lp))))` 49 `+ ssranks[order(sstat[,i]),i] <- 1:dim(sstat)[1]` 50 `+ ssgenes[,i]<-names(sort(sstat[,i],decreasing=FALSE,na.last=TRUE))` 58 51 ` }` 59 52 ` }` 60 53 ` ` 61 `- if(threshold=="cut")` 62 `- {` 54 `+ if(threshold=="cut"){` 63 55 ` geneThresh <- sapply(1:nP,function(x) min(which(ssranks[ssgenes[,x],x] > apply(ssranks[ssgenes[,x],],1,min))))` 64 56 ` ssgenes.th <- sapply(1:nP,function(x) ssgenes[1:geneThresh[x],x])` 65 `- #geneThresh <- apply(sweep(ssranks,1,t(apply(ssranks, 1, min)),"-"),2,function(x) which(x==0))` 66 `- #ssgenes.th <- lapply(geneThresh,names)` 67 57 ` }` 68 `- else if (threshold=="all")` 69 `- {` 70 `- pIndx<-apply(ssranks,1,which.min)` 58 `+ else if (threshold=="all"){` 59 `+ pIndx<-unlist(apply(sstat,1,which.min))` 71 60 ` gBYp <- list()` 72 61 ` for(i in sort(unique(pIndx))){` 73 `- gBYp[[i]]<-names(pIndx[pIndx==i])` 62 `+ #gBYp[[i]]<-names(pIndx[pIndx==i])` 63 `+ gBYp[[i]]<-sapply(strsplit(names(pIndx[pIndx==i]),"[.]"),function(x) x[[1]][1])` 64 `+` 74 65 ` }` 75 66 ` ssgenes.th <- lapply(1:max(sort(unique(pIndx))), function(x) {` 76 67 ` ssgenes[which(ssgenes[,x] %in% gBYp[[x]]),x]` 77 68 ` })` 78 69 ` }` 79 `- else` 80 `- {` 70 `+ else{` 81 71 ` stop("Threshold arguement not viable option")` 82 72 ` }` 83 73 ` ` 84 74 ` if (full)` 85 `- return(list("PatternMarkers"=ssgenes.th,"PatternRanks"=ssranks))` 75 `+ return(list("PatternMarkers"=ssgenes.th,"PatternRanks"=ssranks,"PatternMarkerScores"=sstat))` 86 76 ` else` 87 77 ` return("PatternMarkers"=ssgenes.th)` 88 78 ` }`