R/RIpop.r

In flower: Tools for characterizing flowering traits

RIpop<-function(dd,pop,ind){
fls=as.factor(paste(pop,'-',ind))
pop=as.factor(pop)
m=length(colnames(dd))
bij=tapply(dd[,1],pop,length)
flowernum=aggregate(dd[,1],list(pop,fls),"length")
colnames(flowernum)=c("pop","fls","flowernum")
a=length(levels(fls))
b=tapply(fls,pop,length)
flsdd=array(0,dim=c(m,a))
colnames(flsdd)=levels(fls)
rownames(flsdd)=colnames(dd)
for (i in 1:m){
flsdd[i,]=tapply(dd[,i],fls,sum)
}
flsdd2=t(flsdd)
popfls=unique(data.frame(pop,fls))
popflsdd=cbind(popfls,flsdd2)
aij=popflsdd
LL=levels(aij$pop)
TD=as.matrix(bij)
m1=length(LL)
m2=length(aij)
Rdd2=array(NA,dim=c(1,ncol(aij)))
colnames(Rdd2)=colnames(aij)
i=1
repeat{
Rdd1=Rdd2
subdd=aij[,1:m2][aij$pop==LL[i],]
td=TD[rownames(TD)==LL[i]]
xij=subdd[3:m2]/td
Rdd0=cbind(subdd[,1:2],xij)
Rdd2=rbind(Rdd0,Rdd1)
i=i+1
if (i>m1) break
}
X=Rdd2[1:nrow(aij),]
R0=rowSums(X[,3:ncol(X)])
R1=X[,1:2]
R=cbind(R1,as.matrix(R0))
rownames(R)=c(1:nrow(aij))
colnames(R)=c("population","individual","r")
R.max=tapply(R$r,R$population,max)
R.min=tapply(R$r,R$population,min)
R.mean=tapply(R$r,R$population,mean)
R.sd=tapply(R$r,R$population,sd)
R.length=tapply(R$r,R$population,length)
Result=t(rbind(R.length,R.min,R.max,R.mean,R.sd))
print(round(Result,2))
list(res=Result,NO.of.ind=a,aij=aij,bij=TD,xij=X,R=R)
}