[R] some addition in the codes
arun
smartpink111 at yahoo.com
Wed Oct 16 05:48:04 CEST 2013
Hi Eliza,
Some lines of code in the end didn't look very convincing for me. (I didn't change it anyway). For example:
#####
amata<-data.frame(amata)
aavg<-as.matrix(amata, ncol=1)
b<-aavg
sss<-(max(b)+max(amata))/2
####
Also, multiple objects of the same name were created through out the code, which makes it bit hard.
##solution
Eliz <- load("/home/arunksa111/Downloads/Elizaaa.RData" )
Dm <- `Dm`
ffr <- `ffr`
j <- `j`
m <- `m`
d15<-Dm/mean(Dm)
dr1<-ffr/mean(ffr)
t<-as.matrix((d15)+(dr1))
w<-sqrt(t)
mat1<-w
zz<-w ## multiple objects!!
rlst<- lapply(1:124,function(i) matrix(sort(as.matrix(zz)[i,],index.return=TRUE)$ix,ncol=1))
rlstN <- lapply(rlst,function(x) {
u<- x[2:8,1]
mata <- m[,u]
a <- matrix(rowMeans(mata),ncol=1)
mat <- cbind(j,a)
lst1<-lapply(split(mat,col(mat)),function(x){
big<- x>0.8*max(x)
n<- length(big)
startRunOfBigs<- which(c(big[1],!big[-n] & big[-1]))
endRunOfBigs<- which(c(big[-n] & !big[-1], big[n]))
index<- vapply(seq_along(startRunOfBigs),function(i) which.max(x[startRunOfBigs[i]:endRunOfBigs[i]])+startRunOfBigs[i]-1L,0L) index<-ifelse(sum(is.na(match(index,c(1,12))))==0 & x[index]!=max(x[index]), NA,index)
data.frame(Index=index[!is.na(index)],Value=x[index[!is.na(index)]])
})
nm <- lapply(lst1,function(x) x$Index)
max_length<- max(unlist(lapply(nm,length)))
nm_filled<-lapply(nm,function(x){
ans<- rep(NA,length=max_length)
ans[1:length(x)]<- x
return(ans)
})
xx<-do.call(cbind,nm_filled) ##didn't see this part being used in the end
mat})
###Using a subset of list elements
srlstN <- rlstN[61:62]
library(hydroGOF)
res <- lapply(srlstN, function(x) {
i<- as.list(fun3(x))
xx<- do.call(cbind,i)
xx<- t(xx)
x1 <- matrix(xx,nrow=1)
y <- matrix(0,nrow=125,ncol=125)
y[lower.tri(y)]<- x1
yy <- as.dist(y)
list1<- lapply(seq_len(ncol(x)),function(j) t(apply(x,1,function(u) u[j]-u)))
x2<- matrix(unlist(list1),ncol=15625)
x2<- abs(x2)
y1 <- colSums(x2,na.rm=FALSE)
z1 <- matrix(y1,ncol=125)
zz <- as.dist(z1)
x3 <- apply(x,2,max)
xx1 <- dist(x3)
xx1[yy==0] <-0
ff <- zz+yy+xx1
r <- matrix(sort(as.matrix(ff)[125,],index.return=TRUE)$ix,ncol=1)
u1 <- r[2:8,1]
mata <- x[,u1]
amata <- data.frame(rowMeans(mata))
aavg <- as.matrix(amata, ncol=1)
sss <- (max(aavg)+max(amata))/2
aavg[which(aavg==max(aavg))] <- sss
mat2<- do.call(rbind,lapply(seq_len(ncol(x)), function(j){
RRR <- rmse(aavg,matrix(x[,j],ncol=1))
UUU <- NSE(aavg,matrix(x[,j],ncol=1))
cc <- sum(abs(aavg - x[,j]))
c(RRR,UUU,cc)
}))
colnames(mat2) <- c("RRR","UUU","cc")
mat2
})
head(res[[1]])
# RRR UUU cc
#[1,] 0.3830867 0.5155312 3.617801
#[2,] 0.5149736 -0.6779912 4.194520
#[3,] 1.4246430 -1.3620793 15.116817
#[4,] 1.0875600 -1.4012783 11.170334
#[5,] 1.3309777 -0.8873588 14.078342
#[6,] 0.2056404 0.9170877 1.959848
A.K.
On Tuesday, October 15, 2013 12:08 PM, eliza botto <eliza_botto at hotmail.com> wrote:
Dear Arun,
You once helped prepared me following codes for my work. Now i automatically want to replace "61" in all the four steps indicated with ">>>>>" in the beginning, with 1,2,3,4........, 124 so that i have three lists in the end each for RRR, UU and cc.
Can it be done? I hope i am clear in my question.
Thanks in advance
Eliza
## d15 and dr1 are distance matrices of 8*8 dimensions
d15<-Dm/mean(Dm)
dr1<-ffr/mean(ffr)
t<-as.matrix((d15)+(dr1))
w<-sqrt(t)
mat1<-w
zz<-w
>>>>>r<-matrix(sort(as.matrix(zz)[61,],index.return=TRUE)$ix,ncol=1)
u<-r[c(2,3,4,5,6,7,8),1]
mata<-m[,c(u)]##(shifted)
amata<-apply(mata,1,mean)
amata<-data.frame(amata)
aavg<-as.matrix(amata, ncol=1)
a<-aavg
## j is matrix of 8 rows and 2 columns
m<-cbind(j,a)
mat<-m
lst1<-lapply(split(mat,col(mat)),function(x){big<- x>0.8*max(x); n<- length(big);startRunOfBigs<- which(c(big[1],!big[-n] & big[-1])); endRunOfBigs<- which(c(big[-n] & !big[-1], big[n]));index<- vapply(seq_along(startRunOfBigs),function(i) which.max(x[startRunOfBigs[i]:endRunOfBigs[i]])+startRunOfBigs[i]-1L,0L); index<-ifelse(sum(is.na(match(index,c(1,12))))==0 & x[index]!=max(x[index]), NA,index);data.frame(Index=index[!is.na(index)],Value=x[index[!is.na(index)]]) })
nm<-lapply(lst1,function(x)(x$Index))
max_length<- max(unlist(lapply(nm,length)))
nm_filled<-lapply(nm,function(x){ans<- rep(NA,length=max_length);
ans[1:length(x)]<- x;
return(ans)})
xx<-do.call(cbind,nm_filled)
fun1<- function(x){
big<- x>0.8*max(x)
n<- length(big)
startRunOfBigs<- which(c(big[1],!big[-n] & big[-1]))
endRunOfBigs<- which(c(big[-n] & !big[-1], big[n]))
index<- vapply(seq_along(startRunOfBigs),function(i) which.max(x[startRunOfBigs[i]:endRunOfBigs[i]])+startRunOfBigs[i]-1L,0L)
index<-ifelse(sum(is.na(match(index,c(1,12))))==0 & x[index]!=max(x[index]), NA,index)
data.frame(Index=index[!is.na(index)],Value=x[index[!is.na(index)]])
}
fun3<- function(mat){
indmat<-combn(seq_len(ncol(mat)),2)
lst1<- lapply(seq_len(ncol(indmat)),function(i) {mat[,indmat[,i]]})
names(lst1)<-as.character(interaction(as.data.frame(t(indmat)),sep="_",drop=TRUE))
lst2<- lapply(lst1,function(x) {x1<- apply(x,2,fun1)})
lst3<- lapply(lst2,function(x) expand.grid(lapply(x,function(y) y[,1])))
lst4<-lapply(lst3,function(x) unlist(x[which.min(apply(x,1,function(y) abs(diff(y)))),]) )
lst5<- lapply(lst4,function(x){
if(abs(diff(x))>(nrow(mat)/2)){
nrow(mat)-abs(diff(x))
}
else(abs(diff(x)))
})
lst6<- lapply(seq_along(lst5),function(i) {
x2<-lst1[[i]]
if(lst5[[i]]==0) {
#indx1<- seq(length(x2[,2]))
#sum(abs(x2[,1]-x2[indx1,2]))
0 ######################## set to zero
}
else{
lapply(seq(1+lst5[[i]]),function(j){x3<-x2[,2]
indx1<-seq(length(x3)-(j-1))
indx2<-c(setdiff(seq_along(x3),indx1),indx1)
sum(abs(x2[,1]-x2[indx2,2]))
})
}
})
names(lst6)<- names(lst1)
lst7<-lapply(lst6,unlist)
lst8<- lapply(lst7,function(x) {
Seq1<-seq_along(x)
if(length(Seq1)==1) x
else if(length(Seq1)==2){
sum(abs(x[1]-x[2]))
}
else{
ind<-rep(Seq1,each=2)[-1]
ind1<-ind[-length(ind)]
Reduce(`+`,lapply(split(ind1,(seq_along(ind1)-1)%/%2+1),function(i) {
abs(diff(x[i]))
}))
}
}
)
lst9<-do.call(rbind,lst8)
lst9
}
fun3(m)
########
i<-as.list(fun3(m))
xx<-do.call(cbind, i)
xx<-t(xx)
x<-matrix(xx,nrow=1)
y <- matrix(0, nrow=125, ncol=125)
y[lower.tri(y)] <- x
yy<-as.dist(y)
##===============
list1<-list()
for(i in 1:ncol(m)){
list1[[i]]<-t(apply(m,1,function(x) x[i]-x))
list1}
x<-list1
x<-matrix(unlist(x),ncol=15625)
x<-abs(x)
y<-colSums(x, na.rm=FALSE)
z<-matrix(y, ncol=125)
zz<-as.dist(z)
x<-apply(m, 2, max)
xx<-dist(x)
xx<-as.dist(xx)
xx[yy==0]<-0
ff<-((zz))+((yy))+((xx))
r<-matrix(sort(as.matrix(ff)[125,],index.return=TRUE)$ix,ncol=1)
u<-r[c(2,3,4,5,6,7,8),1]
mata<-m[,c(u)]##(shifted)
amata<-apply(mata,1,mean)
amata<-data.frame(amata)
aavg<-as.matrix(amata, ncol=1)
b<-aavg
sss<-(max(b)+max(amata))/2
b[which(b == max(b))]<-sss
library(hydroGOF)
>>>>>RRR<-rmse(b,matrix(m[,61],ncol=1))
>>>>>UUU<-NSE(b,matrix(m[,61],ncol=1))
>>>>>cc<-sum(abs(b-m[,61]))
More information about the R-help
mailing list