[Esm-commits] r15 - pkg/ESM/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 13 12:43:39 CET 2009
Author: timotheepoisot
Date: 2009-11-13 12:43:39 +0100 (Fri, 13 Nov 2009)
New Revision: 15
Added:
pkg/ESM/R/adv.barplot.r
pkg/ESM/R/hist-dis.r
pkg/ESM/R/logplot.r
pkg/ESM/R/mBP.R
pkg/ESM/R/mat2d.r
pkg/ESM/R/nest.r
pkg/ESM/R/partition.var.r
pkg/ESM/R/persp.withcol.r
Removed:
pkg/ESM/R/GDS.r
pkg/ESM/R/draw.network.r
pkg/ESM/R/functions.r
pkg/ESM/R/matrix.hr.r
pkg/ESM/R/sortmat.byspe.r
pkg/ESM/R/std.matrix.r
Log:
R for AdGraph
Deleted: pkg/ESM/R/GDS.r
===================================================================
--- pkg/ESM/R/GDS.r 2009-11-13 11:42:43 UTC (rev 14)
+++ pkg/ESM/R/GDS.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -1,12 +0,0 @@
-GDS <- function(mat)
-{
- D <- dim(mat)
- N <- prod(D)
- Ni <- sum(mat>0)/N
- out <- NULL
- out$RES <- D[1]
- out$ORGA <- D[2]
- out$SIZE <- N
- out$COMP <- Ni
- return(out)
-}
\ No newline at end of file
Added: pkg/ESM/R/adv.barplot.r
===================================================================
--- pkg/ESM/R/adv.barplot.r (rev 0)
+++ pkg/ESM/R/adv.barplot.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,32 @@
+adv.barplot <- function(data,datanames=c(1:length(data)),col='lightgrey',bars=TRUE,barsborder=FALSE,forceylim=c(0,0),...,bartype=1)
+{
+ nbars <- length(data)
+ yspan <- range(data)
+ if(sum(forceylim)>0)
+ {
+ yspan <- forceylim
+ }
+ M <- NULL
+ SD <- NULL
+ bcol <- ifelse(barsborder,1,NA)
+ if(length(col)<length(data)){col <- rep(col,length(data))}
+ ##
+ plot(1,1,col=NA,xlim=c(0.5,nbars+0.5),ylim=yspan,xaxt='n',bty='n',...)
+ for(current.data in 1:nbars)
+ {
+ M[current.data] <- mean(data[[current.data]])
+ SD[current.data] <- sd(data[[current.data]])
+ rect(current.data-0.4,min(yspan),current.data+0.4,M[current.data],col=col[current.data],border=bcol)
+ if(bartype==1)
+ {
+ arrows(current.data,M[current.data],current.data,M[current.data]+SD[current.data],length=0.075,angle=90,col=1,lwd=2)
+ }
+ if(bartype==2)
+ {
+ arrows(current.data,M[current.data]-SD[current.data],current.data,M[current.data]+SD[current.data],length=0.075,angle=90,code=3,col=1,lwd=2)
+ }
+
+ }
+ axis(side=1,tick=FALSE,labels=datanames,at=c(1:nbars))
+ return(M)
+}
\ No newline at end of file
Deleted: pkg/ESM/R/draw.network.r
===================================================================
--- pkg/ESM/R/draw.network.r 2009-11-13 11:42:43 UTC (rev 14)
+++ pkg/ESM/R/draw.network.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -1,57 +0,0 @@
-draw.network <- function(data,org.col='grey',res.col='grey',border=NA,sortorg=c(1:nrow(data)),sortres=c(1:ncol(data)),...)
-{
-
- data <- sortmat.byspe(data,sortorg)
- data <- t(sortmat.byspe(t(data),sortres))
-
- n.elements <- max(dim(data))
-
- pos.h <- seq(from=1,to=n.elements,length.out=ncol(data))
- pos.p <- seq(from=1,to=n.elements,length.out=nrow(data))
-
- par(bty='n',xaxt='n',yaxt='n')
- symbols(
- pos.p,
- y = rep(2,length(pos.p)),
- circles=rep(0.3,length(pos.p)),
- inches=FALSE,
- add=FALSE,
- ylim=c(0.7,2.3),
- bg=org.col,
- fg=border,
- ...
- )
-
- for(p in 1:nrow(data))
- {
- for(h in 1:ncol(data))
- {
- if(data[p,h]>0)
- {
- arrows(pos.p[p],2,pos.h[h],1,lwd=(data[p,h]/1)*3+0.1,code=0)
- }
- }
- }
-
- symbols(
- pos.p,
- y = rep(2,length(pos.p)),
- circles=rep(0.4,length(pos.p)),
- inches=FALSE,
- add=TRUE,
- bg=org.col,
- fg=border,
- main='Réseau',
- xlab='',
- ylab=''
- )
- symbols(
- pos.h,
- y = rep(1,length(pos.h)),
- circles=rep(0.4,length(pos.h)),
- inches=FALSE,
- add=TRUE,
- bg=res.col,
- fg=border
- )
-}
\ No newline at end of file
Deleted: pkg/ESM/R/functions.r
===================================================================
--- pkg/ESM/R/functions.r 2009-11-13 11:42:43 UTC (rev 14)
+++ pkg/ESM/R/functions.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -1,117 +0,0 @@
-get.HR <- function(pop)
-{
- Ni <- sum(pop>0)
- N <- length(pop)
- return(1-Ni/N)
-}
-
-get.SHANNON <- function(pop)
-{
- partiel <- NULL
- pop <- as.vector(pop)+0.0000000001
- for(i in 1:length(pop))
- {
- p <- pop[i]/sum(pop)
- partiel[i] <- p * log(p)
- }
- shannon <- ifelse(length(pop)<=1,0,-sum(partiel) / log(length(pop)))
- return(shannon)
-}
-
-get.DFP <- function(fit)
-{
- score <- NULL
- fit <- as.vector(fit)
- fit <- na.exclude(sort(fit,decreasing=TRUE))
- vecdiff <- NULL
- for(i in 1:(length(fit)-1))
- {
- vecdiff[i] <- (fit[i+1]-fit[i])+1
- }
- score <- prod(abs(vecdiff))
- return(1-score)
-}
-
-get.WADFP <- function(fit)
-{
- ngen <- length(fit)
- sorted <- sort(fit,decreasing=TRUE)
- tempS <- NULL
- correc <- (ngen-1)/ngen
- for(g in 1:(ngen-1))
- {
- tempS[g] <- (1+sorted[g]-sorted[g+1])*sorted[g]
- }
- S <- sum(tempS)/sum(fit)
- S <- (S-correc)/(2-correc)
- return(S)
-}
-
-get.SSI <- function(occup)
-{
- score <- NULL
- fit <- as.vector(occup)
- h <- sum(fit>0)
- H <- length(occup)
- SSI <- sqrt((H/h-1)/(H-1))
- return(SSI)
-}
-
-dfp <- function(m)
-{
- spe <- vector('numeric',length=nrow(m))
- for(i in 1:nrow(m))
- {
- spe[i] <- get.DFP(m[i,])
- }
- return(spe)
-}
-
-wadfp <- function(m)
-{
- spe <- vector('numeric',length=nrow(m))
- for(i in 1:nrow(m))
- {
- spe[i] <- get.WADFP(m[i,])
- }
- return(spe)
-}
-
-
-shannon <- function(m)
-{
- spe <- vector('numeric',length=nrow(m))
- for(i in 1:nrow(m))
- {
- spe[i] <- get.SHANNON(as.vector(as.numeric(m[i,])))
- }
- return(spe)
-}
-
-ssi <- function(m)
-{
- spe <- vector('numeric',length=nrow(m))
- for(i in 1:nrow(m))
- {
- spe[i] <- get.SSI(as.vector(as.numeric(m[i,])))
- }
- return(spe)
-}
-
-hr <- function(m)
-{
- spe <- vector('numeric',length=nrow(m))
- for(i in 1:nrow(m))
- {
- spe[i] <- get.HR(as.vector(as.numeric(m[i,])))
- }
- return(spe)
-}
-
-getspe <- function(mat,measure=hr)
-{
- if(max(mat)!=1){mat<-mat/max(mat)}
- out <- measure(as.matrix(mat))
- names(out) <- rownames(mat)
- return(out)
-}
\ No newline at end of file
Added: pkg/ESM/R/hist-dis.r
===================================================================
--- pkg/ESM/R/hist-dis.r (rev 0)
+++ pkg/ESM/R/hist-dis.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,21 @@
+hist.disc <- function(vecteur,as.prop=FALSE,do.plot=FALSE,ylab='',xlab='')
+{
+ niveaux <- as.integer(levels(as.factor(vecteur)))
+ quantite <- NULL
+ for(i in 1:length(niveaux))
+ {
+ quantite[i] <- sum(match(vecteur,niveaux[i],nomatch=0))
+ }
+ proportion <- quantite/length(vecteur)
+
+ if(as.prop){hauteur <- proportion} else {hauteur <- quantite}
+
+ if(do.plot)
+ {
+ par(lend=1,yaxs='i')
+ plot(niveaux,hauteur,type='h',ylim=c(0,max(hauteur)),lwd=12,ylab=ylab,xlab=xlab)
+ par(lend=0,yaxs='r',xaxs='r')
+ }
+
+ return(as.data.frame(cbind(niveaux,quantite,proportion)))
+}
\ No newline at end of file
Added: pkg/ESM/R/logplot.r
===================================================================
--- pkg/ESM/R/logplot.r (rev 0)
+++ pkg/ESM/R/logplot.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,45 @@
+drawlogaxis <- function(side,range)
+{
+ par(tck=0.02)
+ d <- range
+ mlog <- floor(min(d))
+ Mlog <- ceiling(max(d))
+ SeqLog <- c(mlog:Mlog)
+ Nlog <- (Mlog-mlog)+1
+ axis(side,at=SeqLog,labels=10^SeqLog)
+ ats <- log(seq(from=2,to=9,by=1),10)
+ mod <- NULL
+ for(i in SeqLog)
+ {
+ mod <- c(mod,rep(i,length(ats)))
+ }
+ ats <- rep(ats,Nlog)
+ ats <- ats+mod
+ par(tck=0.02/3)
+ axis(side,at=ats,labels=NA)
+}
+
+logplot <- function(x=c(1:length(y)),y,log='xy',forceylim=c(0,0),forcexlim=c(0,0),...)
+{
+ par(tck=0.02)
+ xlg <- FALSE
+ ylg <- FALSE
+ if('x'%in%strsplit(log,'')[[1]]){x <- log(x,10);xlg=TRUE}
+ if('y'%in%strsplit(log,'')[[1]]){y <- log(y,10);ylg=TRUE}
+ yl <- ifelse(forceylim==c(0,0),range(y),forceylim)
+ xl <- ifelse(forcexlim==c(0,0),range(x),forcexlim)
+ plot(x,y,...,axes=FALSE,ylim=yl,xlim=xl)
+ if(xlg){drawlogaxis(1,xl)}else{axis(1,at=pretty(xl),labels=pretty(xl))}
+ if(ylg){drawlogaxis(2,yl)}else{axis(2,at=pretty(yl),labels=pretty(yl))}
+ box()
+}
+
+addlog <- function(x=c(1:length(y)),y,log='xy',...)
+{
+ xlg <- FALSE
+ ylg <- FALSE
+ if('x'%in%strsplit(log,'')[[1]]){x <- log(x,10);xlg=TRUE}
+ if('y'%in%strsplit(log,'')[[1]]){y <- log(y,10);ylg=TRUE}
+ points(x,y,...)
+
+}
\ No newline at end of file
Added: pkg/ESM/R/mBP.R
===================================================================
--- pkg/ESM/R/mBP.R (rev 0)
+++ pkg/ESM/R/mBP.R 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,47 @@
+mBP <- function(list.of.lists,...,condnames=0,pal=colorRampPalette(c('grey','cornsilk')),seriesnames=0,legendpos='topleft',legh=TRUE,do.pty='s')
+{
+ par(pty=do.pty,mgp=c(1.9,0.8,0),oma=c(0,0,0,0),mar=c(4,3,2,1),bg='transparent',bty='o',tck=0.02,yaxs='i')
+ NofList <- length(list.of.lists)
+ NofSubList <- length(list.of.lists[[1]])
+ if(condnames==0){condnames=c(1:NofList)}
+ if(seriesnames==0){seriesnames=c(1:NofSubList)}
+ dim.mat.treat <- (NofList+1)*NofSubList
+ pos <- c(1:dim.mat.treat)
+ pos <- matrix(pos,nrow=(NofList+1))
+ nbreaks <- dim.mat.treat+1
+ par(xaxs='i',yaxs='i',bty='o')
+ plot(0,0,pch=NA,xlim=c(0,nbreaks),ylim=c(min(pretty(range(list.of.lists))),max(pretty(range(list.of.lists)))),xaxt='n',yaxt='n',...)
+ calc.ylab <- pretty(range(list.of.lists))
+ lab.ylab <- round(calc.ylab,2)
+ abline(h=pretty(range(list.of.lists)),lty=3,col='grey',lwd=2)
+ abline(h=0,col='darkgrey',lwd=1.4)
+ palette <- pal(NofList)
+ for(condition in 1:NofList)
+ {
+ for(treatment in 1:NofSubList)
+ {
+ CD <- list.of.lists[[condition]][[treatment]]
+ CDm <- mean(CD)
+ CDv <- sd(CD)
+ x.coord <- pos[condition,treatment]
+ rect(x.coord,0,x.coord+1,CDm,col=palette[condition])
+ arrows(x.coord+0.5,CDm+CDv,x.coord+0.5,CDm-CDv,angle=90,code=3,length=0.05)
+ }
+ }
+ axis(side=2,at=calc.ylab,labels=lab.ylab,tick=TRUE)
+ #abline(h=calc.ylab[1])
+ abline(h=pretty(range(list.of.lists))[1])
+ fills <- c(1:NofList)
+ legend(legendpos,legend=condnames,fill=palette[fills],bty='n',horiz=legh,cex=1)
+ cl.tab <- (c(1:NofSubList)-1)*NofSubList + NofList/2 +1
+ lab.cond <- NULL
+ int.lab.cond <- pos[c(1:(nrow(pos)-1)),]
+ for(COL in 1:ncol(int.lab.cond))
+ {
+ lab.cond[COL] <- mean(int.lab.cond[,COL])+0.5
+ }
+ axis(side=1,at=lab.cond,labels=seriesnames,tick=FALSE)
+ par(xaxs='r')
+ if(min(pretty(range(list.of.lists)))<0){abline(h=0,lwd=1.1)}
+ box()
+}
\ No newline at end of file
Added: pkg/ESM/R/mat2d.r
===================================================================
--- pkg/ESM/R/mat2d.r (rev 0)
+++ pkg/ESM/R/mat2d.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,30 @@
+mat2d <- function(x,y,...)
+{
+ yule <- function(n)
+ {
+ return(2*floor(2.5*sqrt(sqrt(length(n)))))
+ }
+ matrice <- matrix(0,ncol=yule(y),nrow=yule(x))
+ effX <- cut(x,yule(x),labels=FALSE)
+ effY <- cut(y,yule(y),labels=FALSE)
+ rownames(matrice) <- c(1:yule(x))
+ colnames(matrice) <- c(1:yule(y))
+ X <- range(pretty(range(x)))
+ X <- seq(min(X),max(X),length.out=nrow(matrice))
+ Y <- range(pretty(range(y)))
+ Y <- seq(min(Y),max(Y),length.out=ncol(matrice))
+ for(i in 1:nrow(matrice))
+ {
+ for(j in 1:ncol(matrice))
+ {
+ matrice[i,j] <- sum(match(effX,as.numeric(rownames(matrice))[i],nomatch=0)*match(effY,as.numeric(colnames(matrice))[j],nomatch=0))
+ }
+ }
+ pal <- colorRampPalette(c('white','black'))
+ image(X,Y,matrice,col=pal(100),...)
+ rug(x,ticksize = 0.01)
+ rug(y,side=2,ticksize = 0.01)
+ colnames(matrice) <- Y
+ rownames(matrice) <- X
+ return(matrice)
+}
\ No newline at end of file
Deleted: pkg/ESM/R/matrix.hr.r
===================================================================
--- pkg/ESM/R/matrix.hr.r 2009-11-13 11:42:43 UTC (rev 14)
+++ pkg/ESM/R/matrix.hr.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -1,11 +0,0 @@
-matrix.hr <- function(matrix)
-{
- for(c in 1:ncol(matrix))
- {
- for(r in 1:nrow(matrix))
- {
- if(matrix[r,c]>0){matrix[r,c]<-1}
- }
- }
- return(matrix)
-}
\ No newline at end of file
Added: pkg/ESM/R/nest.r
===================================================================
--- pkg/ESM/R/nest.r (rev 0)
+++ pkg/ESM/R/nest.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,41 @@
+nest = function(matrice,do.plot)
+{
+ perm <- 1
+ while(perm != 0)
+ {
+ perm <- 0
+ for(i in 1:(nrow(matrice)-1))
+ {
+ temp.i <- matrice[i,]
+ temp.s <- matrice[(i+1),]
+ if(sum(temp.i)<sum(temp.s))
+ {
+ matrice[i,] <- temp.s
+ matrice[(i+1),] <- temp.i
+ perm <- perm + 1
+ }
+ }
+ }
+ perm <- 1
+ while(perm != 0)
+ {
+ perm <- 0
+ for(i in 1:(ncol(matrice)-1))
+ {
+ temp.i <- matrice[,i]
+ temp.s <- matrice[,(i+1)]
+ if(sum(temp.i)<sum(temp.s))
+ {
+ matrice[,i] <- temp.s
+ matrice[,(i+1)] <- temp.i
+ perm <- perm + 1
+ }
+ }
+ }
+ if(do.plot)
+ {
+ cols <- colorRampPalette(c("#FFFFFF", "#000000"))
+ image(matrice,col= cols(5))
+ }
+ return(matrice)
+}
\ No newline at end of file
Added: pkg/ESM/R/partition.var.r
===================================================================
--- pkg/ESM/R/partition.var.r (rev 0)
+++ pkg/ESM/R/partition.var.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,15 @@
+partition.var <- function(comp)
+{
+ pdf(file='partition-variance.pdf',width=6,height=3)
+ par(mai=c(0,0,0,0))
+ plot(0,0,pch=NA,axes=F,xlab='',ylab='',ylim=c(-1,1),xlim=c(0,100))
+ rect(0,-0.1,comp[1],0.1,col='darkgrey')
+ rect(comp[1],-0.1,sum(comp[1:2]),0.1,col='black')
+ rect(sum(comp[1:2]),-0.1,sum(comp[1:3]),0.1,col='lightgrey')
+ rect(sum(comp[1:3]),-0.1,sum(comp),0.1,col='white')
+
+ text(0,0.2,'Env.',adj=0)
+ text(comp[1],-0.2,'Shared',adj=0)
+ text(sum(comp[1:2]),0.2,'Phyl.',adj=0)
+ dev.off()
+}
\ No newline at end of file
Added: pkg/ESM/R/persp.withcol.r
===================================================================
--- pkg/ESM/R/persp.withcol.r (rev 0)
+++ pkg/ESM/R/persp.withcol.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -0,0 +1,20 @@
+persp.withcol <- function(x,y,z,pal=heat.colors,nb.col=10,xlg=TRUE,ylg=TRUE,...)
+{
+ colnames(z) <- y
+ rownames(z) <- x
+
+ nrz <- nrow(z)
+ ncz <- ncol(z)
+
+ color <- pal(nb.col)
+ zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]
+ facetcol <- cut(zfacet, nb.col)
+ par(xlog=xlg,ylog=ylg)
+ persp(
+ as.numeric(rownames(z)),
+ as.numeric(colnames(z)),
+ as.matrix(z),
+ col=color[facetcol],
+ ...
+ )
+}
\ No newline at end of file
Deleted: pkg/ESM/R/sortmat.byspe.r
===================================================================
--- pkg/ESM/R/sortmat.byspe.r 2009-11-13 11:42:43 UTC (rev 14)
+++ pkg/ESM/R/sortmat.byspe.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -1,5 +0,0 @@
-sortmat.byspe <- function(mat,spe)
-{
- mat[rank(spe),] <- mat[c(1:nrow(mat)),]
- return(mat)
-}
\ No newline at end of file
Deleted: pkg/ESM/R/std.matrix.r
===================================================================
--- pkg/ESM/R/std.matrix.r 2009-11-13 11:42:43 UTC (rev 14)
+++ pkg/ESM/R/std.matrix.r 2009-11-13 11:43:39 UTC (rev 15)
@@ -1,7 +0,0 @@
-std.matrix <- function(filename)
-{
- dat <- read.table(filename)
- if(t){dat<-t(dat)}
- dat <- dat/max(dat)
- return(dat)
-}
\ No newline at end of file
More information about the Esm-commits
mailing list