From 214f358574ccd3e844ec407438dfe98eea3367b8 Mon Sep 17 00:00:00 2001 From: Clement Calenge Date: Tue, 16 Jan 2007 00:00:00 +0000 Subject: [PATCH] version 1.5-2 --- CONTENTS | 6 + DESCRIPTION | 6 +- INDEX | 1 + R/angles.r | 124 +- R/ararea.r | 34 +- R/area2dxf.r | 31 +- R/area2spol.r | 35 +- R/as.area.r | 14 +- R/as.asc.r | 13 +- R/as.kasc.r | 21 +- R/as.ltraj.r | 194 +- R/as.sahrlocs.r | 22 +- R/as.traj.r | 37 +- R/asc2im.r | 16 +- R/asc2spixdf.r | 46 +- R/ascgen.r | 94 +- R/attpol2area.r | 67 +- R/biv.plot.r | 147 +- R/biv.test.r | 329 +- R/buffer.ani.r | 47 +- R/buffer.line.r | 30 +- R/buffer.r | 111 +- R/clusthr.r | 180 +- R/colasc.r | 45 +- R/compana.r | 161 +- R/contour.asc.r | 22 +- R/convnum.r | 30 +- R/count.points.id.r | 21 +- R/count.points.r | 55 +- R/data2enfa.r | 14 +- R/df2kasc.r | 65 +- R/df2traj.r | 56 +- R/distfacmap.r | 44 +- R/domain.r | 40 +- R/eisera.r | 59 +- R/enfa.r | 28 +- R/explore.kasc.r | 33 +- R/export.asc.r | 26 +- R/fpt.r | 49 +- R/gdltraj.r | 25 +- R/getXYcoords.r | 28 +- R/getascattr.r | 20 +- R/getburst.r | 39 +- R/getcontour.r | 139 +- R/getkasc.r | 34 +- R/getkascattr.r | 10 +- R/getsahrlocs.r | 16 +- R/getverticeshr.r | 52 +- R/getvolumeUD.r | 43 +- R/hist.kselect.r | 31 +- R/histniche.r | 211 +- R/hr.rast.r | 12 +- R/im2asc.r | 11 +- R/image.asc.r | 30 +- R/image.kasc.r | 62 +- R/image.khr.r | 42 +- R/image.sahrlocs.r | 154 +- R/import.asc.r | 191 +- R/join.asc.r | 43 +- R/join.kasc.r | 27 +- R/kasc2df.r | 37 +- R/kasc2spixdf.r | 12 +- R/kernel.area.r | 90 +- R/kernelUD.r | 283 +- R/kernelbb.r | 31 +- R/kplot.kselect.r | 135 +- R/kselect.r | 122 +- R/labcon.r | 61 +- R/lowres.asc.r | 107 +- R/lowres.kasc.r | 3 +- R/lowres.r | 3 +- R/ltraj2sldf.r | 34 +- R/ltraj2spdf.r | 10 +- R/madifa.r | 753 +-- R/mahasuhab.r | 92 +- R/managNAkasc.r | 21 +- R/mcp.area.r | 61 +- R/mcp.r | 74 +- R/mcp.rast.r | 55 +- R/meanfpt.r | 36 +- R/morphology.r | 18 +- R/niche.test.r | 35 +- R/perarea.r | 27 +- R/persp.asc.r | 22 +- R/plot.area.r | 18 +- R/plot.asc.r | 18 +- R/plot.fipati.r | 30 +- R/plot.hrsize.r | 6 + R/plot.kselect.r | 116 +- R/plot.kver.r | 18 +- R/plot.ltraj.r | 142 +- R/plot.sahrlocs.r | 198 +- R/plot.traj.r | 109 +- R/plot.wi.r | 185 +- R/plotLSCV.r | 26 +- R/predict.enfa.r | 14 +- R/print.NNCH.r | 7 +- R/print.asc.r | 18 +- R/print.compana.r | 9 +- R/print.dataenfa.r | 7 +- R/print.enfa.r | 79 +- R/print.kasc.r | 36 +- R/print.khr.r | 53 +- R/print.kselect.r | 22 +- R/print.plotsahr.r | 13 +- R/print.rand.kselect.r | 7 +- R/print.sahrlocs.r | 17 +- R/print.traj.r | 15 +- R/print.wiI.r | 9 +- R/print.wiII.r | 12 +- R/print.wiIII.r | 12 +- R/profilehab.r | 83 +- R/rand.kselect.r | 86 +- R/randtest.enfa.r | 9 +- R/rec.r | 9 +- R/redisltraj.r | 142 +- R/rotxy.r | 21 +- R/sahrlocs2kselect.r | 118 +- R/sahrlocs2niche.r | 23 +- R/scatterniche.r | 192 +- R/schoener.r | 55 +- R/schoener.rtest.r | 62 +- R/setmask.r | 62 +- R/speed.r | 52 +- R/spixdf2kasc.r | 67 +- R/spol2area.r | 157 +- R/storemapattr.r | 14 +- R/subsetmap.asc.r | 32 +- R/subsetmap.kasc.r | 26 +- R/subsetmap.r | 7 +- R/summary.traj.r | 43 +- R/traj2df.r | 13 +- R/traj2sldf.r | 42 +- R/traj2spdf.r | 12 +- R/varlogfpt.r | 36 +- R/widesI.r | 146 +- R/widesII.r | 177 +- R/widesIII.r | 166 +- data/puech.rda | Bin 0 -> 25916 bytes data/puechcirc.rda | Bin 9207 -> 6553 bytes man/c.ltraj.Rd | 2 +- man/puech.Rd | 32 + man/puechcirc.Rd | 4 +- src/tests.c | 10280 ++++++++++++++++++++------------------- 144 files changed, 10429 insertions(+), 8632 deletions(-) create mode 100644 data/puech.rda mode change 100755 => 100644 data/puechcirc.rda create mode 100644 man/puech.Rd diff --git a/CONTENTS b/CONTENTS index 2b43421..c657d47 100755 --- a/CONTENTS +++ b/CONTENTS @@ -360,6 +360,12 @@ Keywords: multivariate Description: Habitat Suitability Maps Built from the ENFA URL: ../../../library/habitat/html/predict.enfa.html +Entry: puech +Aliases: puech +Keywords: datasets +Description: Radio-Tracking Data of Wild Boars (2) +URL: ../../../library/habitat/html/puech.html + Entry: puechabon Aliases: puechabon Keywords: datasets diff --git a/DESCRIPTION b/DESCRIPTION index 811fcbf..b48d01a 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: adehabitat -Version: 1.5-1 -Date: 2006/10/30 +Version: 1.5-2 +Date: 2007/01/16 Title: Analysis of habitat selection by animals Author: Clement Calenge, contributions from Mathieu Basille, Stephane Dray and Scott Fortmann-Roe Maintainer: Clement Calenge @@ -9,4 +9,4 @@ Suggests: gpclib, sp, spatstat, MASS, tkrplot, shapefiles Description: A collection of tools for the analysis of habitat selection by animals Encoding: latin1 License: GPL version 2 or newer -Packaged: Mon Oct 30 10:08:16 2006; calenge +Packaged: Tue Jan 16 11:42:18 2007; calenge diff --git a/INDEX b/INDEX index 36d9b65..d655037 100644 --- a/INDEX +++ b/INDEX @@ -86,6 +86,7 @@ plot.area Graphical Display of Objects of Class "area" plot.ltraj Graphical Display of an Object of Class "ltraj" plot.sahrlocs Exploratory Analysis of Habitat Selection predict.enfa Habitat Suitability Maps Built from the ENFA +puech Radio-Tracking Data of Wild Boar (2) puechabon Radio-Tracking Data of Wild Boar puechcirc Movements of wild boars tracked at Puechabon puechdesIII Habitat Selection by the Wild Boar at Puechabon diff --git a/R/angles.r b/R/angles.r index 03423f9..31f7910 100755 --- a/R/angles.r +++ b/R/angles.r @@ -1,68 +1,100 @@ -"angles" <- -function (x, id = levels(x$id), burst = levels(x$burst), - date = NULL, slsp = c("remove", "missing")) - { +"angles" <- function (x, id = levels(x$id), burst = levels(x$burst), + date = NULL, slsp = c("remove", "missing")) +{ + ## The function is deprecated .Deprecated("as.ltraj") + + ## Verifications if (!inherits(x, "traj")) - stop("x should be of class \"traj\"") + stop("x should be of class \"traj\"") slsp <- match.arg(slsp) + + ## prepangles is used to remove successive relocations + ## located at the same place prepangles <- function(x) - { + { + ## Verifications if (!inherits(x, "traj")) - stop("x should be of class \"traj\"") + stop("x should be of class \"traj\"") + + ## split per burst li <- split(x, x$burst) + + ## keeps only the successive relocations at different places foo <- function(y) { - oo <- unlist(lapply(2:nrow(y), - function(i) (!all(y[i,c("x","y")]==y[i-1,c("x","y")])))) - oo <- c(TRUE,oo) - y <- y[oo,] + oo <- unlist(lapply(2:nrow(y), + function(i) + (!all(y[i,c("x","y")]==y[i-1,c("x","y")])))) + oo <- c(TRUE,oo) + y <- y[oo,] } + + ## output res <- do.call("rbind", lapply(li, foo)) return(res) - } + } + ## gets the selected bursts x <- getburst(x, burst = burst, id = id, date = date) + + ## if the angles are to be removed when successive relocations are + ## on the same place if (slsp=="remove") - x <- prepangles(x) + x <- prepangles(x) + + ## split per burst li <- split(x, x$burst) + ## To compute the angles foo <- function(x) { - xy<-as.matrix(x[,c("x","y")]) - ang<-1:(nrow(xy)-2) - for (i in 2:(nrow(xy)-1)) { - na <- 0 - ref1<-xy[i-1,] - xyb1<-t(t(xy)-ref1) - ang1<--atan2(xyb1[i,2],xyb1[i,1]) - - ## calcul de la position de x2 et x3 rotaté - x2<-c(sqrt(sum(xyb1[i,]^2)), 0) - if (sum(abs(x2)) < 1e-7) - na<-1 - x3b<-x3<-xyb1[i+1,] - x3b[1]= cos(ang1)*x3[1] - sin(ang1)*x3[2] - x3b[2]= sin(ang1)*x3[1] + cos(ang1)*x3[2] - x3<-x3b - - ## et recalcul de l'angle - x3<-x3-x2 - if (sum(abs(x3)) < 1e-7) - na<-1 - ang[i-1]<-atan2(x3[2],x3[1]) - if (na > 0.5) - if (slsp == "missing") - ang[i - 1] <- NA - } - so<-data.frame(id=x$id[-c(1,nrow(xy))], - x=xy[-c(1,nrow(xy)),1], - y=xy[-c(1,nrow(xy)),2], - date=x$date[-c(1,nrow(xy))], - burst=x$burst[-c(1,nrow(xy))], - angles=ang) + + ## gets the coordinates + xy<-as.matrix(x[,c("x","y")]) + ang<-1:(nrow(xy)-2) + + + for (i in 2:(nrow(xy)-1)) { + + ## current relocation, with the previous one + na <- 0 + ref1<-xy[i-1,] + + ## the origin of the space is placed on the previous reloc + xyb1<-t(t(xy)-ref1) + ang1<--atan2(xyb1[i,2],xyb1[i,1]) + + ## Position of rotated x2 and x3 + x2<-c(sqrt(sum(xyb1[i,]^2)), 0) + if (sum(abs(x2)) < 1e-7) + na<-1 + x3b<-x3<-xyb1[i+1,] + x3b[1]= cos(ang1)*x3[1] - sin(ang1)*x3[2] + x3b[2]= sin(ang1)*x3[1] + cos(ang1)*x3[2] + x3<-x3b + + ## Computation of the angles + x3<-x3-x2 + if (sum(abs(x3)) < 1e-7) + na<-1 + ang[i-1]<-atan2(x3[2],x3[1]) + if (na > 0.5) + if (slsp == "missing") + ang[i - 1] <- NA + } + + ## output + so<-data.frame(id=x$id[-c(1,nrow(xy))], + x=xy[-c(1,nrow(xy)),1], + y=xy[-c(1,nrow(xy)),2], + date=x$date[-c(1,nrow(xy))], + burst=x$burst[-c(1,nrow(xy))], + angles=ang) } + + ## output lo <- do.call("rbind", lapply(li, foo)) row.names(lo) <- 1:nrow(lo) return(lo) - } +} diff --git a/R/ararea.r b/R/ararea.r index cafecde..3e23de4 100755 --- a/R/ararea.r +++ b/R/ararea.r @@ -1,17 +1,23 @@ -"ararea" <- -function(x) +"ararea" <- function(x) { - if (!inherits(x, "area")) - stop("x should be of class \"area\"") - if (!require(gpclib)) - stop("package gpclib needed for this function") - uu <- split(x[,2:3], x[,1]) - foo <- function(y) { - class(y) <- "data.frame" - u <- area.poly(as(y, "gpc.poly")) - } - res <- unlist(lapply(uu, foo)) - names(res) <- names(uu) - return(res) + ## Verifications + if (!inherits(x, "area")) + stop("x should be of class \"area\"") + + ## package gpclib needed + if (!require(gpclib)) + stop("package gpclib needed for this function") + + ## Computes the area of each polygon + uu <- split(x[,2:3], x[,1]) + foo <- function(y) { + class(y) <- "data.frame" + u <- area.poly(as(y, "gpc.poly")) + } + + ## Output + res <- unlist(lapply(uu, foo)) + names(res) <- names(uu) + return(res) } diff --git a/R/area2dxf.r b/R/area2dxf.r index 8ad7f05..3e6403c 100755 --- a/R/area2dxf.r +++ b/R/area2dxf.r @@ -1,23 +1,22 @@ -"area2dxf" <- -function(x, file, lay=1:nlevels(factor(x[,1]))) - { - ## vérification du format du fichier +"area2dxf" <- function(x, file, lay=1:nlevels(factor(x[,1]))) +{ + ## Verifications of file format if (!inherits(x, "area")) - stop("x should be of class area") + stop("x should be of class area") if (substr(file, nchar(file)-3, nchar(file))!=".dxf") - file<-paste(file, ".dxf", sep="") + file<-paste(file, ".dxf", sep="") - ## Vérification que le premier et le dernier point de chaque polygone - ## sont identiques. Sinon modifier de fichier de façon ad hoc + ## Verifications that the polygons are closed (identical first + ## and last point for all polygons) lipol<-split(x, x[,1]) for (i in 1:length(lipol)) { - j<-lipol[[i]] - if (!all(j[1,]==j[nrow(j),])) - lipol[[i]]<-rbind.data.frame(lipol[[i]], lipol[[i]][1,]) + j<-lipol[[i]] + if (!all(j[1,]==j[nrow(j),])) + lipol[[i]]<-rbind.data.frame(lipol[[i]], lipol[[i]][1,]) } x<-do.call("rbind.data.frame",lipol) - - ## header + + ## header of file text<-" 0\nSECTION\n 2\nHEADER\n 9\n$EXTMIN\n 10\n" text<-paste(text, min(x[,2]),"\n", sep="") text<-paste(text, " 20\n", sep="") @@ -30,8 +29,8 @@ function(x, file, lay=1:nlevels(factor(x[,1]))) text<-paste(text, "2\nTABLES\n 0\nENDSEC\n 0\n", sep="") text<-paste(text, "SECTION\n 2\nBLOCKS\n 0\n", sep="") text<-paste(text, "ENDSEC\n 0\nSECTION\n 2\nENTITIES\n", sep="") - - ## création du corps du fichier: boucle + + ## The main part of the file lp<-split(x[,2:3], x[,1]) for (i in 1:length(lp)) { text<-paste(text, " 0\nPOLYLINE\n 8\n", sep="") @@ -43,6 +42,8 @@ function(x, file, lay=1:nlevels(factor(x[,1]))) text<-paste(text, " 0\nSEQEND\n") } text<-paste(text, " 0\nENDSEC\n 0\nEOF\n") + + ## write the file cat(text, file=file) } diff --git a/R/area2spol.r b/R/area2spol.r index 62c31c3..33b92a7 100755 --- a/R/area2spol.r +++ b/R/area2spol.r @@ -1,21 +1,32 @@ -"area2spol" <- -function(ar) - { +"area2spol" <- function(ar) +{ + ## Verifications if (!inherits(ar, "area")) - stop("ka should be of class \"area\"") + stop("ka should be of class \"area\"") + + ## sp needed if (!require(sp)) - stop("the package sp is required for this function") + stop("the package sp is required for this function") + + ## splits ar into a list where each element is a polygon class(ar) <- "data.frame" li <- split(ar[,2:3],ar[,1]) + + ## stores the elements as SpatialPolygons res <- lapply(li, function(x) { - if (!all(unlist(x[1,]==x[nrow(x),]))) - x <- rbind(x,x[1,]) - x <- as.matrix(x) - y <- Polygon(x, hole=FALSE) - if (y@ringDir<0) - y <- Polygon(x[nrow(x):1,], hole=FALSE) - return(y) + + ## Verification that the polygon is closed + if (!all(unlist(x[1,]==x[nrow(x),]))) + x <- rbind(x,x[1,]) + + ## converts as spol + x <- as.matrix(x) + y <- Polygon(x, hole=FALSE) + if (y@ringDir<0) + y <- Polygon(x[nrow(x):1,], hole=FALSE) + return(y) }) + ## The output resb <- SpatialPolygons(lapply(1:length(res), function(i) Polygons(list(res[[i]]), names(res)[i]))) diff --git a/R/as.area.r b/R/as.area.r index bf313b6..66934ce 100755 --- a/R/as.area.r +++ b/R/as.area.r @@ -1,12 +1,14 @@ -"as.area" <- -function(x) - { +"as.area" <- function(x) +{ + ## Verifications if (!inherits(x, "data.frame")) - stop("x should be of class \"data.frame\"") + stop("x should be of class \"data.frame\"") if (ncol(x) != 3) - stop("x should have three columns") + stop("x should have three columns") + ## ID is again transormed into a factor if (!is.factor(x[,1])) - x<-factor(x[,1]) + x[,1] <-factor(x[,1]) + ## The class class(x)<-c("area", "data.frame") return(x) } diff --git a/R/as.asc.r b/R/as.asc.r index d4f7fe4..722b810 100755 --- a/R/as.asc.r +++ b/R/as.asc.r @@ -1,10 +1,13 @@ -"as.asc" <- -function(x, xll=1, yll=1, cellsize=1, type=c("numeric", "factor"), - lev=levels(factor(x))) - { +"as.asc" <- function(x, xll=1, yll=1, cellsize=1, + type=c("numeric", "factor"), + lev=levels(factor(x))) +{ + ## Verifications type<-match.arg(type) if (!inherits(x, "matrix")) stop("x should be a matrix") + + ## creates the attributes mode(x)<-"numeric" attr(x, "xll")<-xll attr(x, "yll")<-yll @@ -13,6 +16,8 @@ function(x, xll=1, yll=1, cellsize=1, type=c("numeric", "factor"), if (type=="factor") attr(x, "levels")<-lev class(x)<-"asc" + + ## Output return(x) } diff --git a/R/as.kasc.r b/R/as.kasc.r index 0e45e4c..c57eab6 100755 --- a/R/as.kasc.r +++ b/R/as.kasc.r @@ -1,8 +1,7 @@ -"as.kasc" <- -function(l) - { +"as.kasc" <- function(l) +{ -### 1. Verification que les attributs de tous les asc sont identiques +### 1. Verification that all "asc" attributes are similar clobj<-unlist(lapply(l,class)) if (!all(clobj=="asc")) stop("input should be a list of \"asc\" objects") u<-TRUE @@ -15,8 +14,8 @@ function(l) o<-o[names(o)!="type"] o<-o[names(o)!="dimnames"] -### 2. stockage des attributs, mais on benne le type de variable -### et un éventuel levels +### 2. storage of attributes, but we delete the variable type and an +### eventual "levels" attribute if (length(l)>1) { for (i in 2:length(l)) { @@ -26,13 +25,13 @@ function(l) } tmp<-tmp[names(tmp)!="type"] tmp<-tmp[names(tmp)!="dimnames"] - + u[i]<-all(sort(unlist(tmp))==sort(unlist(o))) } if (!all(u)) stop("all the objects should have the same attributes") } - -### 3. Calcul du kasc + +### 3. Computation of the kasc u<-as.vector(l[[1]]) if (attr(l[[1]], "type")=="factor") { ct<-levels(l[[1]]) @@ -61,7 +60,7 @@ function(l) } } -### 5. Les attributs +### 5. The attributes attr(output, "cellsize")<-attr(l[[1]], "cellsize") attr(output, "xll")<-attr(l[[1]], "xll") attr(output, "yll")<-attr(l[[1]], "yll") @@ -70,6 +69,6 @@ function(l) attr(output, "type")<-unlist(lapply(l, function(x) attr(x, "type"))) names(output)<-names(l) class(output)<-c("kasc","data.frame") - return(output) + return(output) } diff --git a/R/as.ltraj.r b/R/as.ltraj.r index 72dcb2f..3846078 100755 --- a/R/as.ltraj.r +++ b/R/as.ltraj.r @@ -1,97 +1,105 @@ as.ltraj <- function(xy, date, id, burst=id, slsp = c("remove", "missing")) { - if (!inherits(date,"POSIXct")) - stop("date should be of class \"POSIXct\"") - if (length(date) != nrow(xy)) - stop("date should be of the same length as xy") - - slsp <- match.arg(slsp) - - ## longueur de id - if (length(id)==1) - id <- rep(as.character(id), nrow(xy)) - if (length(id)!=nrow(xy)) - stop("id should be of the same length as xy, or of length 1") - id <- as.character(id) - - ## longueur de burst - if (length(burst)==1) - burst <- rep(as.character(burst), nrow(xy)) - if (length(burst)!=nrow(xy)) - stop("burst should be of the same length as xy, or of length 1") - burst <- as.character(burst) - - ## Vérification de l'unicité des bursts pour chaque id - id1 <- factor(id) - burst1 <- factor(burst) - if (!all(apply(table(id1,burst1)>0,2,sum)==1)) - stop("one burst level should belong to only one id level") - - x <- xy[,1] - y <- xy[,2] - res <- split(data.frame(x=x,y=y, date=date), burst) - liid <- split(id, burst) - - ## Tri des dates - res <- lapply(res, function(y) y[order(y$date),]) - - ## Vérification que pas de doublons des dates - rr <- any(unlist(lapply(res, - function(x) (length(unique(x$date))!=length(x$date))))) - if (rr) - stop("non unique dates for a given burst") - - - - ## Calcul des descripteurs - foo <- function(x) { - x1 <- x[-1, ] - x2 <- x[-nrow(x), ] - dist <- c(sqrt((x1$x - x2$x)^2 + (x1$y - x2$y)^2),NA) - R2n <- (x$x - x$x[1])^2 + (x$y - x$y[1])^2 - dt <- c(unclass(x1$date) - unclass(x2$date), NA) - dx <- c(x1$x - x2$x, NA) - dy <- c(x1$y - x2$y, NA) - abs.angle <- ifelse(dist<1e-07,NA,atan2(dy,dx)) - ## angle absolu est NA si dx==dy==0 - so <- cbind.data.frame(dx=dx, dy=dy, dist=dist, - dt=dt, R2n=R2n, abs.angle=abs.angle) - return(so) - } - speed <- lapply(res, foo) - res <- lapply(1:length(res), function(i) cbind(res[[i]],speed[[i]])) - - ang.rel <- function(df,slspi=slsp) { - ang1 <- df$abs.angle[-nrow(df)] # angle i-1 - ang2 <- df$abs.angle[-1] # angle i - - if(slspi=="remove"){ - dist <- c(sqrt((df[-nrow(df),"x"] - df[-1,"x"])^2 + (df[-nrow(df),"y"] - df[-1,"y"])^2),NA) - wh.na <- which(dist<1e-7) - if(length(wh.na)>0){ - no.na <- (1:length(ang1))[!(1:length(ang1)) %in% wh.na] - for (i in wh.na){ - indx <- no.na[no.na0,2,sum)==1)) + stop("one burst level should belong to only one id level") + + x <- xy[,1] + y <- xy[,2] + res <- split(data.frame(x=x,y=y, date=date), burst) + liid <- split(id, burst) + + ## sort the dates + res <- lapply(res, function(y) y[order(y$date),]) + + ## Unique dates? + rr <- any(unlist(lapply(res, + function(x) (length(unique(x$date))!=length(x$date))))) + if (rr) + stop("non unique dates for a given burst") + + + + ## Descriptive parameters + foo <- function(x) { + x1 <- x[-1, ] + x2 <- x[-nrow(x), ] + dist <- c(sqrt((x1$x - x2$x)^2 + (x1$y - x2$y)^2),NA) + R2n <- (x$x - x$x[1])^2 + (x$y - x$y[1])^2 + dt <- c(unclass(x1$date) - unclass(x2$date), NA) + dx <- c(x1$x - x2$x, NA) + dy <- c(x1$y - x2$y, NA) + abs.angle <- ifelse(dist<1e-07,NA,atan2(dy,dx)) + ## absolute angle = NA if dx==dy==0 + so <- cbind.data.frame(dx=dx, dy=dy, dist=dist, + dt=dt, R2n=R2n, abs.angle=abs.angle) + return(so) + } + + speed <- lapply(res, foo) + res <- lapply(1:length(res), function(i) cbind(res[[i]],speed[[i]])) + + ## The relative angle + ang.rel <- function(df,slspi=slsp) { + ang1 <- df$abs.angle[-nrow(df)] # angle i-1 + ang2 <- df$abs.angle[-1] # angle i + + if(slspi=="remove"){ + dist <- c(sqrt((df[-nrow(df),"x"] - df[-1,"x"])^2 + + (df[-nrow(df),"y"] - df[-1,"y"])^2),NA) + wh.na <- which(dist<1e-7) + if(length(wh.na)>0){ + no.na <- (1:length(ang1))[!(1:length(ang1)) %in% wh.na] + for (i in wh.na){ + indx <- no.na[no.na pi, res -2*pi,res) + return(c(NA,res)) } - res <- ang2-ang1 - res <- ifelse(res <= (-pi), 2*pi+res,res) - res <- ifelse(res > pi, res -2*pi,res) - return(c(NA,res)) - } - rel.angle <- lapply(res, ang.rel) - res <- lapply(1:length(res), - function(i) data.frame(res[[i]], rel.angle=rel.angle[[i]])) - res <- lapply(1:length(res), function(i) { - x <- res[[i]] - attr(x, "id") <- as.character(liid[[i]][1]) - attr(x,"burst") <- levels(factor(burst))[i] - return(x) - }) - class(res) <- c("ltraj","list") - return(res) + + ## Output + rel.angle <- lapply(res, ang.rel) + res <- lapply(1:length(res), + function(i) data.frame(res[[i]], rel.angle=rel.angle[[i]])) + res <- lapply(1:length(res), function(i) { + x <- res[[i]] + attr(x, "id") <- as.character(liid[[i]][1]) + attr(x,"burst") <- levels(factor(burst))[i] + return(x) + }) + + ## Output + class(res) <- c("ltraj","list") + return(res) } @@ -119,7 +127,7 @@ traj2ltraj <- function(traj,slsp = c("remove", "missing")) if (sum((!missing(i))+(!missing(id))+(!missing(burst)))!=1) stop("non convenient subset") x <- unclass(x) - + if (!missing(i)) y <- x[i] if (!missing(id)) { @@ -190,9 +198,9 @@ ltraj2traj <- function(x) { if (!inherits(x, "ltraj")) stop("x should be of class \"ltraj\"") - id <- factor(unlist(lapply(x, function(y) + id <- factor(unlist(lapply(x, function(y) id <- rep(attr(y,"id"), nrow(y))))) - burst <- factor(unlist(lapply(x, function(y) + burst <- factor(unlist(lapply(x, function(y) id <- rep(attr(y,"burst"), nrow(y))))) res <- do.call("rbind", x) res <- cbind(id,burst,res) diff --git a/R/as.sahrlocs.r b/R/as.sahrlocs.r index a36781b..753eea3 100755 --- a/R/as.sahrlocs.r +++ b/R/as.sahrlocs.r @@ -1,26 +1,26 @@ -"as.sahrlocs" <- -function(mlocs, mhr, msa, descan=NULL) - { +"as.sahrlocs" <- function(mlocs, mhr, msa, descan=NULL) +{ + ## Verifications if (!inherits(mlocs, "kasc")) stop("non convenient data") if (!inherits(mhr, "kasc")) stop("non convenient data") if (!inherits(msa, "kasc")) stop("non convenient data") - atze<-attributes(msa) - nlocs<-nrow(as.data.frame(unclass(mlocs))) nhr<-nrow(as.data.frame(unclass(mhr))) nsa<-nrow(as.data.frame(unclass(msa))) - if (!((nlocs==nhr)&(nlocs==nsa))) - stop("the \"asc\" objects should describe the same area") - + stop("the \"asc\" objects should describe the same area") nclocs<-ncol(as.data.frame(unclass(mlocs))) nchr<-ncol(as.data.frame(unclass(mhr))) - if (nclocs!=nchr) stop("different number of individuals in mhr and mlocs") + if (nclocs!=nchr) + stop("different number of individuals in mhr and mlocs") - output<-list(sa=as.data.frame(unclass(msa)), hr=as.data.frame(unclass(mhr)), + ## Creation of the object sahrlocs + output<-list(sa=as.data.frame(unclass(msa)), + hr=as.data.frame(unclass(mhr)), locs=as.data.frame(unclass(mlocs)), descan=descan) - + + ## output attr(output, "nrow")<-atze$nrow attr(output, "ncol")<-atze$ncol attr(output, "xll")<-atze$xll diff --git a/R/as.traj.r b/R/as.traj.r index c888a70..d6b47f7 100755 --- a/R/as.traj.r +++ b/R/as.traj.r @@ -1,17 +1,18 @@ -"as.traj" <- -function(id, xy, date, burst=id, ...) - { +"as.traj" <- function(id, xy, date, burst=id, ...) +{ + ## Verifications if (!is.data.frame(xy)) - stop("xy should be a data.frame") + stop("xy should be a data.frame") if (ncol(xy)!=2) - stop("xy should have two columns") + stop("xy should have two columns") if (!inherits(date, "POSIXct")) - stop("date should be of class \"POSIXct\"") + stop("date should be of class \"POSIXct\"") id <- factor(id) burst <- factor(burst) if (!all(apply(table(id,burst)>0,2,sum)==1)) - stop("one burst level should belong to only one id level") + stop("one burst level should belong to only one id level") + ## Bases names(xy)<-c("x", "y") bas<-data.frame(id=id, xy, date=date, burst=burst, ...) @@ -20,20 +21,22 @@ function(id, xy, date, burst=id, ...) nl <- unlist(lapply(li, nrow)) > 1 li <- li[nl] if (any(!nl)) - warning(paste("At least two relocations are needed for a burst:\n", - sum(!nl), "circuits have been deleted")) + warning(paste("At least two relocations are needed for a burst:\n", + sum(!nl), "circuits have been deleted")) li<-lapply(li, foo) - ## Vérification que pas de doublons au niveau des dates + + ## Verification that no double dates foob<-function(x) { - ind<-rep(0,nrow(x)) - for (i in 2:nrow(x)) { - if ((as.numeric(x$date))[i]==(as.numeric(x$date))[i-1]) - ind[i]<-1 - } - return(x[ind==0,]) + ind<-rep(0,nrow(x)) + for (i in 2:nrow(x)) { + if ((as.numeric(x$date))[i]==(as.numeric(x$date))[i-1]) + ind[i]<-1 + } + return(x[ind==0,]) } + ## output li<-lapply(li, foob) bas<-do.call("rbind", li) row.names(bas)<-as.character(1:nrow(bas)) @@ -41,5 +44,5 @@ function(id, xy, date, burst=id, ...) bas$burst <- factor(bas$burst) class(bas)<-c("traj", "data.frame") return(bas) - } +} diff --git a/R/asc2im.r b/R/asc2im.r index 6860ab1..c4fae05 100755 --- a/R/asc2im.r +++ b/R/asc2im.r @@ -1,12 +1,16 @@ -"asc2im" <- -function(x) - { +"asc2im" <- function(x) +{ + ## Verifications if (!inherits(x, "asc")) - stop("should be an object of class \"asc\"") + stop("should be an object of class \"asc\"") if (attr(x, "type")=="factor") - stop("function not yet implemented for factors") + stop("function not yet implemented for factors") + + ## spatstat needed if (!require(spatstat)) - stop("the package spatstat should be available for this function") + stop("the package spatstat should be available for this function") + + ## Results xy<-getXYcoords(x) sorties<-im(t(unclass(x)), xy$x,xy$y) return(sorties) diff --git a/R/asc2spixdf.r b/R/asc2spixdf.r index 89ca044..eb24f4c 100755 --- a/R/asc2spixdf.r +++ b/R/asc2spixdf.r @@ -1,21 +1,31 @@ -"asc2spixdf" <- -function(a) +"asc2spixdf" <- function(a) { - if (!inherits(a, "asc")) - stop("a should be of class \"asc\"") - if (!require(sp)) - stop("the package sp is required for this function") - xyc <- getXYcoords(a) - xc <- rep(xyc$x, times=length(xyc$y)) - yc <- rep(xyc$y, each=length(xyc$x)) - xyc<-data.frame(x=xc,y=yc) - cons <- (1:length(c(a)))[!is.na(c(a))] - var <- c(a)[cons] - xyc <- xyc[cons,] - names(xyc) <- c("x","y") - df1 <- data.frame(xyc, var) - coordinates(df1) <- c("x","y") - gridded(df1) <- TRUE - return(df1) + ## Verifications + if (!inherits(a, "asc")) + stop("a should be of class \"asc\"") + + ## sp needed + if (!require(sp)) + stop("the package sp is required for this function") + + ## creates the data frame of coordinates + xyc <- getXYcoords(a) + xc <- rep(xyc$x, times=length(xyc$y)) + yc <- rep(xyc$y, each=length(xyc$x)) + xyc<-data.frame(x=xc,y=yc) + + ## keep only the mapped areas for the variable + cons <- (1:length(c(a)))[!is.na(c(a))] + var <- c(a)[cons] + xyc <- xyc[cons,] + names(xyc) <- c("x","y") + + ## created the spatial data frame + df1 <- data.frame(xyc, var) + coordinates(df1) <- c("x","y") + gridded(df1) <- TRUE + + ## Output + return(df1) } diff --git a/R/ascgen.r b/R/ascgen.r index 39ef1ea..ffb64d3 100755 --- a/R/ascgen.r +++ b/R/ascgen.r @@ -1,43 +1,57 @@ -"ascgen" <- -function(xy=NULL, cellsize=NULL, nrcol=10, count=TRUE) +"ascgen" <- function(xy = NULL, cellsize = NULL, + nrcol = 10, count = TRUE) { - xl<-c(min(xy[,1]), max(xy[,1])) - yl<-c(min(xy[,2]), max(xy[,2])) - rx<-xl[2]-xl[1] - ry<-yl[2]-yl[1] - u<-rx - ref<-"x" - if (ry>rx) { - u<-ry - ref<-"y" - } - xll<-xl[1] - yll<-yl[1] - - if (!is.null(cellsize)) { - cx<-ceiling(rx/cellsize)+1 - cy<-ceiling(ry/cellsize)+1 - asc<-matrix(0, nrow=cx, ncol=cy) - attr(asc, "xll")<-xll - attr(asc, "yll")<-yll - attr(asc, "cellsize")<-cellsize - attr(asc, "type")<-"numeric" - class(asc)<-"asc" - } else { - asc<-matrix(0, nrow=nrcol, ncol=nrcol) - cellsize<-u/(nrcol-1) - attr(asc, "xll")<-xll - attr(asc, "yll")<-yll - attr(asc, "cellsize")<-cellsize - attr(asc, "type")<-"numeric" - class(asc)<-"asc" - } - - if (count) { - kasc<-as.kasc(list(a=asc)) - asc<-count.points(xy, kasc) - } - - return(asc) + ## Verifications + if (ncol(xy)!=2) + stop("xy should have two columns") + + ## Remove the possible missing values + xy <- xy[!is.na(xy[,1]),] + xy <- xy[!is.na(xy[,2]),] + + + ## Identifies the axis on which the points cover the maximum range + xl<-c(min(xy[,1]), max(xy[,1])) + yl<-c(min(xy[,2]), max(xy[,2])) + rx<-xl[2]-xl[1] + ry<-yl[2]-yl[1] + u<-rx + ref<-"x" + if (ry>rx) { + u<-ry + ref<-"y" + } + + ## xll and yll attributes + xll<-xl[1] + yll<-yl[1] + + if (!is.null(cellsize)) { + cx<-ceiling(rx/cellsize)+1 + cy<-ceiling(ry/cellsize)+1 + asc<-matrix(0, nrow=cx, ncol=cy) + attr(asc, "xll")<-xll + attr(asc, "yll")<-yll + attr(asc, "cellsize")<-cellsize + attr(asc, "type")<-"numeric" + class(asc)<-"asc" + } else { + asc<-matrix(0, nrow=nrcol, ncol=nrcol) + cellsize<-u/(nrcol-1) + attr(asc, "xll")<-xll + attr(asc, "yll")<-yll + attr(asc, "cellsize")<-cellsize + attr(asc, "type")<-"numeric" + class(asc)<-"asc" + } + + ## If count TRUE, the number of points is added for each pixel + if (count) { + kasc<-as.kasc(list(a=asc)) + asc<-count.points(xy, kasc) + } + + ## Output + return(asc) } diff --git a/R/attpol2area.r b/R/attpol2area.r index fdc7f6f..50eddee 100755 --- a/R/attpol2area.r +++ b/R/attpol2area.r @@ -1,30 +1,43 @@ -"attpol2area" <- -function(srdf) +"attpol2area" <- function(srdf) { - if (!inherits(srdf, "SpatialPolygonsDataFrame")) - stop("sr should be of class \"SpatialPolygonsDataFrame\"") - dat <- srdf@data - sr <- polygons(srdf) - - res <- lapply(1:length(sr@polygons), function(i) { - x <- sr@polygons[[i]] - y <- x@Polygons - nom <- x@ID - ll <- length(y) - hh <- unlist(lapply(y, function(o) o@hole)) - hol <- sum(hh) - ll <- ll-hol - if (ll == 1) { - re <- data.frame(nom=nom,dat[i,]) - } - if (ll > 1) { - nom <- paste(nom, 1:ll, sep=".") - re <- data.frame(nom=nom, dat[rep(i,ll),]) - } - return(re) - }) - res <- do.call("rbind.data.frame", res) - row.names(res) <- 1:nrow(res) - return(res) + ## Verifications + if (!inherits(srdf, "SpatialPolygonsDataFrame")) + stop("sr should be of class \"SpatialPolygonsDataFrame\"") + + ## Gets the attributes and the polygons + dat <- srdf@data + sr <- polygons(srdf) + + ## Gets the contour of the polygons for each polygon + res <- lapply(1:length(sr@polygons), function(i) { + + ## gets the polygon + x <- sr@polygons[[i]] + y <- x@Polygons + + ## The ID + nom <- x@ID + + ## we delete the holes + ll <- length(y) + hh <- unlist(lapply(y, function(o) o@hole)) + hol <- sum(hh) + ll <- ll-hol + + ## the output + if (ll == 1) { + re <- data.frame(nom=nom,dat[i,]) + } + if (ll > 1) { + nom <- paste(nom, 1:ll, sep=".") + re <- data.frame(nom=nom, dat[rep(i,ll),]) + } + return(re) + }) + + ## general ouput + res <- do.call("rbind.data.frame", res) + row.names(res) <- 1:nrow(res) + return(res) } diff --git a/R/biv.plot.r b/R/biv.plot.r index fee5157..5b64963 100755 --- a/R/biv.plot.r +++ b/R/biv.plot.r @@ -1,27 +1,31 @@ -"biv.plot" <- -function(dfxy, br = 10, points = TRUE, density = TRUE, - kernel = TRUE, o.include = FALSE, pch, cex, col, h, sub, - side = c("top", "bottom", "none"), ...) +"biv.plot" <- function(dfxy, br = 10, points = TRUE, density = TRUE, + kernel = TRUE, o.include = FALSE, pch, + cex, col, h, sub, + side = c("top", "bottom", "none"), ...) { + ## Verifications side <- match.arg(side) - if (!inherits(dfxy, "data.frame")) - stop("dfxy should be a data frame") - if (ncol(dfxy) < 2) - stop("dfxy should have at least two columns") - if (!require(MASS) & kernel) - stop("This function needs the package MASS") + if (!inherits(dfxy, "data.frame")) + stop("dfxy should be a data frame") + if (ncol(dfxy) < 2) + stop("dfxy should have at least two columns") + if (!require(MASS) & kernel) + stop("This function needs the package MASS") if (missing(pch)) - pch <- 16 + pch <- 16 if (missing(cex)) - cex <- 0.5 + cex <- 0.5 if (missing(col)) - col <- grey(0.7) + col <- grey(0.7) + + ## Graphical parameters old.par <- par(no.readonly = TRUE) on.exit(par(old.par)) - lay <- layout(matrix(c(2,4,1,3),2,2, byrow = TRUE), c(3,1), + lay <- layout(matrix(c(2,4,1,3),2,2, byrow = TRUE), c(3,1), c(1,3), TRUE) layout.show(lay) - + + ## preparation of the data x <- dfxy[, 1] y <- dfxy[, 2] xr <- diff(range(x)) @@ -33,92 +37,109 @@ function(dfxy, br = 10, points = TRUE, density = TRUE, yp <- 0 yn <- 0 if (max(x)>0) - xp <- seq(0, max(x)+xby, by = xby) + xp <- seq(0, max(x)+xby, by = xby) if (max(y)>0) - yp <- seq(0, max(y)+yby, by = yby) + yp <- seq(0, max(y)+yby, by = yby) if (min(x)<0) - xn <- seq(0, min(x)-xby, by = -xby) + xn <- seq(0, min(x)-xby, by = -xby) if (min(y)<0) - yn <- seq(0, min(y)-yby, by = -yby) + yn <- seq(0, min(y)-yby, by = -yby) + xbr <- c(rev(xn[-1]), xp) ybr <- c(rev(yn[-1]), yp) + + ## Cuts the points into classes xhist <- hist(x, plot = FALSE, br = xbr, freq = FALSE) yhist <- hist(y, plot = FALSE, br = ybr, freq = FALSE) + + ## Limits of the graphs if (o.include) { - xlim <- c(min(x, 0)-xr*0.05, max(x, 0)+xr*0.05) - ylim <- c(min(y, 0)-yr*0.05, max(y, 0)+yr*0.05) + xlim <- c(min(x, 0)-xr*0.05, max(x, 0)+xr*0.05) + ylim <- c(min(y, 0)-yr*0.05, max(y, 0)+yr*0.05) } else { - xlim <- c(min(x)-xr*0.05, max(x)+xr*0.05) - ylim <- c(min(y)-yr*0.05, max(y)+yr*0.05) + xlim <- c(min(x)-xr*0.05, max(x)+xr*0.05) + ylim <- c(min(y)-yr*0.05, max(y)+yr*0.05) } xhistlim <- c(0, max(xhist$density)*1.05) yhistlim <- c(0, max(yhist$density)*1.05) - + + ## The main graph par(mar = c(0.1, 0.1, 0.1, 0.1)) - plot.default(min(x), min(y), type = "n", xlab = "", ylab = "", - xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, + ## background + plot.default(min(x), min(y), type = "n", xlab = "", ylab = "", + xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, xaxs = "i", yaxs = "i", frame.plot = FALSE) abline(v = xbr, col = grey(0.9)) abline(h = ybr, col = grey(0.9)) abline(h = 0) abline(v = 0) + + ## adds the points if(points) - points(x, y, pch = pch, cex = cex) + points(x, y, pch = pch, cex = cex) + + ## an eventual 2D smoothing if(kernel) { - if (missing(h)) - h <- c(bandwidth.nrd(x), bandwidth.nrd(y)) - dens <- kde2d(x, y, h = h, lims = c(xlim, ylim)) - contour(dens, drawlabels = FALSE, col = col, add = TRUE) + if (missing(h)) + h <- c(bandwidth.nrd(x), bandwidth.nrd(y)) + dens <- kde2d(x, y, h = h, lims = c(xlim, ylim)) + contour(dens, drawlabels = FALSE, col = col, add = TRUE) } + + ## the scale box if (side != "none") { - tra <- paste(" dx = ", signif(xby, 2), " ", "\n", " dy = ", - signif(yby, 2), " ", sep = "") - wt <- strwidth(tra, cex = 1) - ht <- strheight(tra, cex = 1) * 1.5 - xl <- par("usr")[1] - yu <- par("usr")[4] - yd <- par("usr")[3] - if (side == "top") { - rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) - text(xl + wt/2, yu - ht/2, tra, cex = 1) - } - if (side == "bottom") { - rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) - text(xl + wt/2, yd + ht/2, tra, cex = 1) - } + tra <- paste(" dx = ", signif(xby, 2), " ", "\n", " dy = ", + signif(yby, 2), " ", sep = "") + wt <- strwidth(tra, cex = 1) + ht <- strheight(tra, cex = 1) * 1.5 + xl <- par("usr")[1] + yu <- par("usr")[4] + yd <- par("usr")[3] + if (side == "top") { + rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) + text(xl + wt/2, yu - ht/2, tra, cex = 1) + } + if (side == "bottom") { + rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) + text(xl + wt/2, yd + ht/2, tra, cex = 1) + } } box() - + + ## Histogram and density of x par(mar = c(0.1, 0.1, 0.1, 0.1)) if(density) { - xdens <- density(x) - xhistlim <- c(0, max(xhist$density, xdens$y)*1.05) + xdens <- density(x) + xhistlim <- c(0, max(xhist$density, xdens$y)*1.05) } - plot.default(min(x), 0, type = "n", xlab = "", ylab = "", - xaxt = "n", yaxt = "n", xlim = xlim, ylim = xhistlim, + plot.default(min(x), 0, type = "n", xlab = "", ylab = "", + xaxt = "n", yaxt = "n", xlim = xlim, ylim = xhistlim, xaxs = "i", yaxs = "i", frame.plot = FALSE) rect(xbr[-length(xbr)], rep(0, br), xbr[-1], xhist$density) if(density) - lines(xdens, col = col) + lines(xdens, col = col) abline(h = 0) - + + ## Histogram and density of y par(mar = c(0.1, 0.1, 0.1, 0.1)) if(density) { - ydens <- density(y) - yhistlim <- c(0, max(yhist$density, ydens$y)*1.05) - } - plot.default(min(x), 0, type = "n", xlab = "", ylab = "", - xaxt = "n", yaxt = "n", xlim = yhistlim, ylim = ylim, + ydens <- density(y) + yhistlim <- c(0, max(yhist$density, ydens$y)*1.05) + } + plot.default(min(x), 0, type = "n", xlab = "", ylab = "", + xaxt = "n", yaxt = "n", xlim = yhistlim, ylim = ylim, xaxs = "i", yaxs = "i", frame.plot = FALSE) rect(rep(0, br), ybr[-length(ybr)], yhist$density, ybr[-1]) - if(density) - lines(ydens$y, ydens$x, col = col) + if(density) + lines(ydens$y, ydens$x, col = col) + - plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", + ## Main title of the graph + plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = FALSE) if (missing(sub)) - sub <- "Biplot and \nmarginals\ndistributions" + sub <- "Biplot and \nmarginals\ndistributions" mtext(text = paste(sub), adj = 0.5, line = -8, cex = 1.5) - } +} diff --git a/R/biv.test.r b/R/biv.test.r index 6328006..1586976 100755 --- a/R/biv.test.r +++ b/R/biv.test.r @@ -1,152 +1,187 @@ -"biv.test" <- -function(dfxy, point, br = 10, points = TRUE, density = TRUE, - kernel = TRUE, o.include = FALSE, pch, cex, col, Pcol, h, sub, - side = c("top", "bottom", "none"), ...) +"biv.test" <- function(dfxy, point, br = 10, points = TRUE, density = TRUE, + kernel = TRUE, o.include = FALSE, pch, cex, + col, Pcol, h, sub, + side = c("top", "bottom", "none"), ...) { - side <- match.arg(side) - if (!inherits(dfxy, "data.frame")) - stop("dfxy should be a data frame") - if (ncol(dfxy) < 2) - stop("dfxy should have at least two columns") - if (!require(MASS) & kernel) - stop("This function needs the package MASS") - if (missing(pch)) - pch <- 16 - if (missing(cex)) - cex <- 0.5 - if (missing(col)) - col <- grey(0.6) - if (missing(Pcol)) - Pcol <- grey(0.6) - old.par <- par(no.readonly = TRUE) - on.exit(par(old.par)) - lay <- layout(matrix(c(2,4,1,3),2,2, byrow = TRUE), c(3,1), - c(1,3), TRUE) - layout.show(lay) - - x <- dfxy[, 1] - y <- dfxy[, 2] - xr <- diff(range(x)) - yr <- diff(range(y)) - xby <- xr/(br-1) - yby <- yr/(br-1) - xp <- 0 - xn <- 0 - yp <- 0 - yn <- 0 - if (max(x)>0 | point[1]>0) - xp <- seq(0, max(x, point[1])+xby, by = xby) - if (max(y)>0 | point[2]>0) - yp <- seq(0, max(y, point[2])+yby, by = yby) - if (min(x)<0 | point[1]<0) - xn <- seq(0, min(x, point[1])-xby, by = -xby) - if (min(y)<0 | point[2]<0) - yn <- seq(0, min(y, point[2])-yby, by = -yby) - xbr <- c(rev(xn[-1]), xp) - ybr <- c(rev(yn[-1]), yp) - xhist <- hist(x, plot = FALSE, br = xbr, freq = FALSE) - yhist <- hist(y, plot = FALSE, br = ybr, freq = FALSE) - if (o.include) { - xlim <- c(min(x, 0, point[1])-xr*0.05, max(x, 0, - point[1])+xr*0.05) - ylim <- c(min(y, 0, point[2])-yr*0.05, max(y, 0, - point[2])+yr*0.05) - } - else { - xlim <- c(min(x, point[1])-xr*0.05, max(x, - point[1])+xr*0.05) - ylim <- c(min(y, point[2])-yr*0.05, max(y, - point[2])+yr*0.05) - } - xhistlim <- c(0, max(xhist$density)*1.05) - yhistlim <- c(0, max(yhist$density)*1.05) - - par(mar = c(0.1, 0.1, 0.1, 0.1)) - plot.default(min(x), min(y), type = "n", xlab = "", ylab = "", - xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, - xaxs = "i", yaxs = "i", frame.plot = FALSE) - abline(v = xbr, col = grey(0.9)) - abline(h = ybr, col = grey(0.9)) - abline(h = 0) - abline(v = 0) - if(points) - points(x, y, pch = pch, cex = cex) - if(kernel) { - if (missing(h)) - h <- c(bandwidth.nrd(x), bandwidth.nrd(y)) - dens <- kde2d(x, y, h = h, lims = c(xlim, ylim)) - contour(dens, drawlabels = FALSE, col = col, add = TRUE) - } - lines(c(point[1], xlim[2]), rep(point[2], 2), lty = 3) - lines(rep(point[1], 2), c(point[2], ylim[2]), lty = 3) - if (side != "none") { - tra <- paste(" dx = ", signif(xby, 2), " ", "\n", " dy = ", - signif(yby, 2), " ", sep = "") - wt <- strwidth(tra, cex = 1) - ht <- strheight(tra, cex = 1) * 1.5 - xl <- par("usr")[1] - yu <- par("usr")[4] - yd <- par("usr")[3] - if (side == "top") { - rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) - text(xl + wt/2, yu - ht/2, tra, cex = 1) + ## Verifications + side <- match.arg(side) + if (!inherits(dfxy, "data.frame")) + stop("dfxy should be a data frame") + if (ncol(dfxy) < 2) + stop("dfxy should have at least two columns") + if (!require(MASS) & kernel) + stop("This function needs the package MASS") + if (missing(pch)) + pch <- 16 + if (missing(cex)) + cex <- 0.5 + if (missing(col)) + col <- grey(0.6) + if (missing(Pcol)) + Pcol <- grey(0.6) + + ## Graphical settings + old.par <- par(no.readonly = TRUE) + on.exit(par(old.par)) + lay <- layout(matrix(c(2,4,1,3),2,2, byrow = TRUE), c(3,1), + c(1,3), TRUE) + layout.show(lay) + + ## preparation of the data + x <- dfxy[, 1] + y <- dfxy[, 2] + xr <- diff(range(x)) + yr <- diff(range(y)) + xby <- xr/(br-1) + yby <- yr/(br-1) + xp <- 0 + xn <- 0 + yp <- 0 + yn <- 0 + if (max(x)>0 | point[1]>0) + xp <- seq(0, max(x, point[1])+xby, by = xby) + if (max(y)>0 | point[2]>0) + yp <- seq(0, max(y, point[2])+yby, by = yby) + if (min(x)<0 | point[1]<0) + xn <- seq(0, min(x, point[1])-xby, by = -xby) + if (min(y)<0 | point[2]<0) + yn <- seq(0, min(y, point[2])-yby, by = -yby) + xbr <- c(rev(xn[-1]), xp) + ybr <- c(rev(yn[-1]), yp) + + ## Cuts the points into classes + xhist <- hist(x, plot = FALSE, br = xbr, freq = FALSE) + yhist <- hist(y, plot = FALSE, br = ybr, freq = FALSE) + + ## Limits of the graphs + if (o.include) { + xlim <- c(min(x, 0, point[1])-xr*0.05, max(x, 0, + point[1])+xr*0.05) + ylim <- c(min(y, 0, point[2])-yr*0.05, max(y, 0, + point[2])+yr*0.05) + } + else { + xlim <- c(min(x, point[1])-xr*0.05, max(x, + point[1])+xr*0.05) + ylim <- c(min(y, point[2])-yr*0.05, max(y, + point[2])+yr*0.05) + } + xhistlim <- c(0, max(xhist$density)*1.05) + yhistlim <- c(0, max(yhist$density)*1.05) + + ## The main graph + par(mar = c(0.1, 0.1, 0.1, 0.1)) + + ## background + plot.default(min(x), min(y), type = "n", xlab = "", ylab = "", + xaxt = "n", yaxt = "n", xlim = xlim, ylim = ylim, + xaxs = "i", yaxs = "i", frame.plot = FALSE) + abline(v = xbr, col = grey(0.9)) + abline(h = ybr, col = grey(0.9)) + abline(h = 0) + abline(v = 0) + + ## adds the points + if(points) + points(x, y, pch = pch, cex = cex) + + ## an eventual 2D smoothing + if(kernel) { + if (missing(h)) + h <- c(bandwidth.nrd(x), bandwidth.nrd(y)) + dens <- kde2d(x, y, h = h, lims = c(xlim, ylim)) + contour(dens, drawlabels = FALSE, col = col, add = TRUE) + } + + ## lines showing the abscissa of the observation + lines(c(point[1], xlim[2]), rep(point[2], 2), lty = 3) + ## lines showing the ordinate of the observation + lines(rep(point[1], 2), c(point[2], ylim[2]), lty = 3) + + ## The scale box + if (side != "none") { + tra <- paste(" dx = ", signif(xby, 2), " ", "\n", " dy = ", + signif(yby, 2), " ", sep = "") + wt <- strwidth(tra, cex = 1) + ht <- strheight(tra, cex = 1) * 1.5 + xl <- par("usr")[1] + yu <- par("usr")[4] + yd <- par("usr")[3] + if (side == "top") { + rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) + text(xl + wt/2, yu - ht/2, tra, cex = 1) + } + if (side == "bottom") { + rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) + text(xl + wt/2, yd + ht/2, tra, cex = 1) + } + } + ## the observation of the test + points(point[1], point[2], pch = 18, cex = cex*4, col = Pcol) + box() + + + ## Marginal distribution for X + par(mar = c(0.1, 0.1, 0.1, 0.1)) + if(density) { + xdens <- density(x) + xhistlim <- c(0, max(xhist$density, xdens$y)*1.05) } - if (side == "bottom") { - rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) - text(xl + wt/2, yd + ht/2, tra, cex = 1) + plot.default(min(x), 0, type = "n", xlab = "", ylab = "", + xaxt = "n", yaxt = "n", xlim = xlim, ylim = xhistlim, + xaxs = "i", yaxs = "i", frame.plot = FALSE) + rect(xbr[-length(xbr)], rep(0, br), xbr[-1], xhist$density) + if(density) + lines(xdens, col = col) + abline(h = 0) + + ## observation of the test + lines(rep(point[1], 2), c(0, max(xhist$density*2/3)), + col = Pcol, lwd = 2) + points(point[1], max(xhist$density*2/3), pch = 18, cex = 2, + col = Pcol) + + ## ... and P-value + pX <- (sum(dfxy[,1] >= point[1]) + 1)/(length(dfxy[,1]) + 1) + if (pX > 0.5) + pX <- (sum(dfxy[,1] <= point[1]) + 1)/(length(dfxy[,1]) + 1) + mtext(text = paste("p =", round(pX, 3)), side = 3, adj = 1, + line = -1) + + + ## Marginal distribution for y + par(mar = c(0.1, 0.1, 0.1, 0.1)) + if(density) { + ydens <- density(y) + yhistlim <- c(0, max(yhist$density, ydens$y)*1.05) } - } - points(point[1], point[2], pch = 18, cex = cex*4, col = Pcol) - box() - - par(mar = c(0.1, 0.1, 0.1, 0.1)) - if(density) { - xdens <- density(x) - xhistlim <- c(0, max(xhist$density, xdens$y)*1.05) - } - plot.default(min(x), 0, type = "n", xlab = "", ylab = "", - xaxt = "n", yaxt = "n", xlim = xlim, ylim = xhistlim, - xaxs = "i", yaxs = "i", frame.plot = FALSE) - rect(xbr[-length(xbr)], rep(0, br), xbr[-1], xhist$density) - if(density) - lines(xdens, col = col) - abline(h = 0) - lines(rep(point[1], 2), c(0, max(xhist$density*2/3)), - col = Pcol, lwd = 2) - points(point[1], max(xhist$density*2/3), pch = 18, cex = 2, - col = Pcol) - pX <- (sum(dfxy[,1] >= point[1]) + 1)/(length(dfxy[,1]) + 1) - if (pX > 0.5) - pX <- (sum(dfxy[,1] <= point[1]) + 1)/(length(dfxy[,1]) + 1) - mtext(text = paste("p =", round(pX, 3)), side = 3, adj = 1, - line = -1) - - par(mar = c(0.1, 0.1, 0.1, 0.1)) - if(density) { - ydens <- density(y) - yhistlim <- c(0, max(yhist$density, ydens$y)*1.05) - } - plot.default(min(x), 0, type = "n", xlab = "", ylab = "", - xaxt = "n", yaxt = "n", xlim = yhistlim, ylim = ylim, - xaxs = "i", yaxs = "i", frame.plot = FALSE) - rect(rep(0, br), ybr[-length(ybr)], yhist$density, ybr[-1]) - if(density) - lines(ydens$y, ydens$x, col = col) - abline(v = 0) - lines(c(0, max(yhist$density*2/3)), rep(point[2], 2), - col = Pcol, lwd = 2) - points(max(yhist$density*2/3), point[2], pch = 18, cex = 2, - col = Pcol) - pY <- (sum(dfxy[,2] >= point[2]) + 1)/(length(dfxy[,2]) + 1) - if (pY > 0.5) - pY <- (sum(dfxy[,2] <= point[2]) + 1)/(length(dfxy[,2]) + 1) - mtext(text = paste("p =", round(pY, 3)), side = 3, adj = 1, - line = -1, las = 0) - - plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", - yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = FALSE) - if (missing(sub)) - sub <- "Biplot and\n univariate\ntests" - mtext(text = paste(sub), adj = 0.5, line = -8, cex = 1.5) + plot.default(min(x), 0, type = "n", xlab = "", ylab = "", + xaxt = "n", yaxt = "n", xlim = yhistlim, ylim = ylim, + xaxs = "i", yaxs = "i", frame.plot = FALSE) + rect(rep(0, br), ybr[-length(ybr)], yhist$density, ybr[-1]) + if(density) + lines(ydens$y, ydens$x, col = col) + abline(v = 0) + + ## observation of the test + lines(c(0, max(yhist$density*2/3)), rep(point[2], 2), + col = Pcol, lwd = 2) + points(max(yhist$density*2/3), point[2], pch = 18, cex = 2, + col = Pcol) + + ## ... and P-value of the univariate test + pY <- (sum(dfxy[,2] >= point[2]) + 1)/(length(dfxy[,2]) + 1) + if (pY > 0.5) + pY <- (sum(dfxy[,2] <= point[2]) + 1)/(length(dfxy[,2]) + 1) + mtext(text = paste("p =", round(pY, 3)), side = 3, adj = 1, + line = -1, las = 0) + + + ## Main title of the graph + plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", + yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = FALSE) + if (missing(sub)) + sub <- "Biplot and\n univariate\ntests" + mtext(text = paste(sub), adj = 0.5, line = -8, cex = 1.5) } diff --git a/R/buffer.ani.r b/R/buffer.ani.r index 14ca49a..fe4e4be 100755 --- a/R/buffer.ani.r +++ b/R/buffer.ani.r @@ -1,25 +1,28 @@ -"buffer.ani" <- -function(pts, fac, x, dist) +"buffer.ani" <- function(pts, fac, x, dist) { - if (inherits(x, "asc")) - x<-as.kasc(list(toto=x)) - if (inherits(x, "kasc")) - x<-storemapattr(x) - if (!inherits(x, "mapattr")) - stop("non convenient format for x") - if (length(fac)!=nrow(pts)) - stop("factor should have the same length as pts") - - lipts<-split(pts, fac) - sorties<-list() - - for (i in names(lipts)) { - ptst<-lipts[[i]] - sorties[[i]]<-buffer(ptst, x, dist) - } - - sor<-as.kasc(sorties) - - return(sor) + ## Verifications + if (inherits(x, "asc")) + x<-as.kasc(list(toto=x)) + if (inherits(x, "kasc")) + x<-storemapattr(x) + if (!inherits(x, "mapattr")) + stop("non convenient format for x") + if (length(fac)!=nrow(pts)) + stop("factor should have the same length as pts") + + ## split the points into a list of several elements, and use + ## the function buffer for each element + lipts<-split(pts, fac) + sorties<-list() + + for (i in names(lipts)) { + ptst<-lipts[[i]] + sorties[[i]]<-buffer(ptst, x, dist) + } + + ## output as kasc + sor<-as.kasc(sorties) + + return(sor) } diff --git a/R/buffer.line.r b/R/buffer.line.r index 2c3cda8..36a091c 100755 --- a/R/buffer.line.r +++ b/R/buffer.line.r @@ -1,31 +1,45 @@ -"buffer.line" <- -function(xy, x, dist) - { +"buffer.line" <- function(xy, x, dist) +{ + ## Verifications if (inherits(x, "kasc")) - x <- getkasc(x, 1) + x <- getkasc(x, 1) if (!inherits(x, "asc")) - stop("x should be an object of class asc") + stop("x should be an object of class asc") + + ## First remove the eventual missing values + xy <- xy[!is.na(xy[,1]),] + xy <- xy[!is.na(xy[,2]),] + + ## very small jitter to avoid the points loated exactly on the + ## limit between two pixels ra<- attr(x, "cellsize")/100 xy[,1]<-jitter(xy[,1], amount=ra) xy[,2]<-jitter(xy[,2], amount=ra) + + ## a first buffer on the points bu <- buffer(xy, x, dist) bu[is.na(bu)]<-0 - + + ## preparation for a buffer on the lines carter <- matrix(0, nrow=nrow(x), ncol = ncol(x)) xyg <- getXYcoords(x) xgr<-xyg$x ygr<-xyg$y - + + ## the above results are passed as arguments to the C function + ## "bufligr" which computes a buffer around the lines toto <- .C("bufligr", as.double(t(xy)), as.double(dist), as.double(t(carter)), as.double(xgr), as.double(ygr), as.integer(nrow(x)), as.integer(ncol(x)), as.integer(nrow(xy)), PACKAGE="adehabitat")[[3]] + ## the buffer on the line is summed to the buffer on the points output <- matrix(toto, nrow = nrow(x), byrow = TRUE) output <- output + bu output[output>0]<-1 - + + ## Output as an asc object output[output == 0] <- NA attr(output, "xll") <- attr(x, "xll") attr(output, "yll") <- attr(x, "yll") diff --git a/R/buffer.r b/R/buffer.r index 17d56fe..c1ef411 100755 --- a/R/buffer.r +++ b/R/buffer.r @@ -1,71 +1,110 @@ -".buffer.point.unic" <- -function(x, md) - { +## buffer.point.unic is used to compute a "mask" for buffers: +## It returns a matrix containing a rasterized circle of radius +## equal to the buffer size, with the same resolution as the map + +".buffer.point.unic" <- function(x, md) +{ + ## gets the cell size res<-attr(x, "cellsize") + ## the number of pixels of the "mask" matrix nmax<-ceiling(md/res) - + + ## creates the mini-matrix of NA calc<-matrix(NA,ncol = 2*nmax+1, nrow=2*nmax+1) cour<-nmax+1 + ## cour contains the index of the row (and of the column) + ## of the pixel located at the center of the map + ## each pixel of the map takes the value 1 if its center + ## is located at a distance < md of the center of the map for (i in 1:nrow(calc)) { - for (j in 1:ncol(calc)) { - d1<-(((cour-i-0.5)*res)^2+((cour-j-0.5)*res)^2) - d2<-(((cour-i-0.5)*res)^2+((cour-j+0.5)*res)^2) - d3<-(((cour-i+0.5)*res)^2+((cour-j-0.5)*res)^2) - d4<-(((cour-i+0.5)*res)^2+((cour-j+0.5)*res)^2) - - if (min(c(d1,d2,d3,d4))<= md^2) - calc[i,j]<-1 - } + for (j in 1:ncol(calc)) { + d1<-(((cour-i-0.5)*res)^2+((cour-j-0.5)*res)^2) + d2<-(((cour-i-0.5)*res)^2+((cour-j+0.5)*res)^2) + d3<-(((cour-i+0.5)*res)^2+((cour-j-0.5)*res)^2) + d4<-(((cour-i+0.5)*res)^2+((cour-j+0.5)*res)^2) + + if (min(c(d1,d2,d3,d4))<= md^2) + calc[i,j]<-1 + } } + + ## output return(calc) - } +} + -"buffer" <- -function(pts, x, dist) - { +"buffer" <- function(pts, x, dist) +{ + ## Verifications if (inherits(x, "asc")) - x<-as.kasc(list(toto=x)) + x<-as.kasc(list(toto=x)) if (inherits(x, "kasc")) - x<-storemapattr(x) + x<-storemapattr(x) if (!inherits(x, "mapattr")) - stop("non convenient format for x") + stop("non convenient format for x") res<-attr(x, "cellsize") nmax<-ceiling(dist/res) - - ## calcul du calque + + ## removes the missing values + pts <- pts[!is.na(pts[,1]),] + pts <- pts[!is.na(pts[,2]),] + + ## Computation of the "mask" with .buffer.point.unic (see above) + ## and replace the NA by 0 calc<-.buffer.point.unic(x, dist) calc0<-calc calc0[is.na(calc0)]<-0 + + ## Count the points in each pixel of the map: allows to + ## identify the pixels containing at least one point asc<-count.points(pts, x) vasc<-as.vector(asc) - - ## Calcul d'un idlig et d'un idcol de la meme longueur que vasc - ## idasc permettra de déterminer quelles sont les idlig et idcol - ## des cellules ou >0 + + ## Computation of an idlig and idcol of the same length as vasc. + ## idasc will allow to identify the values of idlig et idcol + ## for which the cells are >0 idasc<-1:length(vasc) idcons<-idasc[vasc>0] idlig<-as.vector(row(asc)) idcol<-as.vector(col(asc)) - + + ## keeps only the indices of the rows and columns for the + ## pixels containing at least one point ligcons<-idlig[idcons] colcons<-idcol[idcons] + ## output matrix + ## temporarily adds rows and columns to the map, so that it is + ## sufficiently large to place the "mask" matrix (so that we + ## add +2*nmax) sorties<-matrix(0, nrow=(attr(x, "ncol")+2*nmax), - ncol=(attr(x, "nrow")+2*nmax)) + ncol=(attr(x, "nrow")+2*nmax)) + ## for each non-empty pixel, adds the mask on the map for (i in 1:length(idcons)) { - car<-matrix(0, nrow=(attr(x, "ncol")+2*nmax), - ncol=(attr(x, "nrow")+2*nmax)) - - car[c(ligcons[i]:(ligcons[i]+2*nmax)), c(colcons[i]:(colcons[i]+2*nmax))]<- - car[c(ligcons[i]:(ligcons[i]+2*nmax)), c(colcons[i]:(colcons[i]+2*nmax))]+ - calc0 - sorties<-sorties+car + + ## places the "mask" matrix on the area, depending on + ## the non-empty pixel location + car<-matrix(0, nrow=(attr(x, "ncol")+2*nmax), + ncol=(attr(x, "nrow")+2*nmax)) + car[c(ligcons[i]:(ligcons[i]+2*nmax)), + c(colcons[i]:(colcons[i]+2*nmax))]<- + car[c(ligcons[i]:(ligcons[i]+2*nmax)), + c(colcons[i]:(colcons[i]+2*nmax))]+ + calc0 + ## ...and adds this temporary matrix to the output map + sorties<-sorties+car } - sorties<-sorties[c((nmax+1):(nrow(sorties)-nmax)),c((nmax+1):(ncol(sorties)-nmax))] + + ## remove the additional rows and columns added previously + sorties<-sorties[c((nmax+1):(nrow(sorties)-nmax)), + c((nmax+1):(ncol(sorties)-nmax))] + + ## The matrix is either 0 (outside the buffer) or 1 (inside) sorties<-matrix(as.numeric(sorties!=0), ncol=attr(x, "nrow")) + ## Output sorties[sorties==0]<-NA attr(sorties, "cellsize")<-attr(x, "cellsize") attr(sorties, "xll")<-attr(x, "xll") diff --git a/R/clusthr.r b/R/clusthr.r index 7944d36..05cccdd 100755 --- a/R/clusthr.r +++ b/R/clusthr.r @@ -1,5 +1,6 @@ clusthr <-function(xy, id=NULL) { + ## Verifications if (ncol(xy)!=2) stop("xy should have two columns") if (is.null(id)) @@ -7,9 +8,17 @@ clusthr <-function(xy, id=NULL) id<-factor(id) if (length(id)!=nrow(xy)) stop("id should have the same length as xy") + + ## splits the coordinates into one component per animal lixy<-split(xy, id) + + ## the output list res<-list() + ## The function clubase is used to compute the length + ## of the output vectors. It relies on the C function "longfacclust". + ## It is needed to reserve memory for the main C function "clusterhrr" + ## called below clubase <- function(xy) { nr <- as.integer(nrow(xy)) @@ -21,26 +30,42 @@ clusthr <-function(xy, id=NULL) return(toto) } - + ## for each animal, an home range is desired for (i in names(lixy)){ x<-lixy[[i]] - ## calcul de la longueur des vecteurs de sortie + + ## computation of the output vectors len <- clubase(x) - ## calcul de l'arbre + + ## Computation of the tree: call to the C function "clusterhrr" toto <- .C("clusterhrr", as.double(t(as.matrix(x))), as.integer(nrow(x)), integer(len), integer(len), integer(len), as.integer(len), PACKAGE = "adehabitat") - facso <- toto[[3]] - nolocso <- toto[[4]] - cluso <- toto[[5]] + + facso <- toto[[3]] # contains indices of the step of the + # algorithm (First step =1, second = 2) + + nolocso <- toto[[4]] # contains the indices of the + # relocations clustered at the step + # indicated by the factor step + + cluso <- toto[[5]] # contains the indices of the cluster + # in which the relocations clustered + # at the step i are clustered + + ## output re <- data.frame(step = facso, clust = cluso, reloc = nolocso) res[[i]] <- list(xy = x, results = re) } + + ## Output class(res) <- "clusthr" return(res) } + + print.clusthr <- function(x, ...) { if (!inherits(x, "clusthr")) @@ -63,13 +88,16 @@ print.clusthr <- function(x, ...) plot.clusthr <- function(x, whi = names(x), pch = 21, - bgpts = "white", colpts="black", cex=0.7, - plotit = TRUE, colpol = "grey",...) + bgpts = "white", colpts="black", cex=0.7, + plotit = TRUE, colpol = "grey",...) { + ## Verifications if (!inherits(x, "clusthr")) stop("x should be of class \"clusthr\"") x <- x[whi] class(x) <- "clusthr" + + ## Graphical settings if (plotit) { if (length(whi)>1) { opar <- par(mfrow = n2mfrow(length(whi)), mar=c(0,0,2,0)) @@ -77,39 +105,63 @@ plot.clusthr <- function(x, whi = names(x), pch = 21, } } - ## Pour chaque animal + ## For each animal restep <- lapply(whi, function(i) { - ## Un graphe, pour commencer + + ## The main graph, with relocations if (plotit) { plot(x[[i]]$xy, asp=1, ty="n", main=names(x[i]), axes=(length(whi)==1),...) box() points(x[[i]]$xy, pch= pch, bg = bgpts, col = colpts, cex=cex) } - ## Variables locales + + ## local variables step <- x[[i]]$results$step clust <- x[[i]]$results$clust reloc <- x[[i]]$results$reloc - ## On calcule les niveaux de clusters dispo pour chaque étape: + ################## + ## Computes the home ranges for each step of the algorithm + ## as an object of class "area" + + ## The relocations clustered at step one liclu <- list() liclu[[1]] <- reloc[step==1] + + ## The home range at step one poltot <- list() pc <- data.frame(id=factor(rep(1,3)),x[[i]]$xy[reloc[step==1],]) - class(pc) <- c("area", "data.frame") + pc <- as.area(pc) attr(pc,"nlocs") <- 3 + + ## poltot contains the home range poltot[1] <- list(pc) + + + ## For each step: for (j in 2:max(step)) { + + ## The relocations clustered at step j relocj <- reloc[step==j] r1 <- relocj[1] + + ## are the relocations already clustered (in which case the step is + ## a merging of two clusters) oussa <- unlist(lapply(1:length(liclu), function(o) r1%in%liclu[[o]])) + + ## If it is a merging of two clusters if (any(oussa)) { + ## we merge the two sets of relocations liclu[[which(oussa)]] <- liclu[[which(oussa)]][-c(which(liclu[[which(oussa)]]%in%relocj))] } + + ## update liclu according to the new cluster liclu[clust[step==j][1]] <- list(c(unlist(liclu[clust[step==j][1]]), relocj)) + ## computes the convex polygons around all current clusters kkk <- lapply(1:length(liclu), function(m) { k <- liclu[[m]] xy2 <- x[[i]]$xy[k,] @@ -119,13 +171,25 @@ plot.clusthr <- function(x, whi = names(x), pch = 21, attr(pol,"nlocs") <- nrow(xy2) return(pol) }) + + ## Computes the number of relocations already clustered nlocc <- sum(unlist(lapply(kkk, function(w) attr(w,"nlocs")))) + + ## creates an object of class area with the polygons + ## described above pol2 <- do.call("rbind", kkk) pol2[,1] <- factor(pol2[,1]) class(pol2) <- c("area", "data.frame") attr(pol2, "nlocs") <- nlocc + + ## the home range is stored in poltot poltot[j] <- list(pol2) } + + ## In case of relocations located at the same place, + ## the home range does not change. + ## We delete the repetitions of the same home range + ## and store the results in poltot2 poltot2 <- list() poltot2[[1]] <- poltot[[1]] k <- 2 @@ -136,7 +200,10 @@ plot.clusthr <- function(x, whi = names(x), pch = 21, } } + ## And plots the result if (plotit) { + + ## The color of the polygons if (!is.na(colpol)) { foncol <- get(colpol, pos=".GlobalEnv") if (colpol=="grey") { @@ -147,14 +214,20 @@ plot.clusthr <- function(x, whi = names(x), pch = 21, } else { colp <- NA } + + ## plots the polygons and the points lapply(length(poltot2):1, function(h) { ii <- poltot2[[h]] lapply(split(ii[,2:3], ii[,1]), function(u) polygon(u, col=colp[h],border="black")) }) points(x[[i]]$xy, pch= pch, bg = bgpts, col = colpts, cex=cex) } + + ## returns the home ranges return(poltot2) }) + + ## The function returns the home ranges invisible(restep) } @@ -163,21 +236,35 @@ plot.clusthr <- function(x, whi = names(x), pch = 21, clusthr.area <- function(x, percent = seq(20, 100, by = 5), - unin = c("m", "km"), unout = c("ha", "km2", "m2"), - plotit=TRUE) + unin = c("m", "km"), unout = c("ha", "km2", "m2"), + plotit=TRUE) { + ## Verifications if (!inherits(x, "clusthr")) stop("x should be of class \"clusthr\"") + if (!require(gpclib)) + stop("package gpclib required") unin <- match.arg(unin) unout <- match.arg(unout) + + ## graphical settings if (plotit) { opar <- par(mfrow=n2mfrow(length(x))) on.exit(par(opar)) } + + ## Computes the home range u <- plot(x, plotit=FALSE) + + ## for each animal li <- lapply(1:length(u), function(d) { + + ## gets the home range o <- u[[d]] + ## number of relocs nlo <- unlist(lapply(o, function(y) attr(y, "nlocs"))) + + ## computes the area of the polygons ou <- unlist(lapply(o, function(y) { lib <- split(y[,2:3], y[,1]) ji <- sum(unlist(lapply(lib, function(r) { @@ -189,6 +276,8 @@ clusthr.area <- function(x, percent = seq(20, 100, by = 5), }))) return(ji) })) + + ## Depending on the ooutput units, change if (unin == "m") { if (unout == "ha") ou <- ou/10000 @@ -202,8 +291,12 @@ clusthr.area <- function(x, percent = seq(20, 100, by = 5), ou <- ou * 1e+06 } + ## percentage of relocations included in the home range nlo <- 100 * nlo/nrow(x[[d]]$xy) rere <- data.frame(nlo,ou) + + ## finds the home range containing the percentage + ## of relocations the closest to the specified percent if (!is.null(percent)) { rere <- unlist(lapply(percent, function(e) { if (any(nlo1e-16) { return(rbind(x, x[1,])) }})) + + ## The attributes of the shapefile (ID of the polygons and + ## names of the animals to identify the home ranges Idatt <- c(Idatt, (nlo+1):(nlo+length(unique(kv[[i]][,1])))) Names <- c(Names, rep(names(kv)[i], length(unique(kv[[i]][,1])))) + + ## update nlo nlo <- nlo+length(unique(kv[[i]][,1])) } + + ## Output shp <- do.call("rbind", kv) names(shp) <- c("Id","X","Y") att <- data.frame(Id=Idatt, Names=Names) diff --git a/R/colasc.r b/R/colasc.r index 64f9266..e2caacc 100755 --- a/R/colasc.r +++ b/R/colasc.r @@ -1,21 +1,30 @@ -"colasc" <- -function(x, ...) +"colasc" <- function(x, ...) { - if (!inherits(x, "asc")) - stop("Should be an \"asc\" object") - l<-list(...) - n<-names(l) - i<-NA - tc<-levels(x) - for (i in n) { - if (!any(tc==i)) - stop(paste(i, "is not a valid level of the factors")) - } - coul<-0 - for (i in 1:length(tc)) { - u<-tc[i] - coul[i]<-l[[u]] - } - return(coul) + ## Verifications + if (!inherits(x, "asc")) + stop("Should be an \"asc\" object") + + ## the list of colors with levels of maps + l<-list(...) + n<-names(l) + i<-NA + + ## levels of the map + tc<-levels(x) + + ## Verifications that the names of "..." correspond to the + ## levels of x + for (i in n) { + if (!any(tc==i)) + stop(paste(i, "is not a valid level of the factors")) + } + + ## creates the vector of colors + coul<-0 + for (i in 1:length(tc)) { + u<-tc[i] + coul[i]<-l[[u]] + } + return(coul) } diff --git a/R/compana.r b/R/compana.r index 084e89b..72850cb 100755 --- a/R/compana.r +++ b/R/compana.r @@ -1,8 +1,7 @@ -"compana" <- -function(used, avail, test = c("randomisation", "parametric"), - rnv = 0.01, nrep = 500, alpha=0.1) +"compana" <- function(used, avail, test = c("randomisation", "parametric"), + rnv = 0.01, nrep = 500, alpha=0.1) { - ### 1. Vérifications + ### 1. Verifications test<-match.arg(test) used<-as.matrix(used) avail<-as.matrix(avail) @@ -16,9 +15,9 @@ function(used, avail, test = c("randomisation", "parametric"), stop("the two matrices should have the same dimensions") if (!all(colnames(used)==colnames(avail))) stop("the two matrices should have the same habitat names") - if (is.null(colnames(used))) + if (is.null(colnames(used))) colnames(used) <- paste("Habitat", 1:ncol(u), sep = "") - if (is.null(colnames(avail))) + if (is.null(colnames(avail))) colnames(avail) <- paste("Habitat", 1:ncol(a), sep = "") ## 2. Bases @@ -30,97 +29,121 @@ function(used, avail, test = c("randomisation", "parametric"), nrep=1 sorties<-list() - ## 3. Première partie: test global + ## 3. First part: global test + ## relies on a call to the C function "aclamda" toto<-.C("aclambda", as.double(t(used)), as.double(t(avail)), - as.integer(na), as.integer(nh), + as.integer(na), as.integer(nh), as.double(proj1), as.double(proj2), as.double(rnv), double(nrep), as.integer(nrep), double(nh), double(nh), PACKAGE="adehabitat") - + + ## output vrand<-toto[[8]] sorties$used<-used sorties$avail<-avail sorties$type.test<-test if (test=="randomisation") { - sorties$random.res<-list(sim=vrand, obs=vrand[1]) - sorties$test<-c(vrand[1], length(vrand[vrand<=vrand[1]])/nrep) - names(sorties$test)<-c("Lambda", "P") + sorties$random.res<-list(sim=vrand, obs=vrand[1]) + sorties$test<-c(vrand[1], length(vrand[vrand<=vrand[1]])/nrep) + names(sorties$test)<-c("Lambda", "P") } else { - sorties$test<-c(vrand[1], ncol(used)-1, 1-pchisq(-na*log(vrand[1]), ncol(used)-1)) - names(sorties$test)<-c("Lambda", "df", "P") + sorties$test<-c(vrand[1], ncol(used)-1, + 1-pchisq(-na*log(vrand[1]), ncol(used)-1)) + names(sorties$test)<-c("Lambda", "df", "P") } - - ## Deuxième partie: ranking matrix + + + ## 4. Second part: ranking matrix for habitat types if (test=="randomisation") { - toto<-.C("rankma", as.double(t(used)), as.double(t(avail)), - double(nh**2), double(nh**2), double(nh**2), - double(nh**2), as.integer(nh), as.integer(na), - as.integer(nrep), as.double(rnv), PACKAGE="adehabitat") - - rmp<-t(matrix(toto[[3]]/nrep, nh, nh)) - rmm<-t(matrix(toto[[4]]/nrep, nh, nh)) - rmv<-t(matrix(toto[[5]], nh, nh)) - rmnb<-t(matrix(toto[[6]], nh, nh)) + + ## 4.1 For randomization tests: + ## relies on a call to the C function "rankma" + toto<-.C("rankma", as.double(t(used)), as.double(t(avail)), + double(nh**2), double(nh**2), double(nh**2), + double(nh**2), as.integer(nh), as.integer(na), + as.integer(nrep), as.double(rnv), PACKAGE="adehabitat") + + rmp<-t(matrix(toto[[3]]/nrep, nh, nh)) + rmm<-t(matrix(toto[[4]]/nrep, nh, nh)) + rmv<-t(matrix(toto[[5]], nh, nh)) + rmnb<-t(matrix(toto[[6]], nh, nh)) } else { - used[used==0]<-rnv - rmv<-matrix(0, nh, nh) - rmse<-matrix(0, nh, nh) - rmm<-matrix(0, nh, nh) - rmp<-matrix(0, nh, nh) - rmnb<-matrix(0, nh, nh) - - for (i in 1:nh) { - for (j in 1:nh) { - dlr<-log(used[,i]/used[,j])-log(avail[,i]/avail[,j]) - rmv[i,j]<-mean(dlr) - rmse[i,j]<-sqrt(var(dlr)/na) - if (i!=j) - rmv[i,j]<-rmv[i,j]/rmse[i,j] - rmp[i,j]<-pt(rmv[i,j], na-1) - rmm[i,j]<-1-rmp[i,j] - rmnb[i,j]<-na + ## 4.2 For parametric tests: + + ## 4.2.1 output matrices + used[used==0]<-rnv + rmv<-matrix(0, nh, nh) + rmse<-matrix(0, nh, nh) + rmm<-matrix(0, nh, nh) + rmp<-matrix(0, nh, nh) + rmnb<-matrix(0, nh, nh) + + + for (i in 1:nh) { + for (j in 1:nh) { + + ## The matrix of the difference of log ratios + dlr<-log(used[,i]/used[,j])-log(avail[,i]/avail[,j]) + + ## mean DLR + rmv[i,j]<-mean(dlr) + + ## standard deviations + rmse[i,j]<-sqrt(var(dlr)/na) + + ## t-test statistic + if (i!=j) + rmv[i,j]<-rmv[i,j]/rmse[i,j] + + ## P-values + rmp[i,j]<-pt(rmv[i,j], na-1) + rmm[i,j]<-1-rmp[i,j] + rmnb[i,j]<-na + } } - } } - + + ## preparation of the ranking matrix rm<-matrix("0", nh, nh) - - ## ranking matrix: juste les signes + + ## ranking matrix: keeps only the signs of the mean DLR for (i in 1:nh) { - for (j in 1:nh) { - if (rmv[i,j]<0) - rm[i,j]<-"-" - if (rmv[i,j]>0) - rm[i,j]<-"+" - } + for (j in 1:nh) { + if (rmv[i,j]<0) + rm[i,j]<-"-" + if (rmv[i,j]>0) + rm[i,j]<-"+" + } } + ## adds the significance to the tests for (i in 1:nh) { - for (j in 1:nh) { - if (rmp[i,j] < (alpha/2)) { - rm[i,j]<-"---" - } - if (rmm[i,j] < (alpha/2)) { - rm[i,j]<-"+++" + for (j in 1:nh) { + if (rmp[i,j] < (alpha/2)) { + rm[i,j]<-"---" + } + if (rmm[i,j] < (alpha/2)) { + rm[i,j]<-"+++" + } + if (i==j) + rm[i,j]<-"0" } - if (i==j) - rm[i,j]<-"0" - } } - + ## Computes the ranks of habitat types (number of DLR >0) rank<-rep(0, nh) for (j in 1:nh) { - for (i in 1:nh) { - if (rmv[j,i]>0) - rank[j]<-rank[j]+1 - } + for (i in 1:nh) { + if (rmv[j,i]>0) + rank[j]<-rank[j]+1 + } } - + + ## row and column names for the various matrices names(rank)<-colnames(avail) rownames(rm)<-colnames(avail) colnames(rm)<-colnames(avail) @@ -132,11 +155,13 @@ function(used, avail, test = c("randomisation", "parametric"), colnames(rmm)<-colnames(avail) rownames(rmnb)<-colnames(avail) colnames(rmnb)<-colnames(avail) + + ## output sorties$rmnb<-rmnb sorties$rank<-rank sorties$rm<-rm sorties$rmv<-rmv - + sorties$profile<-profilehab(rm, rank) class(sorties)<-"compana" return(sorties) diff --git a/R/contour.asc.r b/R/contour.asc.r index e9aa4d8..5f903ae 100755 --- a/R/contour.asc.r +++ b/R/contour.asc.r @@ -1,13 +1,15 @@ -"contour.asc" <- -function(x, ...) +"contour.asc" <- function(x, ...) { - if (!inherits(x, "asc")) stop("not an \"asc\" object") - if (attr(x, "type")=="factor") - stop("function contour cannot be used with factors") - z<-x - xy<-getXYcoords(z) - x<-xy$x - y<-xy$y - contour(x=x, y=y, z, ...) + ## Verifications + if (!inherits(x, "asc")) stop("not an \"asc\" object") + if (attr(x, "type")=="factor") + stop("function contour cannot be used with factors") + + ## Use of the function contour + z<-x + xy<-getXYcoords(z) + x<-xy$x + y<-xy$y + contour(x=x, y=y, z, ...) } diff --git a/R/convnum.r b/R/convnum.r index d0bd7cd..41fb0bd 100755 --- a/R/convnum.r +++ b/R/convnum.r @@ -1,13 +1,21 @@ -"convnum" <- -function(kasc) { - if (!inherits(kasc, "kasc")) - stop("should be of class kasc") - litab<-kasc2df(kasc) - dud<-dudi.mix(litab$tab, scannf=FALSE) - toto <- dud$tab - names(toto) - cw<-dud$cw - scores <- df2kasc(toto, litab$index, kasc) - return(list(kasc=scores, weight=cw)) +"convnum" <- function(kasc) +{ + ## Verifications + if (!inherits(kasc, "kasc")) + stop("should be of class kasc") + + ## converts as df + litab<-kasc2df(kasc) + ## performs a dudi.mix + dud<-dudi.mix(litab$tab, scannf=FALSE) + + ## converts the resulting table as kasc + toto <- dud$tab + names(toto) + cw<-dud$cw + scores <- df2kasc(toto, litab$index, kasc) + + ## output + return(list(kasc=scores, weight=cw)) } diff --git a/R/count.points.id.r b/R/count.points.id.r index c506012..e546c3d 100755 --- a/R/count.points.id.r +++ b/R/count.points.id.r @@ -1,15 +1,24 @@ -"count.points.id" <- -function(xy, id, w) - { +"count.points.id" <- function(xy, id, w) +{ + ## Verifications + if (ncol(xy)!=2) + stop("xy should have 2 columns") + if (length(id) != nrow(xy)) + stop("id should be of the same length as xy") + + ## Prepares the data x<-xy[,1] y<-xy[,2] id<-factor(id) lx<-split(x, id) ly<-split(y, id) output<-list() - for (i in 1:length(levels(id))) - output[[levels(id)[i]]]<-count.points(cbind(lx[[i]], ly[[i]]), w) + ## Use of the function count.points for each animal + for (i in 1:length(levels(id))) + output[[levels(id)[i]]]<-count.points(cbind(lx[[i]], ly[[i]]), w) + + ## output output<-as.kasc(output) - } +} diff --git a/R/count.points.r b/R/count.points.r index ac36dc8..6f43d3e 100755 --- a/R/count.points.r +++ b/R/count.points.r @@ -1,34 +1,33 @@ -"count.points" <- -function(xy, w) +"count.points" <- function(xy, w) { - if (inherits(w, "asc")) - w<-as.kasc(list(toto=w)) - if (inherits(w, "kasc")) - w<-storemapattr(w) - if (!inherits(w, "mapattr")) - stop("non convenient format for w") + ## Verifications + if (inherits(w, "asc")) + w<-as.kasc(list(toto=w)) + if (inherits(w, "kasc")) + w<-storemapattr(w) + if (!inherits(w, "mapattr")) + stop("non convenient format for w") + ## Prepares a vector containing the boundaries of the pixels + xyc<-getXYcoords(w) + xc<-xyc$x-attr(w, "cellsize")/2 + yc<-xyc$y-attr(w, "cellsize")/2 + xc<-c(xc, max(xc)+attr(w, "cellsize")) + yc<-c(yc, max(yc)+attr(w, "cellsize")) - xyc<-getXYcoords(w) - xc<-xyc$x-attr(w, "cellsize")/2 - yc<-xyc$y-attr(w, "cellsize")/2 - xc<-c(xc, max(xc)+attr(w, "cellsize")) - yc<-c(yc, max(yc)+attr(w, "cellsize")) - x<-xy[,1] - y<-xy[,2] + ## discretize the points according to these classes + x<-xy[,1] + y<-xy[,2] + x<-cut(x, xc) + y<-cut(y, yc) - x<-cut(x, xc) - y<-cut(y, yc) - output<-as.matrix(table(x, y)) - if (inherits(x, "kasc")) { - attr(output, "nrow")<-attr(w, "nrow") - attr(output, "ncol")<-attr(w, "ncol") - } - attr(output, "xll")<-attr(w, "xll") - attr(output, "yll")<-attr(w, "yll") - attr(output, "cellsize")<-attr(w, "cellsize") - attr(output, "type")<-"numeric" - class(output)<-"asc" - return(output) + ## Transform into an object of class "asc" + output<-as.matrix(table(x, y)) + attr(output, "xll")<-attr(w, "xll") + attr(output, "yll")<-attr(w, "yll") + attr(output, "cellsize")<-attr(w, "cellsize") + attr(output, "type")<-"numeric" + class(output)<-"asc" + return(output) } diff --git a/R/data2enfa.r b/R/data2enfa.r index 336cfa1..0929a63 100755 --- a/R/data2enfa.r +++ b/R/data2enfa.r @@ -1,18 +1,22 @@ -"data2enfa" <- -function (kasc, pts) +"data2enfa" <- function (kasc, pts) { - if (!inherits(kasc, "kasc")) + ## Verifications + if (!inherits(kasc, "kasc")) stop("should be an object of class \"kasc\"") - if (ncol(pts) != 2) + if (ncol(pts) != 2) stop("pts should have 2 columns") + + ## prepares the output attr <- storemapattr(kasc) tab <- kasc2df(kasc) index <- tab$index tab <- tab$tab pr <- as.vector(count.points(pts, kasc))[index] - dataenfa <- list(tab = data.frame(tab), pr = pr, + dataenfa <- list(tab = data.frame(tab), pr = pr, index = index, attr = attr) class(dataenfa) <- "dataenfa" + + ## output return(invisible(dataenfa)) } diff --git a/R/df2kasc.r b/R/df2kasc.r index 1a09e2a..4baaefe 100755 --- a/R/df2kasc.r +++ b/R/df2kasc.r @@ -1,30 +1,41 @@ -"df2kasc" <- -function(df, index, x) +"df2kasc" <- function(df, index, x) { - if (!inherits(df,"data.frame")) stop("non convenient data type") - if ((!inherits(x,"kasc"))&(!inherits(x,"mapattr"))) - stop("non convenient data type") - - o<-x - class(o)<-"data.frame" - N<-attr(o, "nrow")*attr(o, "ncol") - indw<-c(1:N) - li<-df - n1<-nrow(li) - - compl<-as.data.frame(matrix(NA, nrow=N-n1, ncol=ncol(li))) - names(compl) <- names(li) - output<-rbind.data.frame(li, compl) - indcompl<-indw[is.na(match(indw, index))] - indtot<-c(index, indcompl) - output<-output[sort(indtot, index.return=TRUE)$ix,] - class(output)<-c("kasc","data.frame") - attr(output, "nrow")<-attr(x, "nrow") - attr(output, "ncol")<-attr(x, "ncol") - attr(output, "xll")<-attr(x, "xll") - attr(output, "yll")<-attr(x, "yll") - attr(output, "cellsize")<-attr(x, "cellsize") - - return(output) + ## Verifications + if (!inherits(df,"data.frame")) stop("non convenient data type") + if ((!inherits(x,"kasc"))&(!inherits(x,"mapattr"))) + stop("non convenient data type") + + ## prepare the data + class(x)<-"data.frame" + N<-attr(x, "nrow")*attr(x, "ncol") + indw<-c(1:N) ## a vector of the indices of the rows of the output kasc + n1<-nrow(df) + + ## The missing values to be inserted ("compl"ementary) + compl<-as.data.frame(matrix(NA, nrow=N-n1, ncol=ncol(df))) + names(compl) <- names(df) + + ## we bind these NA to the DF + output<-rbind.data.frame(df, compl) + + ## The indices of the pixels with NA in the output kasc + indcompl<-indw[is.na(match(indw, index))] + + ## concatenate the vectors of indices of the pixels with values (index) + ## and the vectors of indices of the pixels with NAs (indcompl) + indtot<-c(index, indcompl) + + ## sort the table according to this resulting vector + output<-output[sort(indtot, index.return=TRUE)$ix,] + + ## Output + class(output)<-c("kasc","data.frame") + attr(output, "nrow")<-attr(x, "nrow") + attr(output, "ncol")<-attr(x, "ncol") + attr(output, "xll")<-attr(x, "xll") + attr(output, "yll")<-attr(x, "yll") + attr(output, "cellsize")<-attr(x, "cellsize") + + return(output) } diff --git a/R/df2traj.r b/R/df2traj.r index 58e431f..e4ac995 100755 --- a/R/df2traj.r +++ b/R/df2traj.r @@ -1,31 +1,33 @@ -"df2traj" <- -function(df) { - x<-df - if (!inherits(x, "data.frame")) - stop("x should be of class data.frame") +"df2traj" <- function(df) +{ + ## Verifications + x<-df + if (!inherits(x, "data.frame")) + stop("x should be of class data.frame") - ## vérification du format: - ok<-1 - if (is.null(x$id)) - ok<-0 - if (is.null(x$x)) - ok<-0 - if (is.null(x$y)) - ok<-0 - if (is.null(x$date)) - ok<-0 - if (is.null(x$burst)) - ok<-0 - if (!inherits(x$date, "POSIXct")) - ok<-0 - if (!is.factor(x$id)) - ok<-0 - if (!is.factor(x$burst)) - ok<-0 + ## Verification of the format: + ok<-1 + if (is.null(x$id)) + ok<-0 + if (is.null(x$x)) + ok<-0 + if (is.null(x$y)) + ok<-0 + if (is.null(x$date)) + ok<-0 + if (is.null(x$burst)) + ok<-0 + if (!inherits(x$date, "POSIXct")) + ok<-0 + if (!is.factor(x$id)) + ok<-0 + if (!is.factor(x$burst)) + ok<-0 - if (ok == 0) - stop("non convenient format.\n please create the object with the function as.traj") - class(x)<-c("traj", "data.frame") - return(x) + ## Output + if (ok == 0) + stop("non convenient format.\n please create the object with the function as.traj") + class(x)<-c("traj", "data.frame") + return(x) } diff --git a/R/distfacmap.r b/R/distfacmap.r index 661ab55..128e244 100755 --- a/R/distfacmap.r +++ b/R/distfacmap.r @@ -1,33 +1,45 @@ -"distfacmap" <- -function(x) - { +"distfacmap" <- function(x) +{ + ## Verifications if (!inherits(x, "asc")) - stop("x should be of class \"asc\"") + stop("x should be of class \"asc\"") if (attr(x, "type")!="factor") - stop("x should be of type \"factor\"") + stop("x should be of type \"factor\"") + + ## Bases for the function xyc <- getXYcoords(x) xc <- rep(xyc$x, times=length(xyc$y)) yc <- rep(xyc$y, each=length(xyc$x)) xyc<-data.frame(x=xc,y=yc) lev <- as.numeric(levels(factor(c(x)))) li <- list() - + + ## For each level of the map: for (i in lev) { - tmp <- x - tmp[x!=i] <- NA - tmp[x==i] <- 1 - ptsoui <- xyc[!is.na(c(tmp)),] - toto <- .C("distxyr", as.double(t(as.matrix(xyc))), - as.double(t(as.matrix(ptsoui))), - as.integer(nrow(xyc)), as.integer(nrow(ptsoui)), - double(nrow(xyc)), PACKAGE="adehabitat") - li[[i]] <- toto[[5]] + + ## keeps only the coordinates of the pixels + ## corresponding to this level + tmp <- x + tmp[x!=i] <- NA + tmp[x==i] <- 1 + ptsoui <- xyc[!is.na(c(tmp)),] + + ## these objects are passed to a call to the C function "distxyr", + ## which computes the distance of each pixel to the nearest pixel + ## for which the level is i + toto <- .C("distxyr", as.double(t(as.matrix(xyc))), + as.double(t(as.matrix(ptsoui))), + as.integer(nrow(xyc)), as.integer(nrow(ptsoui)), + double(nrow(xyc)), PACKAGE="adehabitat") + li[[i]] <- toto[[5]] } + + ## output as a kasc object names(li) <- levels(x) ka <- as.kasc(list(x1=x)) li <- as.data.frame(li) li <- getkascattr(ka,li) li <- setmask(li, x) return(li) - } +} diff --git a/R/domain.r b/R/domain.r index 92ce06f..71b6412 100755 --- a/R/domain.r +++ b/R/domain.r @@ -1,15 +1,15 @@ "domain" <- function(kasc, pts, type=c("value", "potential"), thresh=0.95) - { - ## Vérifications +{ + ## Verifications if (!inherits(kasc, "kasc")) - stop("should be an object of class \"kasc\"") + stop("should be an object of class \"kasc\"") if (ncol(pts)!=2) - stop("pts should have 2 columns") + stop("pts should have 2 columns") typ<-"" for (i in 1:length(kasc)) { - if (is.factor(kasc[[i]])) { + if (is.factor(kasc[[i]])) { typ[i] <- "factor" } else { @@ -17,28 +17,29 @@ function(kasc, pts, type=c("value", "potential"), } } if (!all(typ=="numeric")) - stop("All variables in kasc should be of mode numeric") + stop("All variables in kasc should be of mode numeric") type<-match.arg(type) - ## Préparation des données pour passage à - ## La fonction C - ## 1. jointure spatiale des points + ## Preparation of the data to be passed to the C function "fctdomain" + ## 1. spatial join of the points ptsmod<-as.matrix(join.kasc(pts, kasc)) - ## 2. suppression des valeurs manquantes + + ## 2. deletes the missing values kasct<-kasc2df(kasc) kascmod<-as.matrix(kasct$tab) if (any(is.na(kascmod))) - stop("the same area should be provided for all variables") - ## 3. Calcul du range + stop("the same area should be provided for all variables") + + ## 3. Computation of the range of environmental variables rg<-apply(kascmod, 2, function(x) range(x)[2] - range(x)[1]) - ## Fonction C + ## Call to the C function toto<-.C("fctdomain", as.double(t(kascmod)), as.double(t(ptsmod)), as.double(rg), as.integer(nrow(ptsmod)), as.integer(nrow(kascmod)), as.integer(ncol(ptsmod)), double(nrow(kascmod)), PACKAGE="adehabitat")[[7]] - ## Transfo du vecteur de sortie en Carte + ## Transfo of the output vector into a map (equivalent to df2kasc) N <- nrow(kasc) indw <- c(1:N) n1 <- length(toto) @@ -49,17 +50,18 @@ function(kasc, pts, type=c("value", "potential"), output <- output[sort(indtot, index.return = TRUE)$ix] output<-matrix(output, attr(kasc,"ncol")) - ## Seuil ou carte ? + ## Should the value or the potential habitat be exported in the output ? if (type!="value") { - output[output<=thresh]<-NA - output[output>thresh]<-1 + output[output<=thresh]<-NA + output[output>thresh]<-1 } - + + ## Output attr(output, "xll") <- attr(kasc, "xll") attr(output, "yll") <- attr(kasc, "yll") attr(output, "cellsize") <- attr(kasc, "cellsize") attr(output, "type") <- "numeric" class(output)<-"asc" return(output) - } +} diff --git a/R/eisera.r b/R/eisera.r index c7db069..de7ea74 100755 --- a/R/eisera.r +++ b/R/eisera.r @@ -1,27 +1,47 @@ eisera <- function(used, available, scannf = TRUE, nf = 2) - { +{ + ## Verifications if (!all(dim(used)==dim(available))) - stop("used and available should have the same dimension") + stop("used and available should have the same dimension") ut <- as.matrix(used) av <- as.matrix(available) + + ## Computation of the table of selection ratios av <- av/apply(av,1,sum) wij <- ut/apply(ut,1,sum)/av - 1 + + ## If 0 availability, therefore wij = 0 wij[av<1e-07] <- 0 + + ## the table to be analysed mT <- sqrt(av)*wij + ## row weights D <- apply(ut,1,sum) + + ## The eigenanalysis of selection ratios o <- as.dudi(as.data.frame(mT), rep(1,ncol(ut)), D, scannf, nf, call=match.call(), type="esr") + + ## Output + + ## Scores of the habitat types uuu <- wij uuv <- apply(uuu,2,function(x) x*o$lw) o$co <- t(as.matrix(uuv))%*%as.matrix(o$l1) o$c1 <- NULL + + ## original tables o$available <- as.data.frame(av) o$used <- as.data.frame(ut) + + ## selection ratios o$wij <- ut/apply(ut,1,sum)/av + return(o) } + print.esr <- function (x, ...) { cat("Factorial analysis of selection ratios\n") @@ -33,10 +53,10 @@ print.esr <- function (x, ...) cat("\neigen values: ") l0 <- length(x$eig) cat(signif(x$eig, 4)[1:(min(5, l0))]) - if (l0 > 5) + if (l0 > 5) cat(" ...\n") else cat("\n") - sumry <- array("", c(3, 4), list(1:3, c("vector", "length", + sumry <- array("", c(3, 4), list(1:3, c("vector", "length", "mode", "content"))) sumry[1, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights") sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights") @@ -44,34 +64,37 @@ print.esr <- function (x, ...) class(sumry) <- "table" print(sumry) cat("\n") - sumry <- array("", c(6, 4), list(1:6, c("data.frame", "nrow", + sumry <- array("", c(6, 4), list(1:6, c("data.frame", "nrow", "ncol", "content"))) sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array") sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates") sumry[3, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates") - sumry[4, ] <- c("$available", nrow(x$available), ncol(x$available), + sumry[4, ] <- c("$available", nrow(x$available), ncol(x$available), "available proportions") sumry[5, ] <- c("$used", nrow(x$used), ncol(x$used), "number of relocations") sumry[6, ] <- c("$wij", nrow(x$used), ncol(x$used), "selection ratios") - + class(sumry) <- "table" print(sumry) } + + scatter.esr <- function(x, xax = 1, yax = 2, csub = 1, possub = "bottomleft", ...) { - if (!inherits(x, "esr")) - stop("x should be of class \"esr\"") - - opar <- par(mfrow=c(2,1), mar=c(0,0,0,0)) - s.label(x$co, xax = xax, yax = yax, ...) - if (csub > 0) - scatterutil.sub("Habitat types", csub, possub) - s.arrow(x$li, xax = xax, yax = yax, ...) - if (csub > 0) - scatterutil.sub("Animals", csub, possub) - par(opar) + ## Verifications + if (!inherits(x, "esr")) + stop("x should be of class \"esr\"") + + opar <- par(mfrow=c(2,1), mar=c(0,0,0,0)) + s.label(x$co, xax = xax, yax = yax, ...) + if (csub > 0) + scatterutil.sub("Habitat types", csub, possub) + s.arrow(x$li, xax = xax, yax = yax, ...) + if (csub > 0) + scatterutil.sub("Animals", csub, possub) + par(opar) } diff --git a/R/enfa.r b/R/enfa.r index 4c157ce..a6d2ba5 100755 --- a/R/enfa.r +++ b/R/enfa.r @@ -2,7 +2,7 @@ ####################################################################### ####### ###### ####### ###### -####### ENFA généralisée ###### +####### Generalized ENFA ###### ####### ###### ####### ###### ####################################################################### @@ -11,6 +11,7 @@ enfa <- function(dudi, pr, scannf = TRUE, nf = 1) { + ## Verifications if (!inherits(dudi, "dudi")) stop("object of class dudi expected") call <- match.call() @@ -19,7 +20,7 @@ enfa <- function(dudi, pr, scannf = TRUE, nf = 1) if (!is.vector(pr)) stop("pr should be a vector") - ## Les "ingrédients" de l'analyse + ## Bases of the function prb <- pr pr <- pr/sum(pr) row.w <- dudi$lw/sum(dudi$lw) @@ -31,56 +32,63 @@ enfa <- function(dudi, pr, scannf = TRUE, nf = 1) Z <- sweep(Z, 2, center) - ## Passage à l'espace étoilé + ## multiply with the square root of the column weights Ze <- sweep(Z, 2, sqrt(col.w), "*") - ## Calcul des matrices d'inertie S et G + ## Inertia matrices S and G DpZ <- apply(Ze, 2, function(x) x*pr) - ## Calcul de la marginalité + ## Marginality computation mar <- apply(Z,2,function(x) sum(x*pr)) me <- mar*sqrt(col.w) Se <- crossprod(Ze, DpZ) Ge <- crossprod(Ze, apply(Ze,2,function(x) x*row.w)) - - ## Calcul de S^(-1/2) + ## Computation of S^(-1/2) eS <- eigen(Se) S12 <- eS$vectors %*% diag(eS$values^(-0.5)) %*% t(eS$vectors) - ## Passage au pb 3 + ## Passage to the third problem W <- S12 %*% Ge %*% S12 x <- S12%*%me b <- x / sqrt(sum(x^2)) + ## Eigenstructure of H H <- (diag(ncol(Ze)) - b%*%t(b)) %*% W %*% (diag(ncol(Ze)) - b%*%t(b)) s <- eigen(H)$values[-ncol(Z)] + ## Number of eigenvalues if (scannf) { barplot(s) cat("Select the number of specialization axes: ") nf <- as.integer(readLines(n = 1)) } - if (nf <= 0 | nf > (ncol(Ze) - 1)) nf <- 1 + ## coordinates of the columns on the specialization axes co <- matrix(nrow = ncol(Z), ncol = nf + 1) tt <- data.frame((S12 %*% eigen(H)$vectors)[, 1:nf]) ww <- apply(tt, 2, function(x) x/sqrt(col.w)) norw <- sqrt(diag(t(as.matrix(tt))%*%as.matrix(tt))) co[, 2:(nf + 1)] <- sweep(ww, 2, norw, "/") + + ## coordinates of the columns on the marginality axis m <- me/sqrt(col.w) co[, 1] <- m/sqrt(sum(m^2)) + + ## marginality m <- sum(m^2) + ## Coordinates of the rows on these axes li <- Z %*% apply(co, 2, function(x) x*col.w) + + ## Output co <- as.data.frame(co) li <- as.data.frame(li) names(co) <- c("Mar", paste("Spe", (1:nf), sep = "")) row.names(co) <- dimnames(dudi$tab)[[2]] names(li) <- c("Mar", paste("Spe", (1:nf), sep = "")) - enfa <- list(call = call, tab = data.frame(Z), pr = prb, cw = col.w, nf = nf, m = m, s = s, lw = row.w, li = li, co = co, mar = mar) diff --git a/R/explore.kasc.r b/R/explore.kasc.r index ec12d3c..49f20fb 100644 --- a/R/explore.kasc.r +++ b/R/explore.kasc.r @@ -4,7 +4,9 @@ explore.kasc <- function (ka, coltxt="blue", if (!inherits(ka,"kasc")) stop("ka should be of class kasc") nn <<- NULL - whi <<- 1 + whi <<- 1 ## current graph + + ## function replot: to replot the content of the object replot <- function() { if (lim) { xlim <- range(getXYcoords(ka)$x) @@ -21,24 +23,25 @@ explore.kasc <- function (ka, coltxt="blue", opar <- par(mar=c(0,0,2,0)) image(getkasc(ka,i), main=i, axes=F, xlim=xlim, ylim=ylim) if (ajoupo) { - text(a5[1], a5[2], ka[ia5,i], col=coltxt, font=2, cex=1.15) - } + text(a5[1], a5[2], ka[ia5,i], col=coltxt, font=2, cex=1.15) + } + box() + par(opar) + }) + screen(1) + opar <- par(mar=c(0,0,2,0)) + image(getkasc(ka,whi), main=na[whi], axes=FALSE, + xlim=xlim, ylim=ylim) + cusr <<- par("usr") + cplt <<- par("plt") + if (ajouli) + lines(c(a1[1], a2[1]), c(a1[2], a2[2]), lwd = 2, + col = "red") box() par(opar) - }) - screen(1) - opar <- par(mar=c(0,0,2,0)) - image(getkasc(ka,whi), main=na[whi], axes=FALSE, - xlim=xlim, ylim=ylim) - cusr <<- par("usr") - cplt <<- par("plt") - if (ajouli) - lines(c(a1[1], a2[1]), c(a1[2], a2[2]), lwd = 2, - col = "red") - box() - par(opar) } + N <- length(ka) D <- 0 xlim <- range(getXYcoords(ka)$x) diff --git a/R/export.asc.r b/R/export.asc.r index e7d15fa..1921ae0 100755 --- a/R/export.asc.r +++ b/R/export.asc.r @@ -1,13 +1,11 @@ -"export.asc" <- -function(x, file) - { - - if (!inherits(x, "asc")) stop("Non convenient data") - -### File header reading +"export.asc" <- function(x, file) +{ + ## verifications + if (!inherits(x, "asc")) stop("Non convenient data") if (substr(file, nchar(file)-3, nchar(file))!=".asc") - file<-paste(file, ".asc", sep="") - + file<-paste(file, ".asc", sep="") + + ## Creates the file header file.create(file) zz<-file(file, "w") nc<-paste("ncols", " ", nrow(x), sep="") @@ -19,6 +17,7 @@ function(x, file) cs<-paste("cellsize", " ", attr(x, "cellsize"), sep="") nas<-paste("NODATA_value", -9999, sep=" ") + ## write to the file writeLines(nc, zz) writeLines(nl, zz) writeLines(xll, zz) @@ -26,14 +25,19 @@ function(x, file) writeLines(cs, zz) writeLines(nas, zz) - close(zz) + close(zz) ## close the connection + + + ## replace the missing values, adds newlines at the end + ## of the rows OF THE MAP (so column of the matrix) x[is.na(x)]<--9999 x<-x[,ncol(x):1] x<-rbind(x, rep("\n", ncol(x))) + ## ... and sinks to the file sink(file, append=TRUE) cat(x) sink() - + } diff --git a/R/fpt.r b/R/fpt.r index 1349d80..3079e75 100755 --- a/R/fpt.r +++ b/R/fpt.r @@ -1,39 +1,44 @@ -"fpt" <- -function (lt, radii, units = c("seconds", "hours", "days")) - { +"fpt" <- function (lt, radii, units = c("seconds", "hours", "days")) +{ + ## verifications if (!inherits(lt, "ltraj")) stop("should be an object of class 'ltraj'") - ## On supprime les données manquantes: + + ## One deletes the missing values lt <- lapply(lt, function(i) { - jj <- i[!is.na(i$x),] - attr(jj, "id") <- attr(i,"id") - attr(jj, "burst") <- attr(i,"burst") - return(jj) + jj <- i[!is.na(i$x),] + attr(jj, "id") <- attr(i,"id") + attr(jj, "burst") <- attr(i,"burst") + return(jj) }) units <- match.arg(units) + + ## foo computes the first passage time with the help of an external + ## call to the C function "fipatir" foo <- function(x) { - toto <- .C("fipatir", as.double(x$x), as.double(x$y), - as.double(x$date), as.integer(nrow(x)), - as.double(radii), as.integer(length(radii)), - double(nrow(x)*length(radii)), PACKAGE = "adehabitat") - mat <- matrix(toto[[7]], ncol = length(radii), byrow = TRUE) - mat[mat==-1] <- NA - mat <- as.data.frame(mat) - names(mat) <- paste("r",1:length(radii),sep="") - row.names(mat)=row.names(x) - return(mat) + toto <- .C("fipatir", as.double(x$x), as.double(x$y), + as.double(x$date), as.integer(nrow(x)), + as.double(radii), as.integer(length(radii)), + double(nrow(x)*length(radii)), PACKAGE = "adehabitat") + mat <- matrix(toto[[7]], ncol = length(radii), byrow = TRUE) + mat[mat==-1] <- NA + mat <- as.data.frame(mat) + names(mat) <- paste("r",1:length(radii),sep="") + row.names(mat)=row.names(x) + return(mat) } + ## Output lo <- lapply(lt, foo) names(lo) <- unlist(lapply(lt, function(x) attr(x,"burst"))) if (units == "hours") lo <- lapply(lo, function(x) x/3600) if (units == "days") lo <- lapply(lo, function(x) x/(3600*24)) lo <- lapply(1:length(lo), function(i) { - attr(lo[[i]], "date") <- lt[[i]]$date - attr(lo[[i]], "id") <- attr(lt[[i]], "id") - attr(lo[[i]], "burst") <- attr(lt[[i]], "burst") - return(lo[[i]]) + attr(lo[[i]], "date") <- lt[[i]]$date + attr(lo[[i]], "id") <- attr(lt[[i]], "id") + attr(lo[[i]], "burst") <- attr(lt[[i]], "burst") + return(lo[[i]]) }) attr(lo, "radii") <- radii class(lo) <- "fipati" diff --git a/R/gdltraj.r b/R/gdltraj.r index 89f38b8..1d36575 100755 --- a/R/gdltraj.r +++ b/R/gdltraj.r @@ -1,21 +1,26 @@ gdltraj <- function(x, min, max, - type=c("POSIXct","sec","min","hour", - "mday","mon","year","wday","yday")) - { + type=c("POSIXct","sec","min","hour", + "mday","mon","year","wday","yday")) +{ + ## Verifications if (!inherits(x, "ltraj")) - stop("x should be of class \"ltraj\"") + stop("x should be of class \"ltraj\"") type <- match.arg(type) + + ## gets the traj within the boundaries if (type=="POSIXct") { - x <- lapply(x, function(y) y[(y$date>min)&(y$datemin)&(y$date=min)&(da=min)&(da=date[1])&(x$date=date[1])&(x$date=3) + { + ## computes the number of vertices of the connex components + toto<-.C("lcontour", as.double(t(tmp)), as.integer(nrow(tmp)), + as.integer(ncol(tmp)), as.integer(0), + PACKAGE="adehabitat")[[4]] + + ## computes the connex components + pol<-.C("getcontour", as.double(t(tmp)), as.integer(nrow(tmp)), + as.integer(ncol(tmp)), integer(toto), integer(toto), + as.integer(toto), PACKAGE="adehabitat") + + ## output + xt<-c(0,xyc$x,0) + yt<-c(0,xyc$y,0) + x<-xt[pol[[4]]] + y<-yt[pol[[5]]] + sorties<-rbind(sorties, cbind(rep(j,length(x)), x, y)) + } } - - x[!is.na(x)]<-1 - x[is.na(x)]<-0 - - x<-rajfond(x) - toto<-.C("seqeticorr", as.double(t(x)), as.integer(nrow(x)), - as.integer(ncol(x)), PACKAGE="adehabitat") - etiquete<-matrix(toto[[1]], nrow=nrow(x), byrow=TRUE) - etiquete<-etiquete[-c(1,nrow(etiquete)),-c(1,ncol(etiquete))] - entree<-list() - sorties<-c(0, 0, 0) - lev<-levels(factor(toto[[1]])) - lev<-lev[lev!="0"] - for (i in lev) { - j<-as.numeric(i) - tmp<-etiquete - tmp[tmp!=j]<-0 - tmp[tmp==j]<-1 - tmp<-rajfond(tmp) - if (sum(as.vector(tmp))<3) - stop("The parts of the object should contain at least 3 pixels") - toto<-.C("lcontour", as.double(t(tmp)), as.integer(nrow(tmp)), - as.integer(ncol(tmp)), as.integer(0), PACKAGE="adehabitat")[[4]] - pol<-.C("getcontour", as.double(t(tmp)), as.integer(nrow(tmp)), - as.integer(ncol(tmp)), integer(toto), integer(toto), - as.integer(toto), PACKAGE="adehabitat") - xt<-c(0,xyc$x,0) - yt<-c(0,xyc$y,0) - x<-xt[pol[[4]]] - y<-yt[pol[[5]]] - sorties<-rbind(sorties, cbind(rep(j,length(x)), x, y)) - } - sorties<-sorties[-1,] - row.names(sorties)<-1:nrow(sorties) - sorties<-as.data.frame(sorties) - sorties[,1]<-factor(sorties[,1]) - names(sorties)<-c("id","x", "y") - sorties<-as.area(sorties) - return(sorties) + ## output as area + sorties<-sorties[-1,] + row.names(sorties)<-1:nrow(sorties) + sorties<-as.data.frame(sorties) + sorties[,1]<-factor(sorties[,1]) + names(sorties)<-c("id","x", "y") + sorties<-as.area(sorties) + return(sorties) } diff --git a/R/getkasc.r b/R/getkasc.r index eadd5f2..9f73b90 100755 --- a/R/getkasc.r +++ b/R/getkasc.r @@ -1,23 +1,27 @@ -"getkasc" <- -function(x, var) - { - w<-x - if (!inherits(w, "kasc")) stop("Non convenient data") +"getkasc" <- function(x, var) +{ + ## Verifications + if (!inherits(x, "kasc")) stop("Non convenient data") + if (length(var)>1) + stop("var should be of length one") + ## gets the specified variable and transform them into a matrix v<-x[[var]] if ((is.numeric(v))|(is.logical(v))) { - e<-matrix(w[[var]], ncol=attr(w, "nrow")) - attr(e, "type")<-"numeric" + e<-matrix(x[[var]], ncol=attr(x, "nrow")) + attr(e, "type")<-"numeric" } else { - tc2<-levels(v) - v<-as.numeric(v) - e<-matrix(v, ncol=attr(w, "nrow")) - attr(e, "type")<-"factor" - attr(e, "levels")<-tc2 + tc2<-levels(v) + v<-as.numeric(v) + e<-matrix(v, ncol=attr(x, "nrow")) + attr(e, "type")<-"factor" + attr(e, "levels")<-tc2 } - attr(e, "cellsize")<-attr(w, "cellsize") - attr(e, "xll")<-attr(w, "xll") - attr(e, "yll")<-attr(w, "yll") + + ## Other attributes + attr(e, "cellsize")<-attr(x, "cellsize") + attr(e, "xll")<-attr(x, "xll") + attr(e, "yll")<-attr(x, "yll") class(e)<-"asc" return(e) } diff --git a/R/getkascattr.r b/R/getkascattr.r index 6acbb44..6270eb8 100755 --- a/R/getkascattr.r +++ b/R/getkascattr.r @@ -1,8 +1,10 @@ -"getkascattr" <- -function(xkfrom, xkto) - { +"getkascattr" <- function(xkfrom, xkto) +{ + ## Verifications if (!inherits(xkfrom, "kasc")) - stop("xkfrom should be a kasc object") + stop("xkfrom should be a kasc object") + + ## Copy the attributes from xkfrom to xkto attr(xkto, "xll")<-attr(xkfrom, "xll") attr(xkto, "yll")<-attr(xkfrom, "yll") attr(xkto, "cellsize")<-attr(xkfrom, "cellsize") diff --git a/R/getsahrlocs.r b/R/getsahrlocs.r index b029174..aa34d23 100755 --- a/R/getsahrlocs.r +++ b/R/getsahrlocs.r @@ -1,14 +1,20 @@ -"getsahrlocs" <- -function(x, what=c("sa", "hr", "locs")) - { +"getsahrlocs" <- function(x, what=c("sa", "hr", "locs")) +{ + ## Verifications + if (!inherits(x, "sahrlocs")) + stop("x should be of class sahrlocs") what<-match.arg(what) + + ## Core of the function sahr<-x rm(x) if (!inherits(sahr, "sahrlocs")) stop("non convenient data type") if (is.na(match(what, c("sa", "hr", "locs")))) - stop("what should be either \"sa\", \"hr\", or \"locs\"") - + stop("what should be either \"sa\", \"hr\", or \"locs\"") output<-sahr[[what]] + + + ## Output attr(output, "nrow")<-attr(sahr, "nrow") attr(output, "ncol")<-attr(sahr, "ncol") attr(output, "xll")<-attr(sahr, "xll") diff --git a/R/getverticeshr.r b/R/getverticeshr.r index 995737d..09bf4ca 100755 --- a/R/getverticeshr.r +++ b/R/getverticeshr.r @@ -1,28 +1,30 @@ -"getverticeshr" <- -function(x, lev=95) +"getverticeshr" <- function(x, lev=95) { - if ((!inherits(x,"khr"))) - stop("non convenient data-type") - if (inherits(x,"khrud")) - x<-getvolumeUD(x) - if (inherits(x,"kbbhrud")) - x<-getvolumeUD(x) - contour<-list() - - for (i in 1:length(x)) { - ud<-x[[i]]$UD - ud[ud>lev]<-NA - ud[!is.na(ud)]<-1 - jj <- labcon(ud) - jj <- table(factor(c(jj))) - if (any(jj<4)) - stop("Some parts of the home range contain less than 3 pixels. -Increase the size of the grid used for the estimation in -the function 'kernelUD' (parameter 'grid') and try again") - contour[[i]]<-getcontour(ud) - } - names(contour)<-names(x) - class(contour) <- "kver" - return(contour) + ## Verifications + if ((!inherits(x,"khr"))) + stop("non convenient data-type") + if (inherits(x,"khrud")) + x<-getvolumeUD(x) + if (inherits(x,"kbbhrud")) + x<-getvolumeUD(x) + + ## output list + contour<-list() + + ## for each animal + for (i in 1:length(x)) { + + ## gets the UD and keep areas upper than lev + ud<-x[[i]]$UD + ud[ud>lev]<-NA + ud[!is.na(ud)]<-1 + + ## gets the contour of the connected features + contour[[i]]<-getcontour(ud) + } + ## output of class "kver" + names(contour)<-names(x) + class(contour) <- "kver" + return(contour) } diff --git a/R/getvolumeUD.r b/R/getvolumeUD.r index 54cdba4..b9a4bbe 100755 --- a/R/getvolumeUD.r +++ b/R/getvolumeUD.r @@ -1,25 +1,34 @@ -"getvolumeUD" <- -function(x) - { +"getvolumeUD" <- function(x) +{ + ## Verifications if ((!inherits(x, "khrud"))&(!inherits(x, "kbbhrud"))) - stop("x should be an object of class \"khrud\" or \"kbbhrud\"") + stop("x should be an object of class \"khrud\" or \"kbbhrud\"") + ## for each animal for (i in 1:length(x)) { - asc<-x[[i]]$UD - cs<-attr(asc,"cellsize") - v<-.C("calcvolume", as.double(t(asc)), as.integer(ncol(asc)), - as.integer(nrow(asc)), as.double(cs), PACKAGE="adehabitat")[[1]] - ## - index<-1:length(v) - vord<-v[order(v, decreasing=TRUE)] - indord<-index[order(v, decreasing=TRUE)] - vsu<-cumsum(vord) - vreord<-vsu[order(indord)]*100 - u<-matrix(vreord, ncol=ncol(asc), byrow=TRUE) - x[[i]]$UD<-getascattr(asc,u) + ## gets the UD of the animal + asc<-x[[i]]$UD + cs<-attr(asc,"cellsize") + + ## computes the volume for each pixel + ## thanks to a call to the C function calcvolume + v<-.C("calcvolume", as.double(t(asc)), as.integer(ncol(asc)), + as.integer(nrow(asc)), as.double(cs), PACKAGE="adehabitat")[[1]] + + ## standardize it so that the total volume is 1 over the area + index<-1:length(v) + vord<-v[order(v, decreasing=TRUE)] + indord<-index[order(v, decreasing=TRUE)] + vsu<-cumsum(vord) + vreord<-vsu[order(indord)]*100 + + ## output + u<-matrix(vreord, ncol=ncol(asc), byrow=TRUE) + x[[i]]$UD<-getascattr(asc,u) } + ## OUTPUT class(x)<-c("khrvol", "khr") return(x) - } +} diff --git a/R/hist.kselect.r b/R/hist.kselect.r index 65b4197..bcca373 100755 --- a/R/hist.kselect.r +++ b/R/hist.kselect.r @@ -1,14 +1,16 @@ -"hist.kselect" <- -function(x, xax = 1, mar=c(0,0,0,0), ampl=1, - col.out=gray(0.75), col.in=gray(0.75), ncell=TRUE, - denout=NULL, denin=NULL, lwdout=1, lwdin=1, - maxy=1, csub=2, - possub=c("bottomleft", "topleft", "bottomright", "topright"), - ncla=15, ...) - { +"hist.kselect" <- function(x, xax = 1, mar=c(0,0,0,0), ampl=1, + col.out=gray(0.75), col.in=gray(0.75), ncell=TRUE, + denout=NULL, denin=NULL, lwdout=1, lwdin=1, + maxy=1, csub=2, + possub=c("bottomleft", "topleft", + "bottomright", "topright"), + ncla=15, ...) +{ + ## Verifications possub<-match.arg(possub) if (!inherits(x, "kselect")) stop("should be a 'kselect' object") - + + ## 1. Creation de la liste Xi<-x$initab Xrecalc<-t(as.matrix(apply(Xi, 1, function(y) y*x$lw/sum(x$lw))))%*%as.matrix(x$l1) @@ -16,7 +18,8 @@ function(x, xax = 1, mar=c(0,0,0,0), ampl=1, li.wei<-split(x$initwei, x$initfac) rx<-range(Xrecalc[,xax]) br<-seq(rx[1]-(rx[2]-rx[1])/100, rx[2]+(rx[2]-rx[1])/100, length=ncla) - + + ## Graphical settings def.par <- par(no.readonly = TRUE) on.exit(par(def.par)) ngraph<-length(li.Xi) @@ -28,7 +31,7 @@ function(x, xax = 1, mar=c(0,0,0,0), ampl=1, ## Histogramme extérieur vext<-Xtmp[,xax] - + ## Histogramme interieur poids<-wgtmp if (ncell) poids[poids>0]<-1 @@ -40,7 +43,7 @@ function(x, xax = 1, mar=c(0,0,0,0), ampl=1, plot(rx, c(-maxy, maxy), type="n", axes=FALSE, ylim=c(-maxy,maxy), main="") - + ## Trace des histogrammes p<--hhr$counts/sum(hhr$counts) q<-h$counts/sum(h$counts) @@ -55,9 +58,9 @@ function(x, xax = 1, mar=c(0,0,0,0), ampl=1, csub=csub, possub=possub) box() - + } - + plot(c(-2,2),c(-2,2), type="n", axes=FALSE, xlab="", ylab="") lines(c(0,0), c(-1, 1), lwd=2) lines(c(-0.1,0.1), c(-1, -1), lwd=2) diff --git a/R/histniche.r b/R/histniche.r index 9d2ddff..9fa9d17 100755 --- a/R/histniche.r +++ b/R/histniche.r @@ -1,100 +1,123 @@ -"histniche" <- -function (kasc, pts, type = c("h", "l"), adjust = 1, Acol, Ucol, - Aborder, Uborder, Alwd = 1, Ulwd = 1, ...) +"histniche" <- function (kasc, pts, type = c("h", "l"), adjust = 1, + Acol, Ucol, + Aborder, Uborder, Alwd = 1, Ulwd = 1, ...) { - type <- match.arg(type) - if (!inherits(kasc, "kasc")) - stop("should be an object of class \"kasc\"") - if (ncol(pts) != 2) - stop("pts should have 2 columns") - tab <- kasc2df(kasc) - index <- tab$index - tab <- tab$tab - pr <- as.vector(count.points(pts, kasc))[index] - if (missing(Acol)) { - Acol <- NULL - Acolf <- "white" - Acold <- "black" - } - else { - Acold <- Acol - Acolf <- Acol - } - if (missing(Aborder)) - Aborder <- "black" - if (missing(Ucol)) { - Ucol <- gray(0.8) - Ucold <- gray(0.8) - } - else - Ucold <- Ucol - if (missing(Uborder)) - Uborder <- gray(0.8) - clas <- rep("", ncol(tab)) - for (j in 1:ncol(tab)) { - w1 <- "q" - if (is.factor(tab[, j])) - w1 <- "f" - clas[j] <- w1 - } - if (any(clas == "f") & type == "l") - warning("Type = 'l' is not possible for factors, type = 'h' used instead.\n") - old.par <- par(no.readonly = TRUE) - on.exit(par(old.par)) - par(mar = c(0.5, 0.5, 2, 0.5)) - par(mfrow = rev(n2mfrow(ncol(tab)))) - f1 <- function(j) { - tmpU <- rep(tab[, j], pr) - tmpA <- tab[, j] - name <- names(tab)[j] - if (clas[j] == "f") { - par(mar = c(3, 0.5, 2, 0.5)) - mat <- t(cbind(table(tmpA), table(tmpU))) - mat <- lapply(1:2, function(i) mat[i, ]/sum(mat[i,])) - mat <- rbind(mat[[1]], mat[[2]]) - max <- max(mat) - max <- max + max/20 - ylim <- c(0, max) - barplot(mat, col = c(Acolf, Ucol), border = c(Aborder, Uborder), - ylim = ylim, main = name, ylab = NULL, axes = FALSE, - beside = TRUE, ...) - par(mar = c(0.5, 0.5, 2, 0.5)) + ## Verifications + type <- match.arg(type) + if (!inherits(kasc, "kasc")) + stop("should be an object of class \"kasc\"") + if (ncol(pts) != 2) + stop("pts should have 2 columns") + + ## Prepares the data + tab <- kasc2df(kasc) + index <- tab$index + tab <- tab$tab + pr <- as.vector(count.points(pts, kasc))[index] + ## data ok + + ## Graphical settings + if (missing(Acol)) { + Acol <- NULL + Acolf <- "white" + Acold <- "black" } else { - if (type == "h") { - xrange <- range(tmpA) - H <- hist(tmpU, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) - G <- hist(tmpA, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) - yrange <- c(0, max(H$density, G$density)) - plot(H, freq = FALSE, col = Ucol, border = Uborder, - xlim = xrange, ylim = yrange, main = name, xlab = NULL, - ylab = "Density", axes = FALSE, ...) - plot(G, freq = FALSE, col = Acol, border = Aborder, add = TRUE) - } - if (type == "l") { - densA <- density(tmpA, adjust = adjust) - densU <- density(tmpU, adjust = adjust, from = min(densA$x), - to = max(densA$x)) - max <- max(densU$y, densA$y) - max <- max + max/20 - ylim <- c(0, max) - plot(densU, col = Ucol, ylim = ylim, type = "l", - lwd = Ulwd, main = name, xlab = NULL, ylab = "Density", - axes = FALSE, ...) - lines(rep(mean(tmpU), 2), c(0, densU$y[512 - sum(densU$x > - mean(tmpU))]), - col = Ucol, lty = 2, lwd = Ulwd) - lines(densA, col = Acold, lwd = Alwd) - lines(rep(mean(tmpA), 2), c(0, densA$y[512 - sum(densA$x > - mean(tmpA))]), - col = Acold, lty = 2, lwd = Alwd) - } + Acold <- Acol + Acolf <- Acol + } + if (missing(Aborder)) + Aborder <- "black" + if (missing(Ucol)) { + Ucol <- gray(0.8) + Ucold <- gray(0.8) + } + else + Ucold <- Ucol + if (missing(Uborder)) + Uborder <- gray(0.8) + + ## The type of variable for which a histogram is wanted + clas <- rep("", ncol(tab)) + for (j in 1:ncol(tab)) { + w1 <- "q" + if (is.factor(tab[, j])) + w1 <- "f" + clas[j] <- w1 + } + if (any(clas == "f") & type == "l") + warning("Type = 'l' is not possible for factors, type = 'h' used instead.\n") + + ## Again graphical settings + old.par <- par(no.readonly = TRUE) + on.exit(par(old.par)) + par(mar = c(0.5, 0.5, 2, 0.5)) + par(mfrow = rev(n2mfrow(ncol(tab)))) + + ## The function used for each histogram + f1 <- function(j) { + + ## Use and availability + tmpU <- rep(tab[, j], pr) + tmpA <- tab[, j] + name <- names(tab)[j] + + + ## For factor maps: a barplot + if (clas[j] == "f") { + par(mar = c(3, 0.5, 2, 0.5)) + mat <- t(cbind(table(tmpA), table(tmpU))) + mat <- lapply(1:2, function(i) mat[i, ]/sum(mat[i,])) + mat <- rbind(mat[[1]], mat[[2]]) + max <- max(mat) + max <- max + max/20 + ylim <- c(0, max) + barplot(mat, col = c(Acolf, Ucol), border = c(Aborder, Uborder), + ylim = ylim, main = name, ylab = NULL, axes = FALSE, + beside = TRUE, ...) + par(mar = c(0.5, 0.5, 2, 0.5)) + } + else { + + ## for continuous maps: either a histogram... + if (type == "h") { + xrange <- range(tmpA) + H <- hist(tmpU, plot = FALSE, br = seq(min(xrange), + max(xrange), length = 15)) + G <- hist(tmpA, plot = FALSE, br = seq(min(xrange), + max(xrange), length = 15)) + yrange <- c(0, max(H$density, G$density)) + plot(H, freq = FALSE, col = Ucol, border = Uborder, + xlim = xrange, ylim = yrange, main = name, xlab = NULL, + ylab = "Density", axes = FALSE, ...) + plot(G, freq = FALSE, col = Acol, border = Aborder, add = TRUE) + } + + ## ... or a smoothing of the density + if (type == "l") { + densA <- density(tmpA, adjust = adjust) + densU <- density(tmpU, adjust = adjust, from = min(densA$x), + to = max(densA$x)) + max <- max(densU$y, densA$y) + max <- max + max/20 + ylim <- c(0, max) + plot(densU, col = Ucol, ylim = ylim, type = "l", + lwd = Ulwd, main = name, xlab = NULL, ylab = "Density", + axes = FALSE, ...) + lines(rep(mean(tmpU), 2), c(0, densU$y[512 - sum(densU$x > + mean(tmpU))]), + col = Ucol, lty = 2, lwd = Ulwd) + lines(densA, col = Acold, lwd = Alwd) + lines(rep(mean(tmpA), 2), c(0, densA$y[512 - sum(densA$x > + mean(tmpA))]), + col = Acold, lty = 2, lwd = Alwd) + } + } + box() } - box() - } - lapply(1:ncol(tab), f1) - return(invisible(NULL)) + + ## And we apply this function to each variable + lapply(1:ncol(tab), f1) + return(invisible(NULL)) } diff --git a/R/hr.rast.r b/R/hr.rast.r index 31d38c7..0c63797 100755 --- a/R/hr.rast.r +++ b/R/hr.rast.r @@ -1,16 +1,22 @@ -"hr.rast" <- -function(mcp, w) - { +"hr.rast" <- function(mcp, w) +{ + ## Verifications if (inherits(w, "asc")) w <- as.kasc(list(to=w)) if (!inherits(w, "kasc")) stop("Non convenient data") if (!inherits(mcp, "area")) stop("mcp should be of class \"area\"") + + ## a list with one element = one polygon lpc<-split(mcp[,2:3], mcp[,1]) output<-list() + + ## use of the function mcp.rast for each polygon for (i in 1:length(lpc)) output[[names(lpc)[i]]]<-mcp.rast(lpc[[i]], w) + + ## the output: output<-as.kasc(output) return(output) } diff --git a/R/im2asc.r b/R/im2asc.r index a499756..e9ce90f 100755 --- a/R/im2asc.r +++ b/R/im2asc.r @@ -1,10 +1,11 @@ -"im2asc" <- -function(x) - { +"im2asc" <- function(x) +{ + ## Verifications if (!inherits(x, "im")) - stop("xshould be of class \"im\"") + stop("xshould be of class \"im\"") if (x$xstep!=x$ystep) - stop("the grid cellsize should be identical for both X and Y directions.") + stop("the grid cellsize should be identical for both X and Y directions.") + ## output mat<-x$v xll<-min(x$xcol) yll<-min(x$yrow) diff --git a/R/image.asc.r b/R/image.asc.r index a2b32b5..93e4171 100755 --- a/R/image.asc.r +++ b/R/image.asc.r @@ -1,20 +1,24 @@ -"image.asc" <- -function (x, col = gray((240:1)/256), clfac = NULL, ...) +"image.asc" <- function (x, col = gray((240:1)/256), clfac = NULL, ...) { + ## Verifications if (!inherits(x, "asc")) stop("not an \"asc\" object") - z <- x - xy <- getXYcoords(z) - x <- xy$x - y <- xy$y - if (attr(z, "type") == "numeric") - image(x = x, y = y, z, asp = 1, col = col, ...) - if (attr(z, "type") == "factor") { + + ## Coordinates of the pixels + xy <- getXYcoords(x) + xx <- xy$x + yy <- xy$y + + ## If the variable is numeric + if (attr(x, "type") == "numeric") + image(x = xx, y = yy, x, asp = 1, col = col, ...) + + ## For a factor: creates colors + if (attr(x, "type") == "factor") { if (is.null(clfac)) { - clfac <- rainbow(nlevels(z)) - clfac <- clfac[as.numeric(levels(factor(z)))] + clfac <- rainbow(nlevels(x)) + clfac <- clfac[as.numeric(levels(factor(x)))] } - image(x = x, y = y, z, asp = 1, col = clfac, ...) + image(x = xx, y = yy, x, asp = 1, col = clfac, ...) } } - diff --git a/R/image.kasc.r b/R/image.kasc.r index b1425b2..a844561 100755 --- a/R/image.kasc.r +++ b/R/image.kasc.r @@ -1,35 +1,43 @@ -"image.kasc" <- -function(x, var=names(x), - mar=if (length(var)>1) c(0,0,2,0) else c(5.1,4.1,4.1,2.1), - axes=(length(var) == 1), - clfac=NULL, col=gray((240:1)/256), mfrow=NULL, - ...) - { - w<-x - if (!inherits(w,"kasc")) stop("object should be of class \"kasc\"") +"image.kasc" <- function(x, var=names(x), + mar=if (length(var)>1) c(0,0,2,0) else c(5.1,4.1,4.1,2.1), + axes=(length(var) == 1), + clfac=NULL, col=gray((240:1)/256), mfrow=NULL, + ...) +{ + ## verifications + if (!inherits(x,"kasc")) stop("object should be of class \"kasc\"") if (is.null(mfrow)) - mfrow=n2mfrow(length(var)) + mfrow=n2mfrow(length(var)) + + ## The graph opar<-par(mfrow=mfrow, mar=mar) on.exit(par(opar)) + + ## One graph per variable for (i in var) { - el<-getkasc(x, i) - if (attr(el, "type")=="factor") { - if (!is.null(clfac)) { - clf<-clfac[[i]] + el<-getkasc(x, i) + + ## In the case of a factor map + if (attr(el, "type")=="factor") { + if (!is.null(clfac)) { + clf<-clfac[[i]] + } else { + clf<-NULL + } + + ## if there is only one variable, no title by default + if (length(var)>1) + image.asc(el, main=i, axes=axes, clfac=clf, ... ) + if (length(var)==1) + image.asc(el, axes=axes, clfac=clf, ... ) } else { - clf<-NULL + ## In the case of a numeric map, different colors + if (length(var)>1) + image.asc(el, main=i, axes=axes, col=col, ...) + if (length(var)==1) + image.asc(el, axes=axes, col=col, ... ) } - if (length(var)>1) - image.asc(el, main=i, axes=axes, clfac=clf, ... ) - if (length(var)==1) - image.asc(el, axes=axes, clfac=clf, ... ) - } else { - if (length(var)>1) - image.asc(el, main=i, axes=axes, col=col, ...) - if (length(var)==1) - image.asc(el, axes=axes, col=col, ... ) - } - box() + box() } - } +} diff --git a/R/image.khr.r b/R/image.khr.r index 78c3985..684cd06 100755 --- a/R/image.khr.r +++ b/R/image.khr.r @@ -1,30 +1,32 @@ -"image.khr" <- -function(x, axes=FALSE, mar=c(0,0,2,0), - addcontour=TRUE, addpoints=TRUE,...) - { +"image.khr" <-function(x, axes=FALSE, mar=c(0,0,2,0), + addcontour=TRUE, addpoints=TRUE,...) +{ + ## Verifications if (!inherits(x, "khr")) - stop("x should be an object of class \"khr\"") + stop("x should be an object of class \"khr\"") if ((inherits(x,"khrud"))|(inherits(x,"kbbhrud"))) - col<-gray((256:1)/256) + col<-gray((256:1)/256) if (inherits(x,"khrvol")) - col<-gray((1:256)/256) + col<-gray((1:256)/256) + ## Graphical settings if (length(x) > 1) { - opar<-par(mfrow=n2mfrow(length(x)), mar=mar) - on.exit(par(opar)) + opar<-par(mfrow=n2mfrow(length(x)), mar=mar) + on.exit(par(opar)) } + ## For each animal, an image for (i in 1:length(x)) { - if (length(x)>1) - image(x[[i]]$UD, main=names(x)[i], axes=axes, col=col, ...) - if (length(x)==1) - image(x[[i]]$UD, axes=axes, col=col, ...) - if (addcontour) - contour(x[[i]]$UD, add=TRUE) - if (addpoints) { - points(x[[i]]$locs, pch=21, col="black", bg="white") - } - box() + if (length(x)>1) + image(x[[i]]$UD, main=names(x)[i], axes=axes, col=col, ...) + if (length(x)==1) + image(x[[i]]$UD, axes=axes, col=col, ...) + if (addcontour) + contour(x[[i]]$UD, add=TRUE) + if (addpoints) { + points(x[[i]]$locs, pch=21, col="black", bg="white") + } + box() } - } +} diff --git a/R/image.sahrlocs.r b/R/image.sahrlocs.r index db9af2b..effb49d 100755 --- a/R/image.sahrlocs.r +++ b/R/image.sahrlocs.r @@ -1,96 +1,130 @@ -"image.sahrlocs" <- -function(x, ani=names(x$hr), - var=names(x$sa), - mar=c(0,0,0,0), axes=FALSE, dfidxy=NULL, - colpts="black", pch=21, bg="white", inv=FALSE, cexpts=0.6, - csub=2, possub=c("bottomleft", "bottomright", - "topleft", "topright"), ...) - { +"image.sahrlocs" <- function(x, ani=names(x$hr), + var=names(x$sa), + mar=c(0,0,0,0), axes=FALSE, dfidxy=NULL, + colpts="black", pch=21, bg="white", + inv=FALSE, cexpts=0.6, + csub=2, possub=c("bottomleft", "bottomright", + "topleft", "topright"), ...) +{ + ## Verifications possub<-match.arg(possub) if (!inherits(x, "sahrlocs")) - stop("The object x should be of \"sahrlocs\" type") + stop("The object x should be of \"sahrlocs\" type") + + ## Graphical settings ngraph<-length(ani)*length(var) opar<-par(mfrow=n2mfrow(ngraph), mar=mar) on.exit(par(opar)) if (!is.null(dfidxy)) lxy<-split(dfidxy, dfidxy[,1]) - ## Creation d'un mini-objet compo.hr + ## Bases hr<-x$hr[ani] sa<-x$sa[var] chr<-list() + ## For each animal for (i in 1:length(names(hr))) { - hrt<-hr[,i] - so<-sa - so$ani9999<-hrt - class(so)<-c("kasc", "data.frame") - so<-managNAkasc(so) - chr[[names(hr)[i]]]<-so[names(so)!="ani9999"] + + ## gets the home range + hrt<-hr[,i] + + ## creates a tmp object of the maps of the study area + so<-sa + ## adds the maps of the home range + so$ani9999<-hrt + class(so)<-c("kasc", "data.frame") + + ## Set to NA all areas outside the home range + so<-managNAkasc(so) + chr[[names(hr)[i]]]<-so[names(so)!="ani9999"] } xy<-getXYcoords(x) xc<-xy$x yc<-xy$y - ## Calcul du range + ## Computes the range + r<-list() minx<-0 maxx<-0 miny<-0 maxy<-0 - + for (i in 1:length(ani)) { - rtmp<-matrix(chr[[ani[i]]][[1]], ncol=attr(x, "nrow")) - rowx<-row(rtmp) - coly<-col(rtmp) - minx[i]<-min(rowx[!is.na(rtmp)]) - maxx[i]<-max(rowx[!is.na(rtmp)]) - miny[i]<-min(coly[!is.na(rtmp)]) - maxy[i]<-max(coly[!is.na(rtmp)]) - r[[i]]<-c(maxx[i]-minx[i], maxy[i]-miny[i]) + rtmp<-matrix(chr[[ani[i]]][[1]], ncol=attr(x, "nrow")) + rowx<-row(rtmp) + coly<-col(rtmp) + minx[i]<-min(rowx[!is.na(rtmp)]) + maxx[i]<-max(rowx[!is.na(rtmp)]) + miny[i]<-min(coly[!is.na(rtmp)]) + maxy[i]<-max(coly[!is.na(rtmp)]) + r[[i]]<-c(maxx[i]-minx[i], maxy[i]-miny[i]) } + r<-as.data.frame(r) rx<-max(r[1,])*(attr(x, "cellsize")) ry<-max(r[2,])*(attr(x, "cellsize")) + + + ## Colors cou<-gray((256:1)/256) if (inv) cou<-gray((1:256)/256) - + ## Images + ## For each animal for (i in 1:length(ani)){ - for (j in 1:length(var)){ + df<-chr[[ani[i]]] class(df)<-"data.frame" - - if (is.numeric(df[[var[j]]])) { - im<-matrix(df[[var[j]]], ncol=attr(x, "nrow")) - mx<-min(x$sa[[var[j]]][!is.na(x$sa[[var[j]]])]) - Mx<-max(x$sa[[var[j]]][!is.na(x$sa[[var[j]]])]) - mxMx<-seq(mx, Mx, length=256) - mx1<-min(im[!is.na(im)]) - Mx1<-max(im[!is.na(im)]) - cou1<-cou[(mxMx>mx1)&(mxMxmx1)&(mxMx 1) { - if (length(lev) != length(levels(factor(output)))) - stop("uncorrect length of lev") - } - if (length(lev) == 1) { + ## Verifications + type <- match.arg(type) + if (substr(file, nchar(file) - 3, nchar(file)) != ".asc") + stop("not a valid .asc file") + if ((type != "numeric") & (type != "factor")) + stop("argument type should be \"factor\" or \"numeric\"") + if ((type == "numeric") & (!is.null(lev))) + stop("lev can be specified only when type is \"factor\" ") + if ((type == "factor") & (length(lev) == 1)) + if (!file.exists(lev)) + stop("lev is not a valid file") + + ## Opens a connection + zz <- file(file, "r") + ## reads the header + nc <- readLines(zz, 1) + nl <- readLines(zz, 1) + xll <- readLines(zz, 1) + yll <- readLines(zz, 1) + cs <- readLines(zz, 1) + nas <- readLines(zz, 1) + cs <- strsplit(cs, " ") + cs <- as.numeric(cs[[1]][length(cs[[1]])]) + + ## The coordinates of the lower left cell: + ## Are they coordinates of the corner or thos of the center of the cell? + cornx <- TRUE + corny <- TRUE + + ## values of xll and yll + xll <- strsplit(xll, " ") + if ((xll[[1]][1] == "xllcenter") | (xll[[1]][1] == "XLLCENTER")) + cornx <- FALSE + xll <- as.numeric(xll[[1]][length(xll[[1]])]) + yll <- strsplit(yll, " ") + if ((yll[[1]][1] == "yllcenter") | (xll[[1]][1] == "YLLCENTER")) + corny <- FALSE + yll <- as.numeric(yll[[1]][length(yll[[1]])]) + + ## code for NAs + nas <- strsplit(nas, " ") + nas <- as.numeric(nas[[1]][length(nas[[1]])]) + + ## number of columns + nc <- strsplit(nc, " ") + nc <- as.numeric(nc[[1]][length(nc[[1]])]) + + ## number of rows + nl <- strsplit(nl, " ") + nl <- as.numeric(nl[[1]][length(nl[[1]])]) + + + + ## reads the rest of the file + tmp <- readLines(zz) + + ## and closes the connection + close(zz) + + + + ## opens a new connection to a temporary file + file.create("toto230876.tmp") + zz <- file("toto230876.tmp", "w") + + ## and write the content of tmp + writeLines(tmp, zz) + + ## and finally close this connection + close(zz) + + ## scan this file as usual and remove tmp file + output <-scan("toto230876.tmp", quiet=TRUE) + file.remove("toto230876.tmp") + + ## Place the NAs + output[output == nas] <- NA + + ## and code into a matrix of class "asc" + output<-matrix(c(as.matrix(output)), ncol=nl) + output <- output[, ncol(output):1] + + ## In the case of a factor map + if (type == "factor") { + + ## creates the vector of levels + ## if is null, created from the matrix + if (is.null(lev)) + lev <- levels(factor(output)) + + ## if not null, should contain the same number of labels + ## as there are levels + if (length(lev) > 1) { + if (length(lev) != length(levels(factor(output)))) + stop("uncorrect length of lev") + } + + ## if of length one, then read the correspondence + ## table exported from Arcview + if (length(lev) == 1) { toto <- read.table(lev, header = TRUE, sep = ",") toto <- data.frame(lev = toto[, levnb], hihi = rep(1, nrow(toto)), lab = toto[, labnb]) toto <- toto[order(toto[, 1]), ] - if (nrow(toto) != nlevels(factor(output))) - stop("lev is not a valid correspondence table exported from Arcview") + if (nrow(toto) != nlevels(factor(output))) + stop("lev is not a valid correspondence table exported from Arcview") lev <- as.character(toto[, 3]) - } - attr(output, "levels") <- lev - } - attr(output, "xll") <- xll - if (cornx) - attr(output, "xll") <- xll + cs/2 - attr(output, "yll") <- yll - if (corny) - attr(output, "yll") <- yll + cs/2 - attr(output, "cellsize") <- cs - attr(output, "type") <- type - class(output) <- "asc" - return(output) + } + attr(output, "levels") <- lev + } + + ## rest of the output + attr(output, "xll") <- xll + if (cornx) + attr(output, "xll") <- xll + cs/2 + attr(output, "yll") <- yll + if (corny) + attr(output, "yll") <- yll + cs/2 + attr(output, "cellsize") <- cs + attr(output, "type") <- type + class(output) <- "asc" + return(output) } diff --git a/R/join.asc.r b/R/join.asc.r index 25ec670..73ae326 100755 --- a/R/join.asc.r +++ b/R/join.asc.r @@ -1,36 +1,45 @@ -"join.asc" <- -function(pts, x) - { +"join.asc" <- function(pts, x) +{ + ## Verifications if (!inherits(x, "asc")) stop("non convenient data") + + ## coordinates of the limits of the pixels xy<-getXYcoords(x) xy$x<-xy$x+attr(x, "cellsize")/2 xy$x<-c(xy$x, xy$x[1]-attr(x, "cellsize")/2) xy$y<-xy$y+attr(x, "cellsize")/2 xy$y<-c(xy$y, xy$y[1]-attr(x, "cellsize")/2) + ## cuts the points and stores into two vectors of + ## indices (one for rows and one for columns) xf<-as.numeric(cut(pts[,1], xy$x)) yf<-as.numeric(cut(pts[,2], xy$y)) + ## In case of a factor map, stores the levels fact<-0 - if (attr(x, "type")=="factor") + if (attr(x, "type")=="factor") ct<-attr(x, "levels") + ## For each point for (i in 1:nrow(pts)) { - if (attr(x, "type")=="numeric") { - u<-x[xf[i],yf[i]] - fact[i]<-u - } - if (attr(x, "type")=="factor") { - u<-x[xf[i],yf[i]] - tmp<-ct[u] - if (length(tmp)==1) { - fact[i]<-tmp - } else { - fact[i]<-NA + + ## identifies the value of the map + if (attr(x, "type")=="numeric") { + u<-x[xf[i],yf[i]] + fact[i]<-u + } + if (attr(x, "type")=="factor") { + u<-x[xf[i],yf[i]] + tmp<-ct[u] + if (length(tmp)==1) { + fact[i]<-tmp + } else { + fact[i]<-NA + } } - } } + ## output if (attr(x, "type")=="factor") fact<-factor(fact) return(fact) - } +} diff --git a/R/join.kasc.r b/R/join.kasc.r index 713ce42..b361cbc 100755 --- a/R/join.kasc.r +++ b/R/join.kasc.r @@ -1,16 +1,21 @@ -"join.kasc" <- -function(pts, w) - { - x<-w - if (!inherits(x, "kasc")) stop("non convenient data") +"join.kasc" <- function(pts, w) +{ + ## Verifications + if (!inherits(w, "kasc")) stop("non convenient data") + + ## output sorties<-1:nrow(pts) - for (i in 1:length(x)) { - carp<-getkasc(x, names(x)[i]) - fac<-join.asc(pts, carp) - sorties<-cbind.data.frame(sorties, fac) + + ## applies the function join.asc to each map of w + for (i in 1:length(w)) { + carp<-getkasc(w, names(w)[i]) + fac<-join.asc(pts, carp) + sorties<-cbind.data.frame(sorties, fac) } + + ## output sorties<-sorties[,-1] - names(sorties)<-names(x) + names(sorties)<-names(w) return(sorties) - } +} diff --git a/R/kasc2df.r b/R/kasc2df.r index d3e6399..36a45d1 100755 --- a/R/kasc2df.r +++ b/R/kasc2df.r @@ -1,20 +1,27 @@ -"kasc2df" <- -function(x, var=names(x)) +"kasc2df" <- function(x, var=names(x)) { - if (!inherits(x, "kasc")) stop("Non convenient data type") + ## Verifications + if (!inherits(x, "kasc")) stop("Non convenient data type") - w<-data.frame(x[var]) - index<-c(1:nrow(w)) - abenner<-function(x){ - if (any(is.na(x))) { - return(FALSE) - } else { - return(TRUE) + ## Bases + w<-data.frame(x[var]) + index<-c(1:nrow(w)) + + ## abenner returns TRUE if a vector contains no missing values + abenner<-function(x){ + if (any(is.na(x))) { + return(FALSE) + } else { + return(TRUE) + } } - } - cons<-apply(w, 1, abenner) - indcons<-index[cons] - wcons<-data.frame(w[cons,]) - output<-list(index=indcons, tab=wcons) + + ## deletes all the rows containing NAs + cons<-apply(w, 1, abenner) + indcons<-index[cons] + wcons<-data.frame(w[cons,]) + + ## and return the index + output<-list(index=indcons, tab=wcons) } diff --git a/R/kasc2spixdf.r b/R/kasc2spixdf.r index 2155ae6..299d3bb 100755 --- a/R/kasc2spixdf.r +++ b/R/kasc2spixdf.r @@ -1,17 +1,23 @@ -"kasc2spixdf" <- -function(ka) - { +"kasc2spixdf" <- function(ka) +{ + ## Verifications if (!inherits(ka, "kasc")) stop("ka should be of class \"kasc\"") if (!require(sp)) stop("the package sp is required for this function") + + ## gets the coordinates of the kasc xyc <- getXYcoords(ka) xc <- rep(xyc$x, times=length(xyc$y)) yc <- rep(xyc$y, each=length(xyc$x)) xyc<-data.frame(x=xc,y=yc) + + ## remove the NA ka <- managNAkasc(ka) cons <- (1:nrow(ka))[!is.na(ka[,1])] df <- ka[cons,] + + ## The spatial data frame class(df) <- "data.frame" df <- as.data.frame(lapply(df, function(x) as.numeric(x))) xyc <- xyc[cons,] diff --git a/R/kernel.area.r b/R/kernel.area.r index 471e279..8b5cadb 100755 --- a/R/kernel.area.r +++ b/R/kernel.area.r @@ -1,42 +1,58 @@ -"kernel.area" <- -function (xy, id, h = "href", grid = 40, - same4all = FALSE, hlim = c(0.1, 1.5),kern = "bivnorm", - levels = seq(20, 95, by = 5), unin = c("m", "km"), - unout = c("ha", "km2", "m2")) +"kernel.area" <- function (xy, id, h = "href", grid = 40, + same4all = FALSE, hlim = c(0.1, 1.5), + kern = "bivnorm", + levels = seq(20, 95, by = 5), unin = c("m", "km"), + unout = c("ha", "km2", "m2")) { - unin <- match.arg(unin) - unout <- match.arg(unout) - x <- kernelUD(xy, id, h, grid, same4all, hlim, kern) - x <- getvolumeUD(x) - area <- list() - contours <- list() - for (j in names(x)) { - tmpsurf <- rep(0, length(levels)) - for (i in 1:length(levels)) { - asc <- x[[j]]$UD - tmp <- asc < levels[i] - cs <- attr(asc, "cellsize") + ## Computes the UD and its volume + unin <- match.arg(unin) + unout <- match.arg(unout) + x <- kernelUD(xy, id, h, grid, same4all, hlim, kern) + x <- getvolumeUD(x) + + ## output objects + area <- list() + contours <- list() + + ## For each animal + for (j in names(x)) { + tmpsurf <- rep(0, length(levels)) + + ## for each desired home range level + for (i in 1:length(levels)) { + ## identify the area corresponding to the home range of the + ## specified level + asc <- x[[j]]$UD + tmp <- asc < levels[i] + cs <- attr(asc, "cellsize") + ## the home range size tmpsurf[i] <- sum(as.numeric(tmp)) * cs * cs + } + ## Home range size is stored for each animal + area[[j]] <- tmpsurf } - area[[j]] <- tmpsurf - } - area <- data.frame(area) - row.names(area) <- levels - names(area) <- names(x) - if (unin == "m") { - if (unout == "ha") - area <- area/10000 - if (unout == "km2") - area <- area/1e+06 - } - if (unin == "km") { - if (unout == "ha") - area <- area * 100 - if (unout == "m2") - area <- area * 1e+06 - } - class(area) <- c("hrsize", "data.frame") - attr(area, "units") <- unout - return(area) + + ## output + area <- data.frame(area) + row.names(area) <- levels + names(area) <- names(x) + ## output units + if (unin == "m") { + if (unout == "ha") + area <- area/10000 + if (unout == "km2") + area <- area/1e+06 + } + if (unin == "km") { + if (unout == "ha") + area <- area * 100 + if (unout == "m2") + area <- area * 1e+06 + } + + ## class "hrsize", for further plotting + class(area) <- c("hrsize", "data.frame") + attr(area, "units") <- unout + return(area) } diff --git a/R/kernelUD.r b/R/kernelUD.r index f754026..3662c55 100755 --- a/R/kernelUD.r +++ b/R/kernelUD.r @@ -1,8 +1,8 @@ -"kernelUD" <- -function(xy, id=NULL, h="href", grid=40, same4all=FALSE, - hlim=c(0.1, 1.5), kern = c("bivnorm", "epa")) - { - kern <- match.arg(kern) +"kernelUD" <- function(xy, id=NULL, h="href", grid=40, same4all=FALSE, + hlim=c(0.1, 1.5), kern = c("bivnorm", "epa")) +{ + ## Verifications + kern <- match.arg(kern) if (ncol(xy)!=2) stop("xy should have 2 columns") if ((!is.null(id))&(length(id)!=nrow(xy))) @@ -18,146 +18,163 @@ function(xy, id=NULL, h="href", grid=40, same4all=FALSE, stop("At least 5 relocations are required to fit an home range") - ## split de xy + ## split xy into a list where each animal is an element lixy<-split(xy, id) sorties<-list() typh<-h htmp<-h gr<-grid - ## + ## If the same grid is wanted for all animals: + ## First computes this grid if (same4all) { - if (length(as.vector(gr))==1) { - if (!is.numeric(gr)) - stop("grid should be an object of class asc or a number") - xli<-range(xy[,1]) - yli<-range(xy[,2]) - xli<-c(xli[1]-0.3*abs(xli[2]-xli[1]),xli[2]+0.3*abs(xli[2]-xli[1])) - yli<-c(yli[1]-0.3*abs(yli[2]-yli[1]),yli[2]+0.3*abs(yli[2]-yli[1])) - xygg<-data.frame(x=xli, y=yli) - grid<-ascgen(xygg, nrcol=grid) - cellsize<-attr(grid, "cellsize") - lx<-nrow(grid)*cellsize - ly<-ncol(grid)*cellsize - ref<-lx - if (ly>lx) - ref<-ly - xll<-attr(grid, "xll") - yll<-attr(grid, "yll") - - ## On rajoute des colonnes et des lignes - xll<-xll-lx/2 - yll<-yll-ly/2 - arajlig<-ceiling((lx/2)/cellsize) - arajcol<-ceiling((ly/2)/cellsize) - mrajlig<-matrix(0, ncol=ncol(grid), nrow=arajlig) - grid<-rbind(mrajlig, grid, mrajlig) - mrajcol<-matrix(0, ncol=arajcol, nrow=nrow(grid)) - grid<-cbind(mrajcol, grid, mrajcol) - - ## rajout des attributs - attr(grid, "xll")<-xll - attr(grid, "yll")<-yll - attr(grid, "cellsize")<-cellsize - attr(grid, "type")<-"numeric" - class(grid)<-"asc" - } + + ## if the grid is not given + if (length(as.vector(gr))==1) { + + ## the "core" grid + if (!is.numeric(gr)) + stop("grid should be an object of class asc or a number") + xli<-range(xy[,1]) + yli<-range(xy[,2]) + xli<-c(xli[1]-0.3*abs(xli[2]-xli[1]),xli[2]+0.3*abs(xli[2]-xli[1])) + yli<-c(yli[1]-0.3*abs(yli[2]-yli[1]),yli[2]+0.3*abs(yli[2]-yli[1])) + xygg<-data.frame(x=xli, y=yli) + grid<-ascgen(xygg, nrcol=grid) + cellsize<-attr(grid, "cellsize") + lx<-nrow(grid)*cellsize + ly<-ncol(grid)*cellsize + ref<-lx + if (ly>lx) + ref<-ly + xll<-attr(grid, "xll") + yll<-attr(grid, "yll") + + ## One adds empty rows and columns to the "core" grid + xll<-xll-lx/2 + yll<-yll-ly/2 + arajlig<-ceiling((lx/2)/cellsize) + arajcol<-ceiling((ly/2)/cellsize) + mrajlig<-matrix(0, ncol=ncol(grid), nrow=arajlig) + grid<-rbind(mrajlig, grid, mrajlig) + mrajcol<-matrix(0, ncol=arajcol, nrow=nrow(grid)) + grid<-cbind(mrajcol, grid, mrajcol) + + ## We add the attributes + attr(grid, "xll")<-xll + attr(grid, "yll")<-yll + attr(grid, "cellsize")<-cellsize + attr(grid, "type")<-"numeric" + class(grid)<-"asc" + } } - ## Boucle estimation UD pour chaque ani + + ## UD estimation for each animal for (i in 1:nlevels(id)) { - df<-lixy[[i]] - - ## 1. Calcul de h - varx<-var(df[,1]) - vary<-var(df[,2]) - sdxy<-sqrt(0.5*(varx+vary)) - n<-nrow(df) - ex<-(-1/6) - href<-sdxy*(n^ex) - if (kern=="epa") - href <- href*1.77 - - if (h=="href") { - htmp<-href - } - if (h=="LSCV") { - hvec<-seq(hlim[1]*href, hlim[2]*href, length=100) - CV<-.C("CVmise", as.integer(nrow(df)), as.double(df[,1]), - as.double(df[,2]), - as.double(hvec), double(length(hvec)), - as.integer(length(hvec)), PACKAGE="adehabitat")[[5]] - htmp<-hvec[CV==min(CV)] - if ((CV[CV==min(CV)]==CV[1])|(CV[CV==min(CV)]==CV[length(CV)])) - warning("The algorithm did not converge \nwithin the specified range of hlim: try to increase it") - } - - - ## 3. Construction de la grille - if (length(as.vector(gr))==1) { - if (!is.numeric(gr)) - stop("grid should be an object of class asc or a number") - - if (!same4all) { - grid<-matrix(0, ncol=gr, nrow=gr) - rgx<-range(df[,1]) - rgy<-range(df[,2]) - lx<-rgx[2]-rgx[1] - ly<-rgy[2]-rgy[1] - ref<-lx - if (ly>lx) - ref<-ly - - xll<-rgx[1] - yll<-rgy[1] - cellsize<-ref/ncol(grid) - - ## On rajoute des colonnes et des lignes - xll<-xll-lx/2 - yll<-yll-ly/2 - arajlig<-ceiling((lx/2)/cellsize) - arajcol<-ceiling((ly/2)/cellsize) - mrajlig<-matrix(0, ncol=ncol(grid), nrow=arajlig) - grid<-rbind(mrajlig, grid, mrajlig) - mrajcol<-matrix(0, ncol=arajcol, nrow=nrow(grid)) - grid<-cbind(mrajcol, grid, mrajcol) - - ## rajout des attributs - attr(grid, "xll")<-xll - attr(grid, "yll")<-yll - attr(grid, "cellsize")<-cellsize - attr(grid, "type")<-"numeric" - class(grid)<-"asc" + + df<-lixy[[i]] + + ## 1. Computation of h + varx<-var(df[,1]) + vary<-var(df[,2]) + sdxy<-sqrt(0.5*(varx+vary)) + n<-nrow(df) + ex<-(-1/6) + href<-sdxy*(n^ex) + if (kern=="epa") + href <- href*1.77 + if (h=="href") { + htmp<-href + } + if (h=="LSCV") { + hvec<-seq(hlim[1]*href, hlim[2]*href, length=100) + CV<-.C("CVmise", as.integer(nrow(df)), as.double(df[,1]), + as.double(df[,2]), + as.double(hvec), double(length(hvec)), + as.integer(length(hvec)), PACKAGE="adehabitat")[[5]] + htmp<-hvec[CV==min(CV)] + if ((CV[CV==min(CV)]==CV[1])|(CV[CV==min(CV)]==CV[length(CV)])) + warning("The algorithm did not converge \nwithin the specified range of hlim: try to increase it") + } + + + ## 2. The grid if not the same for all + if (length(as.vector(gr))==1) { + if (!is.numeric(gr)) + stop("grid should be an object of class asc or a number") + + if (!same4all) { + + ## the "core" grid + grid<-matrix(0, ncol=gr, nrow=gr) + rgx<-range(df[,1]) + rgy<-range(df[,2]) + lx<-rgx[2]-rgx[1] + ly<-rgy[2]-rgy[1] + ref<-lx + if (ly>lx) + ref<-ly + + xll<-rgx[1] + yll<-rgy[1] + cellsize<-ref/ncol(grid) + + ## One adds empty rows and columns to the "core" grid + xll<-xll-lx/2 + yll<-yll-ly/2 + arajlig<-ceiling((lx/2)/cellsize) + arajcol<-ceiling((ly/2)/cellsize) + mrajlig<-matrix(0, ncol=ncol(grid), nrow=arajlig) + grid<-rbind(mrajlig, grid, mrajlig) + mrajcol<-matrix(0, ncol=arajcol, nrow=nrow(grid)) + grid<-cbind(mrajcol, grid, mrajcol) + + ## We add the attributes of the grid + attr(grid, "xll")<-xll + attr(grid, "yll")<-yll + attr(grid, "cellsize")<-cellsize + attr(grid, "type")<-"numeric" + class(grid)<-"asc" + } + } + + grille<-grid + xylo<-getXYcoords(grid) + xg<-xylo$x + yg<-xylo$y + + + ## Kernel estimation in itself (the C function called + ## depends on the choosed kernel) + if (kern=="bivnorm") { + toto<-.C("kernelhr", double(nrow(grid)*ncol(grid)),as.double(xg), + as.double(yg), + as.integer(ncol(grid)), as.integer(nrow(grid)), + as.integer(nrow(df)), as.double(htmp), + as.double(df[,1]), as.double(df[,2]), + PACKAGE="adehabitat") + } + if (kern=="epa") { + toto<-.C("kernepan", double(nrow(grid)*ncol(grid)),as.double(xg), + as.double(yg), + as.integer(ncol(grid)), as.integer(nrow(grid)), + as.integer(nrow(df)), as.double(htmp), + as.double(df[,1]), as.double(df[,2]), + PACKAGE="adehabitat") + } + + ## output + UD<-matrix(toto[[1]], nrow=nrow(grid), byrow=TRUE) + UD<-getascattr(grid, UD) + if (typh=="LSCV") { + CV<-data.frame(h=hvec, CV=CV) + convergence<-min(CV[,2])!=CV[1,2] + htmp<-list(CV=CV, convergence=convergence, h=htmp) } - } - grille<-grid - xylo<-getXYcoords(grid) - xg<-xylo$x - yg<-xylo$y - - if (kern=="bivnorm") { - toto<-.C("kernelhr", double(nrow(grid)*ncol(grid)),as.double(xg), - as.double(yg), - as.integer(ncol(grid)), as.integer(nrow(grid)), - as.integer(nrow(df)), as.double(htmp), - as.double(df[,1]), as.double(df[,2]), PACKAGE="adehabitat") - } - if (kern=="epa") { - toto<-.C("kernepan", double(nrow(grid)*ncol(grid)),as.double(xg), - as.double(yg), - as.integer(ncol(grid)), as.integer(nrow(grid)), - as.integer(nrow(df)), as.double(htmp), - as.double(df[,1]), as.double(df[,2]), PACKAGE="adehabitat") - } - UD<-matrix(toto[[1]], nrow=nrow(grid), byrow=TRUE) - UD<-getascattr(grid, UD) - if (typh=="LSCV") { - CV<-data.frame(h=hvec, CV=CV) - convergence<-min(CV[,2])!=CV[1,2] - htmp<-list(CV=CV, convergence=convergence, h=htmp) - } - sorties[[names(lixy)[i]]]<-list(UD=UD, h=htmp, locs=df, hmeth=typh) + sorties[[names(lixy)[i]]]<-list(UD=UD, h=htmp, locs=df, hmeth=typh) } + ## general output class(sorties)<-c("khrud", "khr") return(sorties) } diff --git a/R/kernelbb.r b/R/kernelbb.r index 8a251b0..9792480 100755 --- a/R/kernelbb.r +++ b/R/kernelbb.r @@ -1,11 +1,16 @@ -"kernelbb" <- -function(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) - { +"kernelbb" <- function(tr, sig1, sig2, grid = 40, + same4all=FALSE, byburst=FALSE) +{ + ## verifications x <- ltraj2traj(tr) if (!inherits(x, "traj")) - stop("tr should be of class \"ltraj\"") + stop("tr should be of class \"ltraj\"") + + ## Bases sorties <- list() gr <- grid + x <- x[!is.na(x$x),] + x <- x[!is.na(x$y),] xy<-x[,c("x","y")] sig12<-sig1^2 sig22<-sig2^2 @@ -16,16 +21,16 @@ function(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) fac<-x$id fac<-factor(fac) lixy<-split(x,fac) - + if (same4all) { if (length(as.vector(gr)) == 1) { - if (!is.numeric(gr)) + if (!is.numeric(gr)) stop("grid should be an object of class asc or a number") xli <- range(xy[, 1]) yli <- range(xy[, 2]) - xli <- c(xli[1] - 0.3 * abs(xli[2] - xli[1]), xli[2] + + xli <- c(xli[1] - 0.3 * abs(xli[2] - xli[1]), xli[2] + 0.3 * abs(xli[2] - xli[1])) - yli <- c(yli[1] - 0.3 * abs(yli[2] - yli[1]), yli[2] + + yli <- c(yli[1] - 0.3 * abs(yli[2] - yli[1]), yli[2] + 0.3 * abs(yli[2] - yli[1])) xygg <- data.frame(x = xli, y = yli) grid <- ascgen(xygg, nrcol = grid) @@ -33,7 +38,7 @@ function(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) lx <- nrow(grid) * cellsize ly <- ncol(grid) * cellsize ref <- lx - if (ly > lx) + if (ly > lx) ref <- ly xll <- attr(grid, "xll") yll <- attr(grid, "yll") @@ -57,7 +62,7 @@ function(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) dft<-lixy[[i]] df<-dft[,c("x","y")] if (length(as.vector(gr)) == 1) { - if (!is.numeric(gr)) + if (!is.numeric(gr)) stop("grid should be an object of class asc or a number") if (!same4all) { grid <- matrix(0, ncol = gr, nrow = gr) @@ -66,7 +71,7 @@ function(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) lx <- rgx[2] - rgx[1] ly <- rgy[2] - rgy[1] ref <- lx - if (ly > lx) + if (ly > lx) ref <- ly xll <- rgx[1] yll <- rgy[1] @@ -86,12 +91,12 @@ function(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) class(grid) <- "asc" } } - + xyg<-getXYcoords(grid) date<-as.double(dft$date)-min(as.double(dft$date)) toto<-.C("kernelbb", as.double(t(grid)), as.double(xyg$x), as.double(xyg$y), as.integer(ncol(grid)),as.integer(nrow(grid)), - as.integer(nrow(x)), as.double(sig12), as.double (sig22), + as.integer(nrow(x)), as.double(sig12), as.double (sig22), as.double(df$x), as.double(df$y), as.double(date), PACKAGE="adehabitat") UD <- matrix(toto[[1]], nrow = nrow(grid), byrow = TRUE) diff --git a/R/kplot.kselect.r b/R/kplot.kselect.r index 21d6991..0db7506 100755 --- a/R/kplot.kselect.r +++ b/R/kplot.kselect.r @@ -1,65 +1,80 @@ -"kplot.kselect" <- -function (object, xax = 1, yax = 2, csub = 2, - possub = c("topleft", "bottomleft", "bottomright", "topright"), - addval=TRUE, cpoint=1, csize=1, clegend=2, ...) +"kplot.kselect" <- function (object, xax = 1, yax = 2, csub = 2, + possub = c("topleft", "bottomleft", + "bottomright", "topright"), + addval=TRUE, cpoint=1, csize=1, clegend=2, ...) { - possub<-match.arg(possub) - x<-object - if (!inherits(x, "kselect")) - stop("x should be a 'kselect' object") - if (x$nf == 1) { - hist.kselect(x) - return(invisible()) - } - - ## 1. Calcul des coordonnées des lignes du tableau initial - Xi<-x$initab - Xrecalc<-t(as.matrix(apply(Xi, 1, function(y) y*x$lw/sum(x$lw))))%*%as.matrix(x$l1) - rx<-range(Xrecalc[,xax]) - ry<-range(Xrecalc[,yax]) - - li.Xi<-split(as.data.frame(Xrecalc), x$initfac) - li.wei<-split(x$initwei, x$initfac) - li.wei<-lapply(li.wei, function(x) x/sum(x) ) - maxsqrtw<-max(sqrt(unlist(li.wei))) - - csi<-0 - for (i in 1:length(li.wei)) - csi[i]<-csize*max(sqrt(li.wei[[i]]))/maxsqrtw - - def.par <- par(no.readonly = TRUE) - on.exit(par(def.par)) - ngraph<-length(li.Xi) - par(mfrow = n2mfrow(ngraph+1)) - - for (i in 1:ngraph) { - Xtmp<-li.Xi[[i]] - wgtmp<-li.wei[[i]] + ## Verifications + possub<-match.arg(possub) + x<-object + if (!inherits(x, "kselect")) + stop("x should be a 'kselect' object") + if (x$nf == 1) { + hist.kselect(x) + return(invisible()) + } + + ## Coordinates of the available points on the axes of the K-select + ## (scores of the rows of initab) + Xi<-x$initab + Xrecalc<-t(as.matrix(apply(Xi, 1, + function(y) y*x$lw/sum(x$lw))))%*%as.matrix(x$l1) + ## Preparation of the data needed for this graphs (spliting the "global" + ## table into a list of multiple tables, idem for the utilization weights) + rx<-range(Xrecalc[,xax]) + ry<-range(Xrecalc[,yax]) + li.Xi<-split(as.data.frame(Xrecalc), x$initfac) + li.wei<-split(x$initwei, x$initfac) + li.wei<-lapply(li.wei, function(x) x/sum(x) ) + maxsqrtw<-max(sqrt(unlist(li.wei))) + + ## The graphs + csi<-0 + for (i in 1:length(li.wei)) + csi[i]<-csize*max(sqrt(li.wei[[i]]))/maxsqrtw + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + ngraph<-length(li.Xi) if (addval) { - s.value(Xtmp, wgtmp, xax, yax, - sub=names(li.Xi)[i], cpoint=cpoint, xlim=rx, ylim=ry, clegend=0, - csub=1.5, cgrid=1.5, csize=csi[i]) + par(mfrow = n2mfrow(ngraph+1)) ## +1 for the legend + } else { + par(mfrow = n2mfrow(ngraph)) } - s.distri(Xtmp, wgtmp, xax, yax, - sub=names(li.Xi)[i], add.p=addval, cpoint=cpoint, xlim=rx, ylim=ry, - ...) + + ## One graph per animal + for (i in 1:ngraph) { + Xtmp<-li.Xi[[i]] + wgtmp<-li.wei[[i]] + if (addval) { + s.value(Xtmp, wgtmp, xax, yax, + sub=names(li.Xi)[i], cpoint=cpoint, xlim=rx, + ylim=ry, clegend=0, + csub=1.5, cgrid=1.5, csize=csi[i]) + } + s.distri(Xtmp, wgtmp, xax, yax, + sub=names(li.Xi)[i], add.p=addval, + cpoint=cpoint, xlim=rx, ylim=ry, + ...) } - - if (addval) { - coo <- scatterutil.base(dfxy = Xtmp, xax = xax, yax = yax, - xlim = rx, ylim = ry, grid = FALSE, addaxes = FALSE, - cgrid = 0, include.origin = FALSE, origin = c(0,0), - sub = "", csub = 0, possub = "bottomleft", pixmap = NULL, - contour = NULL, area = NULL, add.plot = FALSE) - - coeff <- diff(range(coo$x))/15 - br0<-pretty(unlist(li.wei), 4) - l0 <- length(br0) - br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2 - sq0 <- sqrt(abs(br0)) - sq0 <- csize * coeff * sq0/max(sqrt(abs(wgtmp))) - sig0 <- sign(br0) - scatterutil.legend.bw.square(pretty(unlist(li.wei), 4), sq0, sig0, clegend=clegend) - } -} + ## adds a legend if addval is TRUE + if (addval) { + coo <- scatterutil.base(dfxy = Xtmp, xax = xax, yax = yax, + xlim = rx, ylim = ry, grid = FALSE, + addaxes = FALSE, + cgrid = 0, include.origin = FALSE, + origin = c(0,0), + sub = "", csub = 0, + possub = "bottomleft", pixmap = NULL, + contour = NULL, area = NULL, add.plot = FALSE) + + coeff <- diff(range(coo$x))/15 + br0<-pretty(unlist(li.wei), 4) + l0 <- length(br0) + br0 <- (br0[1:(l0 - 1)] + br0[2:l0])/2 + sq0 <- sqrt(abs(br0)) + sq0 <- csize * coeff * sq0/max(sqrt(abs(wgtmp))) + sig0 <- sign(br0) + scatterutil.legend.bw.square(pretty(unlist(li.wei), 4), + sq0, sig0, clegend=clegend) + } +} diff --git a/R/kselect.r b/R/kselect.r index e56d074..3615c0e 100755 --- a/R/kselect.r +++ b/R/kselect.r @@ -1,60 +1,70 @@ -"kselect" <- -function(dudi, factor, weight, scannf = TRUE, nf = 2, ewa = FALSE) +"kselect" <- function(dudi, factor, weight, scannf = TRUE, nf = 2, ewa = FALSE) { - # 1. Vérifications - if (!inherits(dudi, "dudi")) stop("Object of class dudi expected") - - X<-dudi$tab - f<-factor - ab<-weight - - if (nrow(X) != length(f)) - stop("The factor should have the same number of observations as the dudi object") - if (nrow(X) != length(ab)) - stop("The vector of weights should have the same number of observations as the dudi object") - if (!is.vector(weight)) - stop("The weights should be placed in a vector") - if (!is.factor(f)) f<-factor(f) - - lo<-split(X,f) - ab<-split(ab,f) - if (!ewa) - poco<-unlist(lapply(ab, function(x) sum(x)/sum(weight))) - if (ewa) - poco<-rep(1/nlevels(f), nlevels(f)) - ab<-lapply(ab, function(x) x/sum(x)) - - - - # 2. Calcul des df des cdg dispo - m<-data.frame(lapply(lo, function(x) apply(x,2,mean))) - - # 3. Calcul des df des cdg utilisés - n<-list() - for (i in 1:length(lo)) { - w<-ab[[i]] - D<-lo[[i]] - n[[names(lo)[i]]]<-apply(D,2,function(x) sum(w*x)) - } - n<-data.frame(n) - - # 4. Analyse - z<-as.dudi(df=n-m, col.w=poco, - row.w=dudi$cw, call=match.call(), type="kselect", - scannf = scannf, nf = nf) - - z$initab<-dudi$tab - z$initfac<-factor - z$initwei<-weight - - U <- as.matrix(z$l1) * unlist(z$lw) - U <- data.frame(t(as.matrix(dudi$c1)) %*% U) - row.names(U) <- names(dudi$li) - names(U) <- names(z$li) - z$as <- U - - - return(z) + ## 1. Verifications + if (!inherits(dudi, "dudi")) stop("Object of class dudi expected") + X<-dudi$tab + f<-factor + ab<-weight + if (nrow(X) != length(f)) + stop("factor should have the same number of observations as dudi") + if (nrow(X) != length(ab)) + stop("weight should have the same number of observations as dudi") + if (!is.vector(weight)) + stop("weight should be placed in a vector") + if (!is.factor(f)) f<-factor(f) + + + ## Split the table into a list of tables (one per animal) giving + ## the values of variables (columns) in each pixel (rows) of the + ## home range of the animals. Idem for weight + lo<-split(X,f) + ab<-split(ab,f) + + ## The weight given to the animals in the analysis + if (!ewa) { + poco<-unlist(lapply(ab, function(x) sum(x)/sum(weight))) + } else { + poco<-rep(1/nlevels(f), nlevels(f)) + } + ab<-lapply(ab, function(x) x/sum(x)) + + ## Computation of the coordinates of the centroids "available" + ## in the ecological space + m<-data.frame(lapply(lo, function(x) apply(x,2,mean))) + + ## Computation of the coordinates of the centroids "used" + ## in the ecological space + n<-list() + for (i in 1:length(lo)) { + w<-ab[[i]] + D<-lo[[i]] + n[[names(lo)[i]]]<-apply(D,2,function(x) sum(w*x)) + } + n<-data.frame(n) + + ## Note that the data frames are such that variables are in rows + ## and animals in columns + + ## Analysis: a non centered PCA of the difference between use and + ## available centroids + z<-as.dudi(df=n-m, col.w=poco, + row.w=dudi$cw, call=match.call(), type="kselect", + scannf = scannf, nf = nf) + + ## The output + z$initab<-dudi$tab + z$initfac<-factor + z$initwei<-weight + + ## Coordinates of the PCA axes on the K-select axes + U <- as.matrix(z$l1) * unlist(z$lw) + U <- data.frame(t(as.matrix(dudi$c1)) %*% U) + row.names(U) <- names(dudi$li) + names(U) <- names(z$li) + z$as <- U + + ## Output + return(z) } diff --git a/R/labcon.r b/R/labcon.r index cfe019a..b54477e 100755 --- a/R/labcon.r +++ b/R/labcon.r @@ -1,28 +1,39 @@ -"labcon" <- -function(x) +"labcon" <- function(x) { - if (!inherits(x, "asc")) - stop("should be an object of class asc") - y<-x - rajfond <- function(x) { - nr <- nrow(x) - nc <- ncol(x) - f <- rep(0, nr) - x <- cbind(f, x, f) - f <- rep(0, nc + 2) - x <- rbind(f, x, f) - } - x[!is.na(x)] <- 1 - x[is.na(x)] <- 0 - x <- rajfond(x) - toto <- .C("seqeticorr", as.double(t(x)), as.integer(nrow(x)), - as.integer(ncol(x)), PACKAGE="adehabitat") - etiquete <- matrix(toto[[1]], nrow = nrow(x), byrow = TRUE) - etiquete <- etiquete[-c(1, nrow(etiquete)), -c(1, ncol(etiquete))] - etiquete[etiquete==0]<-NA - s<-getascattr(y, etiquete) - attr(s, "type")<-"factor" - attr(s, "levels")<-as.character(1:nlevels(factor(etiquete))) - return(s) + ## Verifications + if (!inherits(x, "asc")) + stop("should be an object of class asc") + y<-x + + ## rajfond adds empty lines and columns on the borders of a map + rajfond <- function(x) { + nr <- nrow(x) + nc <- ncol(x) + f <- rep(0, nr) + x <- cbind(f, x, f) + f <- rep(0, nc + 2) + x <- rbind(f, x, f) + } + + ## The map is transformed so that it takes either + ## the value 0 (NA) or 1 (mapped value) + x[!is.na(x)] <- 1 + x[is.na(x)] <- 0 + x <- rajfond(x) + + ## sequential labelling of connex components + ## with the C function "seqeticorr" + toto <- .C("seqeticorr", as.double(t(x)), as.integer(nrow(x)), + as.integer(ncol(x)), PACKAGE="adehabitat") + + ## output + etiquete <- matrix(toto[[1]], nrow = nrow(x), byrow = TRUE) + ## and we delete the empty lines and columns added + etiquete <- etiquete[-c(1, nrow(etiquete)), -c(1, ncol(etiquete))] + etiquete[etiquete==0]<-NA + s<-getascattr(y, etiquete) + attr(s, "type")<-"factor" + attr(s, "levels")<-as.character(1:nlevels(factor(etiquete))) + return(s) } diff --git a/R/lowres.asc.r b/R/lowres.asc.r index fa4ac03..e61c986 100755 --- a/R/lowres.asc.r +++ b/R/lowres.asc.r @@ -1,49 +1,66 @@ -"lowres.asc" <- -function(x, np=2, ...) +"lowres.asc" <- function(x, np=2, ...) { - if (!inherits(x, "asc")) - stop("x sould be of class \"asc\"") - nr<-nrow(x) - nc<-ncol(x) - xy<-getXYcoords(x) - cs<-attr(x, "cellsize") - if (attr(x, "type")=="factor") { - typ <- "factor" - lev <- levels(x) - } else { - typ <- "numeric" - } - x<-x[1:(nr-(((nr/np)-floor(nr/np)))*np),1:(nc-(((nc/np)-floor(nc/np)))*np)] - nr<-nrow(x) - nc<-ncol(x) + ## Verifications + if (!inherits(x, "asc")) + stop("x sould be of class \"asc\"") + nr<-nrow(x) + nc<-ncol(x) + xy<-getXYcoords(x) + cs<-attr(x, "cellsize") + if (attr(x, "type")=="factor") { + typ <- "factor" + lev <- levels(x) + } else { + typ <- "numeric" + } - if (typ=="factor") { - repr<- as.numeric(levels(factor(as.vector(x)))) - lev <- lev[repr] - x <- as.numeric(as.character(factor(x))) - x <- matrix(x, nrow=nr, ncol=nc) - } - - x[is.na(x)]<--9999 - xs<-matrix(0, nrow=nr/np, ncol=nc/np) - if (typ == "numeric") { - mat<-.C("regrouascnumr", as.double(t(x)), as.double(t(xs)), - as.double(nrow(x)), as.double(ncol(x)), - as.double(nrow(xs)), as.double(ncol(xs)), PACKAGE = "adehabitat")[[2]] - } else { - mat<-.C("regroufacascr", as.double(t(x)), as.double(t(xs)), as.integer(np), - as.integer(length(lev)), as.integer(nrow(x)), as.integer(ncol(x)), - as.integer(nrow(xs)), as.integer(ncol(xs)), PACKAGE = "adehabitat")[[2]] - } - mat<-matrix(mat,ncol=ncol(xs), byrow=TRUE) - mat[mat==-9999]<-NA - attr(mat, "xll")<-mean(xy$x[1:np]) - attr(mat, "yll")<-mean(xy$y[1:np]) - attr(mat, "cellsize")<-cs*np - attr(mat, "type")<-typ - if (typ == "factor") - attr(mat, "levels") <- lev - class(mat)<-"asc" - return(mat) + ## build a smaller matrix, multiple of np (to avoid "half-pixels") + x<-x[1:(nr-(((nr/np)-floor(nr/np)))*np), + 1:(nc-(((nc/np)-floor(nc/np)))*np)] + nr<-nrow(x) + nc<-ncol(x) + + ## recomputes the levels of the map if it is a factor + if (typ=="factor") { + repr<- as.numeric(levels(factor(as.vector(x)))) + lev <- lev[repr] + x <- as.numeric(as.character(factor(x))) + x <- matrix(x, nrow=nr, ncol=nc) + } + + ## Replaces the missing values + x[is.na(x)]<--9999 + + ## the future output + xs<-matrix(0, nrow=nr/np, ncol=nc/np) + + if (typ == "numeric") { + ## in case of numeric map: computes the average value for the pixel + mat<-.C("regrouascnumr", as.double(t(x)), as.double(t(xs)), + as.double(nrow(x)), as.double(ncol(x)), + as.double(nrow(xs)), as.double(ncol(xs)), + PACKAGE = "adehabitat")[[2]] + } else { + ## in case of factor maps: computes the most frequent value + ## for the pixel + mat<-.C("regroufacascr", as.double(t(x)), + as.double(t(xs)), as.integer(np), + as.integer(length(lev)), as.integer(nrow(x)), + as.integer(ncol(x)), + as.integer(nrow(xs)), as.integer(ncol(xs)), + PACKAGE = "adehabitat")[[2]] + } + + ## The output + mat<-matrix(mat,ncol=ncol(xs), byrow=TRUE) + mat[mat==-9999]<-NA + attr(mat, "xll")<-mean(xy$x[1:np]) + attr(mat, "yll")<-mean(xy$y[1:np]) + attr(mat, "cellsize")<-cs*np + attr(mat, "type")<-typ + if (typ == "factor") + attr(mat, "levels") <- lev + class(mat)<-"asc" + return(mat) } diff --git a/R/lowres.kasc.r b/R/lowres.kasc.r index 1b6de2a..f46c2ec 100755 --- a/R/lowres.kasc.r +++ b/R/lowres.kasc.r @@ -1,5 +1,4 @@ -"lowres.kasc" <- -function(x, np=2, ...) +"lowres.kasc" <- function(x, np=2, ...) { if (!inherits(x, "kasc")) stop("x sould be of class \"kasc\"") diff --git a/R/lowres.r b/R/lowres.r index c005a11..575b57e 100755 --- a/R/lowres.r +++ b/R/lowres.r @@ -1,5 +1,4 @@ -"lowres" <- -function(x, np = 2, ...) +"lowres" <- function(x, np = 2, ...) { UseMethod("lowres") } diff --git a/R/ltraj2sldf.r b/R/ltraj2sldf.r index fa17b47..bd63a75 100755 --- a/R/ltraj2sldf.r +++ b/R/ltraj2sldf.r @@ -1,26 +1,30 @@ -"ltraj2sldf" <- - function(ltr, byid = FALSE) - { +"ltraj2sldf" <- function(ltr, byid = FALSE) +{ + ## Verifications if (!inherits(ltr, "ltraj")) - stop("ltr should be of class \"ltraj\"") + stop("ltr should be of class \"ltraj\"") + + ## Conversion lixy <- lapply(ltr, function(x) Line(as.matrix(x[!is.na(x$x),c("x","y")]))) id <- unlist(lapply(ltr, function(x) attr(x, "id"))) bu <- unlist(lapply(ltr, function(x) attr(x, "burst"))) - + if (byid) { - lev <- levels(factor(id)) - re1 <- lapply(lev, function(x) Lines(lixy[id==x], ID=x)) - res <- SpatialLines(re1) - df <- data.frame(id=lev) - row.names(df) <- lev + lev <- levels(factor(id)) + re1 <- lapply(lev, function(x) Lines(lixy[id==x], ID=x)) + res <- SpatialLines(re1) + df <- data.frame(id=lev) + row.names(df) <- lev } else { - res <- lapply(1:length(lixy), - function(i) Lines(list(lixy[[i]]), ID=bu[i])) - res <- SpatialLines(res) - df <- data.frame(id=id, burst=bu) - row.names(df) <- bu + res <- lapply(1:length(lixy), + function(i) Lines(list(lixy[[i]]), ID=bu[i])) + res <- SpatialLines(res) + df <- data.frame(id=id, burst=bu) + row.names(df) <- bu } + + ## Output res <- SpatialLinesDataFrame(res, data=df) return(res) } diff --git a/R/ltraj2spdf.r b/R/ltraj2spdf.r index a66662d..825b95b 100755 --- a/R/ltraj2spdf.r +++ b/R/ltraj2spdf.r @@ -1,14 +1,18 @@ -"ltraj2spdf" <- -function(ltr) - { +"ltraj2spdf" <- function(ltr) +{ + ## Verifications if (!inherits(ltr, "ltraj")) stop("ltr should be of class \"ltraj\"") + + ## Conversion tr <- do.call("rbind", ltr) class(tr) <- "data.frame" xy <- tr[!is.na(tr$x),c("x","y")] tr <- tr[!is.na(tr$x),] tr$y <- tr$x <- NULL res <- SpatialPointsDataFrame(xy, tr) + + ## Output return(res) } diff --git a/R/madifa.r b/R/madifa.r index 95d30ea..fbb2a9b 100644 --- a/R/madifa.r +++ b/R/madifa.r @@ -10,16 +10,17 @@ madifa <- function(dudi, pr, scannf = TRUE, nf = 2) - { +{ + ## Verifications if (!inherits(dudi, "dudi")) - stop("object of class dudi expected") + stop("object of class dudi expected") call <- match.call() if (any(is.na(dudi$tab))) stop("na entries in table") if (!is.vector(pr)) stop("pr should be a vector") - ## Les "ingrédients" de l'analyse + ## Bases for the analysis prb <- pr pr <- pr/sum(pr) row.w <- dudi$lw @@ -30,52 +31,57 @@ madifa <- function(dudi, pr, scannf = TRUE, nf = 2) center <- apply(Z, 2, f1) Z <- sweep(Z, 2, center) f2 <- function(v) sum((v^2) * pr) -### et <- apply(Z,2,f2) -### Z <- sweep(Z,2,et,"/") - ## Passage à l'espace étoilé + ## Take into account different weights for the columns Ze <- sweep(Z, 2, sqrt(col.w), "*") - ## Calcul des matrices d'inertie S et G + ## Inertia matrices S and G DpZ <- apply(Ze, 2, function(x) x*pr) - - ## Calcul des matrices d'inertie Se <- crossprod(Ze, DpZ) Ge <- crossprod(Ze, apply(Ze,2,function(x) x*row.w)) - ## Calcul de S^(-1/2) + ## S^(-1/2) eS <- eigen(Se) S12 <- eS$vectors %*% diag(eS$values^(-0.5)) %*% t(eS$vectors) - ## Passage au pb 3 + ## Eigen structure W <- S12 %*% Ge %*% S12 s <- eigen(W)$values + ## number of eigenvalues if (scannf) { - barplot(s) - cat("Select the number of axes: ") - nf <- as.integer(readLines(n = 1)) + barplot(s) + cat("Select the number of axes: ") + nf <- as.integer(readLines(n = 1)) } - if (nf <= 0 | nf > ncol(Ze)) nf <- 1 + ## Coordinates of the columns tt <- as.data.frame((S12 %*% eigen(W)$vectors)) ww <- apply(tt, 2, function(x) x/sqrt(col.w)) norw <- sqrt(diag(t(as.matrix(tt))%*%as.matrix(tt))) co <- sweep(ww, 2, norw, "/") + ## scores of the rows in the distorted space li <- Z %*% apply(co, 2, function(x) x*col.w) + + co <- as.data.frame(co) li <- as.data.frame(li) + + ## Coordinates of the rows in the distorted space varus <- apply(li,2,function(x) sum((x^2)*pr)) l1 <- sweep(li, 2, sqrt(unlist(varus)), "/") + + ## Mahalanobis distances (total) mahasu <- apply(l1, 1, function(x) sqrt(sum(x^2))) + + ## For output co <- data.frame(co[,1:nf]) li <- data.frame(li[,1:nf]) l1 <- data.frame(l1[,1:nf]) - names(co) <- paste("Axis", (1:nf), sep = "") row.names(co) <- dimnames(dudi$tab)[[2]] names(li) <- paste("Comp.", (1:nf), sep = "") @@ -83,16 +89,20 @@ madifa <- function(dudi, pr, scannf = TRUE, nf = 2) row.names(li) <- dimnames(dudi$tab)[[1]] row.names(l1) <- dimnames(dudi$tab)[[1]] - ## les ACP: + ## PCA of the use and availability: f1 <- function(v) sum(v * row.w)/sum(row.w) f2 <- function(v) sqrt(sum(v * v * row.w)/sum(row.w)) centra1 <- sweep(dudi$tab, 2, apply(dudi$tab,2,f1)) centra1 <- sweep(centra1, 2, apply(centra1,2,f2), "/") centra2 <- sweep(dudi$li, 2, apply(dudi$li,2,f1)) centra2 <- sweep(centra2, 2, apply(centra2,2,f2), "/") - corav <- crossprod(as.matrix(apply(centra1, 2, function(x) x*row.w/sum(row.w))), as.matrix(centra2)) + ## Correlation with these axes + corav <- crossprod(as.matrix(apply(centra1, 2, + function(x) x*row.w/sum(row.w))), + as.matrix(centra2)) + ## Output madifa <- list(call = call, tab = data.frame(Z), pr = prb, cw = col.w, nf = nf, eig = s, lw = row.w, li = li, l1 = l1, co = co, mahasu = mahasu, corav = corav) @@ -103,41 +113,41 @@ madifa <- function(dudi, pr, scannf = TRUE, nf = 2) print.madifa <- function (x, ...) { - if (!inherits(x, "madifa")) - stop("Object of class 'madifa' expected") - cat("MADIFA") - cat("\n$call: ") - print(x$call) - cat("\neigen values: ") - l0 <- length(x$eig) - cat(signif(x$eig, 4)[1:(min(5, l0))]) - if (l0 > 5) - cat(" ...") - cat("\n$nf:", x$nf, "axes saved") - cat("\n") - cat("\n") - sumry <- array("", c(5, 4), list(1:5, c("vector", "length", - "mode", "content"))) - sumry[1, ] <- c("$pr", length(x$pr), mode(x$pr), "vector of presence") - sumry[2, ] <- c("$mahasu", length(x$mahasu), mode(x$mahasu), "squared Mahalanobis distances") - sumry[3, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights") - sumry[4, ] <- c("$cw", length(x$lw), mode(x$lw), "column weights") - sumry[5, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values") - class(sumry) <- "table" - print(sumry) - cat("\n") - sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow", - "ncol", "content"))) - sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array") - sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates") - sumry[3, ] <- c("$l1", nrow(x$li), ncol(x$li), "row normed scores (variance weighted by $pr = 1)") - sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates") - sumry[5, ] <- c("$corav", nrow(x$corav), ncol(x$corav), "cor(habitat var., scores) for available points") - class(sumry) <- "table" - print(sumry) - if (length(names(x)) > 15) { cat("\nother elements: ") - cat(names(x)[16:(length(x))], "\n") - } + if (!inherits(x, "madifa")) + stop("Object of class 'madifa' expected") + cat("MADIFA") + cat("\n$call: ") + print(x$call) + cat("\neigen values: ") + l0 <- length(x$eig) + cat(signif(x$eig, 4)[1:(min(5, l0))]) + if (l0 > 5) + cat(" ...") + cat("\n$nf:", x$nf, "axes saved") + cat("\n") + cat("\n") + sumry <- array("", c(5, 4), list(1:5, c("vector", "length", + "mode", "content"))) + sumry[1, ] <- c("$pr", length(x$pr), mode(x$pr), "vector of presence") + sumry[2, ] <- c("$mahasu", length(x$mahasu), mode(x$mahasu), "squared Mahalanobis distances") + sumry[3, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights") + sumry[4, ] <- c("$cw", length(x$lw), mode(x$lw), "column weights") + sumry[5, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values") + class(sumry) <- "table" + print(sumry) + cat("\n") + sumry <- array("", c(5, 4), list(1:5, c("data.frame", "nrow", + "ncol", "content"))) + sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array") + sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates") + sumry[3, ] <- c("$l1", nrow(x$li), ncol(x$li), "row normed scores (variance weighted by $pr = 1)") + sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates") + sumry[5, ] <- c("$corav", nrow(x$corav), ncol(x$corav), "cor(habitat var., scores) for available points") + class(sumry) <- "table" + print(sumry) + if (length(names(x)) > 15) { cat("\nother elements: ") + cat(names(x)[16:(length(x))], "\n") + } } @@ -148,232 +158,297 @@ scatter.madifa <- function (x, xax = 1, yax = 2, pts = FALSE, percent = 95, Uborder, Acol, Ucol, Alty, Ulty, Abg, Ubg, Ainch, Uinch, ...) { - side <- match.arg(side) - if (!inherits(x, "madifa")) - stop("Object of class 'madifa' expected") - old.par <- par(no.readonly = TRUE) - on.exit(par(old.par)) - par(mar = c(0.1, 0.1, 0.1, 0.1), mfrow=c(1,2)) - x1 <- x$l1[, xax] - x1 <- c(x1 - diff(range(x1)/50), x1 + diff(range(x1))/50) - xlim <- range(x1) - y1 <- x$l1[, yax] - y1 <- c(y1 - diff(range(y1)/50), y1 + diff(range(y1))/50) - ylim <- range(y1) - scatterutil.base(dfxy = x$l1[, c(xax, yax)], xax = 1, yax = 2, - xlim = xlim, ylim = ylim, grid = TRUE, addaxes = FALSE, - cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "", - csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL, - area = NULL, add.plot = FALSE) - if (pts) { - if (missing(Acol)) - Acol <- gray(0.8) - if (missing(Ucol)) - Ucol <- "black" - if (missing(Abg)) - Abg <- gray(0.8) - if (missing(Ubg)) - Ubg <- "black" - if (missing(Ainch)) - Ainch <- 0.03 - if (missing(Uinch)) - Uinch <- Ainch * max(x$pr) - symbols(x$l1[, c(xax, yax)], circles = rep(1, length(x$pr)), - fg = Acol, bg = Abg, inches = Ainch, add = TRUE) - symbols(x$l1[x$pr > 0, c(xax, yax)], circles = x$pr[x$pr > 0], - fg = Ucol, bg = Ubg, - inches = Uinch, add = TRUE) - abline(v = 0) - abline(h = 0) - } - else { - if (missing(Adensity)) - Adensity <- NULL - if (missing(Udensity)) - Udensity <- NULL - if (missing(Aangle)) - Aangle <- 45 - if (missing(Uangle)) - Uangle <- 45 - if (missing(Aborder)) - Aborder <- NULL - if (missing(Uborder)) - Uborder <- NULL - if (missing(Acol)) - Acol <- gray(0.95) - if (missing(Ucol)) - Ucol <- gray(0.6) - if (missing(Alty)) - Alty <- NULL - if (missing(Ulty)) - Ulty <- NULL - mcpA <- mcp(x$l1[, c(xax, yax)], id = rep(1, dim(x$li)[1]), - percent = percent) - mcpU <- mcp(x$l1[rep(1:length(x$pr), x$pr), c(xax, yax)], - id = rep(1, sum(x$pr)), percent = percent) - polygon(mcpA[, 2:3], density = Adensity, angle = Aangle, - border = Aborder, col = Acol, lty = Alty) - polygon(mcpU[, 2:3], density = Udensity, angle = Uangle, - border = Uborder, col = Ucol, lty = Ulty) - abline(v = 0) - abline(h = 0) - } - dfarr <- x$co[, c(xax, yax)] - born <- par("usr") - k1 <- min(dfarr[, 1])/born[1] - k2 <- max(dfarr[, 1])/born[2] - k3 <- min(dfarr[, 2])/born[3] - k4 <- max(dfarr[, 2])/born[4] - k <- c(k1, k2, k3, k4) - dfarr <- 0.75 * dfarr/max(k) - xax <- paste("Axis", xax) - yax <- paste("Axis", yax) - if (side != "none") { - tra <- paste(" xax =", xax, "\n yax =", yax) - wt <- strwidth(tra, cex = 1) - ht <- strheight(tra, cex = 1) * 1.5 - xl <- par("usr")[1] - yu <- par("usr")[4] - yd <- par("usr")[3] - if (side == "top") { - rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) - text(xl + wt/2, yu - ht/2, tra, cex = 1) + ## Verifications + side <- match.arg(side) + if (!inherits(x, "madifa")) + stop("Object of class 'madifa' expected") + + ## Graphical settings + old.par <- par(no.readonly = TRUE) + on.exit(par(old.par)) + par(mar = c(0.1, 0.1, 0.1, 0.1), mfrow=c(1,2)) + + ## The bases for the graphs + x1 <- x$l1[, xax] + x1 <- c(x1 - diff(range(x1)/50), x1 + diff(range(x1))/50) + xlim <- range(x1) + y1 <- x$l1[, yax] + y1 <- c(y1 - diff(range(y1)/50), y1 + diff(range(y1))/50) + ylim <- range(y1) + + ## background graph + scatterutil.base(dfxy = x$l1[, c(xax, yax)], xax = 1, yax = 2, + xlim = xlim, ylim = ylim, grid = TRUE, + addaxes = FALSE, + cgrid = 1, include.origin = TRUE, origin = c(0, 0), + sub = "", + csub = 1.25, possub = "bottomleft", + pixmap = NULL, contour = NULL, + area = NULL, add.plot = FALSE) + + ## adds the points + if (pts) { + + ## graphical settings + if (missing(Acol)) + Acol <- gray(0.8) + if (missing(Ucol)) + Ucol <- "black" + if (missing(Abg)) + Abg <- gray(0.8) + if (missing(Ubg)) + Ubg <- "black" + if (missing(Ainch)) + Ainch <- 0.03 + if (missing(Uinch)) + Uinch <- Ainch * max(x$pr) + + ## the points + symbols(x$l1[, c(xax, yax)], circles = rep(1, length(x$pr)), + fg = Acol, bg = Abg, inches = Ainch, add = TRUE) + symbols(x$l1[x$pr > 0, c(xax, yax)], circles = x$pr[x$pr > 0], + fg = Ucol, bg = Ubg, + inches = Uinch, add = TRUE) + abline(v = 0) + abline(h = 0) + } else { + + ## graphical settings + if (missing(Adensity)) + Adensity <- NULL + if (missing(Udensity)) + Udensity <- NULL + if (missing(Aangle)) + Aangle <- 45 + if (missing(Uangle)) + Uangle <- 45 + if (missing(Aborder)) + Aborder <- NULL + if (missing(Uborder)) + Uborder <- NULL + if (missing(Acol)) + Acol <- gray(0.95) + if (missing(Ucol)) + Ucol <- gray(0.6) + if (missing(Alty)) + Alty <- NULL + if (missing(Ulty)) + Ulty <- NULL + + ## adds mcps + mcpA <- mcp(x$l1[, c(xax, yax)], id = rep(1, dim(x$li)[1]), + percent = percent) + mcpU <- mcp(x$l1[rep(1:length(x$pr), x$pr), c(xax, yax)], + id = rep(1, sum(x$pr)), percent = percent) + polygon(mcpA[, 2:3], density = Adensity, angle = Aangle, + border = Aborder, col = Acol, lty = Alty) + polygon(mcpU[, 2:3], density = Udensity, angle = Uangle, + border = Uborder, col = Ucol, lty = Ulty) + abline(v = 0) + abline(h = 0) } - if (side == "bottom") { - rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) - text(xl + wt/2, yd + ht/2, tra, cex = 1) + + ## Bases for the scores for the columns + dfarr <- x$co[, c(xax, yax)] + born <- par("usr") + k1 <- min(dfarr[, 1])/born[1] + k2 <- max(dfarr[, 1])/born[2] + k3 <- min(dfarr[, 2])/born[3] + k4 <- max(dfarr[, 2])/born[4] + k <- c(k1, k2, k3, k4) + dfarr <- 0.75 * dfarr/max(k) + + ## Legend + xax <- paste("Axis", xax) + yax <- paste("Axis", yax) + if (side != "none") { + tra <- paste(" xax =", xax, "\n yax =", yax) + wt <- strwidth(tra, cex = 1) + ht <- strheight(tra, cex = 1) * 1.5 + xl <- par("usr")[1] + yu <- par("usr")[4] + yd <- par("usr")[3] + if (side == "top") { + rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) + text(xl + wt/2, yu - ht/2, tra, cex = 1) + } + if (side == "bottom") { + rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) + text(xl + wt/2, yd + ht/2, tra, cex = 1) + } } - } - box() + box() - s.arrow(x$co, clabel = clabel) - box() + ## column scores + s.arrow(x$co, clabel = clabel) + box() } -hist.madifa <- function (x, scores = TRUE, type = c("h", "l"), adjust = 1, Acol, - Ucol, Aborder, Uborder, Alwd = 1, Ulwd = 1, ...) + + +hist.madifa <- function (x, scores = TRUE, type = c("h", "l"), + adjust = 1, Acol, + Ucol, Aborder, Uborder, Alwd = 1, Ulwd = 1, ...) { - type <- match.arg(type) - if (!inherits(x, "madifa")) - stop("Object of class 'madifa' expected") - if (scores) - tab <- x$li - else tab <- x$tab - pr <- x$pr - if (missing(Acol)) { - Acol <- NULL - Acolf <- "white" - Acold <- "black" - } - else { - Acold <- Acol - Acolf <- Acol + ## verifications + type <- match.arg(type) + if (!inherits(x, "madifa")) + stop("Object of class 'madifa' expected") + + ## which histogram should be drawn? + if (scores) + tab <- x$li + else tab <- x$tab + pr <- x$pr + + ## Graphical settings + if (missing(Acol)) { + Acol <- NULL + Acolf <- "white" + Acold <- "black" + } else { + Acold <- Acol + Acolf <- Acol } - if (missing(Aborder)) - Aborder <- "black" - if (missing(Ucol)) { - Ucol <- gray(0.8) - Ucold <- gray(0.8) - } - else Ucold <- Ucol - if (missing(Uborder)) - Uborder <- gray(0.8) - clas <- rep("", ncol(tab)) - for (j in 1:ncol(tab)) { - w1 <- "q" - if (is.factor(tab[, j])) - w1 <- "f" - clas[j] <- w1 - } - if (any(clas == "f") & type == "l") - warning("Type = 'l' is not possible for factors, type = 'h' used instead.\n") - old.par <- par(no.readonly = TRUE) - on.exit(par(old.par)) - par(mar = c(0.5, 0.5, 2, 0.5)) - par(mfrow = rev(n2mfrow(ncol(tab)))) - f1 <- function(j) { - tmpU <- rep(tab[, j], pr) - tmpA <- tab[, j] - name <- names(tab)[j] - if (clas[j] == "f") { - par(mar = c(3, 0.5, 2, 0.5)) - mat <- t(cbind(table(tmpA), table(tmpU))) - mat <- lapply(1:2, function(i) mat[i, ]/sum(mat[i, - ])) - mat <- rbind(mat[[1]], mat[[2]]) - max <- max(mat) - max <- max + max/20 - ylim <- c(0, max) - barplot(mat, col = c(Acolf, Ucol), border = c(Aborder, - Uborder), ylim = ylim, main = name, ylab = NULL, - axes = FALSE, beside = TRUE, ...) - par(mar = c(0.5, 0.5, 2, 0.5)) + if (missing(Aborder)) + Aborder <- "black" + if (missing(Ucol)) { + Ucol <- gray(0.8) + Ucold <- gray(0.8) } - else { - if (type == "h") { - xrange <- range(tmpA) - H <- hist(tmpU, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) - G <- hist(tmpA, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) - yrange <- c(0, max(H$density, G$density)) - plot(H, freq = FALSE, col = Ucol, border = Uborder, - xlim = xrange, ylim = yrange, main = name, - xlab = NULL, ylab = "Density", axes = FALSE, - ...) - plot(G, freq = FALSE, col = Acol, border = Aborder, - add = TRUE) - } - if (type == "l") { - densA <- density(tmpA, adjust = adjust) - densU <- density(tmpU, adjust = adjust, from = min(densA$x), - to = max(densA$x)) - max <- max(densU$y, densA$y) - max <- max + max/20 - ylim <- c(0, max) - plot(densU, col = Ucol, ylim = ylim, type = "l", - lwd = Ulwd, main = name, xlab = NULL, ylab = "Density", - axes = FALSE, ...) - lines(rep(mean(tmpU), 2), c(0, densU$y[512 - - sum(densU$x > mean(tmpU))]), col = Ucol, lty = 2, - lwd = Ulwd) - lines(densA, col = Acold, lwd = Alwd) - lines(rep(mean(tmpA), 2), c(0, densA$y[512 - - sum(densA$x > mean(tmpA))]), col = Acold, lty = 2, - lwd = Alwd) - } + else Ucold <- Ucol + if (missing(Uborder)) + Uborder <- gray(0.8) + clas <- rep("", ncol(tab)) + + + ## Quantitative or factor? + for (j in 1:ncol(tab)) { + w1 <- "q" + if (is.factor(tab[, j])) + w1 <- "f" + clas[j] <- w1 } - box() - } - lapply(1:ncol(tab), f1) - return(invisible(NULL)) + if (any(clas == "f") & type == "l") + warning("Type = 'l' is not possible for factors, type = 'h' used instead.\n") + + ## Graphical settings, again + old.par <- par(no.readonly = TRUE) + on.exit(par(old.par)) + par(mar = c(0.5, 0.5, 2, 0.5)) + par(mfrow = rev(n2mfrow(ncol(tab)))) + + ## The function used for plotting each variable + f1 <- function(j) { + + ## Use and availability + tmpU <- rep(tab[, j], pr) + tmpA <- tab[, j] + name <- names(tab)[j] + + if (clas[j] == "f") { + + ## in case of factors + par(mar = c(3, 0.5, 2, 0.5)) + mat <- t(cbind(table(tmpA), table(tmpU))) + mat <- lapply(1:2, function(i) mat[i, ]/sum(mat[i, + ])) + mat <- rbind(mat[[1]], mat[[2]]) + max <- max(mat) + max <- max + max/20 + ylim <- c(0, max) + barplot(mat, col = c(Acolf, Ucol), border = c(Aborder, + Uborder), ylim = ylim, main = name, ylab = NULL, + axes = FALSE, beside = TRUE, ...) + par(mar = c(0.5, 0.5, 2, 0.5)) + } + else { + + ## In case of continuous variables + + if (type == "h") { + + ## If an histogram is desired + xrange <- range(tmpA) + H <- hist(tmpU, plot = FALSE, br = seq(min(xrange), + max(xrange), length = 15)) + G <- hist(tmpA, plot = FALSE, br = seq(min(xrange), + max(xrange), length = 15)) + yrange <- c(0, max(H$density, G$density)) + plot(H, freq = FALSE, col = Ucol, border = Uborder, + xlim = xrange, ylim = yrange, main = name, + xlab = NULL, ylab = "Density", axes = FALSE, + ...) + plot(G, freq = FALSE, col = Acol, border = Aborder, + add = TRUE) + } + if (type == "l") { + + ## if a smoothing is wanted + densA <- density(tmpA, adjust = adjust) + densU <- density(tmpU, adjust = adjust, from = min(densA$x), + to = max(densA$x)) + max <- max(densU$y, densA$y) + max <- max + max/20 + ylim <- c(0, max) + plot(densU, col = Ucol, ylim = ylim, type = "l", + lwd = Ulwd, main = name, xlab = NULL, ylab = "Density", + axes = FALSE, ...) + lines(rep(mean(tmpU), 2), c(0, densU$y[512 - + sum(densU$x > + mean(tmpU))]), + col = Ucol, lty = 2, + lwd = Ulwd) + lines(densA, col = Acold, lwd = Alwd) + lines(rep(mean(tmpA), 2), c(0, densA$y[512 - + sum(densA$x > + mean(tmpA))]), + col = Acold, lty = 2, + lwd = Alwd) + } + } + box() + } + + ## applies f1 for each variable + lapply(1:ncol(tab), f1) + return(invisible(NULL)) } + + predict.madifa <- function (object, index, attr, nf, ...) - { - if (!inherits(object, "madifa")) +{ + ## Verifications + if (!inherits(object, "madifa")) stop("object should be of class 'madifa'") if ((missing(nf)) || (nf > object$nf)) - nf <- object$nf - ll <- apply(data.frame(object$l1[, 1:nf]),1, function(x) sum(object$cw * (x^2))) + nf <- object$nf + + ## sum of the squared scores of the variables + ll <- apply(data.frame(object$l1[, 1:nf]),1, + function(x) sum(object$cw * (x^2))) return(getkasc(df2kasc(data.frame(tt=ll, tu=ll), index, attr),1)) } s.madifa <- function(x, xax=1, yax=2, cgrid = 1, clab=1, ...) - { - mad <- x - if (!inherits(mad, "madifa")) - stop("Object of class 'madifa' expected") - co <- mad$co - cw <- mad$cw +{ + ## Verifications + if (!inherits(x, "madifa")) + stop("Object of class 'madifa' expected") + co <- x$co + cw <- x$cw out <- seq(1,-1,length=200) + + ## graphical settings opar <- par(mar=c(0,0,0,0)) on.exit(par(opar)) + ## trouvcoo finds the coordinates of the vertices of the ellipse trouvcoo <- function(co, cw, z, xax=1,yax=2) - { + { x <- co[,xax]*sqrt(cw) y <- co[,yax]*sqrt(cw) mat <- rbind(z, sqrt(1-(z^2))) @@ -382,15 +457,23 @@ s.madifa <- function(x, xax=1, yax=2, cgrid = 1, clab=1, ...) u2 <- c(sum(x*y), sqrt(1 - ((sum(x*y))^2))) out <- cbind(c(z,z[length(z):1]), apply(mat,2,function(x) sum(x*u2))) return(out) - } + } + + ## These coordinates are in yy yy <- trouvcoo(co, cw, out, xax, yax) + + ## The "outside" polygon, masking what is outside the ellipse pol <- data.frame(c(1,1,-1,-1,1,1),c(0,1,1,-1,-1,0)) po <- rbind(as.matrix(pol),yy) + + ## Draws the plot s.arrow(co, xax=xax, yax=yax, xlim=c(-1,1), ylim=c(-1,1), clab=clab) polygon(yy) polygon(po, col="white") s.arrow(co, xax=xax, yax=yax, xlim=c(-1,1), ylim=c(-1,1), add.p=TRUE, clab=clab, ...) + + ## scale box xaxp <- par("xaxp") ax <- (xaxp[2] - xaxp[1])/xaxp[3] yaxp <- par("yaxp") @@ -405,72 +488,104 @@ s.madifa <- function(x, xax=1, yax=2, cgrid = 1, clab=1, ...) rect(x1 - xh, y1 - yh, x1 + xh, y1 + yh, col = "white", border = 0) text(x1 - xh/2, y1 - yh/2, cha, cex = cex0) - } +} + + + plot.madifa <- function(x, index, attr, xax=1, yax=2, cont=TRUE,...) { - if (!inherits(mad, "madifa")) - stop("Object of class 'enfa' expected") - opar <- par(mfrow=c(3,3)) - on.exit(par(opar)) - scatterutil.eigen(x$eig, wsel = c(xax, yax)) - s.madifa(x, xax, yax, cgrid=2, clab=1.25) - - foo <- function() + + ## Verifications + if (!inherits(mad, "madifa")) + stop("Object of class 'enfa' expected") + + ## Graphical settings + opar <- par(mfrow=c(3,3)) + on.exit(par(opar)) + + ## The eigenvaloue diagram + scatterutil.eigen(x$eig, wsel = c(xax, yax)) + + ## Column scores + s.madifa(x, xax, yax, cgrid=2, clab=1.25) + + + ## Function to draw the niche + foo <- function() { - opar2 <- par(mar = c(0.1, 0.1, 0.1, 0.1)) - x1 <- x$l1[, xax] - x1 <- c(x1 - diff(range(x1)/50), x1 + diff(range(x1))/50) - xlim <- range(x1) - y1 <- x$l1[, yax] - y1 <- c(y1 - diff(range(y1)/50), y1 + diff(range(y1))/50) - ylim <- range(y1) - scatterutil.base(dfxy = x$l1[, c(xax, yax)], xax = 1, yax = 2, - xlim = xlim, ylim = ylim, grid = TRUE, addaxes = FALSE, - cgrid = 2, include.origin = TRUE, origin = c(0, 0), sub = "", - csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL, - area = NULL, add.plot = FALSE) - Acol <- gray(0.8) - Ucol <- "black" - Abg <- gray(0.8) - Ubg <- "black" - Ainch <- 0.03 - Uinch <- Ainch * max(x$pr) - symbols(x$l1[, c(xax, yax)], circles = rep(1, length(x$pr)), - fg = Acol, bg = Abg, inches = Ainch, add = TRUE) - symbols(x$l1[x$pr > 0, c(xax, yax)], circles = x$pr[x$pr > 0], - fg = Ucol, bg = Ubg, - inches = Uinch, add = TRUE) - abline(v = 0) - abline(h = 0) - box() - par(opar2) - } - foo() - ka <- df2kasc(data.frame(Maha=x$mahasu, - mod=apply(x$l1[,c(xax,yax)],1,function(x) sqrt(sum(x^2))), - xa=x$l1[,xax], ya=x$l1[,yax]), index, attr) - u <- par(mar=c(0.1,0.1,2,0.1)) - image(getkasc(ka,1),main="Mahalanobis distances", axes=F) - if (cont) - contour(getkasc(ka,1), add=T) - box() - image(getkasc(ka,2),main="From the analysis", axes=F) - if (cont) - contour(getkasc(ka,2), add=T) - box() - par(u) - - s.arrow(x$corav, xax=xax,yax=yax,sub="Cor(habitat var., scores) available", - clab=1.25, csub=2, cgrid=2, xlim=c(-1,1), ylim=c(-1,1)) - u <- par(mar=c(0.1,0.1,2,0.1)) - image(getkasc(ka,3),main="Axis 1", axes=F) - if (cont) - contour(getkasc(ka,3), add=T) - box() - image(getkasc(ka,4),main="Axis 2", axes=F) - if (cont) - contour(getkasc(ka,4), add=T) - box() - par(u) + ## Some bases for the plot + opar2 <- par(mar = c(0.1, 0.1, 0.1, 0.1)) + x1 <- x$l1[, xax] + x1 <- c(x1 - diff(range(x1)/50), x1 + diff(range(x1))/50) + xlim <- range(x1) + y1 <- x$l1[, yax] + y1 <- c(y1 - diff(range(y1)/50), y1 + diff(range(y1))/50) + ylim <- range(y1) + + ## Background plot + scatterutil.base(dfxy = x$l1[, c(xax, yax)], xax = 1, yax = 2, + xlim = xlim, ylim = ylim, + grid = TRUE, addaxes = FALSE, + cgrid = 2, include.origin = TRUE, + origin = c(0, 0), sub = "", + csub = 1.25, possub = "bottomleft", + pixmap = NULL, contour = NULL, + area = NULL, add.plot = FALSE) + + ## Graphical settings + Acol <- gray(0.8) + Ucol <- "black" + Abg <- gray(0.8) + Ubg <- "black" + Ainch <- 0.03 + Uinch <- Ainch * max(x$pr) + + ## adds available and used points + symbols(x$l1[, c(xax, yax)], circles = rep(1, length(x$pr)), + fg = Acol, bg = Abg, inches = Ainch, add = TRUE) + symbols(x$l1[x$pr > 0, c(xax, yax)], circles = x$pr[x$pr > 0], + fg = Ucol, bg = Ubg, + inches = Uinch, add = TRUE) + + ## axes + abline(v = 0) + abline(h = 0) + box() + par(opar2) + } + foo() + + ## The maps + ka <- df2kasc(data.frame(Maha=x$mahasu, + mod=apply(x$l1[,c(xax,yax)],1, + function(x) sqrt(sum(x^2))), + xa=x$l1[,xax], ya=x$l1[,yax]), index, attr) + u <- par(mar=c(0.1,0.1,2,0.1)) + image(getkasc(ka,1),main="Mahalanobis distances", axes=F) + if (cont) + contour(getkasc(ka,1), add=T) + box() + image(getkasc(ka,2),main="From the analysis", axes=F) + if (cont) + contour(getkasc(ka,2), add=T) + box() + par(u) + + ## Correlation with the environmental variables + s.arrow(x$corav, xax=xax,yax=yax, + sub="Cor(habitat var., scores) available", + clab=1.25, csub=2, cgrid=2, xlim=c(-1,1), ylim=c(-1,1)) + u <- par(mar=c(0.1,0.1,2,0.1)) + + ## Again the maps + image(getkasc(ka,3),main="Axis 1", axes=F) + if (cont) + contour(getkasc(ka,3), add=T) + box() + image(getkasc(ka,4),main="Axis 2", axes=F) + if (cont) + contour(getkasc(ka,4), add=T) + box() + par(u) } diff --git a/R/mahasuhab.r b/R/mahasuhab.r index 9f2c39e..328be18 100755 --- a/R/mahasuhab.r +++ b/R/mahasuhab.r @@ -1,45 +1,53 @@ -"mahasuhab" <- -function(kasc, pts, type=c("distance", "probability")) +"mahasuhab" <- function(kasc, pts, type=c("distance", "probability")) { - x<-pts - type<-match.arg(type) - if (!inherits(kasc, "kasc")) - stop("should be an object of class \"kasc\"") - if (ncol(x)!=2) - stop("x should have 2 columns") - kasc<-managNAkasc(kasc) - - ## utilisation: - hihi<-join.kasc(x, kasc) - used<-list() - for (i in 1:ncol(hihi)) { - if (is.factor(hihi[,i])) - used[[i]]<-acm.disjonctif(data.frame(hihi[,i]))[,-1] - else - used[[i]]<-hihi[,i] - } - used[[i+1]]<-rep(1, nrow(hihi)) - hihi<-as.data.frame(used) - hihi<-hihi[!is.na(hihi[,1]),] - mu<-apply(hihi,2, function(x) mean(x, na.rm=TRUE)) - varcov<-t(as.matrix(hihi))%*%as.matrix(hihi)/nrow(hihi) - - ## disponibilité - ava<-list() - for (i in 1:ncol(kasc)) { - if (is.factor(kasc[,i])) - ava[[i]]<-acm.disjonctif(data.frame(kasc[,i]))[,-1] - else - ava[[i]]<-kasc[,i] - } - ava[[i+1]]<-rep(1, nrow(kasc)) - df<-as.data.frame(ava) - map<-mahalanobis(as.matrix(df), mu, varcov) - if (type=="probability") - map<-1-pchisq(map, ncol(hihi)-1) - mat<-matrix(map, attr(kasc,"ncol"), attr(kasc,"nrow")) - mat<-getascattr(getkasc(kasc, names(kasc)[1]), mat) - - return(mat) + ## Verifications + x<-pts + type<-match.arg(type) + if (!inherits(kasc, "kasc")) + stop("should be an object of class \"kasc\"") + if (ncol(x)!=2) + stop("x should have 2 columns") + kasc<-managNAkasc(kasc) + + ## Computation of the variance-covariance matrix of the used points: + hihi<-join.kasc(x, kasc) + used<-list() + + ## factors are transformed into dummy variables + for (i in 1:ncol(hihi)) { + if (is.factor(hihi[,i])) + used[[i]]<-acm.disjonctif(data.frame(hihi[,i]))[,-1] + else + used[[i]]<-hihi[,i] + } + used[[i+1]]<-rep(1, nrow(hihi)) + hihi<-as.data.frame(used) + hihi<-hihi[!is.na(hihi[,1]),] + mu<-apply(hihi,2, function(x) mean(x, na.rm=TRUE)) + varcov<-t(as.matrix(hihi))%*%as.matrix(hihi)/nrow(hihi) + + + ## habitat Availability + ava<-list() + + ## factors are transformed into dummy variables + for (i in 1:ncol(kasc)) { + if (is.factor(kasc[,i])) + ava[[i]]<-acm.disjonctif(data.frame(kasc[,i]))[,-1] + else + ava[[i]]<-kasc[,i] + } + + ava[[i+1]]<-rep(1, nrow(kasc)) + df<-as.data.frame(ava) + + ## computation of the Mahalanobis distances + map<-mahalanobis(as.matrix(df), mu, varcov) + if (type=="probability") + map<-1-pchisq(map, ncol(hihi)-1) + mat<-matrix(map, attr(kasc,"ncol"), attr(kasc,"nrow")) + mat<-getascattr(getkasc(kasc, names(kasc)[1]), mat) + + return(mat) } diff --git a/R/managNAkasc.r b/R/managNAkasc.r index 5722823..9642be1 100755 --- a/R/managNAkasc.r +++ b/R/managNAkasc.r @@ -1,13 +1,14 @@ -"managNAkasc" <- -function(x) +"managNAkasc" <- function(x) { - if (!inherits(x,"kasc")) stop("non convenient data") - class(x)<-"data.frame" - ## Conservation que des pixels non NA pour toutes les cartes - tmpy<-is.na(x) - tmp<-apply(tmpy, 1, function(x) sum(as.numeric(x))) - x[tmp!=0,]<-rep(NA, ncol(x)) - class(x)<-c("kasc", "data.frame") - return(x) + ## Verifications + if (!inherits(x,"kasc")) stop("non convenient data") + class(x)<-"data.frame" + + ## We only keep the mapped pixels for ALL variables + tmpy<-is.na(x) + tmp<-apply(tmpy, 1, function(x) sum(as.numeric(x))) + x[tmp!=0,]<-rep(NA, ncol(x)) + class(x)<-c("kasc", "data.frame") + return(x) } diff --git a/R/mcp.area.r b/R/mcp.area.r index cee02b6..37b76aa 100755 --- a/R/mcp.area.r +++ b/R/mcp.area.r @@ -1,50 +1,59 @@ -"mcp.area" <- -function(xy, id, percent = seq(20,100, by=5), - unin=c("m", "km"), - unout=c("ha", "km2", "m2"), plotit = TRUE) - { - xy <- xy[!is.na(xy[, 1]), ] - xy <- xy[!is.na(xy[, 2]), ] - id <- id[!is.na(xy[, 1])] - id <- id[!is.na(xy[, 2])] +"mcp.area" <- function(xy, id, percent = seq(20,100, by=5), + unin=c("m", "km"), + unout=c("ha", "km2", "m2"), plotit = TRUE) +{ + ## Verifications unin<-match.arg(unin) unout<-match.arg(unout) if (length(id) != nrow(xy)) - stop("xy and id should be of the same length") + stop("xy and id should be of the same length") if (!require(gpclib)) - stop("package gpclib required") + stop("package gpclib required") + ## remove the missing values + xy <- xy[!is.na(xy[, 1]), ] + xy <- xy[!is.na(xy[, 2]), ] + id <- id[!is.na(xy[, 1])] + id <- id[!is.na(xy[, 2])] + + ## Bases lev<-percent res<-list() ar<-matrix(0,nrow=length(lev), ncol=nlevels(factor(id))) + + ## For each home range level, computes the MCP, and its area for (i in 1:length(lev)) { - res[[i]]<-mcp(xy, id, percent=lev[i]) - class(res[[i]])<-"data.frame" - res[[i]]<-split(res[[i]][,2:3], res[[i]][,1]) - for (j in 1:nlevels(factor(id))) - ar[i,j]<-area.poly(as(res[[i]][[j]], "gpc.poly")) + res[[i]]<-mcp(xy, id, percent=lev[i]) + class(res[[i]])<-"data.frame" + res[[i]]<-split(res[[i]][,2:3], res[[i]][,1]) + for (j in 1:nlevels(factor(id))) + ar[i,j]<-area.poly(as(res[[i]][[j]], "gpc.poly")) } + ar <- as.data.frame(ar) names(ar)<-levels(factor(id)) - ## modif des unités + + ## output units if (unin=="m") { - if (unout=="ha") - ar<-ar/10000 - if (unout=="km2") - ar<-ar/1000000 + if (unout=="ha") + ar<-ar/10000 + if (unout=="km2") + ar<-ar/1000000 } if (unin=="km") { - if (unout=="ha") - ar<-ar*100 - if (unout=="m2") - ar<-ar*1000000 + if (unout=="ha") + ar<-ar*100 + if (unout=="m2") + ar<-ar*1000000 } + + ## output row.names(ar)<-lev class(ar)<-c("hrsize", "data.frame") attr(ar, "units")<-unout if (plotit) plot(ar) return(ar) - } +} diff --git a/R/mcp.r b/R/mcp.r index fe2c45a..fe2ef5b 100755 --- a/R/mcp.r +++ b/R/mcp.r @@ -1,39 +1,44 @@ -"mcp" <- -function(xy, id, percent=95) +"mcp" <- function(xy, id, percent=95) { - xy<-xy[!is.na(xy[,1]),] - xy<-xy[!is.na(xy[,2]),] - id<-id[!is.na(xy[,1])] - id<-id[!is.na(xy[,2])] - if (length(id)!=nrow(xy)) stop("xy and id should be of the same length") - if (percent>100) { + ## Verifications + if (length(id)!=nrow(xy)) stop("xy and id should be of the same length") + if (percent>100) { warning("The MCP is estimated using all relocations (percent>100)") percent<-100 - } + } + if (min(table(id))<5) + stop("At least 5 relocations are required to fit an home range") - id<-factor(id) - if (min(table(id))<5) - stop("At least 5 relocations are required to fit an home range") + ## First remove the missing values + xy<-xy[!is.na(xy[,1]),] + xy<-xy[!is.na(xy[,2]),] + id<-id[!is.na(xy[,1])] + id<-id[!is.na(xy[,2])] + id<-factor(id) - r<-split(xy, id) - est.cdg<-function(xy) apply(xy, 2, mean) - cdg<-lapply(r,est.cdg) - levid<-levels(id) + ## Computes the centroid of the relocations for each animal + r<-split(xy, id) + est.cdg<-function(xy) apply(xy, 2, mean) + cdg<-lapply(r,est.cdg) + levid<-levels(id) -### Préparation des sorties - X<-0 - Y<-0 - ID<-"0" + ## Preparation of outputs + X<-0 + Y<-0 + ID<-"0" + + ## Then, for each animal... + for (i in 1:nlevels(id)) { - for (i in 1:nlevels(id)) { k<-levid[i] df.t<-r[[levid[i]]] cdg.t<-cdg[[levid[i]]] -### Calcul des distances au centre de gravité et conservation des plus proches + ## Distances from the relocations to the centroid: we keep + ## the "percent" closest dist.cdg<-function(xyt) { - d<-sqrt( ( (xyt[1]-cdg.t[1])^2 ) + ( (xyt[2]-cdg.t[2])^2 ) ) - return(d) + d<-sqrt( ( (xyt[1]-cdg.t[1])^2 ) + ( (xyt[2]-cdg.t[2])^2 ) ) + return(d) } di<-apply(df.t, 1, dist.cdg) @@ -43,21 +48,22 @@ function(xy, id, percent=95) xy.t<-df.t[acons,] - ## Coordonnées du MCP + ## Coordinates of the MCP coords.t<-chull(xy.t[,1], xy.t[,2]) xy.bord<-xy.t[coords.t,] X<-c(X,xy.bord[,1]) Y<-c(Y,xy.bord[,2]) ID<-c(ID, rep(as.character(levid[i]), nrow(xy.bord))) - } - - ID<-as.data.frame(ID) - res<-cbind.data.frame(ID,X,Y) - res<-res[-1,] - res[,1]<-factor(res[,1]) - names(res) <- c("ID","X","Y") - res<-as.area(res) - return(res) + } + + ## Outputs: an object of class "area" + ID<-as.data.frame(ID) + res<-cbind.data.frame(ID,X,Y) + res<-res[-1,] + res[,1]<-factor(res[,1]) + names(res) <- c("ID","X","Y") + res<-as.area(res) + return(res) } diff --git a/R/mcp.rast.r b/R/mcp.rast.r index b791efe..c04206f 100755 --- a/R/mcp.rast.r +++ b/R/mcp.rast.r @@ -1,31 +1,38 @@ -"mcp.rast" <- -function(poly, w) +"mcp.rast" <- function(poly, w) { - if (inherits(w, "asc")) - w <- as.kasc(list(to=w)) - if (!inherits(w, "kasc")) stop("non convenient data") - if (ncol(poly)!=2) - stop("poly should have two columns") - if (!all(poly[1,]==poly[nrow(poly),])) - poly<-rbind(poly, poly[1,]) - xy<-getXYcoords(w) - huhu<-getkasc(w, names(w)[1]) - huhu[is.na(huhu)]<--9999 + ## Verifications + if (inherits(w, "asc")) + w <- as.kasc(list(to=w)) + if (!inherits(w, "kasc")) stop("non convenient data") + if (ncol(poly)!=2) + stop("poly should have two columns") + ## The first and last relocations should be the same (closed polygon) + if (!all(poly[1,]==poly[nrow(poly),])) + poly<-rbind(poly, poly[1,]) - toto<-.C("rastpolaire", as.double(poly[,1]), as.double(poly[,2]), - as.double(xy$x), as.double(xy$y), as.double(t(huhu)), - as.integer(nrow(huhu)), as.integer(ncol(huhu)), - as.integer(nrow(poly)), PACKAGE="adehabitat") + ## prepares the data + xy<-getXYcoords(w) + huhu<-getkasc(w, names(w)[1]) + huhu[is.na(huhu)]<--9999 - output<-matrix(toto[[5]], nrow = nrow(huhu), byrow = TRUE) - output[output==0]<-NA + ## Use of the C function "rastpolaire" itself calling the C + ## function "rastpol" of the file "tests.c" of adehabitat + toto<-.C("rastpolaire", as.double(poly[,1]), as.double(poly[,2]), + as.double(xy$x), as.double(xy$y), as.double(t(huhu)), + as.integer(nrow(huhu)), as.integer(ncol(huhu)), + as.integer(nrow(poly)), PACKAGE="adehabitat") - attr(output, "xll")<-attr(w, "xll") - attr(output, "yll")<-attr(w, "yll") - attr(output, "cellsize")<-attr(w, "cellsize") - attr(output, "type")<-"numeric" - class(output)<-"asc" - return(output) + ## The output + output<-matrix(toto[[5]], nrow = nrow(huhu), byrow = TRUE) + output[output==0]<-NA + + attr(output, "xll")<-attr(w, "xll") + attr(output, "yll")<-attr(w, "yll") + attr(output, "cellsize")<-attr(w, "cellsize") + attr(output, "type")<-"numeric" + class(output)<-"asc" + return(output) } +## Another name for this function "area2asc" <- mcp.rast diff --git a/R/meanfpt.r b/R/meanfpt.r index bf31faf..230ac2b 100755 --- a/R/meanfpt.r +++ b/R/meanfpt.r @@ -1,28 +1,36 @@ -"meanfpt" <- -function(f, graph=TRUE) - { +"meanfpt" <- function(f, graph=TRUE) +{ + ## Verifications if (!inherits(f, "fipati")) - stop("x should be of class 'fipati'") + stop("x should be of class 'fipati'") + + ## Graphical setting if (graph) - opar <- par(mfrow=n2mfrow(length(f))) + opar <- par(mfrow=n2mfrow(length(f))) + + ## gets the radii s <- attr(f, "radii") + + ## Computes and plots the mean FPT for each radius and for each burst soso <- lapply(f, function(y) { - so <- apply(y,2,function(z) mean(z, na.rm=TRUE)) - if (graph) - plot(s, so, ty="l", xlab="scale", ylab="Mean of FPT", - main=attr(y,"burst")) - return(so) + so <- apply(y,2,function(z) mean(z, na.rm=TRUE)) + if (graph) + plot(s, so, ty="l", xlab="scale", ylab="Mean of FPT", + main=attr(y,"burst")) + return(so) }) + + ## output soso <- as.data.frame(do.call("rbind",soso)) row.names(soso) <- unlist(lapply(f, function(z) attr(z, "burst"))) names(soso) <- paste("r",1:ncol(soso), sep="") attr(soso, "radii") <- attr(f,"radii") if (graph) - par(opar) + par(opar) if (graph) { - invisible(soso) + invisible(soso) } else { - return(soso) + return(soso) } - } +} diff --git a/R/morphology.r b/R/morphology.r index 3bbfe59..54af04d 100755 --- a/R/morphology.r +++ b/R/morphology.r @@ -1,6 +1,6 @@ -"morphology" <- -function(x, operation = c("erode", "dilate"), nt=5) - { +"morphology" <- function(x, operation = c("erode", "dilate"), nt=5) +{ + ## Verifications op<-match.arg(operation) if (nt<1) stop("nt should be > 0") @@ -10,7 +10,8 @@ function(x, operation = c("erode", "dilate"), nt=5) ope<-1 if (!inherits(x,"asc")) stop("should be of class asc") - + + ## Bases nc<-ncol(x) nr<-nrow(x) tmpc<-rep(NA,nc) @@ -20,15 +21,18 @@ function(x, operation = c("erode", "dilate"), nt=5) o<-as.vector(t(u)) o[!is.na(o)]<-1 o[is.na(o)]<-0 - + + ## External call to the C function "erodil" res<-.C("erodil", as.double(o), as.integer(nr+2), as.integer(nc+2), as.integer(nt), as.integer(ope), PACKAGE="adehabitat") + + ## Output res[[1]][res[[1]]==0]<-NA gr<-matrix(res[[1]], nrow=(nr+2), byrow=TRUE) gr <- gr[-c(1, nrow(gr)), -c(1, ncol(gr))] if (all(is.na(gr))) - stop("all the image has been erased\n Please consider a lower value for nt") + stop("all the image has been erased\n Please consider a lower value for nt") gr<-getascattr(x,gr) return(gr) - } +} diff --git a/R/niche.test.r b/R/niche.test.r index 05a151c..cf9c464 100755 --- a/R/niche.test.r +++ b/R/niche.test.r @@ -1,19 +1,24 @@ -"niche.test" <- -function (kasc, points, nrep = 999, o.include = TRUE, ...) +"niche.test" <- function (kasc, points, nrep = 999, o.include = TRUE, ...) { - if (!inherits(kasc, "kasc")) + ## Verifications + if (!inherits(kasc, "kasc")) stop("should be an object of class \"kasc\"") - if (ncol(points) != 2) + if (ncol(points) != 2) stop("points should have 2 columns") nrep <- nrep + 1 toto <- join.kasc(points, kasc) tutu <- apply(toto, 1, function(x) any(is.na(x))) - if (sum(tutu) > 0) + if (sum(tutu) > 0) stop("points outside the study area") + + + ## conversion factors -> dummy variables litab <- kasc2df(kasc) dude <- dudi.mix(litab$tab, scannf = FALSE) cw <- dude$cw kasc <- df2kasc(dude$tab, litab$index, kasc) + + ## prepare the data for the external call asc <- getkasc(kasc, names(kasc)[1]) coo <- getXYcoords(kasc) rc <- lapply(coo, range) @@ -21,17 +26,23 @@ function (kasc, points, nrep = 999, o.include = TRUE, ...) kasc[is.na(kasc)] <- -9999 asc[is.na(asc)] <- -9999 xp <- as.matrix(points) - toto <- .C("randmargtolpts", as.double(t(xp)), as.double(rc$x), - as.double(rc$y), as.double(t(asc)), as.double(cw), as.double(t(kasc)), - as.double(coo$x), as.double(coo$y), as.double(attr(asc, - "cellsize")), double(nrep), double(nrep), as.integer(nrep), - as.integer(nrow(asc)), as.integer(ncol(asc)), as.integer(ncol(kasc)), - as.integer(nrow(xp)), PACKAGE = "adehabitat") + + ## External call to the function randmargtolpts + toto <- .C("randmargtolpts", as.double(t(xp)), as.double(rc$x), + as.double(rc$y), as.double(t(asc)), as.double(cw), + as.double(t(kasc)), as.double(coo$x), as.double(coo$y), + as.double(attr(asc,"cellsize")), double(nrep), + double(nrep), as.integer(nrep), + as.integer(nrow(asc)), as.integer(ncol(asc)), + as.integer(ncol(kasc)), as.integer(nrow(xp)), + PACKAGE = "adehabitat") + + ## Output mar <- toto[[10]] tol <- toto[[11]] dfxy <- data.frame(marginalite = mar, tolerance = tol)[-1,] obs <- c(mar[1], tol[1]) - biv.test(dfxy, obs, sub = "Tests of\nmarginality\nand tolerance", + biv.test(dfxy, obs, sub = "Tests of\nmarginality\nand tolerance", o.include = o.include, ...) return(invisible(list(dfxy = dfxy, obs = obs))) } diff --git a/R/perarea.r b/R/perarea.r index 70c1f95..6b10ed8 100755 --- a/R/perarea.r +++ b/R/perarea.r @@ -1,19 +1,24 @@ -"perarea" <- -function(x) - { +"perarea" <- function(x) +{ + ## Verifications if (!inherits(x, "area")) - stop("x should be of class \"area\"") + stop("x should be of class \"area\"") + uu <- split(x[,2:3], x[,1]) + + ## The function foo computes the perimeter of a polygon foo <- function(x) { - if (!all(x[1,]==x[nrow(x),])) - x <- rbind(x,x[nrow(x),]) - x1 <- x[-1,] - x2 <- x[-nrow(x),] - di <- sum(sqrt(((x2[,1]-x1[,1])^2)+((x2[,2]-x1[,2])^2))) - return(di) + if (!all(x[1,]==x[nrow(x),])) + x <- rbind(x,x[nrow(x),]) + x1 <- x[-1,] + x2 <- x[-nrow(x),] + di <- sum(sqrt(((x2[,1]-x1[,1])^2)+((x2[,2]-x1[,2])^2))) + return(di) } + + ## output res <- unlist(lapply(uu, foo)) names(res) <- names(uu) return(res) - } +} diff --git a/R/persp.asc.r b/R/persp.asc.r index 8e73539..ed7a96d 100755 --- a/R/persp.asc.r +++ b/R/persp.asc.r @@ -1,13 +1,15 @@ -"persp.asc" <- -function(x, ...) +"persp.asc" <- function(x, ...) { - if (!inherits(x, "asc")) stop("not an \"asc\" object") - if (attr(x, "type")=="factor") - stop("function persp cannot be used with factors") - z<-x - xy<-getXYcoords(z) - x<-xy$x - y<-xy$y - persp(x=x, y=y, z, ...) + ## Verifications + if (!inherits(x, "asc")) stop("not an \"asc\" object") + if (attr(x, "type")=="factor") + stop("function persp cannot be used with factors") + + ## The plot + z<-x + xy<-getXYcoords(z) + x<-xy$x + y<-xy$y + persp(x=x, y=y, z, ...) } diff --git a/R/plot.area.r b/R/plot.area.r index 7d8365a..06c9fb8 100755 --- a/R/plot.area.r +++ b/R/plot.area.r @@ -1,13 +1,15 @@ -"plot.area" <- -function(x, which=levels(x[,1]), - colpol = rep("green", nlevels(x[,1])), - colborder = rep("black", nlevels(x[,1])), - lwd = 2, add = FALSE, ...) - { +"plot.area" <- function(x, which=levels(x[,1]), + colpol = rep("green", nlevels(x[,1])), + colborder = rep("black", nlevels(x[,1])), + lwd = 2, add = FALSE, ...) +{ + ## Verifications if (!inherits(x, "area")) - stop("x should be of class \"area\"") + stop("x should be of class \"area\"") + ## draws a graph is add = FALSE if (!add) - plot.default(x[,2:3], type = "n", asp = 1,...) + plot.default(x[,2:3], type = "n", asp = 1,...) + ## adds the polygons li <- split(x[,2:3], x[,1]) lapply(1:length(which), function(i) polygon(li[[which[i]]], col = colpol[i], diff --git a/R/plot.asc.r b/R/plot.asc.r index ec885b9..912f79b 100755 --- a/R/plot.asc.r +++ b/R/plot.asc.r @@ -1,11 +1,13 @@ -"plot.asc" <- -function(x, ...) +"plot.asc" <- function(x, ...) { - if (!inherits(x, "asc")) - stop("should be an object of class \"asc\"") - if (attr(x, "type")=="factor") - stop("not implemented for factors") - xy<-getXYcoords(x) - filled.contour(xy$x, xy$y, x, asp=1, ...) + ## Verifications + if (!inherits(x, "asc")) + stop("should be an object of class \"asc\"") + if (attr(x, "type")=="factor") + stop("not implemented for factors") + + ## The plot + xy<-getXYcoords(x) + filled.contour(xy$x, xy$y, x, asp=1, ...) } diff --git a/R/plot.fipati.r b/R/plot.fipati.r index 89b9608..99b9692 100755 --- a/R/plot.fipati.r +++ b/R/plot.fipati.r @@ -1,19 +1,27 @@ -"plot.fipati" <- -function(x, scale, warn = TRUE, ...) - { +"plot.fipati" <- function(x, scale, warn = TRUE, ...) +{ + ## Verifications if (!inherits(x, "fipati")) - stop("x should be of class 'fipati'") + stop("x should be of class 'fipati'") + + ## graphical settings opar <- par(mfrow=n2mfrow(length(x))) + + ## radius att <- attr(x, "radii") + + ## Does the specified scale exists? ind <- which.min(abs(att-scale)) if (warn) - if (abs(att[ind] - scale) > 1e-7) - warning(paste("No radius equal to ",scale, - ", displayed radius is ", att[ind], sep ="")) + if (abs(att[ind] - scale) > 1e-7) + warning(paste("No radius equal to ",scale, + ", displayed radius is ", att[ind], sep ="")) + + ## Draws the plot lapply(1:length(x), function(i) { - u <- x[[i]] - plot(attr(u,"date"), u[,ind], main = attr(u, "burst"), ylab="FPT",...) - lines(attr(u,"date"), u[,ind])}) + u <- x[[i]] + plot(attr(u,"date"), u[,ind], main = attr(u, "burst"), ylab="FPT",...) + lines(attr(u,"date"), u[,ind])}) par(opar) - } +} diff --git a/R/plot.hrsize.r b/R/plot.hrsize.r index c33630f..b55cdbf 100755 --- a/R/plot.hrsize.r +++ b/R/plot.hrsize.r @@ -1,9 +1,14 @@ plot.hrsize <- function (x, ...) { + ## Verifications if (!inherits(x, "hrsize")) stop("should be of class hrsize") + + ## Graphical settings opar <- par(mfrow = n2mfrow(ncol(x))) on.exit(par(opar)) + + ## The labels if (!is.null(attr(x, "xlabel"))) { xlabel <- attr(x, "xlabel") } else { @@ -15,6 +20,7 @@ plot.hrsize <- function (x, ...) ylabel <- paste("Home-range size (", attr(x, "units"), ")", sep = "") } + ## The plot for (i in 1:ncol(x)) { plot(as.numeric(row.names(x)), x[, i], main = names(x)[i], pch = 16, cex = 0.5, xlab = xlabel, ylab = ylabel) diff --git a/R/plot.kselect.r b/R/plot.kselect.r index c092985..a538d64 100755 --- a/R/plot.kselect.r +++ b/R/plot.kselect.r @@ -1,66 +1,82 @@ -"plot.kselect" <- -function(x, xax=1, yax=2, ...) +"plot.kselect" <- function(x, xax=1, yax=2, ...) { - if (!inherits(x, "kselect")) + ## Verifications + if (!inherits(x, "kselect")) stop("Use only with 'kselect' objects") if (x$nf == 1) { warnings("One axis only : not yet implemented") return(invisible()) } - if (xax > x$nf) - stop("Non convenient xax") - if (yax > x$nf) - stop("Non convenient yax") - def.par <- par(no.readonly = TRUE) - on.exit(par(def.par)) + if (xax > x$nf) + stop("Non convenient xax") + if (yax > x$nf) + stop("Non convenient yax") + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + ## The layout of the graphs + nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), + respect = TRUE) + par(mar = c(0.1, 0.1, 0.1, 0.1)) - - nf <- layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), - respect = TRUE) - par(mar = c(0.1, 0.1, 0.1, 0.1)) - s.corcircle(x$as, xax, yax, sub = "Axis", csub = 2, clab = 1.25) - s.arrow(x$l1, xax, yax, sub = "Variables", csub = 2, clab = 1.25) - scatterutil.eigen(x$eig, wsel = c(xax, yax)) + ## 1. correlations between the PCA axes and the K-select axes + s.corcircle(x$as, xax, yax, sub = "Axis", csub = 2, clab = 1.25) - ## Graphe principal... - ## polygones, vecteurs, et en tout petit, les ru - ## 1. Calcul des RU - U<-as.matrix(x$l1*x$lw) - ls<-as.matrix(x$initab)%*%U - liani<-split(as.data.frame(ls), x$initfac) - liwei<-split(x$initwei, x$initfac) + ## 2. scores of the environmental variables on the + ## K-select axes (eigenvectors) + s.arrow(x$l1, xax, yax, sub = "Variables", csub = 2, clab = 1.25) - mav<-as.data.frame(t(as.matrix(data.frame(lapply(liani, function(x) apply(x, 2, mean)))))) - names(mav)<-names(x$li) - mutemp<-list() - for (i in 1:length(liwei)) - mutemp[[i]]<-apply(liani[[i]], 2, function(x) weighted.mean(x, liwei[[i]])) - mut<-as.data.frame(t(as.matrix(data.frame(mutemp)))) + ## 3. the eigenvalues of the analysis + scatterutil.eigen(x$eig, wsel = c(xax, yax)) - names(mut)<-names(x$li) - row.names(mut)<-names(x$tab) - row.names(mav)<-names(x$tab) - s.label(rbind(mav, mut), xax, yax, clab = 0, cpo = 0, sub = "Marginality vectors", - csub = 2) - + ## 4. main graph: coordinates of the uncentered marginality vectors - for (i in 1:length(liani)) - arrows(mav[i,xax], mav[i,yax], mut[i,xax], mut[i,yax], lwd=2, angle=20) - s.label(mav, xax, yax, add.plot=TRUE, clab=1.5) - - - ## Resource units - s.class(as.data.frame(ls), x$initfac, cstar=0, cellipse=0, clab=1.5, sub="Available Resource units", csub=2) - - for (i in 1:length(liani)) - polygon(liani[[i]][chull(liani[[i]][,xax], liani[[i]][,yax]),xax], - liani[[i]][chull(liani[[i]][,xax], liani[[i]][,yax]),yax]) + ## 4.1. We project the available points (all animals pooled) on + ## the axes of the K-select: matrix U (rows: points, columns: axes) + U<-as.matrix(x$l1*x$lw) + ls<-as.matrix(x$initab)%*%U - ## Animals - s.arrow(x$co, xax, yax, clab = 1.25, cpo = 0.5, sub = "Animals", - csub = 2) - + ## 4.2. coordinates of the "available centroids" on the axes + ## of the K-select + liani<-split(as.data.frame(ls), x$initfac) + liwei<-split(x$initwei, x$initfac) + mav<-as.data.frame(t(as.matrix(data.frame(lapply(liani, + function(x) apply(x, 2, mean)))))) + names(mav)<-names(x$li) + row.names(mav)<-names(x$tab) + + ## 4.3. coordinates of the "used centroids" on the axes + ## of the K-select + mutemp<-list() + for (i in 1:length(liwei)) + mutemp[[i]]<-apply(liani[[i]], 2, function(x) weighted.mean(x, liwei[[i]])) + mut<-as.data.frame(t(as.matrix(data.frame(mutemp)))) + names(mut)<-names(x$li) + row.names(mut)<-names(x$tab) + + ## 4.4. The Marginality vectors are displayed as arrows connecting the + ## "available" centroids to the "used" centroids + + s.label(rbind(mav, mut), xax, yax, clab = 0, cpo = 0, + sub = "Marginality vectors", csub = 2) ## background + for (i in 1:length(liani)) + arrows(mav[i,xax], mav[i,yax], mut[i,xax], mut[i,yax], + lwd=2, angle=20) ## arrows + s.label(mav, xax, yax, add.plot=TRUE, clab=1.5) ## labels + + + ## 5. coordinates of the uncentered available points on the + ## axes of the K-select + s.class(as.data.frame(ls), x$initfac, cstar=0, + cellipse=0, clab=1.5, sub="Available Resource units", csub=2) + for (i in 1:length(liani)) + polygon(liani[[i]][chull(liani[[i]][,xax], liani[[i]][,yax]),xax], + liani[[i]][chull(liani[[i]][,xax], liani[[i]][,yax]),yax]) + + ## 6. coordinates of the recentred marginality vectors on the axes + ## on the K-select + s.arrow(x$co, xax, yax, clab = 1.25, cpo = 0.5, sub = "Animals", + csub = 2) } diff --git a/R/plot.kver.r b/R/plot.kver.r index cd486da..0af05fb 100755 --- a/R/plot.kver.r +++ b/R/plot.kver.r @@ -1,24 +1,26 @@ -"plot.kver" <- -function(x, which = names(x), colpol=rainbow(length(which)), - colborder=rep("black", length(which)), lwd = 2, - add=FALSE, ...) - { +"plot.kver" <- function(x, which = names(x), colpol=rainbow(length(which)), + colborder=rep("black", length(which)), lwd = 2, + add=FALSE, ...) +{ + ## Verifications if (!inherits(x, "kver")) - stop("x should be of class kver") + stop("x should be of class kver") x <- x[which] + ## A first plot if the plot is not to be added to another plot if (!add) { xc <- unlist(lapply(x, function(y) y[,2])) yc <- unlist(lapply(x, function(y) y[,3])) plot(xc, yc, asp=1, ty="n", ...) } - + + ## The plot lapply(1:length(x), function(i) plot.area(x[[i]], colpol = rep(colpol[i], nlevels(x[[i]][,1])), colborder = rep(colborder[i], nlevels(x[[i]][,1])), lwd = lwd, add = TRUE)) - invisible(NULL) + invisible(NULL) } diff --git a/R/plot.ltraj.r b/R/plot.ltraj.r index 58c089e..50c4386 100755 --- a/R/plot.ltraj.r +++ b/R/plot.ltraj.r @@ -5,100 +5,100 @@ plot.ltraj <- function (x, id = unique(unlist(lapply(x, attr, which="id"))), colpol = "green", addpoints = TRUE, addlines = TRUE, perani = TRUE, final = TRUE, ...) { - polygon <- area - if (!is.null(area)) { - if (!inherits(area, "area")) - stop("area should be an object of class area") - } - if (!inherits(x, "ltraj")) - stop("x should be an object of class ltraj") + polygon <- area + if (!is.null(area)) { + if (!inherits(area, "area")) + stop("area should be an object of class area") + } + if (!inherits(x, "ltraj")) + stop("x should be an object of class ltraj") - ## supprimer les NA - x <- lapply(x, function(i) { - jj <- i[!is.na(i$x),] - attr(jj, "id") <- attr(i,"id") - attr(jj, "burst") <- attr(i,"burst") - return(jj) - }) - class(x) <- c("ltraj","list") - id <- id - burst <- burst - x <- ltraj2traj(x) - i <- split(x, x$id) - x <- do.call("rbind", i[id]) - x$id <- factor(x$id) - x$burst <- factor(x$burst) - bu <- levels(x$burst) - burst <- burst[burst%in%bu] + ## supprimer les NA + x <- lapply(x, function(i) { + jj <- i[!is.na(i$x),] + attr(jj, "id") <- attr(i,"id") + attr(jj, "burst") <- attr(i,"burst") + return(jj) + }) + class(x) <- c("ltraj","list") + id <- id + burst <- burst + x <- ltraj2traj(x) + i <- split(x, x$id) + x <- do.call("rbind", i[id]) + x$id <- factor(x$id) + x$burst <- factor(x$burst) + bu <- levels(x$burst) + burst <- burst[burst%in%bu] - i <- split(x, x$burst) - x <- do.call("rbind", i[burst]) - x$id <- factor(x$id) - x$burst <- factor(x$burst) + i <- split(x, x$burst) + x <- do.call("rbind", i[burst]) + x$id <- factor(x$id) + x$burst <- factor(x$burst) - if (!perani) - idc <- "burst" - else idc <- "id" - li <- split(x, x[[idc]]) - id <- levels(x[[idc]]) - if (length(li)>1) - opar <- par(mar = c(0.1, 0.1, 2, 0.1), mfrow = n2mfrow(length(li))) - m <- unlist(lapply(li, function(x) mean(x$date))) - nli <- names(li) - nli <- nli[order(m)] + if (!perani) + idc <- "burst" + else idc <- "id" + li <- split(x, x[[idc]]) + id <- levels(x[[idc]]) + if (length(li)>1) + opar <- par(mar = c(0.1, 0.1, 2, 0.1), mfrow = n2mfrow(length(li))) + m <- unlist(lapply(li, function(x) mean(x$date))) + nli <- names(li) + nli <- nli[order(m)] - if (is.null(xlim)) { - maxxl <- max(unlist(lapply(li, function(ki) range(ki$x)[2] - range(ki$x)[1]))) - xlim <- lapply(li, function(ki) c(min(ki$x), min(ki$x)+maxxl)) - } else { - ma <- max(unlist(lapply(li, function(ki) range(ki$x)[2]))) - mi <- min(unlist(lapply(li, function(ki) range(ki$x)[1]))) - xlim <- lapply(li, function(ki) c(mi,ma)) - } - if (is.null(ylim)) { - maxyl <- max(unlist(lapply(li, function(ki) range(ki$y)[2] - range(ki$y)[1]))) - ylim <- lapply(li, function(ki) c(min(ki$y), min(ki$y)+maxyl)) + if (is.null(xlim)) { + maxxl <- max(unlist(lapply(li, function(ki) range(ki$x)[2] - range(ki$x)[1]))) + xlim <- lapply(li, function(ki) c(min(ki$x), min(ki$x)+maxxl)) + } else { + ma <- max(unlist(lapply(li, function(ki) range(ki$x)[2]))) + mi <- min(unlist(lapply(li, function(ki) range(ki$x)[1]))) + xlim <- lapply(li, function(ki) c(mi,ma)) + } + if (is.null(ylim)) { + maxyl <- max(unlist(lapply(li, function(ki) range(ki$y)[2] - range(ki$y)[1]))) + ylim <- lapply(li, function(ki) c(min(ki$y), min(ki$y)+maxyl)) } else { - ma <- max(unlist(lapply(li, function(ki) range(ki$y)[2]))) - mi <- min(unlist(lapply(li, function(ki) range(ki$y)[1]))) - ylim <- lapply(li, function(ki) c(mi,ma)) + ma <- max(unlist(lapply(li, function(ki) range(ki$y)[2]))) + mi <- min(unlist(lapply(li, function(ki) range(ki$y)[1]))) + ylim <- lapply(li, function(ki) c(mi,ma)) } - names(xlim) <- names(li) - names(ylim) <- names(li) + names(xlim) <- names(li) + names(ylim) <- names(li) - for (i in nli) { + for (i in nli) { if (!is.null(asc)) - image(asc, col = colasc, xlim = xlim[i][[1]], ylim = ylim[i][[1]], - main = i, - axes = (length(li)==1), ...) + image(asc, col = colasc, xlim = xlim[i][[1]], ylim = ylim[i][[1]], + main = i, + axes = (length(li)==1), ...) else plot(li[i][[1]]$x, li[i][[1]]$y, type = "n", asp = 1, xlim = xlim[i][[1]], ylim = ylim[i][[1]], axes = (length(li)==1), main = i, ...) box() if (!is.null(polygon)) { - pol <- split(polygon[, 2:3], factor(polygon[, 1])) - for (j in 1:length(pol)) polygon(pol[[j]], col = colpol) + pol <- split(polygon[, 2:3], factor(polygon[, 1])) + for (j in 1:length(pol)) polygon(pol[[j]], col = colpol) } if (addlines) { - for (j in levels(factor(li[[i]]$burst))) { - lines(x$x[x$burst == j], x$y[x$burst == j]) - } + for (j in levels(factor(li[[i]]$burst))) { + lines(x$x[x$burst == j], x$y[x$burst == j]) + } } if (addpoints) { - for (j in levels(factor(li[[i]]$burst))) { - points(x$x[x$burst == j], x$y[x$burst == j], - pch = 21, col = "black", bg = "white") - } + for (j in levels(factor(li[[i]]$burst))) { + points(x$x[x$burst == j], x$y[x$burst == j], + pch = 21, col = "black", bg = "white") + } } if (final) { for (j in levels(factor(li[[i]]$burst))) { - points(x$x[x$burst == j][c(1, length(x$x[x$burst == + points(x$x[x$burst == j][c(1, length(x$x[x$burst == j]))], x$y[x$burst == j][c(1, length(x$y[x$burst == - j]))], pch = 14, col = c("blue", "red")) + j]))], pch = 14, col = c("blue", "red")) } - } } - if (length(li)>1) +} + if (length(li)>1) par(opar) } diff --git a/R/plot.sahrlocs.r b/R/plot.sahrlocs.r index 2d90b0b..1e3577f 100755 --- a/R/plot.sahrlocs.r +++ b/R/plot.sahrlocs.r @@ -1,86 +1,122 @@ -"plot.sahrlocs" <- -function(x, ani=names(x$hr), - var=names(x$sa), - type=c("hr.in.sa", "locs.in.hr", "locs.in.sa"), - ncla=4, ylog = FALSE, - caxis = 0.7, clab = 0.7, - errbar=c("SE", "CI"), alpha=0.05, - draw=TRUE, ...) +"plot.sahrlocs" <- function(x, ani=names(x$hr), + var=names(x$sa), + type=c("hr.in.sa", "locs.in.hr", "locs.in.sa"), + ncla=4, ylog = FALSE, + caxis = 0.7, clab = 0.7, + errbar=c("SE", "CI"), alpha=0.05, + draw=TRUE, ...) { - type<-match.arg(type) - errbar<-match.arg(errbar) - if (!inherits(x, "sahrlocs")) - stop("should be an object of class \"sahrlocs\"") - if (any(is.na(match(ani, names(x$hr))))) - stop(paste("\"", - ani[is.na(match(ani, names(x$hr)))], - "\" is not a valid name")) - if (length(ani)<2) - stop("please select at least 2 individuals") - - if (any(is.na(match(var, names(x$sa))))) - stop(paste("\"", - var[is.na(match(var, names(x$sa)))], - "\" is not a valid variable")) - ngraph<-length(var)+1 - if (draw) { - opar<-par(mfrow=c(1,2), ask=TRUE) - on.exit(par(opar)) - } - ## liste de sortie - liso<-list() - ty<-strsplit(type, ".in.")[[1]] - - for (i in var) { - v<-x$sa[[i]] - - ## ordonner les wi? - if (is.factor(v)) - noorder<-TRUE - else - noorder<-FALSE - - if (!is.factor(v)) - v<-cut(v, breaks=ncla) - if (ty[2]=="sa") { - av<-table(v) - nav<-names(av) - av<-as.vector(av) - names(av)<-nav - if (ty[1]=="locs") { - locs<-x$locs[ani] - us<-t(as.matrix(as.data.frame(apply(locs,2,function(x) table(rep(v, x)))))) - liso[[i]]<-widesII(us, av, alpha=alpha) - if (draw) - plot(liso[[i]], ylog=ylog, main=i, clab=clab, caxis=caxis, errbar=errbar, noorder=noorder) - } - else { - hr<-x$hr[ani] - hr <- as.data.frame(apply(hr, 2, function(x) {x[is.na(x)] <- 0; return(x)})) - us<-t(as.matrix(as.data.frame(apply(hr,2,function(x) table(rep(v, x)))))) - liso[[i]]<-widesII(us, av, alpha=alpha) - if (draw) - plot(liso[[i]], ylog=FALSE, main=i, clab=clab, caxis=caxis, errbar=errbar, noorder=noorder) - } + ## Verifications + type<-match.arg(type) + errbar<-match.arg(errbar) + if (!inherits(x, "sahrlocs")) + stop("should be an object of class \"sahrlocs\"") + if (any(is.na(match(ani, names(x$hr))))) + stop(paste("\"", + ani[is.na(match(ani, names(x$hr)))], + "\" is not a valid name")) + if (length(ani)<2) + stop("please select at least 2 individuals") + if (any(is.na(match(var, names(x$sa))))) + stop(paste("\"", + var[is.na(match(var, names(x$sa)))], + "\" is not a valid variable")) + + ## Graphical settings + ngraph<-length(var)+1 + if (draw) { + opar<-par(mfrow=c(1,2), ask=TRUE) + on.exit(par(opar)) } - else { - hr<-x$hr[ani] - hr <- as.data.frame(apply(hr, 2, function(x) {x[is.na(x)] <- 0; return(x)})) - av<-t(as.matrix(as.data.frame(apply(hr,2,function(x) table(rep(v, x)))))) - locs<-x$locs[ani] - us<-t(as.matrix(as.data.frame(apply(locs,2,function(x) table(rep(v, x)))))) - ## Vérifications que pas de classes vides - toto<-as.vector(apply(av,2,sum)) - av<-av[,toto!=0] - us<-us[,toto!=0] - options(warn=-1) - liso[[i]]<-widesIII(us, av, alpha=alpha) - options(warn=0) - if (draw) - plot(liso[[i]], ylog, main=i, clab=clab, caxis=caxis, errbar=errbar, noorder=noorder) + + ## Output list + liso<-list() + ty<-strsplit(type, ".in.")[[1]] + + ## For each habitat variables + for (i in var) { + v<-x$sa[[i]] + + ## We order the selection ratios if the variable is continuous + if (is.factor(v)) + noorder<-TRUE + else + noorder<-FALSE + + ## Transform the variable into a factor + if (!is.factor(v)) + v<-cut(v, breaks=ncla) + + ## If the available RUs are defined by the study area + if (ty[2]=="sa") { + + ## the number of units per habitat type + av<-table(v) + nav<-names(av) + av<-as.vector(av) + names(av)<-nav + + if (ty[1]=="locs") { + + ## The used resource units = relocations + locs<-x$locs[ani] + us<-t(as.matrix(as.data.frame(apply(locs,2, + function(x) table(rep(v, x)))))) + ## The selection ratios + liso[[i]]<-widesII(us, av, alpha=alpha) + + ## plot them + if (draw) + plot(liso[[i]], ylog=ylog, main=i, clab=clab, + caxis=caxis, errbar=errbar, noorder=noorder) + } else { + + ## The used resource units = the home range + hr<-x$hr[ani] + hr <- as.data.frame(apply(hr, 2, + function(x) {x[is.na(x)] <- 0; return(x)})) + us<-t(as.matrix(as.data.frame(apply(hr,2,function(x) table(rep(v, x)))))) + + ## The selection ratios + liso[[i]]<-widesII(us, av, alpha=alpha) + + ## plot them + if (draw) + plot(liso[[i]], ylog=FALSE, main=i, + clab=clab, caxis=caxis, errbar=errbar, + noorder=noorder) + } + + } else { + + ## The home range is available + hr<-x$hr[ani] + hr <- as.data.frame(apply(hr, 2, function(x) {x[is.na(x)] <- 0; + return(x)})) + av<-t(as.matrix(as.data.frame(apply(hr,2, + function(x) table(rep(v, x)))))) + locs<-x$locs[ani] + us<-t(as.matrix(as.data.frame(apply(locs,2, + function(x) table(rep(v, x)))))) + ## Verification that no empty habitat types (not available) + toto<-as.vector(apply(av,2,sum)) + av<-av[,toto!=0] + us<-us[,toto!=0] + options(warn=-1) + + ## selection ratios + liso[[i]]<-widesIII(us, av, alpha=alpha) + options(warn=0) + + ## plot them + if (draw) + plot(liso[[i]], ylog, main=i, clab=clab, + caxis=caxis, errbar=errbar, noorder=noorder) + } } - } - class(liso)<-"plotsahr" - invisible(liso) + + ## Output + class(liso)<-"plotsahr" + invisible(liso) } diff --git a/R/plot.traj.r b/R/plot.traj.r index b469e7a..8edfd91 100755 --- a/R/plot.traj.r +++ b/R/plot.traj.r @@ -1,37 +1,44 @@ "plot.traj" <- function(x, id=levels(x$id), burst=levels(x$burst), date=NULL, - asc=NULL, area=NULL, - xlim=range(x$x), ylim=range(x$y), - colasc=gray((256:1)/256), colpol="green", - addpoints=TRUE, addlines=TRUE, - perani=TRUE, final=TRUE,...) - { + asc=NULL, area=NULL, + xlim=range(x$x), ylim=range(x$y), + colasc=gray((256:1)/256), colpol="green", + addpoints=TRUE, addlines=TRUE, + perani=TRUE, final=TRUE,...) +{ + ## Verifications polygon<-area if (!is.null(area)) { - if (!inherits(area, "area")) - stop("x should be an object of class area") + if (!inherits(area, "area")) + stop("x should be an object of class area") } if (!inherits(x, "traj")) - stop("x should be an object of class traj") - - ## sélection des dates - if (!is.null(date)) - x<-x[(x$date>=date[1])&(x$date=date[1])&(x$date object$nf)) nf <- object$nf + + ## ... and also keeps the marginality axis Zli <- object$li[, 1:(nf + 1)] + + ## The Mahalanobis distances computed on these axes f1 <- function(x) rep(x, object$pr) Sli <- apply(Zli, 2, f1) m <- apply(Sli, 2, mean) cov <- t(as.matrix(Sli)) %*% as.matrix(Sli)/nrow(Sli) maha <- mahalanobis(Zli, center = m, cov = cov) + + ## Output map <- getkasc(df2kasc(data.frame(toto = maha, tutu = maha), - index, attr), "toto") + index, attr), "toto") return(invisible(map)) } diff --git a/R/print.NNCH.r b/R/print.NNCH.r index 0dbe4e3..b756b33 100755 --- a/R/print.NNCH.r +++ b/R/print.NNCH.r @@ -1,6 +1,5 @@ -"print.NNCH" <- -function(x, ...) - { +"print.NNCH" <- function(x, ...) +{ cat("***********************************************\n") cat("***\n") cat("*** Nearest-neighbor convex hull\n\n") @@ -11,5 +10,5 @@ function(x, ...) cat("\n$area: home-range size estimated at various levels") cat("\n$polygons: objects of class \"gpc.poly\" storing the home-range limits") cat("\n$xy: the relocations\n\n") - } +} diff --git a/R/print.asc.r b/R/print.asc.r index 5685f78..9cbe1ae 100755 --- a/R/print.asc.r +++ b/R/print.asc.r @@ -1,11 +1,13 @@ -"print.asc" <- -function(x, ...) +"print.asc" <- function(x, ...) { - if (!inherits(x, "asc")) stop("Non convenient data") - cat("Raster map of class \"asc\":\n") - cat("Cell size: ", attr(x, "cellsize"), "\n") - cat("Number of rows: ", ncol(x), "\n") - cat("Number of columns: ", nrow(x), "\n") - cat("Type: ", attr(x, "type"), "\n") + ## Verifications + if (!inherits(x, "asc")) stop("Non convenient data") + + ## The output + cat("Raster map of class \"asc\":\n") + cat("Cell size: ", attr(x, "cellsize"), "\n") + cat("Number of rows: ", ncol(x), "\n") + cat("Number of columns: ", nrow(x), "\n") + cat("Type: ", attr(x, "type"), "\n") } diff --git a/R/print.compana.r b/R/print.compana.r index 71d78e5..25930e3 100755 --- a/R/print.compana.r +++ b/R/print.compana.r @@ -1,8 +1,7 @@ -"print.compana" <- -function(x, ...) - { +"print.compana" <- function(x, ...) +{ if (!inherits(x, "compana")) - stop("should be an object of class \"compana\"") + stop("should be an object of class \"compana\"") cat("************ Compositional analysis of habitat use ***************\n\n") cat("The analysis was carried out with", nrow(x$used), "animals and", ncol(x$used), "habitat types\n") @@ -11,5 +10,5 @@ function(x, ...) print(x$test) cat("\n2. Ranking of habitats (profile):\n") print(x$profile, quote=FALSE) - } +} diff --git a/R/print.dataenfa.r b/R/print.dataenfa.r index 9c2e56f..8982109 100755 --- a/R/print.dataenfa.r +++ b/R/print.dataenfa.r @@ -1,11 +1,10 @@ -"print.dataenfa" <- -function (x, ...) +"print.dataenfa" <- function (x, ...) { - if (!inherits(x, "dataenfa")) + if (!inherits(x, "dataenfa")) stop("Object of class 'dataenfa' expected") cat("Data ENFA\n") cat("\n List of 4 elements:\n\n") - sumry <- array("", c(1, 4), list(1, c("data.frame", "nrow", "ncol", + sumry <- array("", c(1, 4), list(1, c("data.frame", "nrow", "ncol", "content"))) sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "table of pixels") class(sumry) <- "table" diff --git a/R/print.enfa.r b/R/print.enfa.r index 8655f80..60fd667 100755 --- a/R/print.enfa.r +++ b/R/print.enfa.r @@ -1,43 +1,42 @@ -"print.enfa" <- -function (x, ...) +"print.enfa" <- function (x, ...) { - if (!inherits(x, "enfa")) - stop("Object of class 'enfa' expected") - cat("ENFA") - cat("\n$call: ") - print(x$call) - cat("\nmarginality: ") - cat(signif(x$m, 4)) - cat("\neigen values of specialization: ") - l0 <- length(x$s) - cat(signif(x$s, 4)[1:(min(5, l0))]) - if (l0 > 5) - cat(" ...") - cat("\n$nf:", x$nf, "axis of specialization saved") - cat("\n") - cat("\n") - sumry <- array("", c(5, 4), list(1:5, c("vector", "length", - "mode", "content"))) - sumry[1, ] <- c("$pr", length(x$pr), mode(x$pr), "vector of presence") - sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights") - sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights") - sumry[4, ] <- c("$mar", length(x$mar), - mode(x$mar), "coordinates of the marginality vector") - sumry[5, ] <- c("$s", length(x$s), - mode(x$s), "eigen values of specialization") - class(sumry) <- "table" - print(sumry) - cat("\n") - sumry <- array("", c(3, 4), list(1:3, c("data.frame", "nrow", - "ncol", "content"))) - sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array") - sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates") - sumry[3, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates") - class(sumry) <- "table" - print(sumry) - if (length(names(x)) > 11) { - cat("\nother elements: ") - cat(names(x)[12:(length(x))], "\n") - } + if (!inherits(x, "enfa")) + stop("Object of class 'enfa' expected") + cat("ENFA") + cat("\n$call: ") + print(x$call) + cat("\nmarginality: ") + cat(signif(x$m, 4)) + cat("\neigen values of specialization: ") + l0 <- length(x$s) + cat(signif(x$s, 4)[1:(min(5, l0))]) + if (l0 > 5) + cat(" ...") + cat("\n$nf:", x$nf, "axis of specialization saved") + cat("\n") + cat("\n") + sumry <- array("", c(5, 4), list(1:5, c("vector", "length", + "mode", "content"))) + sumry[1, ] <- c("$pr", length(x$pr), mode(x$pr), "vector of presence") + sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights") + sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights") + sumry[4, ] <- c("$mar", length(x$mar), + mode(x$mar), "coordinates of the marginality vector") + sumry[5, ] <- c("$s", length(x$s), + mode(x$s), "eigen values of specialization") + class(sumry) <- "table" + print(sumry) + cat("\n") + sumry <- array("", c(3, 4), list(1:3, c("data.frame", "nrow", + "ncol", "content"))) + sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array") + sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates") + sumry[3, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates") + class(sumry) <- "table" + print(sumry) + if (length(names(x)) > 11) { + cat("\nother elements: ") + cat(names(x)[12:(length(x))], "\n") + } } diff --git a/R/print.kasc.r b/R/print.kasc.r index 89c9515..f85fe90 100755 --- a/R/print.kasc.r +++ b/R/print.kasc.r @@ -1,22 +1,24 @@ -"print.kasc" <- -function(x, ...) +"print.kasc" <- function(x, ...) { - if (!inherits(x, "kasc")) stop("Non convenient data") - cat("Raster map of class \"kasc\":\n") - cat("Cell size: ", attr(x, "cellsize"), "\n") - cat("Number of rows: ", attr(x, "nrow"), "\n") - cat("Number of columns: ", attr(x, "ncol"), "\n\n") + ## Verifications + if (!inherits(x, "kasc")) stop("Non convenient data") - cat("Variables measured:\n") - n<-names(x) - for (i in 1:length(n)) { - if (is.factor(x[[i]])) { - typ<-"factor" - } else { - typ<-"numeric" + ## The output + cat("Raster map of class \"kasc\":\n") + cat("Cell size: ", attr(x, "cellsize"), "\n") + cat("Number of rows: ", attr(x, "nrow"), "\n") + cat("Number of columns: ", attr(x, "ncol"), "\n\n") + + cat("Variables measured:\n") + n<-names(x) + for (i in 1:length(n)) { + if (is.factor(x[[i]])) { + typ<-"factor" + } else { + typ<-"numeric" + } + cat(paste(i, ". ", n[i], ": ", typ, "\n", sep="")) } - cat(paste(i, ". ", n[i], ": ", typ, "\n", sep="")) - } - cat("\n") + cat("\n") } diff --git a/R/print.khr.r b/R/print.khr.r index fbdd7f2..0bb2e15 100755 --- a/R/print.khr.r +++ b/R/print.khr.r @@ -1,52 +1,51 @@ -"print.khr" <- -function(x, ...) - { +"print.khr" <- function(x, ...) +{ if (!inherits(x, "khr")) - stop("x should be an object of class khr") + stop("x should be an object of class khr") cat("********** Utilization distribution of Animals ************\n\n") if (inherits(x, "khrud")) - cat("Type: probability density\n") + cat("Type: probability density\n") if (inherits(x, "kbbhrud")) - cat("Type: probability density estimated with the Brownian bridge approach\n") + cat("Type: probability density estimated with the Brownian bridge approach\n") if (inherits(x, "khrvol")) - cat("Type: volume under UD (only used to compute home ranges)\n") + cat("Type: volume under UD (only used to compute home ranges)\n") cat("\nUD have been estimated using the kernel method for the following animals:\n") - + print(names(x), quote=FALSE) th<-x[[1]]$hmeth if (th=="LSCV") - cat("\nThe smoothing parameter was estimated by cross validation\n") + cat("\nThe smoothing parameter was estimated by cross validation\n") if (th=="href") - cat("\nThe smoothing parameter was estimated by the reference method (ad hoc)\n") + cat("\nThe smoothing parameter was estimated by the reference method (ad hoc)\n") if (is.numeric(th)) - cat("\nThe smoothing parameter was set to", th, "\n") - + cat("\nThe smoothing parameter was set to", th, "\n") + cat("\nEach animal is a component of the list, and for each animal,\n") cat("the following elements are available:\n") cat("$UD The utilization distribution (object of class \"asc\")\n") cat("$locs The relocations of the animal\n") if (th=="LSCV") { - cat("$h A list with the following components:\n") - cat(" $CV The results of cross-validation\n") - cat(" $h The value of the smoothing parameter\n") + cat("$h A list with the following components:\n") + cat(" $CV The results of cross-validation\n") + cat(" $h The value of the smoothing parameter\n") } if (th=="href") { - cat("$h The value of the smoothing parameter\n") + cat("$h The value of the smoothing parameter\n") } if (th=="bb") { - cat("$h The values of the smoothing parameters\n") + cat("$h The values of the smoothing parameters\n") } if (th=="LSCV") { - m<-0 - for (i in 1:length(x)) - m[i]<-x[[i]]$h$convergence - names(m)<-names(x) - if (!all(m)) { - cat("\nWARNING!! No convergence in cross-validation for the following animals:\n") - print(names(m)[!m], quote=FALSE) - cat("Consider a new fit of UD using the ad hoc method for h.\n") - } + m<-0 + for (i in 1:length(x)) + m[i]<-x[[i]]$h$convergence + names(m)<-names(x) + if (!all(m)) { + cat("\nWARNING!! No convergence in cross-validation for the following animals:\n") + print(names(m)[!m], quote=FALSE) + cat("Consider a new fit of UD using the ad hoc method for h.\n") + } } - } +} diff --git a/R/print.kselect.r b/R/print.kselect.r index 4525b75..696c711 100755 --- a/R/print.kselect.r +++ b/R/print.kselect.r @@ -1,5 +1,4 @@ -"print.kselect" <- -function (x, ...) +"print.kselect" <- function (x, ...) { cat("Duality diagramm\n") cat("class: ") @@ -12,27 +11,30 @@ function (x, ...) cat("\neigen values: ") l0 <- length(x$eig) cat(signif(x$eig, 4)[1:(min(5, l0))]) - if (l0 > 5) + if (l0 > 5) cat(" ...\n") else cat("\n") - sumry <- array("", c(5, 4), list(1:5, c("vector", "length", - "mode", "content"))) + sumry <- array("", c(5, 4), list(1:5, c("vector", "length", + "mode", "content"))) sumry[1, ] <- c("$cw", length(x$cw), mode(x$cw), "column weights") sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weights") sumry[3, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values") - sumry[4, ] <- c("$initfac", length(x$initfac), mode(x$initfac), "initial factor") - sumry[5, ] <- c("$initwei", length(x$initwei), mode(x$initwei), "row weights of inittab") + sumry[4, ] <- c("$initfac", length(x$initfac), + mode(x$initfac), "initial factor") + sumry[5, ] <- c("$initwei", length(x$initwei), + mode(x$initwei), "row weights of inittab") class(sumry) <- "table" print(sumry, ...) cat("\n") - sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow", - "ncol", "content"))) + sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow", + "ncol", "content"))) sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "modified array") sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates") sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores") sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates") sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores") - sumry[6, ] <- c("$initab", nrow(x$initab), ncol(x$initab), "initial table centered per animal") + sumry[6, ] <- c("$initab", nrow(x$initab), + ncol(x$initab), "initial table centered per animal") sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "axis upon kselect axis") class(sumry) <- "table" print(sumry) diff --git a/R/print.plotsahr.r b/R/print.plotsahr.r index cb94b43..1dde1c2 100755 --- a/R/print.plotsahr.r +++ b/R/print.plotsahr.r @@ -1,10 +1,9 @@ -"print.plotsahr" <- -function(x, ...) +"print.plotsahr" <- function(x, ...) { - cat("***** List of class \"plotsahr\" *****\n\n") - cat("Selection ratios are computed for the following variables:\n\n") - for (i in 1:length(x)) - cat(names(x)[i], "\n") - cat("each variable is a component of the list\n\n") + cat("***** List of class \"plotsahr\" *****\n\n") + cat("Selection ratios are computed for the following variables:\n\n") + for (i in 1:length(x)) + cat(names(x)[i], "\n") + cat("each variable is a component of the list\n\n") } diff --git a/R/print.rand.kselect.r b/R/print.rand.kselect.r index 5428972..971a5f3 100755 --- a/R/print.rand.kselect.r +++ b/R/print.rand.kselect.r @@ -1,6 +1,5 @@ -"print.rand.kselect" <- -function(x, ...) - { +"print.rand.kselect" <- function(x, ...) +{ cat("****** Randomization tests of the k-select analysis ******\n\n") cat("Test of the first eigenvalue:\n") cat("Observed value:", x$global[1], "\n") @@ -15,5 +14,5 @@ function(x, ...) cat("\n\nOther elements of the list $per.ind:") cat("\n $obsval: mean of variables for each animal") cat("\n $pvalue: P-value of the means in $obsval\n\n") - } +} diff --git a/R/print.sahrlocs.r b/R/print.sahrlocs.r index 7ea70b2..9dbc393 100755 --- a/R/print.sahrlocs.r +++ b/R/print.sahrlocs.r @@ -1,8 +1,9 @@ -"print.sahrlocs" <- -function(x, ...) - { +"print.sahrlocs" <- function(x, ...) +{ + ## Verifications if (!inherits(x, "sahrlocs")) stop("object should be of type \"sahrlocs\"") + ## The output cat("************** Object of type sahrlocs **************\n\n") nr<-attr(x, "nrow") nc<-attr(x, "ncol") @@ -14,11 +15,11 @@ function(x, ...) print(names(as.data.frame(unclass(x$sa))), ...) if (!is.null(x$descan)) { - cat("\nthe following variables are available for each monitored animal:\n") - print(names(x$descan), ...) + cat("\nthe following variables are available for each monitored animal:\n") + print(names(x$descan), ...) } else { - cat("\nno variables have been measured on the animals\n") + cat("\nno variables have been measured on the animals\n") } - - } + +} diff --git a/R/print.traj.r b/R/print.traj.r index c5437f7..2f5163e 100755 --- a/R/print.traj.r +++ b/R/print.traj.r @@ -1,17 +1,16 @@ -"print.traj" <- -function(x, ...) - { +"print.traj" <- function(x, ...) +{ if (!inherits(x, "traj")) - stop("x should be an object of class traj") + stop("x should be an object of class traj") levani<-levels(x$id) u<-split(x$burst, x$id) cat("******** Data frame of class traj *********\n\n") for (i in 1:length(u)) { - cat("Animal ",names(u)[i],": ", - nlevels(factor(u[[i]])), " circuits") - cat(" (",length(u[[i]])," relocations)\n", sep="") + cat("Animal ",names(u)[i],": ", + nlevels(factor(u[[i]])), " circuits") + cat(" (",length(u[[i]])," relocations)\n", sep="") } cat("\nVariables measured for each relocation:\n\n") print(names(x), quote=FALSE, ...) - } +} diff --git a/R/print.wiI.r b/R/print.wiI.r index 4d1da91..c63c21e 100755 --- a/R/print.wiI.r +++ b/R/print.wiI.r @@ -1,6 +1,5 @@ -"print.wiI" <- -function(x, ...) - { +"print.wiI" <- function(x, ...) +{ cat("\n\n************** Manly's Selection ratios for design I ********\n\n") cat("Significance of habitat selection:\n") print(x$Khi2L) @@ -9,7 +8,7 @@ function(x, ...) x$alpha/length(x$used.prop),")\n") n<-length(x$used.prop) z<-qnorm(1-x$alpha/(2*n)) - df<-data.frame(used=x$used.prop, + df<-data.frame(used=x$used.prop, avail=x$avail.prop, Wi=x$wi, SE.Wi=x$se.wi, P=x$chisquwi[,2], Bi=x$Bi) df<-round(as.matrix(df),3) @@ -18,5 +17,5 @@ function(x, ...) "% confidence intervals on the differences of Wi :\n") print(x$profile, quote=FALSE) cat("\n") - } +} diff --git a/R/print.wiII.r b/R/print.wiII.r index 3cb5ee2..0c35703 100755 --- a/R/print.wiII.r +++ b/R/print.wiII.r @@ -1,8 +1,7 @@ -"print.wiII" <- -function(x, ...) - { +"print.wiII" <- function(x, ...) +{ if (!inherits(x,"wiII")) - stop("x should be of class \"wiII\"") + stop("x should be of class \"wiII\"") cat("\n\n************** Manly's Selection ratios for design II ********\n\n") cat("1. Test of identical use of habitat by all animals\n") cat(" (Classical Khi-2 performed on the used matrix):\n") @@ -16,8 +15,9 @@ function(x, ...) print(x$Khi2L2MinusL1) cat("\n\nTable of selection ratios:\n") print(data.frame(Available=x$avail.prop, Used=x$used.prop, Wi=x$wi, - SE=x$se.wi, IClower=x$ICwilower, ICupper=x$ICwiupper), ...) - cat("\n\nBonferroni classement \nBased on", (1 - x$alpha) * + SE=x$se.wi, IClower=x$ICwilower, ICupper=x$ICwiupper), + ...) + cat("\n\nBonferroni classement \nBased on", (1 - x$alpha) * 100, "% confidence intervals on the differences of Wi :\n") print(x$profile, quote = FALSE) cat("\n") diff --git a/R/print.wiIII.r b/R/print.wiIII.r index f41c1bd..ec23dfa 100755 --- a/R/print.wiIII.r +++ b/R/print.wiIII.r @@ -1,8 +1,7 @@ -"print.wiIII" <- -function(x, ...) - { +"print.wiIII" <- function(x, ...) +{ if (!inherits(x,"wiIII")) - stop("x should be of class \"wiIII\"") + stop("x should be of class \"wiIII\"") cat("\n\n************** Manly's Selection ratios for design III ********\n\n") cat("1. Test of habitat selection for each animal:\n\n") print(x$Khi2Lj) @@ -11,8 +10,9 @@ function(x, ...) print(x$Khi2L) cat("\n\nTable of selection ratios:\n") print(data.frame(Wi=x$wi, - SE=x$se.wi, IClower=x$ICwilower, ICupper=x$ICwiupper), ...) - cat("\n\nBonferroni classement \nBased on", (1 - x$alpha) * + SE=x$se.wi, IClower=x$ICwilower, + ICupper=x$ICwiupper), ...) + cat("\n\nBonferroni classement \nBased on", (1 - x$alpha) * 100, "% confidence intervals on the differences of Wi :\n") print(x$profile, quote = FALSE) cat("\n") diff --git a/R/profilehab.r b/R/profilehab.r index 5b6c22f..fca79b2 100755 --- a/R/profilehab.r +++ b/R/profilehab.r @@ -1,35 +1,56 @@ -"profilehab" <- -function(rankma, wi) +"profilehab" <- function(rankma, wi) { - s<-(rankma=="+++")|(rankma=="---") - rm.p<-s - n.hab<-ncol(rankma) - classement<-rank(wi) - rankma<-rankma[order(classement, decreasing=TRUE),order(classement, decreasing=TRUE)] - rm.p<-rm.p[order(classement, decreasing=TRUE),order(classement, decreasing=TRUE)] - habitat<-paste(" ",colnames(rankma)[1],sep="") - for (i in 2:n.hab) habitat<-paste(habitat,colnames(rankma)[i],sep=" ") - habitat<-paste(habitat," ",sep="") - nbcar.nom<-nchar(colnames(rankma))+2 - carac<-c(1:n.hab) - profil<-matrix(ncol=1,nrow=n.hab) - - for (i in 1:n.hab){ - for (j in 1:n.hab){ - if (rm.p[i,j]) carac[j]<-" " else carac[j]<-"-" - if (rm.p[i,j]) t<-" " else t<-"-" - for (k in 1:(nbcar.nom[j]-1)) carac[j]<-paste(carac[j],t,sep="") - } - carac.t<-carac[1] - for (j in 2:n.hab) carac.t<-paste(carac.t,carac[j],sep="") - profil[i,1]<-carac.t - carac.t<-0 + ## significant matrix + s<-(rankma=="+++")|(rankma=="---") + rm.p<-s + + ## Order the ranking matrix according to the rank of selection ratios + n.hab<-ncol(rankma) + classement<-rank(wi) + rankma<-rankma[order(classement, decreasing=TRUE), + order(classement, decreasing=TRUE)] + + ## The same for the "significant matrix" + rm.p<-rm.p[order(classement, decreasing=TRUE), + order(classement, decreasing=TRUE)] + + ## header of the profile + habitat<-paste(" ",colnames(rankma)[1],sep="") + for (i in 2:n.hab) + habitat<-paste(habitat,colnames(rankma)[i],sep=" ") + habitat<-paste(habitat," ",sep="") + + ## Number of character for each column of the header + nbcar.nom<-nchar(colnames(rankma))+2 + + ## Matrix of profiles carac<-c(1:n.hab) - } - - rownames(profil)<-colnames(rankma) - profil<-rbind(habitat,profil) - colnames(profil)<-"" - return(profil) + profil<-matrix(ncol=1,nrow=n.hab) + + ## fills the profile matrix with the connecting ("-") or separating (" ") + ## character, depending oon the significance of the test + for (i in 1:n.hab){ + for (j in 1:n.hab){ + if (rm.p[i,j]) carac[j]<-" " else carac[j]<-"-" + if (rm.p[i,j]) t<-" " else t<-"-" + for (k in 1:(nbcar.nom[j]-1)) carac[j]<-paste(carac[j],t,sep="") + + ## repeat the profile character the same number as + ## the number characters of the header + } + + ## paste the results into a row profile + carac.t<-carac[1] + for (j in 2:n.hab) carac.t<-paste(carac.t,carac[j],sep="") + profil[i,1]<-carac.t + carac.t<-0 + carac<-c(1:n.hab) + } + + ## The output + rownames(profil)<-colnames(rankma) + profil<-rbind(habitat,profil) + colnames(profil)<-"" + return(profil) } diff --git a/R/rand.kselect.r b/R/rand.kselect.r index ad92775..e0ceba9 100755 --- a/R/rand.kselect.r +++ b/R/rand.kselect.r @@ -1,15 +1,18 @@ -"rand.kselect" <- -function(dudi, factor, weight, nrep=200, alpha=0.05, ewa = FALSE) - { - if (!inherits(dudi, "dudi")) - stop("Object of class dudi expected") - if (nrow(dudi$tab) != length(factor)) - stop("The factor should have the same length as the dudi object") - if (nrow(dudi$tab) != length(weight)) - stop("The vector of weights should have the same length as the dudi object") - if (!is.vector(weight)) +"rand.kselect" <- function(dudi, factor, weight, nrep=200, + alpha=0.05, ewa = FALSE) +{ + ## Verifications + if (!inherits(dudi, "dudi")) + stop("Object of class dudi expected") + if (nrow(dudi$tab) != length(factor)) + stop("The factor should have the same length as the dudi object") + if (nrow(dudi$tab) != length(weight)) + stop("The vector of weights should have the same length as the dudi object") + if (!is.vector(weight)) stop("The weights should be placed in a vector") + ## Data preparation before the external call to the + ## C function "permutksel" tab<-as.matrix(dudi$tab) fac<-as.numeric(factor) poids<-as.numeric(weight) @@ -18,7 +21,10 @@ function(dudi, factor, weight, nrep=200, alpha=0.05, ewa = FALSE) lev1<-nlevels(factor) nombreani<-tapply(dudi$tab[,1], factor, length) - res<-.C("permutksel", as.double(t(tab)), as.integer(fac), as.double(poids), + ## The C function "permutksel" permutes the weight and computes + ## the marginality vectors + res<-.C("permutksel", as.double(t(tab)), + as.integer(fac), as.double(poids), as.integer(col1), as.integer(lev1), as.integer(lig1), double(col1*lev1), double(col1*lev1), double(col1*lev1), as.integer(nombreani), as.integer(nrep), double(1), @@ -33,7 +39,7 @@ function(dudi, factor, weight, nrep=200, alpha=0.05, ewa = FALSE) "simtout", "poco", "ewa") - ## Tableau de marginalité observé + ## Marginality observed for each animal ad each variable obsval<-matrix(res$mar, ncol=lev1) margs<-matrix(res$simtout, nrow=nrep, byrow=FALSE) pval1<-obsval @@ -41,34 +47,33 @@ function(dudi, factor, weight, nrep=200, alpha=0.05, ewa = FALSE) pval<-obsval sign<-obsval + ### Marginality for each animal ad each variable for (i in 1:nrow(pval)) { - for (j in 1:ncol(pval)) { - k<-(i-1)*lev1+j - pval1[i,j]<-as.randtest(margs[,k], obsval[i,j])$pvalue - pval2[i,j]<-as.randtest(-margs[,k], -obsval[i,j])$pvalue - } + for (j in 1:ncol(pval)) { + k<-(i-1)*lev1+j + pval1[i,j]<-as.randtest(margs[,k], obsval[i,j])$pvalue + pval2[i,j]<-as.randtest(-margs[,k], -obsval[i,j])$pvalue + } } - for (i in 1:nrow(pval)) { - for (j in 1:ncol(pval)) { - pval[i,j]<-min(c(pval1[i,j], pval2[i,j])) - } + for (j in 1:ncol(pval)) { + pval[i,j]<-min(c(pval1[i,j], pval2[i,j])) + } } - + ## Corresponding ranking matrix for (i in 1:nrow(pval)) { - for (j in 1:ncol(pval)) { - if (obsval[i,j]>=0) { - sign[i,j]<-"+" - if (pval[i,j]<(alpha/(2*nrow(pval)*ncol(pval)))) - sign[i,j]<-"+++" - } else { - sign[i,j]<-"-" - if (pval[i,j]<(alpha/(2*nrow(pval)*ncol(pval)))) - sign[i,j]<-"---" + for (j in 1:ncol(pval)) { + if (obsval[i,j]>=0) { + sign[i,j]<-"+" + if (pval[i,j]<(alpha/(2*nrow(pval)*ncol(pval)))) + sign[i,j]<-"+++" + } else { + sign[i,j]<-"-" + if (pval[i,j]<(alpha/(2*nrow(pval)*ncol(pval)))) + sign[i,j]<-"---" + } } - } } - colnames(pval)<-levels(factor) row.names(pval)<-colnames(tab) colnames(obsval)<-levels(factor) @@ -76,23 +81,30 @@ function(dudi, factor, weight, nrep=200, alpha=0.05, ewa = FALSE) colnames(sign)<-levels(factor) row.names(sign)<-colnames(tab) + + ## Marginality per animal o<-matrix(res$simmarg, ncol=lev1, byrow=FALSE) mat<-matrix(0, nrow=lev1, ncol=2) colnames(mat)<-c("observed", "pvalue") mat<-as.data.frame(mat) for (i in 1:lev1) { - mat[i,1]<-res$obsmarg[i] - tmp<-as.randtest(o[,i], res$obsmarg[i]) - mat[i,2]<-tmp$pvalue + mat[i,1]<-res$obsmarg[i] + tmp<-as.randtest(o[,i], res$obsmarg[i]) + mat[i,2]<-tmp$pvalue } row.names(mat)<-levels(factor) + + ## Significance of the first axis of the K-select global<-c(0,0) names(global)<-c("observed","pvalue") global[1]<-res$obseig global[2]<-as.randtest(res$simeig, res$obseig)$pvalue + + + ## output lili<-list(obsval=obsval, pvalue=pval, signification=sign) so<-list(global=global, marg=mat, per.ind=lili, alpha=alpha) class(so)<-"rand.kselect" return(so) - } +} diff --git a/R/randtest.enfa.r b/R/randtest.enfa.r index 93ff7d3..81a0984 100755 --- a/R/randtest.enfa.r +++ b/R/randtest.enfa.r @@ -1,10 +1,13 @@ -"randtest.enfa" <- -function(xtest, nrepet=999, ...) - { +"randtest.enfa" <- function(xtest, nrepet=999, ...) +{ + ## Verifications if (!inherits(xtest,"enfa")) stop("should be an object of class \"enfa\"") if (!isTRUE(all.equal(xtest$cw, rep(1,length(xtest$cw))))) warning("not yet implemented for unequal column weightsw: \n column weights not taken into account") + + ## External call to the C function "randenfar": randomizes the weights + ## to test the significance of the first axis of specialization tab<-as.matrix(xtest$tab) pr<-xtest$pr res<-.C("randenfar", as.double(t(tab)), as.double(pr), diff --git a/R/rec.r b/R/rec.r index 2d15324..8bd9d94 100755 --- a/R/rec.r +++ b/R/rec.r @@ -1,9 +1,12 @@ rec <- function(x, slsp=c("remove","missing")) - { +{ + ## Verifications if (!inherits(x, "ltraj")) - stop("x should be of class \"ltraj\"") + stop("x should be of class \"ltraj\"") + + ## Recomputation slsp <- match.arg(slsp) y <- traj2df(ltraj2traj(x)) return(as.ltraj(xy=y[,c("x","y")], date=y$date, id=y$id, burst=y$burst, slsp=slsp)) - } +} diff --git a/R/redisltraj.r b/R/redisltraj.r index 55b59ec..2e2660f 100755 --- a/R/redisltraj.r +++ b/R/redisltraj.r @@ -1,67 +1,91 @@ -"redisltraj" <- -function(l, u, burst = NULL, samplex0 = FALSE, addbit = FALSE, - nnew=5) +"redisltraj" <- function(l, u, burst = NULL, samplex0 = FALSE, + addbit = FALSE, nnew=5) { - if (!inherits(l, "ltraj")) - stop("l should be of class 'ltraj'") - if (is.null(burst)) { - burst <- unlist(lapply(l, function(x) attr(x, "burst"))) - } - ml <- l - foo <- function(bu) { - l <- ml[burst=bu] - x <- na.omit(l[[1]]$x) - y <- na.omit(l[[1]]$y) - dat <- as.numeric(l[[1]]$dat[!is.na(l[[1]]$x)]) - if (samplex0) { - pente <- (y[2] - y[1]) / (x[2] - x[1]) - ori <- y[2] - pente*x[2] - if (x[1] <= x[2]) - x1 <- runif(1,x[1],x[2]) - if (x[1] > x[2]) - x1 <- runif(1,x[2],x[1]) - - y1 <- pente*x1 + ori - x0 <- c(x1,y1) - di1 = sqrt( (x0[1] - x[1])^2 + (x0[2] - y[1])^2 ) - R = sqrt((x[2] - x[1])^2 + (y[2] - y[1])^2) - di2 = dat[2] - dat[1]; - dat0 = dat[1] + (di1 * di2 / R); - } else { - x0 <- unlist(l[[1]][1,c("x","y")]) - dat0 <- dat[1] + ## Verifications + if (!inherits(l, "ltraj")) + stop("l should be of class 'ltraj'") + if (is.null(burst)) { + burst <- unlist(lapply(l, function(x) attr(x, "burst"))) } - n <- length(x) - nn <- nnew*n + ml <- l + + ## The function to be applied to each burst + foo <- function(bu) { + + ## remove the missing values + l <- ml[burst=bu] + x <- na.omit(l[[1]]$x) + y <- na.omit(l[[1]]$y) + dat <- as.numeric(l[[1]]$dat[!is.na(l[[1]]$x)]) + + ## Should the first relocation be sampled along the first step? + if (samplex0) { + + ## Computation of the slope and intercept for the first step + pente <- (y[2] - y[1]) / (x[2] - x[1]) + ori <- y[2] - pente*x[2] + + ## sample x and y at t=0 + if (x[1] <= x[2]) + x1 <- runif(1,x[1],x[2]) + if (x[1] > x[2]) + x1 <- runif(1,x[2],x[1]) + y1 <- pente*x1 + ori + x0 <- c(x1,y1) + + ## linear interpolation for the date + di1 = sqrt( (x0[1] - x[1])^2 + (x0[2] - y[1])^2 ) + R = sqrt((x[2] - x[1])^2 + (y[2] - y[1])^2) + di2 = dat[2] - dat[1] + dat0 = dat[1] + (di1 * di2 / R) + } else { - toto <- .C("discretrajr", as.double(x), as.double(y), as.double(dat), - double(nn), double(nn), as.integer(n), - as.integer(nn), double(nn), as.double(x0[1]), - as.double(x0[2]), as.double(u), as.double(dat0), integer(1), - PACKAGE = "adehabitat") + ## if not sampled, take the first one + x0 <- c(x[1],y[1]) + dat0 <- dat[1] + } + n <- length(x) + nn <- nnew*n - neff <- toto[[13]] - 1 - if (neff >= (nn-1)) - stop("too small rediscretization step length. Try to increase \"nnew\"") - x <- toto[[4]][1:neff] - y <- toto[[5]][1:neff] - dat <- toto[[8]][1:neff] - class(dat) <- c("POSIXt", "POSIXct") - if (addbit) { - x <- c(x, l[[1]]$x[length(l[[1]]$x)]) - y <- c(y, l[[1]]$y[length(l[[1]]$y)]) - dat <- c(dat, l[[1]]$date[length(l[[1]]$date)]) + ## External call to the C function "discretrajr" + toto <- .C("discretrajr", as.double(x), as.double(y), as.double(dat), + double(nn), double(nn), as.integer(n), + as.integer(nn), double(nn), as.double(x0[1]), + as.double(x0[2]), as.double(u), as.double(dat0), integer(1), + PACKAGE = "adehabitat") + + ## Number of steps + neff <- toto[[13]] - 1 + if (neff >= (nn-1)) + stop("too small rediscretization step length. Try to increase \"nnew\"") + + ## The coordinates and the dates + x <- toto[[4]][1:neff] + y <- toto[[5]][1:neff] + dat <- toto[[8]][1:neff] + class(dat) <- c("POSIXt", "POSIXct") + + ## Should the final fragment of step be added + if (addbit) { + x <- c(x, l[[1]]$x[length(l[[1]]$x)]) + y <- c(y, l[[1]]$y[length(l[[1]]$y)]) + dat <- c(dat, l[[1]]$date[length(l[[1]]$date)]) + } + + ## Converts to traj + opt <- options(warn=-1) + nl <- as.ltraj(data.frame(x,y), dat, id=attr(l[[1]], "id"), + burst = paste(attr(l[[1]], "burst"),".R",u,sep="")) + nl[[1]]$rel.ang[is.na(nl[[1]]$rel.ang)] <- 0 + + ## Output + class(nl) <- "ltraj" + options(opt) + return(nl) } - opt <- options(warn=-1) - nl <- as.ltraj(data.frame(x,y), dat, id=attr(l[[1]], "id"), - burst = paste(attr(l[[1]], "burst"),".R",u,sep="")) - nl[[1]]$rel.ang[is.na(nl[[1]]$rel.ang)] <- 0 - class(nl) <- "ltraj" - options(opt) - return(nl) - } - nl <- do.call("c.ltraj",lapply(burst,foo)) - return(nl) + ## applies the function to all bursts and pool the results + nl <- do.call("c.ltraj",lapply(burst,foo)) + return(nl) } diff --git a/R/rotxy.r b/R/rotxy.r index f176f15..ead7aa6 100755 --- a/R/rotxy.r +++ b/R/rotxy.r @@ -1,14 +1,13 @@ -"rotxy" <- -function (df) +"rotxy" <- function (df) { - X<-scale(df[,2:3],scale=FALSE) - angle<-runif(1,0,2*pi) - co <- cos(angle) - si <- sin(angle) - Y<-as.data.frame(list(id=df[,1], x = co * X[,1] - si * X[,2], y = si * - X[,1] + co * X[,2])) - Y[,2]<-Y[,2]+attr(X, "scaled:center")[1] - Y[,3]<-Y[,3]+attr(X, "scaled:center")[2] - return(Y) + X<-scale(df[,2:3],scale=FALSE) + angle<-runif(1,0,2*pi) + co <- cos(angle) + si <- sin(angle) + Y<-as.data.frame(list(id=df[,1], x = co * X[,1] - si * X[,2], y = si * + X[,1] + co * X[,2])) + Y[,2]<-Y[,2]+attr(X, "scaled:center")[1] + Y[,3]<-Y[,3]+attr(X, "scaled:center")[2] + return(Y) } diff --git a/R/sahrlocs2kselect.r b/R/sahrlocs2kselect.r index 8ffbcdc..cdf4b50 100755 --- a/R/sahrlocs2kselect.r +++ b/R/sahrlocs2kselect.r @@ -1,48 +1,74 @@ -"sahrlocs2kselect" <- -function(sahr) - { - sa<-sahr$sa - fac <- unlist(lapply(sa, is.factor)) - if (any(fac)) { - lev<-list() - for (i in names(fac[fac])) - lev[[i]]<-levels(sa[[i]]) - sa<-lapply(sa, as.numeric) - sa<-as.data.frame(sa) - } - sa<-as.matrix(sa) - hr<-sahr$hr - hr<-lapply(hr, as.numeric) - hr<-as.matrix(as.data.frame(hr)) - locs<-as.matrix(sahr$locs) - - sa[is.na(sa)]<-(-9999) - hr[is.na(hr)]<-(-9999) - - nh<-ncol(sa) - np<-nrow(sa) - na<-ncol(hr) - - so1<-.C("nls2k", as.double(t(sa)), as.double(t(hr)), as.integer(nh), - as.integer(np), as.integer(na), PACKAGE="adehabitat")[[5]] - - so2<-.C("sahr2ksel", as.double(t(sa)), as.double(t(hr)), as.double(t(locs)), - as.integer(nh), as.integer(np), as.integer(na), as.integer(so1), - double (so1*nh), integer(so1), double(so1), PACKAGE="adehabitat") - - ta<-so2[[8]] - ta<-as.data.frame(matrix(ta, ncol=nh, byrow=TRUE)) - names(ta)<-names(sahr$sa) - if (any(fac>0)) { - for (i in names(lev)) - ta[,i]<-factor(ta[[i]], levels=c(1:length(lev[[i]])), labels=lev[[i]]) - } - factor<-so2[[9]] - weight<-so2[[10]] - - factor<-factor(factor, labels=names(sahr$hr)) - - sorties<-list(tab=ta, factor=factor, weight=weight) - return(sorties) +"sahrlocs2kselect" <- function(sahr) +{ + ## Verifications + if (!inherits(sahr, "sahrlocs")) + stop("sahr should be of class sahrlocs") + + ## Converts the kasc of the study area as a matrix of numbers + ## and stores the levels of factors in lev + sa<-sahr$sa + fac <- unlist(lapply(sa, is.factor)) + if (any(fac)) { + lev<-list() + for (i in names(fac[fac])) + lev[[i]]<-levels(sa[[i]]) + sa<-lapply(sa, as.numeric) + sa<-as.data.frame(sa) + } + sa<-as.matrix(sa) + + ## Converts the kasc of the home ranges as a matrix of numbers + hr<-sahr$hr + hr<-lapply(hr, as.numeric) + hr<-as.matrix(as.data.frame(hr)) + + ## Converts the kasc of the relocations as a matrix of numbers + locs<-as.matrix(sahr$locs) + + ## Replace the missing values by -999 + sa[is.na(sa)]<-(-9999) + hr[is.na(hr)]<-(-9999) + + ## Use of the C function nls2k to compute the number of lines of + ## the table in the output + nh<-ncol(sa) + np<-nrow(sa) + na<-ncol(hr) + + so1<-.C("nls2k", as.double(t(sa)), as.double(t(hr)), as.integer(nh), + as.integer(np), as.integer(na), PACKAGE="adehabitat")[[5]] + + ## Use of this number of lines to reserve memory, and computes the + ## tables and vectors to be analysed by the K-select + so2<-.C("sahr2ksel", as.double(t(sa)), as.double(t(hr)), + as.double(t(locs)), as.integer(nh), as.integer(np), + as.integer(na), as.integer(so1), double (so1*nh), + integer(so1), double(so1), PACKAGE="adehabitat") + + ## ta contains the table giving the concatenated tables giving + ## the values of environmental variables (columns) in each pixel of + ## the home ranges + ta<-so2[[8]] + ta<-as.data.frame(matrix(ta, ncol=nh, byrow=TRUE)) + names(ta)<-names(sahr$sa) + + ## retransform into factors when convenient + if (any(fac>0)) { + for (i in names(lev)) + ta[,i]<-factor(ta[[i]], + levels=c(1:length(lev[[i]])), + labels=lev[[i]]) + } + + ## factor and weight contain respectively a factor giving the ID of + ## the animals for each row of ta, and the number of relocations in + ## each pixel in the rows of ta + factor<-so2[[9]] + weight<-so2[[10]] + factor<-factor(factor, labels=names(sahr$hr)) + + ## output + sorties<-list(tab=ta, factor=factor, weight=weight) + return(sorties) } diff --git a/R/sahrlocs2niche.r b/R/sahrlocs2niche.r index 9721fc2..9edcbbb 100755 --- a/R/sahrlocs2niche.r +++ b/R/sahrlocs2niche.r @@ -1,9 +1,12 @@ -"sahrlocs2niche" <- -function(x, ani=names(x$hr), - var=names(x$sa), used=c("hr", "locs")) - { +"sahrlocs2niche" <- function(x, ani=names(x$hr), + var=names(x$sa), used=c("hr", "locs")) +{ + ## Verifications used<-match.arg(used) - if (!inherits(x,"sahrlocs")) stop("non convenient data") + if (!inherits(x,"sahrlocs")) + stop("non convenient data") + + ## The "available" table output<-list() sa<-getsahrlocs(x) sa<-sa[var] @@ -14,16 +17,16 @@ function(x, ani=names(x$hr), output$tab<-e$tab output$index<-e$index + ## The "use" table if (used=="hr") { - Y<-hr - for (i in 1:ncol(hr)) Y[is.na(Y[,i]),i]<-0 + Y<-hr + for (i in 1:ncol(hr)) Y[is.na(Y[,i]),i]<-0 } if (used=="locs") Y<-locs Y<-Y[e$index,] - output$y<-as.data.frame(Y) + ## The output return(output) - - } +} diff --git a/R/scatterniche.r b/R/scatterniche.r index 85cbb36..bb260e3 100644 --- a/R/scatterniche.r +++ b/R/scatterniche.r @@ -1,93 +1,113 @@ scatterniche <- function (x, pr, xax = 1, yax = 2, pts = FALSE, percent = 95, - clabel = 1, side = c("top", "bottom", "none"), Adensity, - Udensity, Aangle, Uangle, Aborder, Uborder, Acol, Ucol, Alty, + clabel = 1, side = c("top", "bottom", "none"), + Adensity, Udensity, Aangle, Uangle, Aborder, + Uborder, Acol, Ucol, Alty, Ulty, Abg, Ubg, Ainch, Uinch, ...) { - side <- match.arg(side) - opar <- par(mar = c(0.1, 0.1, 0.1, 0.1)) - on.exit(par(opar)) - x1 <- x[,xax] - x1 <- c(x1 - diff(range(x1)/50), x1 + diff(range(x1))/50) - xlim <- range(x1) - y1 <- x[, yax] - y1 <- c(y1 - diff(range(y1)/50), y1 + diff(range(y1))/50) - ylim <- range(y1) - scatterutil.base(dfxy = x[, c(xax, yax)], xax = 1, yax = 2, - xlim = xlim, ylim = ylim, grid = TRUE, addaxes = FALSE, - cgrid = 1, include.origin = TRUE, origin = c(0, 0), sub = "", - csub = 1.25, possub = "bottomleft", pixmap = NULL, contour = NULL, - area = NULL, add.plot = FALSE) - if (pts) { - if (missing(Acol)) - Acol <- gray(0.8) - if (missing(Ucol)) - Ucol <- "black" - if (missing(Abg)) - Abg <- gray(0.8) - if (missing(Ubg)) - Ubg <- "black" - if (missing(Ainch)) - Ainch <- 0.03 - if (missing(Uinch)) - Uinch <- Ainch*max(pr)/min(pr[pr>1e-7]) - symbols(x[, c(xax, yax)], circles = rep(1, length(pr)), - fg = Acol, bg = Abg, inches = Ainch, add = TRUE) - symbols(x[pr > 0, c(xax, yax)], circles = pr[pr > 0], - fg = Ucol, bg = Ubg, - inches = Uinch, add = TRUE) - abline(v = 0) - abline(h = 0) - } - else { - if (missing(Adensity)) - Adensity <- NULL - if (missing(Udensity)) - Udensity <- NULL - if (missing(Aangle)) - Aangle <- 45 - if (missing(Uangle)) - Uangle <- 45 - if (missing(Aborder)) - Aborder <- NULL - if (missing(Uborder)) - Uborder <- NULL - if (missing(Acol)) - Acol <- gray(0.95) - if (missing(Ucol)) - Ucol <- gray(0.6) - if (missing(Alty)) - Alty <- NULL - if (missing(Ulty)) - Ulty <- NULL - mcpA <- mcp(x[, c(xax, yax)], id = rep(1, dim(x)[1]), - percent = percent) - mcpU <- mcp(x[pr>1e-7, c(xax, yax)], - id = rep(1, sum(pr>1e-7)), percent = percent) - polygon(mcpA[, 2:3], density = Adensity, angle = Aangle, - border = Aborder, col = Acol, lty = Alty) - polygon(mcpU[, 2:3], density = Udensity, angle = Uangle, - border = Uborder, col = Ucol, lty = Ulty) - abline(v = 0) - abline(h = 0) - } - xax <- paste("Axis", xax) - yax <- paste("Axis", yax) - if (side != "none") { - tra <- paste(" xax =", xax, "\n yax =", yax) - wt <- strwidth(tra, cex = 1) - ht <- strheight(tra, cex = 1) * 1.5 - xl <- par("usr")[1] - yu <- par("usr")[4] - yd <- par("usr")[3] - if (side == "top") { - rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) - text(xl + wt/2, yu - ht/2, tra, cex = 1) + ## Graphical settings + side <- match.arg(side) + opar <- par(mar = c(0.1, 0.1, 0.1, 0.1)) + on.exit(par(opar)) + + ## Bases for the graphs + x1 <- x[,xax] + x1 <- c(x1 - diff(range(x1)/50), x1 + diff(range(x1))/50) + xlim <- range(x1) + y1 <- x[, yax] + y1 <- c(y1 - diff(range(y1)/50), y1 + diff(range(y1))/50) + ylim <- range(y1) + + ## background graph + scatterutil.base(dfxy = x[, c(xax, yax)], xax = 1, yax = 2, + xlim = xlim, ylim = ylim, grid = TRUE, addaxes = FALSE, + cgrid = 1, include.origin = TRUE, + origin = c(0, 0), sub = "", + csub = 1.25, possub = "bottomleft", + pixmap = NULL, contour = NULL, + area = NULL, add.plot = FALSE) + + ## If points are desired + if (pts) { + + ## graphical settings + if (missing(Acol)) + Acol <- gray(0.8) + if (missing(Ucol)) + Ucol <- "black" + if (missing(Abg)) + Abg <- gray(0.8) + if (missing(Ubg)) + Ubg <- "black" + if (missing(Ainch)) + Ainch <- 0.03 + if (missing(Uinch)) + Uinch <- Ainch*max(pr)/min(pr[pr>1e-7]) + + ## draws the points + symbols(x[, c(xax, yax)], circles = rep(1, length(pr)), + fg = Acol, bg = Abg, inches = Ainch, add = TRUE) + symbols(x[pr > 0, c(xax, yax)], circles = pr[pr > 0], + fg = Ucol, bg = Ubg, + inches = Uinch, add = TRUE) + abline(v = 0) + abline(h = 0) } - if (side == "bottom") { - rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) - text(xl + wt/2, yd + ht/2, tra, cex = 1) + else { + ## if polygons are desired + + ## Graphical settings + if (missing(Adensity)) + Adensity <- NULL + if (missing(Udensity)) + Udensity <- NULL + if (missing(Aangle)) + Aangle <- 45 + if (missing(Uangle)) + Uangle <- 45 + if (missing(Aborder)) + Aborder <- NULL + if (missing(Uborder)) + Uborder <- NULL + if (missing(Acol)) + Acol <- gray(0.95) + if (missing(Ucol)) + Ucol <- gray(0.6) + if (missing(Alty)) + Alty <- NULL + if (missing(Ulty)) + Ulty <- NULL + + ## Convex polygons + mcpA <- mcp(x[, c(xax, yax)], id = rep(1, dim(x)[1]), + percent = percent) + mcpU <- mcp(x[pr>1e-7, c(xax, yax)], + id = rep(1, sum(pr>1e-7)), percent = percent) + polygon(mcpA[, 2:3], density = Adensity, angle = Aangle, + border = Aborder, col = Acol, lty = Alty) + polygon(mcpU[, 2:3], density = Udensity, angle = Uangle, + border = Uborder, col = Ucol, lty = Ulty) + abline(v = 0) + abline(h = 0) } - } - box() + ## The legend + xax <- paste("Axis", xax) + yax <- paste("Axis", yax) + if (side != "none") { + tra <- paste(" xax =", xax, "\n yax =", yax) + wt <- strwidth(tra, cex = 1) + ht <- strheight(tra, cex = 1) * 1.5 + xl <- par("usr")[1] + yu <- par("usr")[4] + yd <- par("usr")[3] + if (side == "top") { + rect(xl, yu - ht, xl + wt, yu, col = "white", border = 0) + text(xl + wt/2, yu - ht/2, tra, cex = 1) + } + if (side == "bottom") { + rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) + text(xl + wt/2, yd + ht/2, tra, cex = 1) + } + } + box() } diff --git a/R/schoener.r b/R/schoener.r index 72cf522..32ec9a8 100755 --- a/R/schoener.r +++ b/R/schoener.r @@ -1,31 +1,50 @@ -"schoener" <- -function(tr, keep, byburst=TRUE) - { +"schoener" <- function(tr, keep, byburst=TRUE) +{ + ## Verifications if (!inherits(tr, "traj")) - stop("tr should be of class traj") + stop("tr should be of class traj") + + ## Remove the missing values + tr <- tr[!is.na(tr$x),] + tr <- tr[!is.na(tr$y),] + + ## splits per burst or id li <- split(tr, tr$id) if (byburst) - li <- split(tr, tr$burst) + li <- split(tr, tr$burst) + ## This function computes the schoener ratio + ## for each element of this list foo <- function(tr) { - d <- unclass(tr$date) - x <- tr[,c("x","y")] - r2 <- sum(((x[,1]-mean(x[,1]))^2) + - ((x[,2]-mean(x[,2]))^2))/(nrow(x) -1) - diffd <- outer(d,d,"-") - t2tmp <- as.matrix(dist(x)^2) - cons <- diffd>keep[1]&diffdkeep[1]&diffdkeep[1]&diffdkeep[1]&diffd2) - stop("sg should be defined in two dimensions") + stop("sg should be defined in two dimensions") if (gr[1,2]!=gr[2,2]) - stop("the cellsize should be the same in x and y directions") + stop("the cellsize should be the same in x and y directions") + + + ## gets the coordinates fullgrid(sg) <- TRUE xy <- coordinates(sg) + + ## gets the data and prepare them for the conversion toward kasc ka <- sg@data ka <- ka[order(xy[,1]),] xy <- xy[order(xy[,1]),] ka <- ka[order(xy[,2]),] xy <- xy[order(xy[,2]),] nxy <- colnames(xy) + + ## Adds the attributes attr(ka, "cellsize") <- gr[2,2] attr(ka, "xll") <- gr[1,1] attr(ka, "yll") <- gr[2,1] attr(ka,"ncol") <- gr[1,3] attr(ka,"nrow") <- gr[2,3] class(ka) <- c("kasc", "data.frame") + + ## if there is only one variable + ## in the spixdf -> conversion to "asc" + if (ncol(ka)==1) { - v <- ka[,1] - if ((is.numeric(v)) | (is.logical(v))) { - e <- matrix(v, ncol = attr(ka, "nrow")) - attr(e, "type") <- "numeric" - } - else { - tc2 <- levels(v) - v <- as.numeric(v) - e <- matrix(v, ncol = attr(ka, "nrow")) - attr(e, "type") <- "factor" - attr(e, "levels") <- tc2 - } - attr(e, "cellsize") <- attr(ka, "cellsize") - attr(e, "xll") <- attr(ka, "xll") - attr(e, "yll") <- attr(ka, "yll") - class(e) <- "asc" - ka <- e + + v <- ka[,1] + if ((is.numeric(v)) | (is.logical(v))) { + e <- matrix(v, ncol = attr(ka, "nrow")) + attr(e, "type") <- "numeric" + } else { + tc2 <- levels(v) + v <- as.numeric(v) + e <- matrix(v, ncol = attr(ka, "nrow")) + attr(e, "type") <- "factor" + attr(e, "levels") <- tc2 + } + attr(e, "cellsize") <- attr(ka, "cellsize") + attr(e, "xll") <- attr(ka, "xll") + attr(e, "yll") <- attr(ka, "yll") + class(e) <- "asc" + ka <- e } + + ## Output return(ka) - } +} diff --git a/R/spol2area.r b/R/spol2area.r index c60ccdf..5596841 100755 --- a/R/spol2area.r +++ b/R/spol2area.r @@ -1,78 +1,121 @@ -"spol2area" <- -function(sr) - { +"spol2area" <- function(sr) +{ + ## Verifications if (!require(sp)) - stop("the package sp is required for this function") + stop("the package sp is required for this function") if (inherits(sr, "SpatialPolygonsDataFrame")) - sr <- polygons(sr) + sr <- polygons(sr) if (!inherits(sr, "SpatialPolygons")) - stop("sr should be of class \"SpatialPolygons\" or \"SpatialPolygonsDataFrame\"") + stop("sr should be of class \"SpatialPolygons\" or \"SpatialPolygonsDataFrame\"") + + ## Gets the polygons in the object sr pol <- sr@polygons warh <- 0 warh2 <- 0 warz <- 0 + + ## For each SpatialPolygons res <- lapply(pol, function(x) { - y <- x@Polygons - nom <- x@ID - ll <- length(y) - hh <- unlist(lapply(y, function(o) o@hole)) - hol <- sum(hh) - ll <- ll-hol - if (ll == 1) { - if (hol == 0) { - re <- as.data.frame(y[[1]]@coords) - re <- data.frame( fac = factor(rep(nom,length(re[,1]))), re) - names(re) <- c("fac", "x", "y") - } - if (hol != 0) { - warh <- warh+hol - warh2 <- warh2+1 - re <- as.data.frame(y[!hh][[1]]@coords) - re <- data.frame( fac = factor(rep(nom,length(re[,1]))), re) - names(re) <- c("fac", "x", "y") - } - } - if (ll > 1) { - warz <- warz+1 - if (hol == 0) { - nom <- paste(nom, 1:ll, sep=".") - re1 <- lapply(y, function(o) as.data.frame(o@coords)) - re <- do.call("rbind.data.frame", lapply(1:length(re1), function(i) { - u <- data.frame(fac=factor(rep(nom[i], length(re1[[i]][,1]))), re1[[i]]) - names(u) <- c("fac", "x", "y") - return(u) - })) + + ## gets the polygons and the ID + y <- x@Polygons + nom <- x@ID + ll <- length(y) + + ## Identify the holes + hh <- unlist(lapply(y, function(o) o@hole)) + hol <- sum(hh) + ll <- ll-hol + + ## One polygon + if (ll == 1) { + + if (hol == 0) { + + ## No hole -> creates the object area + re <- as.data.frame(y[[1]]@coords) + re <- data.frame( fac = factor(rep(nom,length(re[,1]))), re) + names(re) <- c("fac", "x", "y") + } + + if (hol != 0) { + + ## Hole present: prevision of the warning + ## we will delete the hole + warh <- warh+hol + warh2 <- warh2+1 + + ## Creation of the object area + re <- as.data.frame(y[!hh][[1]]@coords) + re <- data.frame( fac = factor(rep(nom,length(re[,1]))), re) + names(re) <- c("fac", "x", "y") + } } - if (hol!=0) { - warh <- warh+hol - warh2 <- warh2+1 - nom <- paste(nom, 1:ll, sep=".") - y <- y[!hh] - re1 <- lapply(y, function(o) as.data.frame(o@coords)) - re <- do.call("rbind.data.frame", lapply(1:length(re1), function(i) { - u <- data.frame(fac=factor(rep(nom[i], length(re1[[i]][,1]))), re1[[i]]) - names(u) <- c("fac", "x", "y") - return(u) - })) + + ## More than one polygon + if (ll > 1) { + warz <- warz+1 + + ## No hole + if (hol == 0) { + + ## pools the polygoons into the same area object + nom <- paste(nom, 1:ll, sep=".") + + ## and creates the object of class "area" + re1 <- lapply(y, function(o) as.data.frame(o@coords)) + re <- do.call("rbind.data.frame", + lapply(1:length(re1), function(i) { + u <- data.frame(fac=factor(rep(nom[i], + length(re1[[i]][,1]))), + re1[[i]]) + names(u) <- c("fac", "x", "y") + return(u) + })) + } + + ## Hole present + if (hol!=0) { + + ## predict the warning + warh <- warh+hol + warh2 <- warh2+1 + + ## creates the object of class "area" + nom <- paste(nom, 1:ll, sep=".") + y <- y[!hh] + re1 <- lapply(y, function(o) as.data.frame(o@coords)) + re <- do.call("rbind.data.frame", + lapply(1:length(re1), function(i) { + u <- data.frame(fac=factor(rep(nom[i], + length(re1[[i]][,1]))), + re1[[i]]) + names(u) <- c("fac", "x", "y") + return(u) + })) + } } - } - return(list(re,warh2, warh, warz)) + + ## Output + return(list(re,warh2, warh, warz)) }) + + ## Output object of class "area" warh2 <- sum(unlist(lapply(res, function(x) x[[2]]))) warh <- sum(unlist(lapply(res, function(x) x[[3]]))) warz <- sum(unlist(lapply(res, function(x) x[[4]]))) res <- lapply(res, function(x) x[[1]]) res <- do.call("rbind.data.frame", res) res <- as.area(res) + + ## and a warning if holes are present if (warh2>0) { - warning(paste("Area objects do not take into account holes in polygon.\n", - warh, "holes have been deleted from the data, belonging to\n", - warh2, "polygons")) + warning(paste("Area objects do not take into account holes in polygon.\n", + warh, "holes have been deleted from the data, belonging to\n", + warh2, "polygons")) } -## if (warz>0) { -## warning(paste("Some spatial rings contained several polygons.\n", -## "Labels have therefore been changed for", warz, "objects")) -## } + + ## Output return(res) - } +} diff --git a/R/storemapattr.r b/R/storemapattr.r index a75bd8b..6ddcf69 100755 --- a/R/storemapattr.r +++ b/R/storemapattr.r @@ -1,13 +1,17 @@ -"storemapattr" <- -function(x) - { +"storemapattr" <- function(x) +{ + ## Verifications if ((!inherits(x,"asc"))&(!inherits(x,"kasc"))) - stop("x should be a map of class asc or kasc") + stop("x should be a map of class asc or kasc") + + ## creates an object containing only the attributes of the arguments toto<-0 if (inherits(x, "asc")) - x<-as.kasc(list(x=x)) + x<-as.kasc(list(x=x)) toto<-getkascattr(x,toto) class(toto)<-"mapattr" + + ## output return(toto) } diff --git a/R/subsetmap.asc.r b/R/subsetmap.asc.r index 063aa87..45f2117 100755 --- a/R/subsetmap.asc.r +++ b/R/subsetmap.asc.r @@ -1,32 +1,44 @@ -"subsetmap.asc" <- -function(x, xlim=NULL, ylim=NULL, ...) - { +"subsetmap.asc" <- function(x, xlim=NULL, ylim=NULL, ...) +{ + ## Verifications if (!inherits(x, "asc")) - stop("x should be of class asc") + stop("x should be of class asc") + + ## Asks the boundaries of the new map if ((is.null(xlim))|(is.null(ylim))) { - image(x, main="select the boundaries of the subset") - ii<-locator(2) - xlim<-ii$x - ylim<-ii$y + image(x, main="select the boundaries of the subset") + ii<-locator(2) + xlim<-ii$x + ylim<-ii$y } + + ## The attributes of the new map xy<-getXYcoords(x) xlim<-xlim[order(xlim)] ylim<-ylim[order(ylim)] xll<-attr(x, "xll") yll<-attr(x, "yll") cs<-attr(x, "cellsize") + + ## Gets the indices of the limits of the new map posli1<-round((xlim[1]-xll)/cs, 0)+1 posco1<-round((ylim[1]-yll)/cs, 0)+1 posli2<-round((xlim[2]-xll)/cs, 0)+1 posco2<-round((ylim[2]-yll)/cs, 0)+1 + + ## Gets the new map o<-x[posli1:posli2,posco1:posco2] + + ## Sets the attributes of the new map attr(o, "xll")<-xy$x[posli1] attr(o, "yll")<-xy$y[posco1] attr(o, "cellsize")<-cs attr(o, "type")<-attr(x, "type") if (attr(o, "type")=="factor") - attr(o, "levels")<-attr(x, "levels") + attr(o, "levels")<-attr(x, "levels") class(o)<-"asc" + + ## Output return(o) - } +} diff --git a/R/subsetmap.kasc.r b/R/subsetmap.kasc.r index 68c3e86..780fe11 100755 --- a/R/subsetmap.kasc.r +++ b/R/subsetmap.kasc.r @@ -1,18 +1,24 @@ -"subsetmap.kasc" <- -function(x, xlim=NULL, ylim=NULL, ref=names(x)[1], ...) - { +"subsetmap.kasc" <- function(x, xlim=NULL, ylim=NULL, ref=names(x)[1], ...) +{ + ## Verifications if (!inherits(x, "kasc")) - stop("x should be of class kasc") + stop("x should be of class kasc") + + ## asks the boundaries of the new map if ((is.null(xlim))|(is.null(ylim))) { - image(getkasc(x, ref), main="select the boudaries of the subset") - ii<-locator(2) - xlim<-ii$x - ylim<-ii$y + image(getkasc(x, ref), main="select the boudaries of the subset") + ii<-locator(2) + xlim<-ii$x + ylim<-ii$y } + + ## subsetmap.asc for each map so<-list() for (i in names(x)) - so[[i]]<-subsetmap.asc(getkasc(x, i), xlim=xlim, ylim=ylim) + so[[i]]<-subsetmap.asc(getkasc(x, i), xlim=xlim, ylim=ylim) so<-as.kasc(so) + + ## Output return(so) - } +} diff --git a/R/subsetmap.r b/R/subsetmap.r index 0768a1f..6ad0572 100755 --- a/R/subsetmap.r +++ b/R/subsetmap.r @@ -1,6 +1,5 @@ -"subsetmap" <- -function(x, xlim=NULL, ylim=NULL, ...) - { +"subsetmap" <- function(x, xlim=NULL, ylim=NULL, ...) +{ UseMethod("subsetmap") - } +} diff --git a/R/summary.traj.r b/R/summary.traj.r index 882d2f7..5faab39 100755 --- a/R/summary.traj.r +++ b/R/summary.traj.r @@ -1,34 +1,33 @@ -"summary.traj" <- -function(object, id=levels(object$id), date=NULL, ...) - { +"summary.traj" <- function(object, id=levels(object$id), date=NULL, ...) +{ + ## Verifications x<-object if (!inherits(x, "traj")) - stop("x should be an object of class traj") + stop("x should be an object of class traj") - ## prévoir le cas où un objet vide est choisi - ## sélection des dates - if (!is.null(date)) - x<-x[(x$date>=date[1])&(x$date=date[1])&(x$date SpatialLines + lev <- levels(factor(id)) + re1 <- lapply(lev, function(x) Lines(lixy[id==x], ID=x)) + res <- SpatialLines(re1) + df <- data.frame(id=lev) } else { - res <- lapply(1:length(lixy), - function(i) Lines(list(lixy[[i]]), ID=names(lixy)[i])) - res <- SpatialLines(res) - df <- data.frame(id=id, burst=bu) + + ## If one line per ID -> SpatialLines + res <- lapply(1:length(lixy), + function(i) Lines(list(lixy[[i]]), ID=names(lixy)[i])) + res <- SpatialLines(res) + df <- data.frame(id=id, burst=bu) } + + ## Output res <- SpatialLinesDataFrame(res, data=df) return(res) - } +} diff --git a/R/traj2spdf.r b/R/traj2spdf.r index 145c314..5b10d88 100755 --- a/R/traj2spdf.r +++ b/R/traj2spdf.r @@ -1,12 +1,18 @@ -"traj2spdf" <- -function(tr) - { +"traj2spdf" <- function(tr) +{ + ## Verifications if (!inherits(tr, "traj")) stop("tr should be of class \"traj\"") + + ## Conversion to data frame class(tr) <- "data.frame" xy <- tr[,c("x","y")] tr$y <- tr$x <- NULL + + ## Conversion to SpatialPointsDataFrame res <- SpatialPointsDataFrame(xy, tr) + + ## Output return(res) } diff --git a/R/varlogfpt.r b/R/varlogfpt.r index e7c28b4..644a476 100755 --- a/R/varlogfpt.r +++ b/R/varlogfpt.r @@ -1,28 +1,36 @@ -"varlogfpt" <- -function(f, graph=TRUE) - { +"varlogfpt" <- function(f, graph=TRUE) +{ + ## Verifications if (!inherits(f, "fipati")) - stop("f should be of class 'fipati'") + stop("f should be of class 'fipati'") + + ## graphical settings if (graph) - opar <- par(mfrow=n2mfrow(length(f))) + opar <- par(mfrow=n2mfrow(length(f))) + + ## The radii s <- attr(f, "radii") + + ## Computation oof the variance for each radius and each burst soso <- lapply(f, function(y) { - so <- apply(y,2,function(z) var(log(z), na.rm=TRUE)) - if (graph) - plot(s, so, ty="l", xlab="scale", ylab="Variance of log(FPT)", - main=attr(y,"burst")) - return(so) + so <- apply(y,2,function(z) var(log(z), na.rm=TRUE)) + if (graph) + plot(s, so, ty="l", xlab="scale", ylab="Variance of log(FPT)", + main=attr(y,"burst")) + return(so) }) + + ## Output soso <- as.data.frame(do.call("rbind",soso)) row.names(soso) <- unlist(lapply(f, function(z) attr(z, "burst"))) names(soso) <- paste("r",1:ncol(soso), sep="") attr(soso, "radii") <- attr(f,"radii") if (graph) - par(opar) + par(opar) if (graph) { - invisible(soso) + invisible(soso) } else { - return(soso) + return(soso) } - } +} diff --git a/R/widesI.r b/R/widesI.r index 2ad30d8..9cb56af 100755 --- a/R/widesI.r +++ b/R/widesI.r @@ -1,20 +1,25 @@ -"widesI" <- -function(u, a, avknown=TRUE, alpha=0.05) - { +"widesI" <- function(u, a, avknown=TRUE, alpha=0.05) +{ + ## Verifications if (length(u)!=length(a)) - stop("available and used vector should have the same length") + stop("available and used vector should have the same length") if (is.null(names(u))) - names(u)<-paste("Habitat", 1:length(u), sep="") + names(u)<-paste("Habitat", 1:length(u), sep="") + + + ## Bases sorties<-list() ui<-u ai<-a - oi<-ui/sum(ui) - pi<-ai/sum(ai) - I<-length(u) - wi<-oi/pi - bonferroni<-alpha/(I*(I-1)/2) + + oi<-ui/sum(ui) # proportion used + pi<-ai/sum(ai) # proportion available + I<-length(u) # number of habitats + wi<-oi/pi # selection ratios + bonferroni<-alpha/(I*(I-1)/2) # level of Bonferroni confidence intervals + ## Preparation of output sorties$used.prop<-oi sorties$se.used<-sqrt((oi*(1-oi)/sum(ui))) sorties$avail.prop<-pi @@ -25,65 +30,98 @@ function(u, a, avknown=TRUE, alpha=0.05) } else { sorties$se.wi<-wi*sqrt(1/ui-1/sum(ui)+1/ai-1/sum(ai)) } - + + ## Chi-square of the selection ratios = 1 testwi<-((sorties$wi-1)/sorties$se.wi)^2 sorties$chisquwi<-data.frame(testwi=testwi, p=1-pchisq(testwi, 1)) + + ## Standardised selection ratios sorties$Bi<-sorties$wi/sum(sorties$wi) + if (avknown) { - sorties$Khi2P<-c(tmp<-sum(((ui-sum(u)*pi)^2)/(sum(u)*pi)), - length(u)-1, - 1-pchisq(tmp, I-1)) - tmp<-u*log(u/(sum(u)*pi)) - tmp[is.na(tmp)]<-0 - sorties$Khi2L<-c(tmp<-2*sum(tmp), - length(u)-1, - 1-pchisq(tmp, I-1)) + + ## Classical Chi-square + sorties$Khi2P<-c(tmp<-sum(((ui-sum(u)*pi)^2)/(sum(u)*pi)), + length(u)-1, + 1-pchisq(tmp, I-1)) + + ## Chi-square based on likelihood + tmp<-u*log(u/(sum(u)*pi)) + tmp[is.na(tmp)]<-0 + sorties$Khi2L<-c(tmp<-2*sum(tmp), + length(u)-1, + 1-pchisq(tmp, I-1)) } else { - Eui<-(ai+ui)*sum(ui)/(sum(u)+sum(ai)) - Eai<-(ai+ui)*sum(ai)/(sum(u)+sum(ai)) - sorties$Khi2P<-c(tmp<-sum(((ui-Eui)^2)/Eui + ((ai-Eai)^2)/Eai), - length(u)-1, - 1-pchisq(tmp, I-1)) - sorties$Khi2L<-c(tmp<-2*sum(u*log(u/Eui)+ai*log(ai/Eai)), - length(u)-1, - 1-pchisq(tmp, I-1)) + + Eui<-(ai+ui)*sum(ui)/(sum(u)+sum(ai)) + Eai<-(ai+ui)*sum(ai)/(sum(u)+sum(ai)) + + ## Classical Chi-square + sorties$Khi2P<-c(tmp<-sum(((ui-Eui)^2)/Eui + ((ai-Eai)^2)/Eai), + length(u)-1, + 1-pchisq(tmp, I-1)) + + ## Chi-square based on likelihood + sorties$Khi2L<-c(tmp<-2*sum(u*log(u/Eui)+ai*log(ai/Eai)), + length(u)-1, + 1-pchisq(tmp, I-1)) } - + + ## output names(sorties$Khi2P)<-c("Khi2P", "df", "pvalue") names(sorties$Khi2L)<-c("Khi2L", "df", "pvalue") + + ## Bases for the computation of the + ## ranking matrix of the selection ratios diffwi<-matrix(0, nrow=I, ncol=I) vardif<-matrix(0, nrow=I, ncol=I) sig<-matrix(0, nrow=I, ncol=I) ICdiffupper<-matrix(0, nrow=I, ncol=I) ICdifflower<-matrix(0, nrow=I, ncol=I) sig<-matrix(0, nrow=I, ncol=I) - + + ## filling the ranking matrix for (i in 1:I) { - for (j in 1:I) { - if (i!=j) { - vardif[i,j]<-ifelse(avknown, - (oi[i]*(1-oi[i])/(sum(ui)*(pi[i]^2))+ - oi[j]*(1-oi[j])/(sum(ui)*(pi[j]^2))- - 2*oi[i]*oi[j]/(sum(ui)*pi[i]*pi[j])), - (wi[i]/pi[i]+wi[j]/pi[j]-((wi[i]-wi[j])^2))/sum(ui)+ - ((wi[i]^2)/pi[i]+(wi[j]^2)/pi[j]-((wi[i]-wi[j])^2))/sum(ai)) - diffwi[i,j]<-(wi[i]-wi[j]) - ICdiffupper[i,j]<-round(diffwi[i,j]+sqrt(vardif[i,j])*qnorm(1-bonferroni/2),4) - ICdifflower[i,j]<-round(diffwi[i,j]-sqrt(vardif[i,j])*qnorm(1-bonferroni/2),4) - if (diffwi[i,j]<0) sig[i,j] <- "-" - if (diffwi[i,j]>0) sig[i,j] <- "+" - if (diffwi[i,j]==0) sig[i,j] <- "0" - if (ICdiffupper[i,j]<0) - sig[i,j]<-"---" - if (ICdifflower[i,j]>0) - sig[i,j]<-"+++" - } else { - sig[i,j]<-"0" + for (j in 1:I) { + if (i!=j) { + + ## variance of the difference of selection ratios + vardif[i,j]<-ifelse(avknown, + (oi[i]*(1-oi[i])/(sum(ui)*(pi[i]^2))+ + oi[j]*(1-oi[j])/(sum(ui)*(pi[j]^2))- + 2*oi[i]*oi[j]/(sum(ui)*pi[i]*pi[j])), + (wi[i]/pi[i]+wi[j]/ + pi[j]-((wi[i]-wi[j])^2))/sum(ui)+ + ((wi[i]^2)/pi[i]+(wi[j]^2)/ + pi[j]-((wi[i]-wi[j])^2))/sum(ai)) + + ## difference of selection ratios + diffwi[i,j]<-(wi[i]-wi[j]) + + ## Coonfidence intervals + ICdiffupper[i,j]<-round(diffwi[i,j]+ + sqrt(vardif[i,j])* + qnorm(1-bonferroni/2),4) + ICdifflower[i,j]<-round(diffwi[i,j]- + sqrt(vardif[i,j])* + qnorm(1-bonferroni/2),4) + + ## The ranking matrix + if (diffwi[i,j]<0) sig[i,j] <- "-" + if (diffwi[i,j]>0) sig[i,j] <- "+" + if (diffwi[i,j]==0) sig[i,j] <- "0" + if (ICdiffupper[i,j]<0) + sig[i,j]<-"---" + if (ICdifflower[i,j]>0) + sig[i,j]<-"+++" + } else { + sig[i,j]<-"0" + } } - } - } - + } + + ## row and column names rownames(diffwi)<-names(u) colnames(diffwi)<-names(u) rownames(ICdiffupper)<-names(u) @@ -93,14 +131,16 @@ function(u, a, avknown=TRUE, alpha=0.05) rownames(sig)<-names(u) colnames(sig)<-names(u) + ## Output sorties$avknown<-avknown sorties$comparisons$diffwi<-diffwi sorties$comparisons$ICdiffupper<-ICdiffupper sorties$comparisons$ICdifflower<-ICdifflower sorties$comparisons$signif<-sig + ## the profile sorties$profile<-profilehab(sig, wi) sorties$alpha<-alpha class(sorties)<-c("wiI", "wi") return(sorties) - } +} diff --git a/R/widesII.r b/R/widesII.r index 306c5d8..e838e5e 100755 --- a/R/widesII.r +++ b/R/widesII.r @@ -1,9 +1,11 @@ -"widesII" <- -function(u, a, avknown=TRUE, alpha=0.05) - { +"widesII" <- function(u, a, avknown=TRUE, alpha=0.05) +{ + ## Verifications u<-as.matrix(u) if (ncol(u)!=length(a)) - stop("used and available matrices should have the same number of habitats") + stop("used and available matrices should have the same number of habitats") + + ## Bases uij<-as.matrix(u) ai<-a pi<-ai/sum(ai) @@ -17,8 +19,7 @@ function(u, a, avknown=TRUE, alpha=0.05) sorties$used.prop <- oi sorties$avail.prop <- pi - - ## Calcul de Khi2L1 + ## Computation of Khi2L1 Euij<-outer(upj,uip)/upp tmp<-log(uij/Euij) tmp[abs(tmp)==Inf]<-0 @@ -27,113 +28,119 @@ function(u, a, avknown=TRUE, alpha=0.05) 1 - pchisq(tmp, df)) names(Khi2L1)<-c("Khi2L1", "df", "pvalue") sorties$Khi2L1<-Khi2L1 - - ## Calcul de Khi2L2 + + ## Computation of Khi2L2 if (avknown) { - Euij<-outer(upj,pi) - tmp<-log(uij/Euij) - tmp[abs(tmp)==Inf]<-0 - Khi2L2<-c(tmp<-2*sum(as.vector(uij*tmp)), df<-(I-1)*n, - 1 - pchisq(tmp, df)) - names(Khi2L2)<-c("Khi2L2", "df", "pvalue") - sorties$Khi2L2<-Khi2L2 - - ## Calcul de la différence - Khi2L2MinusL1<-c(tmp<-Khi2L2[1]-Khi2L1[1], I-1, - 1 - pchisq(tmp, I-1)) - names(Khi2L2MinusL1)<-c("Khi2L2MinusL1", "df", "pvalue") - sorties$Khi2L2MinusL1<-Khi2L2MinusL1 - } - else { - uija<-rbind(uij,ai) - upja<-apply(uija, 1, sum) - uipa<-apply(uija, 2, sum) - Euija<-outer(upja,uipa)/sum(upja) - tmp<-log(uija/Euija) - tmp[abs(tmp)==Inf]<-0 - Khi2L2<-c(tmp<-2*sum(as.vector(uija*tmp)), df<-(I-1)*n, - 1 - pchisq(tmp, df)) - names(Khi2L2)<-c("TrickyKhi2", "df", "pvalue") - sorties$Khi2L2<-Khi2L2 - ## Calcul de la différence - Khi2L2MinusL1<-c(tmp<-Khi2L2[1]-Khi2L1[1], I-1, - 1 - pchisq(tmp, I-1)) - names(Khi2L2MinusL1)<-c("Khi2L2MinusL1", "df", "pvalue") - sorties$Khi2L2MinusL1<-Khi2L2MinusL1 + Euij<-outer(upj,pi) + tmp<-log(uij/Euij) + tmp[abs(tmp)==Inf]<-0 + Khi2L2<-c(tmp<-2*sum(as.vector(uij*tmp)), df<-(I-1)*n, + 1 - pchisq(tmp, df)) + names(Khi2L2)<-c("Khi2L2", "df", "pvalue") + sorties$Khi2L2<-Khi2L2 + + + ## The difference between the two Khi squares + Khi2L2MinusL1<-c(tmp<-Khi2L2[1]-Khi2L1[1], I-1, + 1 - pchisq(tmp, I-1)) + names(Khi2L2MinusL1)<-c("Khi2L2MinusL1", "df", "pvalue") + sorties$Khi2L2MinusL1<-Khi2L2MinusL1 + } else { + + ## Khi2L2 when availability is estimated + uija<-rbind(uij,ai) + upja<-apply(uija, 1, sum) + uipa<-apply(uija, 2, sum) + Euija<-outer(upja,uipa)/sum(upja) + tmp<-log(uija/Euija) + tmp[abs(tmp)==Inf]<-0 + Khi2L2<-c(tmp<-2*sum(as.vector(uija*tmp)), df<-(I-1)*n, + 1 - pchisq(tmp, df)) + names(Khi2L2)<-c("TrickyKhi2", "df", "pvalue") + sorties$Khi2L2<-Khi2L2 + + ## Computation of the difference between the two Khi square + Khi2L2MinusL1<-c(tmp<-Khi2L2[1]-Khi2L1[1], I-1, + 1 - pchisq(tmp, I-1)) + names(Khi2L2MinusL1)<-c("Khi2L2MinusL1", "df", "pvalue") + sorties$Khi2L2MinusL1<-Khi2L2MinusL1 } - - ## Matrice des wi + + ## Matrix of selection ratios wij<-t(t(uij/upj)/pi) wi<-(uip/upp)/pi sorties$wij<-wij sorties$wi<-wi - ## Calcul de la variance des wi + ## Variance of selection ratios if (avknown) { - varwi<-apply((((t(t(uij)/pi) - outer(upj,wi) )^2)/(n-1)), - 2, sum)*(n/(upp^2)) - sewi<-sqrt(varwi) - } - else { - Vi<-uip/upp - varVi<-Vi - for (i in 1:length(Vi)) { - varVi[i]<-(sum((u[,i]-Vi[i]*upj)^2 )/(n-1))/(n*(mean(upj)^2)) - } - varpi<-pi*(1-pi)/sum(ai) - sewi<-sqrt(((Vi/pi)^2)*(varVi/(Vi^2)+varpi/(pi^2))) + varwi<-apply((((t(t(uij)/pi) - outer(upj,wi) )^2)/(n-1)), + 2, sum)*(n/(upp^2)) + sewi<-sqrt(varwi) + } else { + Vi<-uip/upp + varVi<-Vi + for (i in 1:length(Vi)) { + varVi[i]<-(sum((u[,i]-Vi[i]*upj)^2 )/(n-1))/(n*(mean(upj)^2)) + } + varpi<-pi*(1-pi)/sum(ai) + sewi<-sqrt(((Vi/pi)^2)*(varVi/(Vi^2)+varpi/(pi^2))) } + + ## Output sorties$se.wi<-sewi sorties$ICwiupper<-round(wi+sewi*qnorm(1 - alpha/(2*I)), 4) sorties$ICwilower<-round(wi-sewi*qnorm(1 - alpha/(2*I)), 4) - - ## calcul des SE des différences des wi + + ## Matrix of the standard errors of + ## the differences of the selection ratios diffwi<-outer(wi,wi,"-") sediffwi<-diffwi if (avknown) { - for (i in 1:I) { - for (j in 1:I) { - tmp<-uij[,i]/pi[i] - uij[,j]/pi[j] - wi[i]*upj + wi[j]*upj - sediffwi[i,j]<-sqrt(((n/(n-1))/(upp^2))*sum(tmp^2)) + for (i in 1:I) { + for (j in 1:I) { + tmp<-uij[,i]/pi[i] - uij[,j]/pi[j] - wi[i]*upj + wi[j]*upj + sediffwi[i,j]<-sqrt(((n/(n-1))/(upp^2))*sum(tmp^2)) + } } - } - } - else { - for (i in 1:I) { - for (j in 1:I) { - tmp<-(sum((uij[,i]/pi[i]-uij[,j]/pi[j]-diffwi[i,j]*upj)^2)/(n-1))*(n/(upp^2)) - tmp<-tmp+((wi[i]^2)/pi[i]+(wi[j]^2)/pi[j]-(diffwi[i,j]^2))/sum(ai) - sediffwi[i,j]<-sqrt(tmp) + } else { + for (i in 1:I) { + for (j in 1:I) { + tmp<-(sum((uij[,i]/pi[i]-uij[,j]/ + pi[j]-diffwi[i,j]*upj)^2)/(n-1))*(n/(upp^2)) + tmp<-tmp+((wi[i]^2)/pi[i]+(wi[j]^2)/ + pi[j]-(diffwi[i,j]^2))/sum(ai) + sediffwi[i,j]<-sqrt(tmp) + } } - } } - ## Calcul des IC - ## pour les différences de wi + + ## Confidence intervals on these differences bonferroni <- alpha/(I * (I - 1)/2) ICdiffupper<-round(diffwi+sediffwi*qnorm(1 - bonferroni/2), 4) ICdifflower<-round(diffwi-sediffwi*qnorm(1 - bonferroni/2), 4) - ## ranking matrix + ## The ranking matrix sig<-diffwi for (i in 1:I) { - for (j in 1:I) { - if (i!=j) { - sig[i, j] <- ifelse(diffwi[i, j] < 0, "-", "+") - if (ICdiffupper[i, j] < 0) - sig[i, j] <- "---" - if (ICdifflower[i, j] > 0) - sig[i, j] <- "+++" - } - else { - sig[i,j]<-"0" + for (j in 1:I) { + if (i!=j) { + sig[i, j] <- ifelse(diffwi[i, j] < 0, "-", "+") + if (ICdiffupper[i, j] < 0) + sig[i, j] <- "---" + if (ICdifflower[i, j] > 0) + sig[i, j] <- "+++" + } + else { + sig[i,j]<-"0" + } } - } } - ## sorties + ## Rownames and colnames rownames(diffwi) <- colnames(u) colnames(diffwi) <- colnames(u) rownames(ICdiffupper) <- colnames(u) @@ -142,6 +149,8 @@ function(u, a, avknown=TRUE, alpha=0.05) colnames(ICdifflower) <- colnames(u) rownames(sig) <- colnames(u) colnames(sig) <- colnames(u) + + ## Output sorties$avknown <- avknown sorties$comparisons$diffwi <- diffwi sorties$comparisons$ICdiffupper <- ICdiffupper @@ -151,5 +160,5 @@ function(u, a, avknown=TRUE, alpha=0.05) sorties$alpha <- alpha class(sorties) <- c("wiII", "wi") return(sorties) - } +} diff --git a/R/widesIII.r b/R/widesIII.r index 660536c..4f38937 100755 --- a/R/widesIII.r +++ b/R/widesIII.r @@ -1,32 +1,29 @@ -"widesIII" <- -function(u, a, avknown = TRUE, alpha = 0.05) - { +"widesIII" <- function(u, a, avknown = TRUE, alpha = 0.05) +{ + ## Verifications u<-as.matrix(u) a<-as.matrix(a) - - ## Vérifications de départ - if (nrow(u) != nrow(a)) + if (nrow(u) != nrow(a)) stop("available and used matrix should have the same number of animals") - if (ncol(u) != ncol(a)) + if (ncol(u) != ncol(a)) stop("available and used matrix should have the same number of habitats") - - ## Les transfos de base + + ## Bases sorties<-list() pij<-as.matrix(a) - ## Calcul de la disponibilité si pas fournie - ## en pourcentages pij + ## Computation of the availability if not given in percentage aip<-apply(a,2,sum) apj<-apply(a,1,sum) - - ## Calcul de l'utilisation (pourcentage) + + ## Computation of the use if not given in percentage uij<-as.matrix(u) - if (is.null(colnames(u))) - colnames(uij) <- paste("Habitat", 1:ncol(u), sep = "") - if (is.null(colnames(a))) - colnames(pij) <- paste("Habitat", 1:ncol(a), sep = "") + if (is.null(colnames(u))) + colnames(uij) <- paste("Habitat", 1:ncol(u), sep = "") + if (is.null(colnames(a))) + colnames(pij) <- paste("Habitat", 1:ncol(a), sep = "") - ## Les deux matrices + ## The two matrices pij<-as.matrix(a/apj) uij<-as.matrix(u) I<-ncol(uij) @@ -39,101 +36,106 @@ function(u, a, avknown = TRUE, alpha = 0.05) wij<-uij/(upj*pij) wi<-uip/apply(pij*upj,2,sum) - ## sorties + ## Output sorties$used.prop <- t(t(uij)/uip) sorties$avail.prop <- pij sorties$wij<-wij sorties$wi<-wi - ## Calcul des Khi2 + ## Computation of the Khi2 Khi2Lj<-matrix(0, nrow=J, ncol=3) colnames(Khi2Lj)<-c("Khi2Lj", "df", "pvalue") for (j in 1:J) { - euij<-uij[j,]*log(uij[j,]/(upj[j]*pij[j,])) - ddl<-length(euij[!is.na(euij)])-1 - euij<-euij[!is.na(euij)] - Khi2Lj[j,1]<-sum(euij) - Khi2Lj[j,2]<-ddl - Khi2Lj[j,3]<-1 - pchisq(Khi2Lj[j,1], ddl) + euij<-uij[j,]*log(uij[j,]/(upj[j]*pij[j,])) + ddl<-length(euij[!is.na(euij)])-1 + euij<-euij[!is.na(euij)] + Khi2Lj[j,1]<-sum(euij) + Khi2Lj[j,2]<-ddl + Khi2Lj[j,3]<-1 - pchisq(Khi2Lj[j,1], ddl) } - rownames(Khi2Lj)<-rownames(u) - + + ## Output sorties$Khi2Lj<-Khi2Lj Khi2L<-apply(Khi2Lj,2,sum) Khi2L[3]<-1 - pchisq(Khi2L[1],Khi2L[2]) names(Khi2L)<-c("Khi2L", "df", "pvalue") sorties$Khi2L<-Khi2L - ## Variance de wi + ## Variance of the selection ratios vwi<-rep(0,I) for (i in 1:I) { - yj<-uij[,i] - xj<-pij[,i]*upj - vwi[i]<-(sum((yj-wi[i]*xj)**2)/(J-1))*(1/(J*(mean(xj)**2))) + yj<-uij[,i] + xj<-pij[,i]*upj + vwi[i]<-(sum((yj-wi[i]*xj)**2)/(J-1))*(1/(J*(mean(xj)**2))) } - sewi<-sqrt(vwi) + + ## Output sorties$se.wi<-sewi sorties$ICwiupper<-round(wi+sewi*qnorm(1 - alpha/(2*I)), 4) sorties$ICwilower<-round(wi-sewi*qnorm(1 - alpha/(2*I)), 4) - ## Différences des selection ratios + ## Matrix of the differences of the selection ratios, the ranking matrix diffwi<-outer(wi,wi,"-") vardif<-matrix(0, I, I) ICdiffupper<-matrix(0, I, I) ICdifflower<-matrix(0, I, I) sig<-matrix("0", I, I) - + for (i in 1:I) { - for (j in 1:I) { - if (avknown) { - ## dispo connue - spi<-sum(pij[,i]*upj) - spj<-sum(pij[,j]*upj) - - vardif[i,j]<-sum(((uij[,i]-wi[i]*upj)/spi + - (uij[,j]-wi[j]*upj)/spj )**2 )*(J/(J-1)) - } - else { - ## dispo inconnue - dftmp<-data.frame(y1=uij[,i],y2=uij[,j], - x1=pij[,i]*upj, x2=pij[,j]*upj) - vc<-var(dftmp) - y1<-uip[i] - y2<-uip[j] - x1<-sum(pij[,i]*upj) - x2<-sum(pij[,j]*upj) - vardif[i,j]<-(1/(y1**2))*vc["x1","x1"] + - ((x1**2)/(y1**4))*vc["y1","y1"] + - (1/(y2**2))*vc["x2","x2"] + - ((x2**2)/(y2**4))*vc["y2","y2"] - - 2*(x1/(y1**3))*vc["x1","y1"] - - 2*(1/(y1*y2))*vc["x1","x2"] + - 2*(x2/(y1*(y2**2)))*vc["x1","y2"] + - 2*(x1/(y2*(y1**2)))*vc["y1","x2"] - - 2*((x1*x2)/((y1**2)*(y2**2)))*vc["y1","y2"] - - 2*(x2/(y2**3))*vc["x2","y2"] + for (j in 1:I) { + if (avknown) { + ## availability known + spi<-sum(pij[,i]*upj) + spj<-sum(pij[,j]*upj) + + ## matrix of the variances + vardif[i,j]<-sum(((uij[,i]-wi[i]*upj)/spi + + (uij[,j]-wi[j]*upj)/spj )**2 )*(J/(J-1)) + } else { + ## unknown availability + dftmp<-data.frame(y1=uij[,i],y2=uij[,j], + x1=pij[,i]*upj, x2=pij[,j]*upj) + vc<-var(dftmp) + y1<-uip[i] + y2<-uip[j] + x1<-sum(pij[,i]*upj) + x2<-sum(pij[,j]*upj) + vardif[i,j]<-(1/(y1**2))*vc["x1","x1"] + + ((x1**2)/(y1**4))*vc["y1","y1"] + + (1/(y2**2))*vc["x2","x2"] + + ((x2**2)/(y2**4))*vc["y2","y2"] - + 2*(x1/(y1**3))*vc["x1","y1"] - + 2*(1/(y1*y2))*vc["x1","x2"] + + 2*(x2/(y1*(y2**2)))*vc["x1","y2"] + + 2*(x1/(y2*(y1**2)))*vc["y1","x2"] - + 2*((x1*x2)/ + ((y1**2)*(y2**2))) * + vc["y1","y2"] - + 2*(x2/(y2**3))* + vc["x2","y2"] + } + vardif[row(vardif)==col(vardif)]<-0 + + ## Confidence intervals on the differences of selection ratios + ICdiffupper[i, j] <- round(diffwi[i, j] + + sqrt(vardif[i,j]) * + qnorm(1 - bonferroni/2), 4) + ICdifflower[i, j] <- round(diffwi[i, j] - + sqrt(vardif[i,j]) * + qnorm(1 - bonferroni/2), 4) + + ## Ranking matrix + sig[i, j] <- ifelse(diffwi[i, j] < 0, "-", "+") + if (ICdiffupper[i, j] < 0) + sig[i, j] <- "---" + if (ICdifflower[i, j] > 0) + sig[i, j] <- "+++" } - vardif[row(vardif)==col(vardif)]<-0 - - ## calcul des ic... - ICdiffupper[i, j] <- round(diffwi[i, j] + - sqrt(vardif[i,j]) * - qnorm(1 - bonferroni/2), 4) - ICdifflower[i, j] <- round(diffwi[i, j] - - sqrt(vardif[i,j]) * - qnorm(1 - bonferroni/2), 4) - sig[i, j] <- ifelse(diffwi[i, j] < 0, "-", "+") - - ## ... et de la signification des différences - if (ICdiffupper[i, j] < 0) - sig[i, j] <- "---" - if (ICdifflower[i, j] > 0) - sig[i, j] <- "+++" - } } - + + ## Row and column names rownames(diffwi) <- colnames(u) colnames(diffwi) <- colnames(u) rownames(ICdiffupper) <- colnames(u) @@ -142,6 +144,8 @@ function(u, a, avknown = TRUE, alpha = 0.05) colnames(ICdifflower) <- colnames(u) rownames(sig) <- colnames(u) colnames(sig) <- colnames(u) + + ## Output sorties$avknown <- avknown sorties$comparisons$diffwi <- diffwi sorties$comparisons$ICdiffupper <- ICdiffupper diff --git a/data/puech.rda b/data/puech.rda new file mode 100644 index 0000000000000000000000000000000000000000..15d18f4cb3ae393280aece4436e0119bf92d25aa GIT binary patch literal 25916 zcmZ^~cUV(d_dh!CI5P+qMgb8i8Ap*OFv!qLY{&otB2A@a6cGg>^b$y-qkvMCu9PUf zM{1~vf`D|Xp(gYINeJmZxxDZ9e((J~_j&Jm&L3y3eV();XlVA za`%yDPizd{=+u+fk7RNqU|i8&}t?9J^IYdQCP=E8M&^eWX;~f3J^!<>co+ z#ovsh5B+p_&Av-dUjBzGw;SKN4BlQmUl`q9m0w<$lUaT*=sj+0BDy`OrZp&MvfN+# zlNbZ;!h}gb+QOL-Jbxh6Mo^4m5m44TpF&y0qu7>wbMX;7f<-%H@LnD3?Si$6qX?KI zh!dO}!~m*hig*n#McWD5S~+zNdjcZ+4T~#Q2 zYy$^q6Lfb4058k~ViMD55LuD6R`i!(sT`YA=e$BifP@RDVB*Q7x9&EK;Q;RzMF4-T zaRwQQ;LgdTNJ=rx89DFioH~F)$tQr*LVCT@-Bxak{U8!>0e)q>D2@WGx8T-M7c%j2 zXx0W&xPD$BpNWV6`4L}j!4*vnc2m?CaGRdNZji-Wf%jX1==DM-KvZ>Jh;V?x&vRoh zwnv#R#fmpKz>c(~>*PUcQ7|pmi-tNYDW*sY?`5zT2Pw=!{6HqY?&XCDjvH+WHKqoK z8*up#PKp&JyEDE6&U0bsxZRpusP;$TyYIu2fogE^qfkl^8m`0TXAa_}Gifl3cCk?= z{zwLb79&W0DPnGT z)7YaXHXWmb_=?O{(bJQ;(>pKp%ET@-Hh&P0|7#Cnv!_NDyJg@}qC+h^K*v2{z#u+j zgFX4u`k)ugomd(R??B^pZ?OM5$+phGBh}(;7T8}fuCcT+@P!b7{o_#a3qP6n)2qGg z3_Rw}NMp2hCzGB{dPaVW(+Qclr^r0>BwK6g1k?b>)Lcc-$`wg}@ zzZBzBNoF9c}z7#`fota;|GXx_1$qqBFN1h;6ZM9ueNZz2h(b(*aeR%$N z%7t++JD6I`c;~(RrtS3>6FR^VCcZ&qo3)sPiEmvMk8e;sY3vsp6!(KMwx8^JE3n8F zSmeJ%IBYwrG9XvQ(O1Q`G*q{t-xuo)0s8IN?!1@c`&Y$rSK+!`vkZYMIiD?^fe~Ni z@;wH-xi&nR78Cdu=)x-Ioj~YzQWWsffu6w{;ddVNxBG9*fNl@8i;X4KV#c`0Onemm z&fBjPyX{y>q5dG=&L)5M0>jy6Y5x2&^t0(9jAIIy_|%1hKH`BBkU`NvNpaZ*rT4rLXx}3lG%f(yaDp>f zH)ydQG`8-KkH*g%o9AcoN2)e(c*n>8%;+OkF*24G`~v{nK#O7wrp50{m;6MJX}MW+ zQvZQ#MqhZs*2mk3L@u-ux<7r{5T^0bhUX^^r?JV;#PTpz8#*BagUS4=x@nm?P4_$L ziLn1e5cf~7zSuG2!l3vF$Ob0P+`tuY;NESpy?DctLK&M_;QQ~uoR`w7e|{kz!H{P7 zHRq7Em%D-eZ$gZ2W8e?XfRQh)0etb&-}@W1x1;9}9_>3geWxv8>rP7`g8$;@xcsgy znvV)_i|+F;;3=BV3E(NZk0h{YHa&f$&r%LG{c&18|54xh+xOz9 zOQ-HA9H~wD*{%OaEuZJv4WEbpZ}mNeBXue9Zv9uad_HD3d>^{=*!N=drBnY=Tec(3ZlR5L)6bdVEAOG5Z9 zwH^Hh+}lUxCMQX#0buC$HM0;)(1yt-+qdkHQShZD(=<)xw&yaOZgpNnAEq?enVWjK zSJ=q42wzIU6y~Mxvxkq#kNqW~3fz$N#MDOb|0bBZchdp}a_uN9)=ff}#-Z!O?c=Q% z^pxwg%wy7XM%ho+eT5*h*S%y7;UayMj$P-LIVg#(+#Am8i-wR}_SqE5f%F5xUw?8#35_4)wei@o+)>oo?4CusIztj@ezLu-i zb$h&S1@;%n)S)@-I@zNtvbI>XHmo@@vxKFWyRRgdq-f3k{0Q)?8+ygoJQ5Hc&83EJ zQQ6~g`)Sh2i4$cW^@Ps>+|q>_ega6SqOGJ$`av<>!wGsOARJz}?LPyr>mj;|Tm13< z3soGaGBz&}cAxcZ4fC%Vx~`Tom1;!0HZ;oW;kcPKVuZNH{ktYwS3F^+WV$gVSnS*ZmX@gm~4FO`*ueJJnX zW#KDNjMY`l-yn0Bq5ITONBEOgSLx*e%ez$scZX`x64-i2sy8*{LHlm^?bVs$mF6o< zxGNK8&s+|^eSaBl#l~s?_dV1^wQ^qPl2lq@wS+I}RGH4_)RwA0LSHMP4-oPb8?267 zJooJ*7pw`szWEFi(g6bqVYgktmdr^ zW_DUhR>}T?n`eD$MP`WbhT`-00u5aM_zk5SLH6R=wNI;~(D+T%JG8a5UOjRW+T_?H z>2Et~S#y1YttEE@q;q6-jZwNlPbxuHc`MF{QZt_iopi{T z#n^D4LUeBJA0njMV%|n?^55^3fI&{tg`B@x&nETJ#=vSbplfn34s->7($Tcvj=p|? ztt`Lw{9VbQEquH{s>$xtk=Yv91$Vr3c*#P$4Rxi(iEZ@uc-%BD6|jq@Nnlf@O8mYY zi;1)6>gyDP6#xq0o5z_2qXBKvy;U;!0nj!0?-j#lAtvR3Z0SgY^`?2fv*u1CvK=wZSHJ|KW0GQEHrg;RigGb z`VlxG_&!S#CcRF9%!IwjRAj8>aqhQ$0N6;Q{f!{A>6vo|8@*7*)-StMsJt$075IDZ z_7R3coI&TC=oT5z2Im{u$NAZ?lsJVTbIMdaXHEF8nMBdUNDJOclYapcWuiYw2gbQX zXVR>L-nt`!fr1*M$xLr>F5*7y_1>Z&wMT2_c&5C?c=V>=QU3UI>4ao;-d)aV#6Hjf zlV#>z8-*_AT?+ES+^>i=n`9JD=6k*Nc82s4s*ImPoHq4!CUtL)XGl{sLriJ*T$!P$ z)RJchlSx}iRDJ$_@ zKu?P0I**F;Mae~fn!iz89?)U1M|G{e{dEe5jKn`KeZI@o1C}aOrXn{E)!UA@jc^8{ z1L;p8Dlzx=)YliKEc`;tY4!ju3;JGA8v_?bmd*AMGjbeDd=e!ZDRhCHtMX~I7Tc41*c8G4WVSQ(P`+JBF;xN5&Wc>r`9i;-FFFNbJqmY||oKxOE z;yJC8IZ*MypH>EWXC4BI>j5=~SA%nuiR5?3swLJ>tp7m!$LpK1-+Hckv|i8|(Wo(K z&^L&FE(NnK(GT7_HwyOg9O|*=zEk&mX#59hx_O1s4b_VqLN{F&p2o+ev|sIW$m@yk7-;aPNla^i0jyG4hYq!#~Q` zDK{fcB05h4o&pmN{OVcyXlAt%DZ9lS$(StZ1rS`MXY;>H*Gil|o*6Q?|0Zr8k~;Zu zU}WzW-yZfxQE+%KYK`!vmjtB_GamPrv1!-E?`0ALRjj$(h%17hr(PTkAfiZLSRI*f z=?bayIF7G(5#BZO6{hlvtw#X2p()@ZcyYOOHeygg;A+;5Ct&IQF4FYH=)KOgUG!*_ zCP>lmiNv}JtG1`LzJ}Kbdl7VM z?$vzuc7uap>2!3paK)DvdC9?V^P{z52zmwcB|Cr>;K4T2DWrYzrV>%#?hfH+p`_bA z8Th5(Ui3rdM5x`!)IDGXWR!7VEeJI*u!S+a3B@zYiX_y;1*uVAGclR&M0ZBhBhR$d zDed@nO20KpwqJi%{8o3-=v{4mksTBFv7QJpdVjbh9^`uu>Cz zS_ac^nwEhi>iTSeqS#)Tzqkr$O9*cE_4OUcR`hR4f_M1xXvOg*=psQcCVeYGk^ku~ z@L~75oKrsgJG6IVQK1^M11NJG1-t;M!O{+zf{-PXMqpO$eR#`ifUAqR4-Dji^v?w??Sr-cZn&s4^pAY2i z#uo&-ndG}-^ej;AtF-l)iD@24D=4>a0Cu_p6>+!ai05I&prKq?5FdXP-A=S)E$feu zbY$Jh6eBnrxAV_e|* zxy}|N$daPD3C)46J|!l9?5X7dS9|gtcerrDhqxluWO);#-}#a^=>SgD0!#t%QE^u> zRYF7D>!2I;MWOd+4w;XpKknNs6WGoSFdp_!KswAZN=C)75`N-Ca9A-&U4fs8`!^%X@CYXBq{)b;?zn8%<10` z$n3}H3(h=m1mgs(_X}$Nktt2ip8`fGXT7-)cz)c?vG*Z)A=z<(g&lR#oSWkLmC7cR zVWsFo1-Z?u-1@CM9@r}^rtb1K{ek?QT-1YIc0iM^Ps_p+%EXQ(WPtIG_C?&lw)sSm zGqkAwgaF;|>O(w0oTDcjs?>P5jzh1-;Yrc`4L5F%>NwAhcV3-In+)bB?e@j~#36{F zF*w8{=rn?0ALL4Q6s&#@U<T`RcmxLYSlo4 z=PBsgan0^ER~7o^6aXI*9;^^vKjKj$(aAmEv?4X=gl%QPQC4@|NeszCs*fKdwf}=V z3%fe-2iOnd$j$3^nA;hhZmW#$H(FFHr?sTFJ}pSNP%#3h!L~28WQP38e;I;^IKj}S zSWs1fM8=53oakA{o)&0J`ZWB@q5#=i@-2NgkoZY+faUAZ&&2Y7^rf2_b!LU>-1us= zh|(1;z%-Wq07?+Hs`b2@el=l7ercfSN573U;ZG?gTbN2uMQj!zGLx(|5e5O(JQbZv zI7j$#6{{-)IGww4g!LPrGtn6t^rmN}w>>%%{k~`A2_a2ACGHZ)m(^9&3oP-T8z!Y| zZwn{qZ%l>GC2@PuV4Trv*H6I{CLoJpJ>U)FzjgJFFLXRMyG8nqbY%a5=n7LiAKnyy z2A&G6yZlynaH@IWZogS9#-553J+v$gFTnf;uY77b>b77Z-E8P$IUn=q@cZWrF*i~# z3uBB5+)KC%ja*vgZMu)3J>i?l`ev>yGE8>3KFUh#{|!z5a~U3an|)$-pcRSfd_!H2 zDiM(of--#Va_8E4GtuP?kbpzh$S`ks+Q(!11Vq;VrrgQ$>=-bj%mo{bI=AdeJOHwG zbKKpY-fOzJ&TmLhP0^;y-9vBfZLBU!|A9|M^Od`9kZ~1z)s9Q9{}T}(bZh-$R)u!( zA>E=!Nt*e1xgh<{p{>|>Y;b)eb=wNg;&WTNM*{AUH5CyTyLe^kJm!ZLmsNRC(=lXi zO;5ls@yeIFjWbCK?$*6Rc9qBTc`U&BdCoM&WRy@Y($D;3=lo@EM?AGQh|geGGD}Q!E?kE|==z z1|6C-idi+Pt+}`a*?HS2tdfZEZhj2>px%AyF;5DW$D<`ps`Z{hJko+$@fSU<<~Q|Q zr2VwgtkyS??|6YRT)7u(-VE1O!*1FzI;jXi#eQOr-(+rns_!D#HVTRF(yY7pq_yxc zWHEWYQP2Y8nq7?bDd)00aG&bExmy;%$r?-jzD|7TqxU*U0)G@s05Ob>D$N-XOX8W< zIF{{!=rwJQ{Y38CS@?LD+B8#t@eHaqG%)M(_Lg^FfktgiRq8QhHoO>EvK~8Yn~P)WlVJ;uY~Lv z0pZ!Bltw1$Q++YdW?lgO9&*tRJ-kJDI)KDeTii{$>tR#5qnP=tiSbjPLh_$*)1^j} z9b<+gtmq%7l->V3!YB9J+tP8uj3rro3;&LhB`F1a>`nUkuqfuvW*wgKVk_SW);n9_yQtQ^i^vsez2`xWpJ7pb*K?x8McRK7-`9(D z?>Sm-X9aZdMu7;qy@+fJw48zErm9hIPvCb!(rmi^Ok(#WKcJku8NVJ*-O^l4Q*r?v z4G^4e_4KpAA6P(ZL(GS(DWCeewKbIxdwJx1nuk*y6?=0tsGNK39@2X!G1UXZ9P&6W zF=|9SV;I!Cn`{F0{l_gtawz*er$Kn}gaJ>isY-oh-h4;13ZP<}O=v z*ixa{%Zj+%HPA4haA0WEHaEiFU6c?{2uF4eX+Vl<-1!i%-pQIKIaDJl6BeS_szNqe z{=^K%Z9dxcV3==)GfOc;XE49?=}~xF@g7JPYjLlZVYQkQ6*D#C7_+`LJTAqKJvKz} zW>?f8W3zLO>V1jBwFekw#2&N5@$A`^EByu+g$rO4Um`|A4s&JEVmn(N5SvZ^^vw$y z&>=X(fZW=szPR*gH&`dIJ z8|Vs>`n8624|=xEWpl6;gQo>h2tY>>Rm(fJfb%AkPz5{Qy(+q~UcRe2Wx7qgsSo6f zQo0E7C&oYNx{4KD%m5tC(3uaubl^8P*O*i#^vFic1H}b+z<$|V4?g~cM zz_SLG=%OlRTIHI7vyz|b*w}Q@#eB!6>@8n}Jr<}CX`yL)y0E_cUS#+GcL8WFZpw7~ zKfy0oc&wRvb$u`W-g-^pf>39Y*@3^aa5C^KBi^k)%ocb_VcUPAB?&(*3)MWH9(Xu> zJ!*YFkG6bjNIM_XTkd>`DoqP}LJ+Y*r0m|m-Q_8_g8t1BzE7x}tc#yL#TTwL)o#L)YXAeW!cKXbV_EE5MxF6dD+djCUa?+rbZ^Un zkzaN4Df)dii=uug7fZC=X`gt57#LW8KjwF1Ca<`_Eeo96TFlE%wH^-{VZ7PJyYO## zb;fn5(C)8e-$#B>;7!pKpIqN8rG?Nk$E=z9B0LHL1^KRL_5^rYG=l@reRoxkUwmHg zeh2ck|E+80^ECBBMiGFW0#DIDZq)lPVN1E3h2PHiuod9#@2+JKcGS-92>-|4BjQm%ON9MzanOLFN54WqiU4RrU9+1fU_v( zWh0^pl5O_8rLkFw8LY*Bs{ImKA=510sMzlyeo_$m7>ONZb&jIk^s_Kc%IdTxFRGa= z#zO#yUixlyrnsd_qiyfkOIn;9>TB?-qnnykoax9gHvAKUIdWj82uf0J2jiujb}= zzwtFP71v>XLkFS_%0H!Mrt))rVAm=g@3#dya}`}3w~o1KiR2Cl%AWkgj+!Ipx6N(^ z8}V=KY>#gNZ;ndC%LG*?X7q=_e{?!EOThZ!8v#Df%tDu#Ot!WzaYz|8T5S~Byz%3HuEgzlP2@U ze_3p&-{s8+Y@A405t&1dfA%3XnuY-=`-mA-3?9OWRRB<@COXe)4)8}E(7)(N#QtjW zx$UJl?j>~Y@SjsfPOxvvkVBZ@&oSLgA&SmWkdv@!3waynq*Xi%Tbpp4-7{YPkc-l) zQ`(p&`fW+hX6nFnI+dKZLbfHkXG@mMZSS)NZ*ZMg2I78PKP5UUROF7(a`m@Xop&JL zqN0@R!^ELaE#a5Gr%LsTF9LPKVD|SHmhCW?M5zg(QoVsSLw&lq^PPn;S|qEr2A?-I z3PYKg+jJQR>C&kh6^51|)v3>Kw1oLSv0p@E9p0RW+|WuI$5S4muR(k(c3)t+N=l-a z@kzi7v4_O(LeBbhHBx))#+k7(&_XnlmzK03aPiw^w5F8?+wPqSF-2C?SriB1{)}2; zNhKOxAC;EZ$v3E96cip13D`r+>gH7VrPsrqSm#$4L$hQ=%j1$(&C!mS1O{E{fp)*1?m%y@(Tw=A+4me0Z`r>h z72Gl2Wo=t@@A+}l@#jjH#=d}nY4_kyj^+R$Z(Nt}Xdki_0g0lV7!0=QZn$$Q5;+ZGek#C`4-SgmD%-xVt7V_eLM-uYjRwt(Mz z@3N#q)4dLRU(kJNPz1h>F~Bf7b(CQ>3-|y*dE6GL5O*5AtScgwieEp-{p1bieKhdx zj`gaF`FlgkV#GXezD5(vBC9_YekSPp^HrDyWQnr}8)*SLwY=K37>it0zemV7m`M}M zV_tiaRlr7v1dD%^<}9^$r>g8D-YuD!nPiVK;AXda%TD0OKOvjy_c{W!HGx*6>Gge^ z<+Em{dgM()2{2DSoaeXQMt14`?#R&(LYHGjX+d!Jj)@zxhAPWp1X-^dGI=*1L~kNNKaMR~c%^?R*e ze@4W%g(4_d_q?A}<1#~_Z`63P{snG)H;uyi7fFufisHgLS>5uE4mw>EfaWv9D&Wqd zQ^xyU<~j&;C01=&6GTiLE- z)r0DmW{4EXLRT(L4|qMYW!|Tb6XS<^m=h3r@0*&@Qe;&@oxcSALMzyg?XFR95BsZf zmBdh7-KZI{U4@V7nny10Tzrd z#ORxiTKEZ@lq-6RTK6BiAeTY{8Ze%aAPN3&a^vP1`SKLnH7ZNxcQSc;FG>N|j0m}C zfGid4$hT4|6|%9!OM=y=Zrvp}QMGmXQt~D7SnR+zZMuCw@)mxHy2!t-4n_t0ATZ>` zTb-8}&PXla^xmlaidyR(l1V1vQGt%LsG{BxOOf@p%!r6v#8_Lb3F>f$;|sI&YO!H_ zAWr8ceL#D20);x)0s zGMms`GC8(ced#C=7x1uKvjzOuebTmlrj%B9_xQP`FR$56kK(kGncT2VhyZuH@(9oTRfNY-TBUa+d}n6QxDDxVaKe z&Lrk+S7eoNd>;Qv@A3r zS_{Y`2RTRADm=~+ud?;#`DUq?kI=@Y1}K&NeMYK|1CmFuC2QC#gUce-=X=h1G0%)H z917gATht4xKMeu9z07ia0KLc4(Y+a7UC`x4GuMD1zbhQf|78weD#UM`t9}yDeyxHsY z#WlJ|Z%auhZSig5i6;=B(a^AkI#FC7r-tD`Ca*?{cFpyTUFSheP znHv9RU}S3cgqhv(zd0NSE%TQHq`9t!a6d)w7e$Z2j>YcGw~)gVWxslZpbb+?ifnrXvkNoSU!vwsYJ6a% z52oiWeU@J^F#wjw4n4rQ?=n)0D#DEtZU@bCO7|x{WLk&)!yfyw1FtOm88sA|R&y*J z-4$lDWA3@6J3HS7>pv_AT_2`~dY^INU+X=?kIui`dEL0~loCpFWG6n-_TWdFbWiyf zn%1a$8&tCoYB(*&1eJt=s5E1KO>o!o0MyJEgj6`N^S72^Kji)f(a&r?yEd}XtPmwd za;fQ9m=7hNLO|jy9+tcBYIk^p0v^cg2){FI?7}bIGV?7i30)IN^^!-Ad=!){q{g)= zZ~u#Y($8qwl8k-|)xCwAUDGzhWo%?A;Ba@#SUjY~>6x%S?Qby0sXa0Aj?U8xRgDpy zsMy7i%If6Rx&{?t%^yo?#K0P#(aZQ+3CJC$#l;x24=klSC)L3}liwDEbXanzh7#b! zV(UP8ZbDw@kSsWG{>ciPFcpp*nTngUx9B(ieybxA#MC&7%FJkzsU|c4UP+-!3NK63 zb8b_MBzt^F!TH^h45Hfi7U_;|NmwxI3Cl6LT zkQH7vMKE;|^{tjeil!IM!8MixeQcw6!UXxb$_cnMEwT{T(}a5DQOwLkPn>cUfe$0S zRy5I6LlxTKlZPVWReg)V8Hf4DzxadBI?V|r%TP$`YGu*%PmiyF6rL7{!qq8R3n91H zl@EN3*IgFbT}4d|*?+UK|AA50Jwum_kHGiatadqqCCPHIu9>HxRaXcaoh*L5esjff zHk${zI=eX1Wq>w?>0|>U55pYOr+y3@Ag65Xj70rtQAQ@|G!|ck?fVSrFm8v>!%WvvYl9^s=LciaPj3!7ZV~-{XJPr%6(b`lNB? z=Cy>hS3v7NiEiPPaj7WuGVE2iRTZq*S%*}!wHIE$SM?V&?;m-dT&Dyu6{X&gY|LCl zKdOfCoR5%+iyPLWQfcO>GKyY}ZHNE5eV0nDU4Y*sn`wJaAk*y$A0&RXkgVT!9bC0ZMW|(~n5Wmk zl`_p$PFlhDvMo2sHD2V)s8(g5E10k8;(VW-bBT4lVxD|!j`aJEPb@L!Hnod+(Q^X- zk{mEGWDUwaK;)4%cFc^p5OkPPzzMz~Fz@{ByR-OqR*0UG^GqMIE_x6^i=o*)|A(m8 zk~{U&r>L8IE&$R5c6Bi!56My9@_XiJaSL5E>P|9IO+bdsRh=k~>n`Hnb*Li99zydT ziTn;Ij7;|9y=br7?ea7AQPULNT6d1^2f|CDNejKU|Kn7nwS$&u#4b&$Vk%?Nxmaxi zF^L>7Kr5fnN&JcsR?A0jd#{dEX|H_t7>umGY;nsW@QKY>6zWFnCl1}B87`xE2}?_~SAI0p!|U=kr0M3^pW@@Kz0M-?{p>@;&? zZ3U(uI4Xn)7FL)oGd zXK^NMNR1dCO>*0MXYY`W;KrYYZAYhy70-%^Ys82d_Ipxa&1B~Gcuf+68Rd{8Yv~Oxe#l&#& zvtU2VNA6nR16wY?lWv(35}z-0c&7jb;JjXbz^dj%-Zn1y zO8MT#&tVWkR);jSBTb(T`FW>0@0=!(h(Rrvzl;mW2?whXXTD1Kmu&@ec6I$iw?RDw z)tA`1?+;h~PMic`W#K=^F$J!J!*cUN_nEQb6%8ewzs5cVj3vY8$_S>#5K%4XnFYj_ z7QTykwU+pYv>Mm!V>sBxGW|hr5`zCuBHI(42D&hWC6S1J)w$xKgu>Q?^}nje5PWJ< z8el}_-Y|}=($ld-;boUKG=-CHX7#Vr4OLF&cs+x4*YeJ#%g+FHs+Q$t;a5bsm_hmI zqCSc{#-xTiLprk>YAf7s-Vl~DK8NhA`f%hl*&lXWK;(vqxa9%h3Ijy4Li=aFx88zT z+?w@zC$VVgDelyx#(iTa?84XGuLI9)bMS|oh3VJD?tRH1GU8XEf>R5iJJz+$GY3D= z_NqI~hU+=q7U@k7ke_xO8^)Q`5XO>q{bqn;Qqpt@Rj^uFF8+2WE(1UCBrE|?0j$Oq zjLrK?bacyXZ@GPdSx%!vzaN#wj0?iIKv%ifay#>Pu}0HHin-Ut6_*DblSM%v0w+SK z4MKF~q*tz}{X(o@fp!^rSYD7iyp}kxyLJwiz~y(qz2i*P(1rZe%j5oW=I6M;RHbTI z0)j!v?;*Sz@)JtJKg~#HMSw`B_@-%`uN~5n>J>zNeBTqddr?ZJK{DUw@yEljvNn%V z;hu3Sxn0X|;!?#O+khjoOABYf^(F4AKzBKGHFc+YA@(jULCHJs==6S8LDxC7PcHgg z+&hfP3;0`cqsdSl1kAZj@(dr4RJO&JmtXO+jvDDL5(NjxUvtCII+dW-jzIS9N zjJ|#WW{{t*}^P7FLD$20v;-JUhbRdaR2DE+SEhz3zA2DG(l!^ zdm8c}>G1SDANIB^ZYj7^)ugQoW_(tJmqlEF-F6}8aa5h=&!!}<_ecm$bVRLvD54Zd z=J;IIw@tY|&|4^2gkf-12l4R^A1F6}fuvDy#rarnrECT6tKo9Gx>cdv@`Zu8?fW}- z9o9EoZlI+CD^gHauieEN6(`|t`&T#RX zqer->sIP5{$+ zKpv(7#w#Cc3PGMyr(Yx?8lb0o0ucMA-z6Czf-Oo3ci6eWcYvTq0JzE$b>7`bRUY*f zo4>~XiKZc5O<0Inr$0{7k7mG9St)vCwdrC(FT)hifh4;+CbrkPgEo07$E{O`U z(J>B@Yj+0;3aiogqA}Vr=Fdf0U4Y!K=lBy_R=#Q~4{*-oA-fm&i^hGtS3?#H$6bhh z?dy>qp-~=?{Txo19fXv_o6w#&F!IGLxtM_kfa0E=gareUM{!T5uv%U8)zXQ&UOnlR zz2r3;oeT=O%e_Py6;yJM?MnMi7wPYUD-8AuCyimZ$!23+?}9D1`oEN9nB~j&jXzHM zeP9>gia1v~?ghe$5kbN*9Kgv%-x3{+|NfDI%rWB6<46zfSwSjv%r1X4Ut=f>MSA~M|;KDcN z_Rj#c(`n?O6gy1nu#U1AdEIv$)#4E1wT_je5~b*+Ethp|fZhj`nRKm8ku%J%On&SY zreX%~Aertwsime$0NVkJvf>&svSx`;1vS?(8>Sh{sK^cGcU2fVKpCUN)AnAae_QUP z4TA$b+vP4iJ7ZMl2Oe^4Q}DJAyt&PlT(x|zWE-T`s(G>fzUYyXPy?E*9A?GrxM=cK zx~ozIy+W1$N})H_jO}on=Ja-@EA9eZpbiaVF9AqVu&r_7?yG8e!2=5^F@mc!^8%{e zm>W7kh7JzLwp^xET2hAao!af~s>0WTy$FW^e46}*;5iXyY&sbA#VOyl?Q~Z}Y&sm7}{H_}~ z;4P7#g8%*QRWOL1ke)N?IQ?VySwX+Aduv}VwWD&VQzz~Y#aAe*4sJV|UHF8qH<{c@ zxw_fpKuy~qD32nGu8rHm#;d#yK~skrUA*y_ofE9UPsrT|mGFavB4+tQ2mvU?5RU)C zD_Rg2@hF`J6Bs0eMhMc1vmX0HNNnTrN{FYg z$O=*r@yhN@u1>^P$9YxxQtMBS__y7>v?9#suALv{XWLk5yAfA}YlS&Ol5O&-?(!(O z?({m8>9`;3$b>pVh+Zx9v<+e_DIuz5j9%aWc9FyM$J_7p=C1)n_^;^_raF9j!o~wn z?%#fm-qBvdRfyVmt;qmG(1ln^25;4Bry+UQDEGpl?%yn;oI)RRlDr?_^LeAHgJyjF z@8b~kpG&w*1QWf_yG&f8w8-I)GSX&WeDc9f8HZR4;O>#LfpuC-r{LgAj^`|Kvf>M+ z;DNG=AVFBXD_|qIOJ$pR;{*09wskioJ3@7|)6+?;FZSXtnttTrefP6rnDepg#k)`^ zCi)^j2^yShWWAXkpTEj}zVRhEe*qo1G{K=2F_t?s5N3^zK>=RER#M*LP&yTS6}Dkd z6(=xee+nHif6s{U5PldH7#{o=`gk*{`}=Bo`UF=}Gf6&8(9>rIbo9YfCpX(WCW$7a z!`Z1*BbzQlVcJ5nFw{c;b6>ZN+#U@mrm=&H9aTXxJ&Lhmp6lzz#J|pf2Xd2kxvl#h z^|bmLZ)~abLNWHd8up>lM?d86z)1=0X-5NZZ|TrGhM2^3#KuP2#JXBQp23Gh6VSLtd!Mu`VrUQK7$&~dlK8eW{|q88w|zo3yU5qPIU;smGH|}d5UDK~ z*n~H`B3lKwXSElq-93a)Jz=*xBMu5p#@DDaVtn@U!Ao|Hc5OF>2<%5=@zWfG3B16` z=PGZ03-}J48JF6Gya9oD@)2(qsWCds(keDxjUideVfi7qc;s1B$^K{V1HvZ<;Mv%| zE$pA7)M51L+$G!(lq1E!yQ>jEON^E!nm_-MR;A}8&BbM5%+F$Idp5+Pu0s#7-o9DY(@?klzRf4|%`)4w*>>A@{5QpRAC7m-GCaBziQts}=FT!aF=?b5-+^2Z+c{5~!G`3B&9{)$yoZ+umg7pCJ|XvHYUP9B6c&?Idw=0({fiB?iBnQbGdi%+YqvhUvLuR zo;9_0yp=L>P!aU!Qn-IQ6#4?$+l-dkwxqtDI+6YgF%WG>jqT9&G*PWCTmECQ&z&>A zqu=dtjWB)9VSTX}5|}Ia2slh}5yi>HI}1(X!vNqiX?9kA548~){28$Gk<9RMsG3vR zzEZYcH|dixaE{@(+NY7DO^vDG9Re}$EJ{v8EnW`?H%)yw^E}AKlEpkZ0}u}HG?_vx z8@$+28Wt5l1xx+Jivxd`_FbPyJ_9E)R9o_$??z1@fx+{+J`uj=X(69qY0yC3D2)Gh({Vm8rTNUmQvXvE#PM~${4r=UoW?>ux zFDfE#cHI`LwWWC;R29h&VQY<*CsD~$%@biM#JOba zQt5PJjKf`m3$iz3;1HxW85pAw+8Qh`I zQmv2(JQ1YmdVIZze+Jpo3q4kj_2tYPe-NNdFfXSrQSH>-D;}Nl1Glk!bl0S*OzVEd z{y+yK0t4VMY*|T2uZ9l1_{YEC*B0m5cx-;-BI!>%(hm-D8G?{%`3meg_I99y)keT? zFRkUqIJPPA69|U8;Ma|#O71m+qb9mXjrzm-0~tSno`0HZEY)2p;WlNITtMI@RjzYekh9 zL?BX2X-3tlvy4D9b5qB&oX@k9_T+&kqlC%>Zt`V82lRF{UGAN8Px91D zhe{zQs-PP7mvHsjB*j%!FqD8v7dBpFE*L7H4so~X#K&Hpce#HX(X$WrAK{;|SGzU; zulQj_7B!Fa9Mu10bLA^`hjXtKxSTkZXQE08bddScXvc=HS+u{drN=Tb&mPyfCEGPMf1aVP24+X4aBr@{ueXJ2D#BJ_yJgV= z35P@F%5m}fW%3`D?@LQjjT;fOa% zU3CmKrrZ9L?z)Kg&NIwemQ5M3EY!qcyUy)qx;}7A5aIAMPR(S~12g zJl5!Ftc^g1>fwCjm@=8d<9#Rbeqn+$`Hei9bsr>tIaKrs*-_~^8+E(}5Zu8! z%RMB)R5Jd*Dml}rCa<;qx8+!RR7|ZRr3|Th6qHJ;sK}5+rAQSaGMS>7ND)y+0hvOE zT0|^Utb!34f*>Gc6hx+wC{rNF90+rO03iejA@lrC-*wh{->?5~dp)1_UeCRr=ib+S z{Vso6EusT{NUpHLwuf`w*4TZ)04z{bx7bhF_!Ef-{sEz@uBC4=Q8yzs4OT??1G7|C zajYPF)hQUz82Qpd^jKtyoJjCOgC9BmMUsgBGoLvdFF(P}#*f~QS%33r)k?l#g^}qgAL=9b zvqP@x`+|HNcBR7f#nb!irElr}`9W0Kfc;6~&&Njf67>=z2VO6fXm_q z>!q#E_{TH-s3W{-*@$E`vdd!43EWV(+fsO_8z76aw^16rh-i-(zYe!+3$T@QHIiqM zO=xvw*@g|Y&Q~xVkyiwRUIFjO1^Hw3wGU&qD<{8F{f!8ieMqt?r3`mRyOqG>f&Q|Z zc;(A%`YYC3NZO4DtX}jH;k`ANLaOOajT;(L$dQ=;)hk6-2bsMs5sXnjlqe;J9;44< zs%DB_>VGx^<-%&xV4HXiv^@3%=!o6CH*U<1OBgG-W{Ss9T(U@>I*4s+(B*@Bkt(#c zuK0ctx_VqbtuYVt~VUxVNPWv}y;j`oJf&GLPi!rmcO3bAJ8J@_c4rdk=;eO71hivPD zNt`S-220Fg;U;dtD-v={LVYtUbLzI0ua63AiyuYUR`^lOMX3=~OZ8s~XLa=wa$5c^ z^=3Bm0b&PFkLuy{Tl?dw`gY!6V`7;0kA?ZljNE4r4!Fz(AjSJ| zD)jK3gZ;Fze`o9X(iET@)hS}*DxB=JkxBTFcDUqY(`>izd_iD#f7w8}$blS_| z^b_Lbr{?_%BKDG|%IIfOC-wl{U!4_WGCX2F1^pU(6c%NV#$}-5yrE(nO6?=lp9elN z|C}H+`!bfz7`qlT1mD>Gf*g)8mVPc6!zhmVE5xN2;ROXa55|~-voUBWX)%SEe@*I5 z(NyA}V^4$=xzC!d;PRD_XHEo%N+SIe@iiuQ2-tV_?>(C*u!BXZ%ifIrX15Z0!TSCMVz6L=>`mAyA7;e1(1iq9ocWHjU0^{MpiGjBp*bj z$iI*UqPMU2+}H@cady28f7-!M+(0_P{2lxL7b(`oeju|SybI@OF-VDdbhHIyc)u7`v+1+zI^0g_ zvx|56Gw2ym{U9<2oAr)*N*oiJI}oy(;IZ~@KQ0VCCkTHw0+rRxy@PS(+Yj?j={yvg ziRK?GRz}BYz^bhFC_J8 zpCHy@eYvB0GiD2EG&k`roPiLsV%UY(TeFfO3P0f7<4qYV)t7=~>HP`mXVrYTj+xod z1}Fw4Fjq?0?Dcr_Z^KhMXvL_4nD|7#yIe?Fv>xr1oU3%)^oMN2bf3wXZIE(;AJkHM z6+KTlFohJLLkgExkX24~;j7eZs2A}xQY(s5q6))&>9ETI;P5nl3C|j6{L66z-n1sX zMeR7A9sL3`_%vkJ<(9cw%O1xk7HhZ1zRXwv{*F6hri6vf9ArgWABvNee3 zSf5oUy#Ofh6ETF-8yEZE0$#hUS@A^CD!$G;dqNA-zSCH1Ca|AMA`{j~x3#}~1g0Mt-o&3kqDames z8RpmF-r4}*Nd+ELafFKWzYe$pek*+%13aK@-#OCzboN4`(_|OgJE>}wr9gh4WvSNqwE60%dJ%*Geo=!PvBJ?LXzIbncQZ*q3x{N3 z1p*FP@fX#uM_d^nn>n9IUycixy@Ef1b~!K4OaOmZ?%NE?c4w0(>Z@9YK!eQgZNddC z^>IesQ`cMo+);S{pBt8QQ0djc5!Nx?ho%?-`c$L_}r`0_d!s=*8E0L1^7YsHFuTL-Z4 zQw$r3YV7f)EFH_@Df8M()Ui4>@QL`HsqlT+Ix{9&hhK4xbcj{xbS*tUT&)b#*MTeU zBc1*qx@Rs&@(4hHJ;E1GLJN=Tyq|6a5Wpl{ji{?uol{;PY6P$9c#!nUwqt(IJ*-0Z z^$GU$a&xl6E z2hHzKf4xp^-!chWbpafe0(OMkh@*q9Z4|OSNF4oRoO5-sN242Lp3Ry-c#c-h%qCz> z-%tB#8Vzt8jrCfu3#b+Xp^*{a$Vjb^rITM<#Hzg}pOxw@f72 zaoXJKMsYK$KCV;|RT{s1V>W3c4)Bt)A_yN8G_iR8wCYgp%~DCkRV-i<%`8N(k7}^% z!(2p?B<)-z=E}X^W|Y9cd0;66Nfo2UBXhZpLsrzBWntl*Zkq%G5gv=F-O4}KXplHf zcSY#-k5Ctes=hX(CW4_=A*CvyHy#kohgdcmV*0$XU)S%^ua6Vzz@o&!Qs!lKGFjE3 zzpa5g=|9r?$OnN?6t4)5MX2Z>TvWmYq%-@}^<^(}5zqhAxgm!`A!* z84hFL=ByrVnf*VC*ngK37b{7O|E2y?`@eo!-#qrl;6h?`?d=l2Ez!FP_89A!w2GZj znVk-ET$r|HX9$n>MCl=5Y1aF;k?gE@y3ef&ly`@)VypMec&?yQTnM@G9P`viV=*1Q zf#t@3(k2&8Ywx-Yr4eJeAHxcYg=XT$^Pl$ERXae$Kj?>8Pp6?&tC{xb(CMFiH+GT^ z70rENy}74JmYyb+Y?sLe__s70E6hHu?-n811w<`5JlX56dF`r=G(w&XU->kUhBEz# zm!P{!lv!y5ZDy;HFL}etpXHvKLiSD2wP?BIhm?!NS3x`44ak%qSC@7`aP&?mD7VcV z$^v{7#C3@vZuyO!d2t9g(rM$mp^{yV7C5sXwaRRYRzR|qb>&a3;)`)w8|yVee~~Y{ ztgKbliHPEg{hsIN9M3!zya9RtqqcwTf=@@6!vOT&Jz;!#WV_Pk3JZ^Ml%WznKlQ>R zpHqii%@Z4P{_2fF_Oi*c&D#Ks6H#U zo`#&8{kR)?O>8dmwg@Q`rX{X25fb;YctVM7-7>V>)^*p6@G6p|b$toFD383dwpZqp zt5|KyeEN50@33^Zxb@yzvWa}u8KW(v5F<~z!tAdxxXxFtWq%Nf#Lt6-b_Bma6;|CF zpYSCR6gLa(c?o4F;7tVPwzdE-QMuP6{jF_?G}FE(4Oqdd5eo}@NADOIV2ZZ1WEEto z&39`u0DK^B`fcyWUY?8U-sCHk!O2dq5-_ zo6I7hu{2*}?%f}3otGWnT;@@_S*fd*R!ybD>bepB`dD*C$iSeW2+_TJOI)?X!QrW5 zr+sFmL27Sd+1*={CEXrl_J22kz#9+@k>~70Gl0^j@N=@uvG$HuMSVN=la$V59K&(Qe(6*6kcX0!1EWL8@(eVp=Vz?iD3PMi1vR3^8s z1Z+v_isr@x{CIG{?GIK-yDD6C?&pN(2xU7N$mdkI0yjj3q_|)ffo|43eVmw1eixoP zyLOyn@R><2rxmj>JAF~3%56u>I2v)@;;}<<=^==S198R@90>e87#6lFa%yj4Ql27| zf2tavKgf-6A#Leg25-Go&9+g}^2P!`y@3#s11Zm0IYXS~Lu#rppRsDo-huuKU469)d1(uzmw(v1IE6hBm zM|FWO+f+F4zWDTbHa9|C$ya1IVAp?zlNj-9>eedt74Tx!8*#)l2h~@iG92t<-$7Bc z;&}^p{nJm=Wa^mHY@?@`K8~M`E;t-;0~|NKdK5t3-1D357gTc|%P%K3fD~DYG_?_V z22=e2;Je~2akRRSV;??7=`GrH+V~juuDJUKCK$r-J98>iJ*HnAT$%B2vMB9BGoFQ=ds6IiH;T#V9|E^j44#~)y+WMV_qfRwSrSQ7_J zu;OBHxe?AV>qy1`&!74cT2HV#g=ILau}or=)aIV<+LnKij>hxhs2T#|*CptU>FMa? z`3s3dxd3OSSe!c$)$gtz$EZaQBW^_@ONEUo(ZU#Rz3#4_Cq*g7kN5x zzNsU*6}rN_+X{YBg2O<6n_Ez;DhP=^PAuWnE(>d3L>B2^8AKy>^4Z?DzD*%o-N6uF zn%^O27vpdpe5horEgB2ypK=rJS==WtGskMr|JX{iZHw_xSjj`onsuoN%dmK5CtDu} zoo~~qO*REQF#-f-7f6)_ssuA*jq5V%jJmrgZbH@X=H3eBGbhx_#n}yk`ip6Bc$%L* zK9{LCcfLtPY}&A+0+8#LxzyzO6=fxDfZ70{I@Zh%NL2bkii^+9c2bDZS)77Mf0y3n zpu4EOekyc24*8|&4C?kkl*;bt+`@W!m3+TtBWUHH&bPF`Rls3gj=u4qKxu;ZNfg&& z?xFb?w5RHK6Ygqq_u$qxoWg0W>FO-C9MGWab-%S;OCVYNdjtvDeFvfJ`e*3&-#ESh zE&=-06i@j7KD9Tw6X2}WA*%sC2L}zGJ*cU&qLke8n$JvQ3M)edm_&-P*RU@(;|wvI zkrcHWsXB^;(!DTO|Auu_Lp3_yD*HWr-LE>9bXE0(%rlMs%2)L;LgLp~!nVuSFF2BS zA6L>#P+UtG%-m7wCno(*M{);QL^Pks!;;Y+2=JxD`L;@)cGp!?%7wL!^ z<^_PtN~sq~oFR@?cf<*IzSu@=i`iXZ^-s25wILF*n>bdE=`ite_!O71<6zv1M|-)s z@NUL%^&{ey65FP#PX992Pdh1(2nz(*?T$**5$gN0`BlRWLI!L*NnF7~jmG6qJ|I6} zD`L^OW8BA3sL zyubc5QF|_Br97LgLx_{KkMM1C{#nXksQizSYeO*$dML)?)q(v%EARqa^6K&WNKdXC zB{-6tk$99QD$%9#;krI$nR)`~`-wf4e&qZwsf^kBg_NGO)fC7>RyWPQUN2AGsE=`8 zMIq{H5MS4{;G|D*lZMo?0`EF=+_4UfXhl6#+jDi4IAR!2RoxddGI!D)Pla zaF8V$Q5hTGbiBnGeRkurd3HF)s`Qc3QlsiqrzpUxhD5LpaXIE5u{D%Rw4n}o6?oZi z9wcT%ZhT{ua^0qez-KW=)^^H@Mcrjw2XK&zDV$qg`n*UozTzU$2R+`Sw)eS%yM<%M`D^bEa};S$if}afQ30 z&qGs+x?fEYs%3T~x%rLQ<)BS+TNfv@m_DG|(V1J|P3esRVuCgP7O0vt30{fM%T=Ql zKoni{9r|vkYBLtX&YOv7j5j)6q59hvs%=xBg3OKv7>cVp_mZo@R~EAQ+m`}jOEz*5 z2PkGK3GQb&ARS?6xzuL#W+4M_kjx8?n5m~4LIJanOyu=!gWk(Rj?uA-AYEqz02}tJS}Rv0y8d3BO0czt^mv z3FZDEz~G5;V5%+k?e4OMgwt>wA3xFPk{F+f?uLuYfK?*-757Hnfb6I=a8wwWOc>fF z=}8K2zHx#)+ciUs*CvYIWvkB<@Ml;muVi_+kQBn z{`9LvqSpUHuA)&M@IwFpgyoWzmsVw!yxc|6~=UaPya!?MYT6$Rb< z8*@~H?wwQ3cU`>)Y_u-q`EpL^^!~N2Q!Od?=3L>x3J6v+(ret9YyRTC+=}Rvc`fk{ zwUWrBZIiQRBGaNejdCLn&3XtEb>4Kv6V+#IEVn5_KE_sdxpd}YNLyhAaKUZp(OFdr zN;O^4Q$FILJg{DNBvj(2JJsYfs&-jc`&9AX8+qrtAh?04>@Fta-eK*Hp+UTWV+3Sx zHqa@z?%N$&pE-oTXNvp|)=-fwSVjZ518e>iS!4-gOWTlQM zW5P&qFCObCpd}>1Dm456-} zgpyImz{i%GjSb{xe#g3knjHD7oC!LDtFOLqV02Y;8g~vewUGd?VNO*=|IA``@p#0Hfi15HsmN<8Bf0xBl0NZQEV{$5UGJyTML0@J6K6@lx zD8}||2UGJnzrshNQM0OTx){KcxAPY$mx!xCW3g0txTw9|ZD|gPa}z6?S01lAHE38wlkY{C^#SuA^k@i-wll7F5SOMMQ6tU+1X=}y}`6A3g zPuC{Dl2U6VNhZSUy*?Bo=x5V%(r|982fn@3c1j>DSJ_7@-9V!=>f3%bKz=%Zu`;SP zFHt+S9PlfwwTF1mCR56*StJ;RuQ)C4nx^cxpS&kt?@(I2&>HqA}Bzodvc9ReMQrW(%-^x>U0E_j;@>BS7BSQL9b zxZrvGFgJl3J}0i4|FyZ9?L;;7RX#F8%Klb-7#WgMNzHi1s5B#R#KoO03eromi*A-C{y_-v29B|I+FGtZ7~VAs zJw^0^L!LF0wnEKc##-H=V?FGtutB`dVL%w1c-0TbC+1MTbz8^XZIZ>R$n!4E*Y@_q zkQHEAG*-RW?$+!lk)7CrV%%U6LK*LJdlQ1Ans{A17>^5;Znl|b?; z15T&$tcou+e5EzpBe2yFgDqic=79FnZU7dmb(rj1U~b{TXj5w?y(S_STbz zm)jY$1aFej^;9^<#b>}n_Bx(#B#Q)4PLR5>AD8Gj=c%Q3;bxh!u!ki58z6os?|pd( z?9Nvv(P*TAs{dS87V4sa!!@TOrkkV66gf!dUq`UOsK3nG&v2z9g9ybobn@>^YcCYF ze~mK_f6rE3Fwv#jipV%vDoU2%h+~n0N`~tLf+auCyZ^GIJp=ofV~)n#;d|)|i^O-j zsrhK}_FOZ)d~b4re$aBnru0|=>ivRpu@@4e+9&#B$))KMXI;aP(J$Z!t(Pj8Gn*I!=9STV)DP$-_TJE)#U)hGCmb zMQUtW;tnGpV5?asbnDNJq^W2+C!sUR3YCq0Fg+YG7<8Mus=4GbRd&vPG~k!L;84Zk zL0vbGZuuJWApmj$V(s(2-793Ga#zc4hkbbzONFCqubA)f2caj?<_ga?Ro|t{RrK=` z_dQ}wcMG`weWnP$mIHF2jAM-iyAx5{RLLyy*?FiWec~A%n1J)0&w?Bx_Q*6$AE3xl zy(7^z{vY4tx|twHgV)X}Po2p;Iy(kXuyZqLSaiGf`CUhl?5v4T-K6>P)k@vX=?Cn% zu_$8U5LAy7g1rpBQfKuGwN&-#-_w@?PbhZPTR_9f8>BFUY}oCTo5bI=cREDQ9;)qq zQ(1ikm+aVe-Qde@Z91^;Y#+4}9{+!&*#BOqY`CG?OEWWxc;Pr+(D1uDwfbN#lPsw? zV9p}n?cA=`480r8{gCdd+3L%^FjfWh+AQuRgrUNmY~P375~jL2HUy7!kG}}4)zlj- z$~wlM!)aGZ2{D~}eJ)|4F}8iw+Pj?!=JT1#krzegxWGk(2b8RoYW4WUn8v*ly)XVB DzC=+S literal 0 HcmV?d00001 diff --git a/data/puechcirc.rda b/data/puechcirc.rda old mode 100755 new mode 100644 index 9a40d666c82964072fae0a85155803b7a77dcf00..217713067229ee4a4c3a3036338360b21e5f7742 GIT binary patch literal 6553 zcmV;K8D{1miwFP!000001MQk;SQN?HhMQrAFlI#*B?}lxLljV~8j`4>BB)>_ClQpO zVnml+ch%iB9Cr<<7#Edf!nE202Qw;0WDOu7B1WR9zpuy7kUdRisDf`KKzx3B%cR=kIWGfo(u6@EABj2{YmRLms3~W^YK(<$m<0VV-FuH6RU6mS&S2iQ`=G`N;@sGs@)v=S)c>IQs@pJ4&V*FKJ; zNOX|R7nvmjPQV-BE+sNoAZnHXNPv2v4)S+^ZU%mb^dzp{ZQvE8HvofxS->73n-W=s zgXRJSjCMGVB6A`1Wg7soMC$e}h@~lbPxHly-$^+!cv5`42{Zl-n zG^jI>5}D|LLOtWfKq2rOpa)Fh;+z0Vfh?#C{Wr;gHq=2wfcub^1C+S-vt;_)2XKY^ zvMV!=;`8>Z3m^g7XAjZ7`9#$kiS{2vRNafHMgmdIRH9nWYXCm_}6Zd!qVB zi5e6W9n_iVU>l-C0*M-~C2I6LQR51trYb~5n5bCZPSi7$sMp_!PLvRx^n$2&U!p!vM5oLlIyH&tw2MTi*Aktn zP1M(os2?}~{@nZraPuF?&3`aA{~_G`hjQ~D#?5~?H~$gb{Lkj*Ka!jOC~p4eaPvQx zoBtSQ{@Xl21pyI$F)@%}#(*hcG8M;<^BmhpnHMVfi4HV0NNFFAXDDb*5`l=nFN1K zp>6@_Y@%|^fP~4^nI_ZU%OLtP#}TsexN_z?E-^y|dJ`yN@_|&DdO5&*pc>d9l{Ukq z%N2kQ0DTR44WH{T+v4+?EiTOccw8~=X5 zUPx~QWxg%8fCjK1@}_WO`|=-+BgEYRG8F2a1y%#M;CKQMEYn9_ne=hM>eCoghOOs? zS_m-XbCBsLq^C1|1(q<^BYPg#)8BnD1NTL@G;|*eX1^F9x0UKt`@~! z?$emV5V|6|TGxPCSauOcXEuf-KHx^Gynpsk=rH8$^{0VlyCk0-7 ziH8c-3Q8mzI7HFE@sXkqo~zaUa*pMG>~OHNY3{hYIN;WG<9e^t*soteW8$lPJT7>x zUida`?2!;BxMZe^1Cxt_y;QYv09BoEsCyLl2cwixc9GotuX+w1yL#mgK8(g+1@JVDiP_^ID} zV$X2*);W?vSocO$@*6weqcKMTz zc&1(N;)cVn2-F5uDYq*Ra4a|xb|Rs}{`sa&)XeTO07tD)Jgz%_5%w9ke8V_z2kfN~ zezkYb`R|}tFT{|X|7gYI`)36wDacljqT!1c<@r~!ucuKW z+pT;&E8SQ=BYPU2rn{um?n}pU>~BT$*PpzGm;Es2PD(~LUYZ{DgSV$IUZ&{&YryL| ztnaXE!OeW@FCO1%-G2-`u-&cYxaB^?D@Yz}D}2)|EZ3`j(tmXTY{8R(eJ9 zn@*GZ^%cn^?ozg%xJw_lT+F*k>ML84c-5r!I_vCod_>>YA4%Yakpjcb&FLskG2}ecR!GRYky-Wn=cm4 zEMxP{vh`WDRd8-qJ~Z+Un{R1Q@wxts&BQ5e`H+R&^+%EG)p@VNs(yYhX}9DLR&^h) zXLax((yjqz*{VIAAoh(W)-u#1agzCDJYOdgttHo?rbgnc{OZK2dKo(|Vg;j6Rt1Z@ zx4Qm2EAVIgPi><}eFe7PR0r>6iCobzWxlrxs$1A?_|bj^5*`(4IDf@B^fEO>;CFhQ zgbEEfxKDi_-E3%=vU8VPOFrh!)Bi=s$bsI6%r$(!{{>0s&5uj14WnxVwH_x}A(?g|>u0fS04~F`s_9z;<=&m29k_dNjDe-WN3#B!+odno4-3@`@JY z%TR5WzKNwAMvW$Sk5y<~M0xIwsiAUasCiP*hI^We>9?1Bn%w;>u~L-g5tj`+==$VU z(|CP<|JwI5U1<~$XK}O%J>PA7?ZHB+L{2`un}yPkbfsfKesVuG32&j>dR{Ln%73sc zcVes-syOIaqo&~6E>4Nz1?S4*Ztcf+zt50WQh&N0eMk3Kn%wTarSRy<`JUO&JL(^j z=3VjF^JFrrzh~-XV=_u2H+aaE?K3vf4HKsfT)9aLQ}$Vh4p;4vP^IUzl6`V%X}}_d zz$3<(|MTOjs}9NS+T**bcdeVRPk+GAGF%63LGSg|$LC33VMQ$kD@i9)tT1CKh~`@F?r@Jc-i1$kQjnx=0jnEs1Dey%3!<3X1bOL1Bf2pz53xZ_%KASoj}86W`|#s@zkhmhmr|c*iQ)^Z z6_o?sQEgd;wJN_W{q|Os$)U=QM;>Uv8eQ2eNp&mU5ViS`qCarE3lmI!UC(VdFb!j@#l+q_vl7`dPt8& zwH@9c)YPEtSJ%!;6xY_IEIIcA)%JbU?}+Lg`dBJjm~D%(Qpu}4>WaEVssF%znbpn` zg{0+|!uK7+yxgZ(RV(;kdmU|8-I0E?gIZSIj8(~G$}MO~#B&LLpkHhdm*xd7_?Y@s z9u^b(F}EcpKfyebODg;M$C&s0H)-h=vos~ylh1!rlQEkoOzcuw{dcvnGUr; z2{UqJ(zj&GWb&;jVP;>z0Fdzij2@C`*ft8f-FvK`y z2h?yhL7pnmpPYBNC(!9ryNA`Fjudn-Ngp=l^3@^#9jFMf;cx}!0&&1l?wEK4!Xw&% zGbKCjWd90z+}Jz zn8D>oP$DCUZ5#{)aEt?-fbl>gkOO?j)n5v1AWp4GCG-jUY`Tb)nT7z~oa5>&K997B z6NhxPiRuz34htEV3m|EV3g`EE-OnSY(fhjv!7fLd1zh zIG3oHII+l)II+lyII+l?II+kjndnI3#3EPX#G=u9M8^;(7P%287P%8A7L6rNEF!-d z&m#}w#G(nriAA1?M7@X;izX5$7ELBjEb=B!Eb{RsI)yl~Xex1H(X=w6Gl&z5W)deB z`4T4<`4J};`Adif5GNJ|5hoS}I}r^bPAm!~PAm!|PAm%N=0Ad)|JmI9M{@HY#ms-3 z2i+H&p{>4rUjlqef&LWx?<&@)>karZh96@#Lizz{txSDpyzL#$~fu1B) z*axK=AZR%c%HPSh%bANqK$-hQRVJS?--ZH8Tr6e)22;cU%>nJfv?P&EsWZm@3GcdEjXZ!SzONX7OZVWh1-tkA zpbyyF*(IZs=V?5p22H&eoP@{n9qV_Sr{I{YKJ(Tj39;2K?U+&W^V`LD4|;wjrcsLB z6DP&h#G7GXYrP=3V<+&`H$N$CU7wG=F6|tSq88*v0cq*5ilWubS$9vj`w@r79SBwzj=rI{coLtjDtTKbd3?Q$Cm9VVolJ+Qipm6IjhZ!^Xuo9msLHH_?(V$*fiv zlJZA8iQeAAs#vg`n0vdmd|UiF>UkKR^`Ixcn?)QuS70IP5514*gTi?EveL!$)2H2LmOnG68?L>b zpmKE~U6Van*;7{u)of5bTP~f2_Np}meHT3g%hxXD=N(*&Daiq=Jt8mq*-^Zdr#DL? z=WH``cgEay@t<1to)#o}gDy0sP0=~ugcYXu4N5T%rr$b63s31zq|>j>T=F{SJ9;si zo8lBf*_XQQPVK^XuK_udYQkjeTY<{MHxCuSpYk`8FEW7Ty{Y z=N(CxDQ<{tSeDVQzr~65Ca)EF=w_b~&EU!XQI)BwRe7EzDl~HB= z?fUgRT<7_7-p7CP{ip7ikL{ORhg?tD@}7Q{RpjJwCP{S;kY z>GI*!m3vq|S#^N*x(jsS_U-YGg~bv@<5Ls$PDasnnd1{&+)_IkufIftl+#Xx5^l4rO%c(qk zHWEDuc@}wLLNQ$!H2-D#$`@a4$~E@w`D>{#lWux>Xw$*5cd*i-<{oLIn>&0CD<1cG zecM%!emhX-;`C9&KAC4`QCaIL15`H3!pwF59@Jobx_MLRbX23^sG9t3B3+GETJJqP zk8XarjaRkFrNi;R`b4<&_3WGI*@OcRwnY3vKk%EP6ui6|D>{|`{J!`0FEhX7TNYOT zO}|Uf*2a>trWD$iwYX73NjaY>XBRaTSsk*w5di_9z+5Rs7EsFEMKX($&fGc77p5B* zpIJ;XFDS;{Vixwyf}$6HK+iX3s}POed6tzsev|v#sfwG#5Rk7yi-8a7mbI=_$g77 zp1^H5J_7yGg7giUJ_R#zxpXrnve-e1%!`0~koEw)0DmA5umgs3`O|=-Pv-JLYmpw_T!)4@Z{0SJpL59jegAUWoF|YGsY)CnQBWo z|I8VbnJZP$Zotof7QZcUP9w0AB9Cr|HhnSwRIfRnxgH<{V0^<-=cl?6>`7q-K%B-W9R~F;Z{T=uXV7@P_KuftXIReUT z_=^UZZFi3U?0CQ@2d=dU`p&d-xJ{YDr?eb17MSrn;eh$Iz`UB72M7=H?o#ANVP3P$ zE4d5gJqGQ`#bF;bIP}6D|N5(j?S5N@OzHE)t~wI?^QB|MEyMn0PcCSC()FZ->o~wt zZ^TrypYYV5>=!Cs5n;Pt`>$*c_Q2D2%#^=5ECB}|P5eHsRvphAJ?!s?L_2V3$&%`> zCZ0HCrM__YNd@dH9DZ_Bt{3*TEr`yWKNI^DYEsD$ig85ffxe6GT429=Ydaj9fum2J z${2k%2K&ysy(h|J*}vU$3>AA^7;EE%WB&HaqIS+cJg;JzRzGt$?6cZ6PyMNVhv$tl zt{i{!+x&L<%OCdJ?$h4@ho7&}jq6>31N61}RVdHKq3^OUT1@g@0w|cE&3IGyJPzdJW^@$$_Fln*i^kR?^U%e76oT{q#W#q5nnsI zT=XN3_P)C&r&hPk8pq+k?dklb{~Ox&zM!}dE)^xqmgCw^n9aX?nUvQ&Su0!qv0g{{ zA98W4c+D@h**F!fr9+A3%()GB3S>iDT@%?TM&02&G)1;QxON@M7bFiN=TT&Xneu6} zp{`puQop-Uk5!fHv8;AkMKBP$$xRdQS)$+Wc)-JS75azb+uSCJ1Y0H3% zf%N4&3m1QQb@pHOL~5TGTROx=pz6)5QkIW8PB&hmOo@Ov7 zhrTyJqsNgwn!^j0Etqr zk9_|cO)UTN%;j-L%dygB$BkEZbi#_?^YV1}m}8}j&8x2+sF%oBPR!8IFhi#bhjyu% zy9f)s*F;^pL1A9u;$;>(H?iFH`|{qG73p{Ty6?KbbScURS5tPj9?|xB@u%-ie*E5Q zFXaXQZ|`CGoMVxGMe8MksYwHVn>$t_=)d5;;{B2I)!{)@$jW>4q*l zlL{h`bn@)8CaN#7ApNvU_1L`<{>)Id*o!8ZTHk~tcE6Jd798(WZ~X^WIDh) ztN;BwkLTrdHF*>g)PEN0Mi!zv-gpNj%Ot`=0uNpsP6eBguHX1r6dJcY0y{cWoIp=wwc@UghK zcvpK_^ZDon^fNNJQ+drGivo$Pf3E_I$%ohwkaKpulr7y;p#Sfi|T;yMk?je(qxshTj%5dI@Y4hOv7< zWPv?}g6%^(M!%!%GogTaMAD~hnilDFy8?i5-Po;A;}L0K`1;h0;h^4%Q-VC8e4)D# zrl9Kk+yW5E(EBvDshm*au~!+t_NZHBy`naeFu?facO%`h|73v+Y7FV)M{t7jgQ-Od zR3@!-=cGV94bUwIpa7xTFb+=SI|+p0lRaUB1K|6RxA7^l-~%mSy`yb{w@jd7u?L_L zLi$j?!xsh62qU(Xg!Jul%p_r<`687=i5g?X!`xYf^fdq&&KtFn_hJ2^==$WhQLd0j z0zAIbjdLEWkuQ*Yp_(60%i?w!_tp`7#Xpp?eAZn)ik>l$Byf?uof-szqnjZVRnKbm zMB=7g@0#ETgJJfqIPY*u_G$$`lMu z=-)P^(Hd>!l?=p{kMx=qLQ4rr^@+^&g)~+7Y<018b^K_9r^m62j0k7TFjae8^@?qA ziz~R5a$lByY1MUj4Dy@vE?K)&&G(wPLt+;HK%Y%WXj=}N=J*nvWfN81MAre?ABJDx zG|3Nzo;V(?g5vXorf5_|G8(`oVKSv%p6de1Ypz& zIu@QWh*r%9<@W~PLsi2YpaKz_zLkG&?1e@UARW_Go`N-q&92}F@#mPbihQI?83 zLKoipu9gp*92_WG8cVh%_~99ts{)941XTxw?kL4ABX|8%OD08p7FGebeeB2|Oep9xV6UZT$QKGCFkQ?}(DO{kmOQD`)T4O@KO_Tf(FxRMo zKnPV<;6Uf<+XJiU^y;wO5_qj(OngPsQU-OCal;kHee0f$s*gZZH%;`l3<6t6l0SX( z7{<_TYob}%Z#-WDR%ks(AxA{b zAlFUXof~=*Vwir_rGyy5x(GzePK%=39kLQ7$ZOEuL*f+lGgOfQ;Bux^VwZAxA##c&3ppe-+ zPjg&{?Gh8K-f3AK<%26Ukq5F3@reK(-_{h2aMc~vFiPE15!_MJaa$(FAJN^-1|ytH z-O$T#s$STK`{Z>CzL=VS*EMdfd}*(}Nw9h>f2T%;Q2GxaPnZ%L<#QD+;`N_OT1D18 zT~&fRsav8M};*(#>Q?7~{GY|e|&N~T=UWh-+N#!iU0_Gi5d5aUb4%$;$XbM*Ucg77~Gh|t)6vSIl3vr&xqx3IoGMd zt5*MM)|d4`9Le9r{H;z2E_36KXX~3(Hkfn9Q)Q1(fP8oVv8U$cLwp+kwU>139XLQ_ zg8o9kHcb3xJGE!zYqa`o%hPjz6KMQCGhJ_x^8C)NYBQduU&5`g;bC0MLFC9YwOp}q z?K}olCl7ATa@@N}t+FzInc^8{YGvlx-m^he)LgRF+45i{?7D>o(E1Me)Opv z+It=oFX{D7;~KlE19Npn3^&5R5LdUVoob_315 zdVLdB!@pP#5l0S#du605O50c3J_>ncx%>#ieGzuv5pjO3Zz?@0*lkU(!#UDl{q_Ec z=+_M%t|$wCSzI~FSAY9)@U&WqIk=~(_p5ez+`TQASAHAle$a+wAruc_G85R^cTcPI zAuJvA1XJ3kd4Be*SIW(n3Q1=(;Q95MdtQ6!Zl9Qqbj9~m_5*Lx#vv`)YofiH>~CuN z7pv5n7*Z*<1DKs#R#i@2qi60?hAGLLTX=g}uvFCEDm zxeCa**;*p`y69;K!O>C76%FzA4;X_%O_xo24fNUl9}RSW7F4T(Ml8m)(#Fs(6EO`k zlVH`WMwd?fI*o{HiccZlO>JIj)RW48P!&7lRNayFEN_5DWkh-I%bpfiyc$9a^r~+4 zp|8O8UFUw6P<;um@+j#W9*~clp@S&7AfIEqD@kp5&;$!_svt`txsHd2TXXKScDt_V zV0WCBqMF2^C&@T!r!q_J?mH5PWGTyzmn#7J}cvJ%c)7#1H(hp>^D&MH^@rZ~gUbIb6euM6D4xCF%I|2kq;!Gpme&3} zKiDj(;(b3n5~X-n$$$!C9J)Y|7oSr3sN&6x=GMcaAI52hdN{g?M$blqZ;|>17^U8w z3rxG+kZjQ>ec&7}gnjyEm>`*IAZEjEzJ>s}vj2FSX^G*4WeIEN?HpfxZ!70$qa&@b zkM_%R_OH;taUW@B4$L_qn%07EbHn5j1a6nG=dW&4#rNjzaR0qSwWVs)qt+bV#Tg*f# zy1e7gzN{IcRGeB5_PA#6V%0A3^YW=vX{o)G3(9}X@X<;(O($N8v*BGCw@U42Z#dZ* zT|y3i0#PH>UMfIh{;wo-KY6Jnd709-g zx8Qk^UYWy;ku=OLAn#Y1Cg=P5V~rj#098?9*z{AKM8?mi>II8)Q@ZA!`%CT81~%aIFyw2TV)??K4L<)g^u0$>Y(wxbe~9|GD&me zU2*C5edQ?VlIm2Iqy05iK8!Ppi3|tx_8`-DQZc8}C9!h2wwu816ld2wO=yl~PfcQD zew_dGSoOf8SHNQ(?S|#C!ar^ycHQUEHW_EPd8U>{wm^;4tz@jBMHEkM`voZR$Znns z;by2tDcN%No)Z4-)JE?P!*njht){- zV@YfR7@>p7en$Bp47rQ1Bg0t|`wf)V#za1&G!dk!3jYtPE{Tl+rFAeF&nV3Wi*de- zdAnuHC`o^^h~xHQ==yRL-mh=Z6Yd?@bFq3Y6_@gB)&IVW`cHCRroUae3=iHiQ<<1; zCth*LjAAFc8T2&tvJjXU3tF`g9SQ0ZdZ&+5RA7VXD|{IAyD*h8LPVfK$h|kO&;~}i zg;gNGK|b3I=`qx?NH>hzSJu2%nA?IHY;~w*j%av%*n|M|M&F2;9%DFOoK*soXaWfC z>gR7FSp}E0$^*GseXA(tRB)pFpxbAK;j&-P- ze=$^9s{5v_+BzOAB+j|%OFJl7KE9j6vt z3{XT*gy!XvM%Z1T_#C1ZY*vT8gmvf_GFQ>>L4NDcZ%ePjfX9-*A>1tjfcAyffU(R1 z{+lJ2BBx?S+M$xk!dZol*aVh0M{W-g&I=nA@-yJxi+Z7Mj~&s)NstsK}L*}Jy{92tqVF=XV8s2lbbhc3Qp3K?q+V;^nMmrEK z^`&)n7{jDPx#}v=@pZ>Uc_+ znoi|gE11L1l;K+a*!(+Bw$HYId7Qk|e?gR~qc8;&1du80$JGe1%8TyAeNP=2vZWqn zFS>FD$<2nWshlvT7{o_yff08mQTB1Z2{!PL5qZlhysEPrh&1{+XaVrjqDnXANEAWh zRF2fXE;?r>cq^*d9@KtZC?NlwG*6jqpofUbS@s|}94m4(lWp2Pb%9zT{^rg@TXITb>1+NM6O%*(Yec2xV>vf5 z!K$vYb0bT~!3t#1pDQ9YoIkojZOQLR6!9HnXiLVg3B~(8!Qlwo=Mx`)?qjxl8)4|w z@y4K*X8}Fu$4&%JC1DGbxo40W140Hy&r*Xj9m=>jqpSbwjZ;*#dG#u?$ zox&D7X^x_gQ@aI!EsqO`MZtUJ&_muutHI0tLzMBmvI=-=K!g#N*P><=E2?@1h>A2cjUGe-!g6?$f-r5k3j3D43MPRS{C1ekW+Ic&HrfD2Y?4>_COtxB>| zqA!WmGBFy3JEy+i2za2sRRM9rSOyP>wf;a)e3PJc&~4iQIcwA2KR#j&^@N^u%^P|A5e*XiBT^+jc@0ul-nrZS1g4bR>^1EzQ^W!jI8f>$Hlm+m<3rE=R~o(oa{1_mmRYqr_(*S z;ItT0K+7Z#=+Y)_1fJQgoZKpcVf_h3V~ucg-t8O>bk}r*{g(Nqp`t~o-D?8}^xS=C z4iU?$NKFl3^xaHVE4r(N90_n3XEuj-p7VB*)*4Zk7-!+{sqi3$sGh%``uB zo8k*)i{F(JG2RP%%zT^(Q*tGG>JreEmD;1!r*E0Lk27U7QUu;Qp0~MF6=p~&Hr&I< z04_8(Zts@uVS|g-bQuNe7wx07ic^gHajzoB0Vi?|`Sa<37_!R5t-;x&UUE6HS5ImW zkY}}6$e&T{vlqH}ch<xN(3(dZ)8P%W7Ex>KK8`sg*_0tMu?FFIOyOl;-~ zxqK0_E>mOKnt#a4c|@@;ZS|1*TuX7*@_O!NIceUo_+dG$xUW>~ys|eORZpkht@F|8 zI)rZO3(yU>7{G=d-F2oqt1nYZM8^l~J|Ip|R-#Lu(b+{5fJPMNl8(|;t05RSOb-GH z628F>_7ght_$=ICu9B%wXDu%l0r-cBMy1(|yo9e|Ojnr|eEuwte97llr{2jx>#N~d zldw(c17OYm1LJ^EBP+-r@a2OZm*urZq^_Vb89k@O?)Zzjm?a}I|Jpx5|G$qjlRv=a zIx_C6aP%{iao}w+Qck%UP|8VKBz=j3ONy4^< zVLy_phT$+0r-tDml3RZ^mD$B%DLaen$YQcx$Mye=ZjxttaZQ*yc@mn}ke`eY`4*Pb#E6Sz9`X4Y&bJxr zArNPq{zhJ1@O+Pb&0IOmRJoo^1VijW7Mr zxb&aQQWUf+ojF7_JBe%sf3J@GSq(`-YB-G1)^on@Q}q5OqTw{xr|2%A$@Tg@AxF}) zD)W(#O5mbfTVS_1(BMc&yEDw>A~p%$L-4fjen1AM({Q~0bZ0-nAWyUE*`+G%td3}> zI3TB9cXiU;F7v?dIZ^X23}p*C!NSBnz{@0=J-^ z|6-HF(4!p>n;(}*A^GTO2|v-23eOM8_bD3TKJzODOk?IOoJ@YN5ktH#y`>iIL!@IA z1}xpA_KgOh1>B#KSAS=;*u@FqTHyKS>q+UP8u%_3%JH`MNL?2yl-oB74V;sji-X4I z9VzWqmrvi$Rz&cD>)Cd0`psokU5bn21{2U1*JkxCup2v&oD^hSgWaw0(RKl|rj)_X zM9=Ed(oTG>@g{KkVSQ5I%Ozu#JB%?e1tc4B%>0`X&lQ!>`2KuO>G~yJorUM3E(bO< zb0|w0*n>1VzU1X&cc6#&-S+2B2MCtI*z@7Wv+0M5u*+P!Yi#iBZmA;mP}qf(tEs?C zxbCHdYv`Xct@H;G)Fq+2x5WxFg+&`3xz(XU^Rq!+LA~*W#(TmSxF{*d4Wgnn8_d zrLq!3)dukZ7a7Y(ch~-pItfiCQaD311eauhXoZ-0@pd1z1jEHU%>6Tl$E4wo-z1aM zSL?*UV5OpOdnrADtsN;iAv#9H5ZPQ4mWDrj&oruJabt*k7pjO|A8+1Ojt?AbOkN*R z7+wO7u$oW0`u-}2XQB%pqgSugH4zS{Q$6%rs2IpwT3NE6hR6UV*gK(|1e=`e-1QL? zUdr>X0S1hB;cqFQHJKO7`3G~ZN_Q<9sN6HZI0>UXjYrn{AN!){q}sI=dH6xy0k>YT z!yH>EKUH#RIygqMCa+;IUd*LVYFW zoK5RcQbnTupmxFceni7hg;;B~i^6}(aaG@KF?52ZXRR#!2$ygA++DP-3vrjLsS9c2 z3b*1o$7WHWH{@@h!m7-s`}o=V{@#o9aV``jo$x(PbHg6+ zvDz{kmLRjm=7B86v`5lmiK)hAaCw6?5GQ1s?gv0+6ZC3ZvHV8 zN7CJC#$2!l*}<1;A9~>9Ct%wW?V`ml+RLOar#ji70>^odMh?B%##~G%-bLZa6`coF zWa_Aa!#n9HG^QUU>RIde^9-m2`KLWgY{pcXxz~{>qQG2!Bz%1tU9OzQyE(OM6{V!Q zznZC0_A~i2AQ+o11!EQ$yGG;qV^0`Sah7P!`I*`AACDr96;jQpZ->k0QZ`1dENgs? z0XFFZ`uE>=e(7uQu~p9tn3Plrp)VYVLYnP;I_Y(pc!@D~d$T6W;2?@I{p#6D4 zN%XI!p2<<(ZRILFC-1U*aiB?oJ0Lk)qYK3Ei zI0S_$%h6zR7=UO20O8t8L--oTD*>zrq*n*%?nIr+K8Q%43@BZaSt;{r8%vx?eZH~? zoRMPk{4*HC;ly|@Scpv-2p@z&b@B-e2n0X@W9`jhWS_sY2FyW-LZEN6po&b64<_0g zjjPD>jh-KGoMKKqDUXE-pEU}G@^`!tTx2vbfcFJ2>Cel8S!eGIf%LzUP z058M#lpLf(>d-3mSGB8f#;5DNm9s_z4W#QsW;%plu*ip))o$`n#;=F)nd|i@9rMOg z`<^uKGCsGs`_$Z@`Nn|)na#cfE|Z8bX2WnIjd4?IzT97ko(!W`vQ>-X4r9pgEjzXu zP#API7FXubpByoxmzc+_lUQXvmemD0v!AzSHBYO%H7ZssI!Qh?$ImnEC4N6)q zh~UIa_2#mFopjo7-yZy>4CZ3E?01qG?pGZ7JC__iBB8+0w|O@uu7`;C{xh`PVwSO~ z*iNBWNYrw_-u_(dZ4TS2NF~Yr_?XrzTjFWolGsIMgt+?WR_(f!?baRN?yM&T%2)+= z?72>ukNnFW6DVZ}^B=7GwW$HY(w|@ec{T3n0KirWs>7BBF~G9s zhDNj^r)Br(F6#Pkn=F8F*u>EnxAqIl=I&k?!tT)~i|5|a4C4Dhf4O(fb;$Wk^+3PH z$B*;MJoTal5tsETCnQ4?t}lacSqW`}e#^{y&afbecT4HI7%m3RE2i==&Ov_d|R7R=lvK)xK&tC!v>S z0&2!?kDE{{QZ?v}PFu4;Pr3|bpFYcLk}hX9d90g*`Y8@Zir#4LMMzdUE|$&%qZ-P= zuxK3yyw1W?Kh?>m*hr)fJfi?aE;c;7gAN^iaX>}E2K9#{e?>~YLURJ5so4CnD40_@ z(;mvg#z5ONXzGd%GeFwoZmWx5_THI%gdmUhOj2<1L z?H6j-2xl0)&IMqe{}f)Len_958(#n;3O=tXG0=Pxw>etY!yV0X9?ZiBOHlf?emf&! z8>Zgu5i5&B_hX`$Z2F=?dP)tRxL3Z=vyV{k-D(3^AL|x-``_jwN(oTJOm>A2(T7Oi zIGnW%Tb}NN4(8|3(5gl&pSW{C1hv98m-Pjhxi}GNy)H53AK!|v_p3oKzUZL8>R?kx zty;SIpxY*r66&?-j~08r5Ai?yj{-&qU6-~?wr+&K9#!ZoOKn(8^91P8+)Xw44QT)b zLQ+FQhthYh4{;}v9L1ULj00z4+4}aHuK@sjrNqiRgL}=r3&PV`C%|ujb3-=Irpa~N zK9OvFr`iu6!><+T^;e}O4)CgS-G}O2e~YsLY{G22HMCT_y2@97CEHgU#=B38pQHtk zt}$5r@KisXPS-Qe(bdhj1=hmZXw?^EFwfAAXsKcrv@6OqU{%qzefC?OQx+6XZopyV zK?$qDa+Moyy8EZJ3%@%x0Q+5SvKLj671DxTkfd&cSXGwprI9k)R4R>Nvc|CV6ctaL z9>-=DX<9wh8u#&8t70Yr!%Ne*H5`!HMCNvci`2E6He1x#OK`beQY@lpu^nAwr@n0> zA||z*r2Qxov2EmI>+{pFVSC`CZ6oV+s<`qr@zTJ0tgiSd=6#2=i#e03!ugH|b8EJp z?5(bGCe5QKhDS9Lck*r_7cxP$OuLoBn1rn=t8S9ZY-V!QQn7v$-9aH2BLT529}nY^ z#h>;SCkO8AEcE{wTe7oQjx5I8S6m$a-$=K&ZkC-D?V9B5z%ivT)IQ3~^ZDo>wl&LB zwx%-fFL8vf>z2mrjpNPPW_-AdxUEI*_!DxL!%KyD!#BI*N0)Jter #include + +/* *********************************************************************** + * * + * Declaration of functions * + * * + * ********************************************************************* */ + + + +/* Functions coming from the package ade4 */ + void vecpermut (double *A, int *num, double *B); double alea (void); void aleapermutvec (double *a); @@ -28,6 +39,13 @@ void matmodifcs (double **tab, double *poili); void matmodifcn (double **tab, double *poili); void matmodifcm (double **tab, double *poili); void DiagobgComp (int n0, double **w, double *d, int *rang); + + + + + + +/* Functions from the package adehabitat */ void topoids(double *vec, int *n); void multpoco(double **tab, double *poco); void aleadistrivec(double *vec, double *no); @@ -35,12 +53,14 @@ void randksel(int *fac, double *pu, int *nani, int *ni); void rks(int *fac, double *pdsu, int *nani, int *nbani, int *nl); void ksel(double *tab, int *fac, double *poidsut, int *nhab, int *nani, int *nloctot, double *ut, double *di, - double *marg, int *nombreani, double *eigenvp, double *poidsco, int *ewa); + double *marg, int *nombreani, double *eigenvp, + double *poidsco, int *ewa); void permutksel(double *tab, int *fac, double *poidsut, int *nhab, int *nani, int *nloctot, double *ut, double *di, double *marg, int *nombreani, int *npermut, double *obseig, double *simeig, double *obsmarg, - double *simmarg, double *eigenvp, double *simtout, double *poidsco, + double *simmarg, double *eigenvp, + double *simtout, double *poidsco, int *ewa); void sahr2ksel(double *Usa, double *Uhr, double *Ulo, int *nhab, int *npix, int *nani, int *nlig, double *dud, @@ -66,7 +86,8 @@ void getcontour(double *grille, int *nlig, int *ncol, int *indicelig, void lcontour(double *grille, int *nlig, int *ncol, int *lcont); void levels(double *vec, double *lev, int *lvec); void seqeticorr(double *grille, int *nlig, int *ncol); -void epa(double *X, double *Y, double *xl, double *yl, double *val, double *fen); +void epa(double *X, double *Y, double *xl, double *yl, + double *val, double *fen); void kernelhr(double *grille, double *xgri, double *ygri, int *ncolgri, int *nliggri, int *nloc, double *fen, double *xlo, double *ylo); void CVmise(int *nloc, double *xlo, double *ylo, @@ -74,7 +95,8 @@ void CVmise(int *nloc, double *xlo, double *ylo, void calcvolume(double *grille, int *ncolgri, int *nliggri, double *cellsize); void calcsim(double *pix, double **pts, double *rg, int *nvar, int *npts, double *similarite); -void fctdomain(double *kascmod, double *ptsmod, double *range, int *npts, int *npix, +void fctdomain(double *kascmod, double *ptsmod, + double *range, int *npts, int *npix, int *nvar, double *qualhab); void wml(double **used, double **avail, double *wmla, int na, int nh, double **proj1, double **proj2, double *nbassocie, int krep); @@ -82,7 +104,8 @@ void aclambda(double *util, double *dispo, int *nani, int *nhab, double *xxtxxtmod1, double *xxtxxtmod2, double *rnv, double *wmla, int *nrep, double *wm, double *nb); void rankma(double *used, double *avail, double *rankmap, double *rankmam, - double *rankmav, double *rankmanb, int *nhab, int *nani, int *nrep, double *rnv); + double *rankmav, double *rankmanb, + int *nhab, int *nani, int *nrep, double *rnv); void erodil(double *grille, int *nlig, int *ncol, int *ntour, int *oper); void inout(double *x, double *y, double *xp, double *yp, int *deds); @@ -127,7 +150,8 @@ void rpoint(double **xp, double *rcx, double *rcy, double **asc, double *xc, double *yc, double *cs); void randmargtolpts(double *xpr, double *rcrx, double *rcry, double *ascr, double *cwr, double *kascr, double *xcr, double *ycr, - double *csr, double *marr, double *tolr, int *nrepr, int *nlasc, + double *csr, double *marr, double *tolr, + int *nrepr, int *nlasc, int *ncasc, int *nvarr, int *nlocsr); void regroufacasc(double **asce, double **ascs, int *np, int *nlev); @@ -135,7 +159,8 @@ void regroufacascr(double *ascer, double *ascsr, int *npr, int *nlevr, int *nle, int *nce, int *nls, int *ncs); void regrouascnum(double **ascent, double **ascso); -void regrouascnumr(double *ascentr, double *ascsor, double *nler, double *ncer, +void regrouascnumr(double *ascentr, double *ascsor, + double *nler, double *ncer, double *nlsr, double *ncsr); void regroukasc(double *kascr, double *kascniou, int *nrow, int *ncol, int *nvar, int *npix, @@ -149,8 +174,29 @@ void enfar(double *Zr, double *pr, int *nvar, int *npix, void randenfa(double **Z, double *p, int *nrep, double *res); void randenfar(double *Zr, double *pr, int *nvar, int *npix, int *nrep, double *resr); +void integrno(double *XG, double *X1, double *X2, + double *T, double *sig1, + double *sig2, double *alpha, double *res); +void udbbnoeud(double *XG, double **XY, double *T, double *sig1, + double *sig2, double *alpha, double *res); +void kernelbb(double *grille, double *xgri, double *ygri, int *ncolgri, + int *nliggri, int *nloc, double *sig1, double *sig2, + double *xlo, double *ylo, double *Tr); +void ligpoly(double *x, double *y, double r, double *xp, double *yp); +void buflig(double **x, double r, double **carte, double *xg, double *yg); +void bufligr(double *xr, double *rr, double *carter, + double *xgr, double *ygr, int *nlr, int *ncr, + int *nlocr); +void distxy(double **xy1, double **xy2, double *di); +void distxyr(double *xy1r, double *xy2r, int *n1r, + int *n2r, double *dire); +void dtmp(double x1, double x2, double y1, double y2, + double *di); void fptt(double *x, double *y, double *t, int pos, double radius, double *fptto, int nlo); +void fipati(double *x, double *y, double *t, + int nlo, int nra, double *rad, + double **fpt); void fipatir(double *xr, double *yr, double *tr, int *nlocs, double *radius, int *nrad, double *fptr); @@ -167,6 +213,21 @@ void discretrajr(double *xr, double *yr, double *datr, double *xnr, double *ynr, int *nr, int *nnr, double *datnr, double *xdeb, double *ydeb, double *ur, double *dat0, int *neff); +void trouveclustmin(double **xy, int *clust, int *lo1, int *lo2, + int *lo3, double *dist); +void trouveclustminr(double *xyr, int *nr, int *clustr, int *lo1, int *lo2, + int *lo3, double *dist); +void nndistclust(double **xy, double *xyp, double *dist); +void parclust(double **xy, int *clust, int *noclust, + int *noloc, double *dist); +void trouveminclust(double **xy, int *liclust, int *clust, + int *noclust, int *noloc, double *dist); +void choisnvclust(double **xy, int *liclust, int *clust, int *ordre); +void clusterhr(double **xy, int *facso, int *nolocso, int *cluso); +void longfacclust(double **xy, int *len2); +void longfacclustr(double *xyr, int *nr, int *len2); +void clusterhrr(double *xyr, int *nr, int *facsor, + int *nolocsor, int *clusor, int *len); @@ -174,7 +235,7 @@ void discretrajr(double *xr, double *yr, double *datr, double *xnr, /********************************************************************* ********************************************************************* ********* ***** - ********* Les sources de ADE-4 ***** + ********* The sources of ADE-4 ***** ********* -------------------- ***** ********************************************************************* ********************************************************************* @@ -185,30 +246,30 @@ void discretrajr(double *xr, double *yr, double *datr, double *xnr, /**************************/ double alea (void) { - double w; - w = ((double) rand())/ (double)RAND_MAX; - return (w); + double w; + w = ((double) rand())/ (double)RAND_MAX; + return (w); } /*************************/ void aleapermutvec (double *a) { - /* permute au hasard les ÚlÚments du vecteur a - Manly p. 42 Le vecteur est modifiÚ - from Knuth 1981 p. 139 */ - int lig, i,j, k; - double z; - - lig = a[0]; - for (i=1; i<=lig-1; i++) { - j=lig-i+1; - k = (int) (j*alea()+1); - /* k = (int) (j*genrand()+1); */ - if (k>j) k=j; - z = a[j]; - a[j]=a[k]; - a[k] = z; - } + /* Randomly permutes the elements of a vector a + Manly p. 42 The vector is modified + from Knuth 1981 p. 139 */ + int lig, i,j, k; + double z; + + lig = a[0]; + for (i=1; i<=lig-1; i++) { + j=lig-i+1; + k = (int) (j*alea()+1); + /* k = (int) (j*genrand()+1); */ + if (k>j) k=j; + z = a[j]; + a[j]=a[k]; + a[k] = z; + } } @@ -216,853 +277,871 @@ void aleapermutvec (double *a) void vecpermut (double *A, int *num, double *B) { /*--------------------------------------- -* A est un vecteur n elements -* B est une vecteur n elements -* num est une permutation alÂŽatoire des n premiers entiers -* B contient en sortie les elements de A permutÂŽes -* ---------------------------------------*/ - - int lig, lig1, lig2, i, k; - - lig = A[0]; - lig1 = B[0]; - lig2 = num[0]; - - - if ( (lig!=lig1) || (lig!=lig2) ) { - /* err_message ("Illegal parameters (vecpermut)"); - closelisting(); */ - } - - for (i=1; i<=lig; i++) { - k=num[i]; - B[i] = A[k]; - } + * A is a vector with n elements + * B is a vector with n elements + * num is a random permutation of the n first integers + * B contains in output the permuted elements of A + * ---------------------------------------*/ + + int lig, lig1, lig2, i, k; + + lig = A[0]; + lig1 = B[0]; + lig2 = num[0]; + + + if ( (lig!=lig1) || (lig!=lig2) ) { + /* err_message ("Illegal parameters (vecpermut)"); + closelisting(); */ + } + + for (i=1; i<=lig; i++) { + k=num[i]; + B[i] = A[k]; + } } -/*******************/ +/********* Centring accrding to row weights poili **********/ void matcentrage (double **A, double *poili, char *typ) { - - if (strcmp (typ,"nc") == 0) { - return; - } else if (strcmp (typ,"cm") == 0) { - matmodifcm (A, poili); - return; - } else if (strcmp (typ,"cn") == 0) { - matmodifcn (A, poili); - return; - } else if (strcmp (typ,"cp") == 0) { - matmodifcp (A, poili); - return; - } else if (strcmp (typ,"cs") == 0) { - matmodifcs (A, poili); - return; - } else if (strcmp (typ,"fc") == 0) { - matmodiffc (A, poili); - return; - } else if (strcmp (typ,"fl") == 0) { - matmodifcm (A, poili); - return; - } + + if (strcmp (typ,"nc") == 0) { + return; + } else if (strcmp (typ,"cm") == 0) { + matmodifcm (A, poili); + return; + } else if (strcmp (typ,"cn") == 0) { + matmodifcn (A, poili); + return; + } else if (strcmp (typ,"cp") == 0) { + matmodifcp (A, poili); + return; + } else if (strcmp (typ,"cs") == 0) { + matmodifcs (A, poili); + return; + } else if (strcmp (typ,"fc") == 0) { + matmodiffc (A, poili); + return; + } else if (strcmp (typ,"fl") == 0) { + matmodifcm (A, poili); + return; + } } /*********************/ void matmodifcm (double **tab, double *poili) /*-------------------------------------------------- -* tab est un tableau n lignes, m colonnes -* disjonctif complet -* poili est un vecteur n composantes -* la procedure retourne tab centre par colonne -* pour la ponderation poili (somme=1) -* centrage type correspondances multiples ---------------------------------------------------*/ + * tab is a complete disjonctive table with n rows and m columns + * poili is a vector with n components + * The process returns tab centred by column + * with weighting poili (sum=1) + * centring type multple correspondances + --------------------------------------------------*/ { - double poid; - int i, j, l1, m1; - double *poimoda; - double x, z; - - l1 = tab[0][0]; - m1 = tab[1][0]; - vecalloc(&poimoda, m1); - - - for (i=1;i<=l1;i++) { - poid = poili[i]; - for (j=1;j<=m1;j++) { - poimoda[j] = poimoda[j] + tab[i][j] * poid; - } - } - + double poid; + int i, j, l1, m1; + double *poimoda; + double x, z; + + l1 = tab[0][0]; + m1 = tab[1][0]; + vecalloc(&poimoda, m1); + + + for (i=1;i<=l1;i++) { + poid = poili[i]; for (j=1;j<=m1;j++) { - x = poimoda[j]; - if (x==0) { - for (i=1;i<=l1;i++) tab[i][j] = 0; - } else { - - for (i=1;i<=l1;i++) { - z = tab[i][j]/x - 1.0; - tab[i][j] = z; - } - } + poimoda[j] = poimoda[j] + tab[i][j] * poid; + } + } + + for (j=1;j<=m1;j++) { + x = poimoda[j]; + if (x==0) { + for (i=1;i<=l1;i++) tab[i][j] = 0; + } else { + + for (i=1;i<=l1;i++) { + z = tab[i][j]/x - 1.0; + tab[i][j] = z; + } } - freevec (poimoda); + } + freevec (poimoda); } /*********************************************************/ void matmodifcn (double **tab, double *poili) /*-------------------------------------------------- -* tab est un tableau n lignes, p colonnes -* poili est un vecteur n composantes -* la procedure retourne tab norme par colonne -* pour la ponderation poili (somme=1) ---------------------------------------------------*/ + * tab is a table n rows and p columns + * poili is a vector with n components + * the function returns tab normed by column + * with the weighting poili (sum=1) + --------------------------------------------------*/ { - double poid, x, z, y, v2; - int i, j, l1, c1; - double *moy, *var; - - l1 = tab[0][0]; - c1 = tab[1][0]; - - vecalloc(&moy, c1); - vecalloc(&var, c1); - - + double poid, x, z, y, v2; + int i, j, l1, c1; + double *moy, *var; + + l1 = tab[0][0]; + c1 = tab[1][0]; + + vecalloc(&moy, c1); + vecalloc(&var, c1); + + /*-------------------------------------------------- -* calcul du tableau centre/norme ---------------------------------------------------*/ - - for (i=1;i<=l1;i++) { - poid = poili[i]; - for (j=1;j<=c1;j++) { - moy[j] = moy[j] + tab[i][j] * poid; - } - } - - for (i=1;i<=l1;i++) { - poid=poili[i]; - for (j=1;j<=c1;j++) { - x = tab[i][j] - moy[j]; - var[j] = var[j] + poid * x * x; - } + * centred and normed table + --------------------------------------------------*/ + + for (i=1;i<=l1;i++) { + poid = poili[i]; + for (j=1;j<=c1;j++) { + moy[j] = moy[j] + tab[i][j] * poid; } - + } + + for (i=1;i<=l1;i++) { + poid=poili[i]; for (j=1;j<=c1;j++) { - v2 = var[j]; - if (v2<=0) v2 = 1; - v2 = sqrt(v2); - var[j] = v2; + x = tab[i][j] - moy[j]; + var[j] = var[j] + poid * x * x; } - - for (i=1;i<=c1;i++) { - x = moy[i]; - y = var[i]; - for (j=1;j<=l1;j++) { - z = tab[j][i] - x; - z = z / y; - tab[j][i] = z; - } + } + + for (j=1;j<=c1;j++) { + v2 = var[j]; + if (v2<=0) v2 = 1; + v2 = sqrt(v2); + var[j] = v2; + } + + for (i=1;i<=c1;i++) { + x = moy[i]; + y = var[i]; + for (j=1;j<=l1;j++) { + z = tab[j][i] - x; + z = z / y; + tab[j][i] = z; } - - freevec(moy); - freevec(var); - + } + + freevec(moy); + freevec(var); + } /*********************************************************/ void matmodifcs (double **tab, double *poili) /*-------------------------------------------------- -* tab est un tableau n lignes, p colonnes -* poili est un vecteur n composantes -* la procedure retourne tab standardise par colonne -* pour la ponderation poili (somme=1) ---------------------------------------------------*/ + * tab is a tableau n rows, p columns + * poili is a vector with n components + * The function returns tab standardised by column + * for the weighting poili (sum=1) + --------------------------------------------------*/ { double poid, x, z, y, v2; int i, j, l1, c1; double *moy, *var; - + l1 = tab[0][0]; c1 = tab[1][0]; - + vecalloc(&var, c1); - + /*-------------------------------------------------- -* calcul du tableau standardise ---------------------------------------------------*/ - + * calculation of the standardised table + --------------------------------------------------*/ + for (i=1;i<=l1;i++) { - poid=poili[i]; - for (j=1;j<=c1;j++) { - x = tab[i][j]; - var[j] = var[j] + poid * x * x; - } + poid=poili[i]; + for (j=1;j<=c1;j++) { + x = tab[i][j]; + var[j] = var[j] + poid * x * x; + } } for (j=1;j<=c1;j++) { - v2 = var[j]; - if (v2<=0) v2 = 1; - v2 = sqrt(v2); - var[j] = v2; + v2 = var[j]; + if (v2<=0) v2 = 1; + v2 = sqrt(v2); + var[j] = v2; } for (i=1;i<=c1;i++) { - x = moy[i]; - y = var[i]; - for (j=1;j<=l1;j++) { - z = tab[j][i]; - z = z / y; - tab[j][i] = z; - } + x = moy[i]; + y = var[i]; + for (j=1;j<=l1;j++) { + z = tab[j][i]; + z = z / y; + tab[j][i] = z; + } } freevec(var); } + /**********/ void matmodifcp (double **tab, double *poili) /*-------------------------------------------------- -* tab est un tableau n lignes, p colonnes -* poili est un vecteur n composantes -* la procedure retourne tab centre par colonne -* pour la ponderation poili (somme=1) ---------------------------------------------------*/ + * tab is a table with n rows and p colonnes + * poili is a vector with n components + * The function returns tab centred by column + * for the weighting poili (sum=1) + --------------------------------------------------*/ { - double poid; - int i, j, l1, c1; - double *moy, x, z; - - l1 = tab[0][0]; - c1 = tab[1][0]; - vecalloc(&moy, c1); - - + double poid; + int i, j, l1, c1; + double *moy, x, z; + + l1 = tab[0][0]; + c1 = tab[1][0]; + vecalloc(&moy, c1); + + /*-------------------------------------------------- -* calcul du tableau centre ---------------------------------------------------*/ - - for (i=1;i<=l1;i++) { - poid = poili[i]; - for (j=1;j<=c1;j++) { - moy[j] = moy[j] + tab[i][j] * poid; - } + * Centred table + --------------------------------------------------*/ + + for (i=1;i<=l1;i++) { + poid = poili[i]; + for (j=1;j<=c1;j++) { + moy[j] = moy[j] + tab[i][j] * poid; } - - - for (i=1;i<=c1;i++) { - x = moy[i]; - for (j=1;j<=l1;j++) { - z = tab[j][i] - x; - tab[j][i] = z; - } + } + + + for (i=1;i<=c1;i++) { + x = moy[i]; + for (j=1;j<=l1;j++) { + z = tab[j][i] - x; + tab[j][i] = z; } - freevec(moy); + } + freevec(moy); } /*********************/ void matmodiffc (double **tab, double *poili) /*-------------------------------------------------- -* tab est un tableau n lignes, m colonnes -* de nombres positifs ou nuls -* poili est un vecteur n composantes -* la procedure retourne tab centre doublement -* pour la ponderation poili (somme=1) -* centrage type correspondances simples ---------------------------------------------------*/ + * tab is a table with n rows and m columns + * of number >=0 + * poili is a vector with n components + * The function returns tab doubly centred + * for the weighting poili (sum=1) + * centring type simple correspondance analysis + --------------------------------------------------*/ { - double poid; - int i, j, l1, m1; - double *poimoda; - double x, z; - - l1 = tab[0][0]; - m1 = tab[1][0]; - vecalloc(&poimoda, m1); - - - for (i=1;i<=l1;i++) { - x = 0; - for (j=1;j<=m1;j++) { - x = x + tab[i][j]; - } - if (x!=0) { - for (j=1;j<=m1;j++) { - tab[i][j] = tab[i][j]/x; - } - } + double poid; + int i, j, l1, m1; + double *poimoda; + double x, z; + + l1 = tab[0][0]; + m1 = tab[1][0]; + vecalloc(&poimoda, m1); + + + for (i=1;i<=l1;i++) { + x = 0; + for (j=1;j<=m1;j++) { + x = x + tab[i][j]; } - - for (i=1;i<=l1;i++) { - poid = poili[i]; - for (j=1;j<=m1;j++) { - poimoda[j] = poimoda[j] + tab[i][j] * poid; - } + if (x!=0) { + for (j=1;j<=m1;j++) { + tab[i][j] = tab[i][j]/x; + } + } + } + + for (i=1;i<=l1;i++) { + poid = poili[i]; + for (j=1;j<=m1;j++) { + poimoda[j] = poimoda[j] + tab[i][j] * poid; + } + } + + for (j=1;j<=m1;j++) { + x = poimoda[j]; + if (x==0) { + /* err_message("column has a nul weight (matmodiffc)"); */ } - for (j=1;j<=m1;j++) { - x = poimoda[j]; - if (x==0) { - /* err_message("column has a nul weight (matmodiffc)"); */ - } - - for (i=1;i<=l1;i++) { - z = tab[i][j]/x - 1.0; - tab[i][j] = z; - } + for (i=1;i<=l1;i++) { + z = tab[i][j]/x - 1.0; + tab[i][j] = z; } - freevec (poimoda); + } + freevec (poimoda); } + + + + + + + + /*****************/ void getpermutation (int *numero, int repet) /*---------------------- -* affectation d'une permutation alÚatoire des n premiers entiers -* dans dans un vecteur d'entiers de dimension n -* vecintalloc prÚalable exigÚ -* *numero est un vecteur d'entier -* repet est un entier qui peut prendre une valeur arbitraire -* utilise dans le germe du generateur de nb pseudo-aleatoires -* si on l'incremente dans des appels repetes (e.g. simulation) garantit -* que deux appels donnent deux resultats distincts (seed=clock+repet) -------------------------*/ + * affects a random permutation of the first n integers + * in an integer vector of length n + * First vecintalloc is needed + * *numero is a vector of integer + * repet is an integer which can take any arbitrary value + * used in the seed of the pseudo-random number generation process + * if it is increased in repeated calls (e.g. simulation), it is ensured that + * two calls returns different results (seed=clock+repet) + ------------------------*/ { - int i, n, seed; - int *alea; - - n=numero[0]; - vecintalloc (&alea,n); - - /*------------- - * numerotation dans numero - -----------*/ - for (i=1;i<=n;i++) { - numero[i]=i; - } - - /*------------- - * affectation de nombres aleatoires dans alea - ----------------*/ - seed = clock(); - seed = seed + repet; - srand(seed); - for (i=1;i<=n;i++) { - alea[i]=rand(); - } - - trirapideint (alea , numero, 1, n); - freeintvec (alea); + int i, n, seed; + int *alea; + + n=numero[0]; + vecintalloc (&alea,n); + + /*------------- + * numbering in numero + -----------*/ + for (i=1;i<=n;i++) { + numero[i]=i; + } + + /*------------- + * affects random numbers in alea + ----------------*/ + seed = clock(); + seed = seed + repet; + srand(seed); + for (i=1;i<=n;i++) { + alea[i]=rand(); + } + + trirapideint (alea , numero, 1, n); + freeintvec (alea); } /*****************************************/ +/* Sorting: used in getpermutation */ + void trirapideint (int *x , int *num, int gauche, int droite) { - int j, dernier, milieu, t; - - if ( (droite-gauche)<=0) return; - - milieu = (gauche+droite)/2; - trirapideintswap (x, gauche, milieu); - trirapideintswap (num, gauche, milieu); - - t=x[gauche]; - dernier=gauche; - for (j = gauche+1; j<=droite; j++) { - if (x[j] < t) { - dernier = dernier + 1; - trirapideintswap (x, dernier, j); - trirapideintswap (num, dernier, j); - } + int j, dernier, milieu, t; + + if ( (droite-gauche)<=0) return; + + milieu = (gauche+droite)/2; + trirapideintswap (x, gauche, milieu); + trirapideintswap (num, gauche, milieu); + + t=x[gauche]; + dernier=gauche; + for (j = gauche+1; j<=droite; j++) { + if (x[j] < t) { + dernier = dernier + 1; + trirapideintswap (x, dernier, j); + trirapideintswap (num, dernier, j); } - trirapideintswap (x, gauche, dernier); - trirapideintswap (num, gauche, dernier); - - trirapideint (x, num, gauche, dernier-1); - trirapideint (x, num, dernier+1, droite); - + } + trirapideintswap (x, gauche, dernier); + trirapideintswap (num, gauche, dernier); + + trirapideint (x, num, gauche, dernier-1); + trirapideint (x, num, dernier+1, droite); + } /**************************************/ +/* Sorting: used in trirapideint */ + void trirapideintswap (int *v, int i, int j) { - int provi; - - provi=v[i]; - v[i]=v[j]; - v[j]=provi; + int provi; + + provi=v[i]; + v[i]=v[j]; + v[j]=provi; } /***********************************************************************/ void sqrvec (double *v1) /*-------------------------------------------------- -* Racine carree des elements d'un vecteur ---------------------------------------------------*/ + * Square root of the elements of a vector + --------------------------------------------------*/ { - int i, c1; - double v2; - - c1 = v1[0]; - - for (i=1;i<=c1;i++) { - v2 = v1[i]; - /* if (v2 < 0.0) err_message("Error: Square root of negative number (sqrvec)"); */ - v2 = sqrt(v2); - v1[i] = v2; - } + int i, c1; + double v2; + + c1 = v1[0]; + + for (i=1;i<=c1;i++) { + v2 = v1[i]; + /* if (v2 < 0.0) err_message("Error: Square root of negative number (sqrvec)"); */ + v2 = sqrt(v2); + v1[i] = v2; + } } /***********************************************************************/ void DiagobgComp (int n0, double **w, double *d, int *rang) /*-------------------------------------------------- -* Diagonalisation -* T. FOUCART Analyse factorielle de tableaux multiples, -* Masson, Paris 1984,185p., p. 62. D'apr?s VPROP et TRIDI, -* de LEBART et coll. ---------------------------------------------------*/ + * Eigenstructure of a matrix. See + * T. FOUCART Analyse factorielle de tableaux multiples, + * Masson, Paris 1984,185p., p. 62. D'apr?s VPROP et TRIDI, + * de LEBART et coll. + --------------------------------------------------*/ { - double *s; - double a, b, c, x, xp, q, bp, ab, ep, h, t, u , v; - double dble; - int ni, i, i2, j, k, jk, ijk, ij, l, ix, m, m1, isnou; - - vecalloc(&s, n0); - a = 0.000000001; - ni = 100; - if (n0 == 1) { - d[1] = w[1][1]; - w[1][1] = 1.0; - *rang = 1; - freevec (s); - return; + double *s; + double a, b, c, x, xp, q, bp, ab, ep, h, t, u , v; + double dble; + int ni, i, i2, j, k, jk, ijk, ij, l, ix, m, m1, isnou; + + vecalloc(&s, n0); + a = 0.000000001; + ni = 100; + if (n0 == 1) { + d[1] = w[1][1]; + w[1][1] = 1.0; + *rang = 1; + freevec (s); + return; + } + + for (i2=2;i2<=n0;i2++) { + + b=0.0; + c=0.0; + i=n0-i2+2; + k=i-1; + if (k < 2) goto Et1; + for (l=1;l<=k;l++) { + c = c + fabs((double) w[i][l]); } + if (c != 0.0) goto Et2; - for (i2=2;i2<=n0;i2++) { - - b=0.0; - c=0.0; - i=n0-i2+2; - k=i-1; - if (k < 2) goto Et1; - for (l=1;l<=k;l++) { - c = c + fabs((double) w[i][l]); - } - if (c != 0.0) goto Et2; - -Et1: s[i] = w[i][k]; - goto Etc; - -Et2: for (l=1;l<=k;l++) { - x = w[i][l] / c; - w[i][l] = x; - b = b + x * x; - } - xp = w[i][k]; - ix = 1; - if (xp < 0.0) ix = -1; + Et1: s[i] = w[i][k]; + goto Etc; + + Et2: for (l=1;l<=k;l++) { + x = w[i][l] / c; + w[i][l] = x; + b = b + x * x; + } + xp = w[i][k]; + ix = 1; + if (xp < 0.0) ix = -1; /* q = -sqrt(b) * ix; */ - dble = b; - dble = -sqrt(dble); - q = dble * ix; - - s[i] = c * q; - b = b - xp * q; - w[i][k] = xp - q; - xp = 0; - for (m=1;m<=k;m++) { - w[m][i] = w[i][m] / b / c; - q = 0; - for (l=1;l<=m;l++) { - q = q + w[m][l] * w[i][l]; - } - m1 = m + 1; - if (k < m1) goto Et3; - for (l=m1;l<=k;l++) { - q = q + w[l][m] * w[i][l]; - } - -Et3: s[m] = q / b; - xp = xp + s[m] * w[i][m]; - } - bp = xp * 0.5 / b; - for (m=1;m<=k;m++) { - xp = w[i][m]; - q = s[m] - bp * xp; - s[m] = q; - for (l=1;l<=m;l++) { - w[m][l] = w[m][l] - xp * s[l] - q * w[i][l]; - } - } - for (l=1;l<=k;l++) { - w[i][l] = c * w[i][l]; - } - -Etc: d[i] = b; - } /* for (i2=2;i2= h) { + l = m; + h = d[m]; + } + } + if (l == i) { + goto Etb; + } else { + d[l] = d[i]; + d[i] = h; + } + for (m=1;m<=n0;m++) { + h = w[m][i]; + w[m][i] = w[m][l]; + w[m][l] = h; + } + + Etb:; + } /* for (ij=2;ij<=n0;ij++) */ + + /* final:; */ + *rang = 0; + for (i=1;i<=n0;i++) { + /* + if (d[i] / d[1] < 0.00001) d[i] = 0.0; + if (d[i] != 0.0) *rang = *rang + 1; + */ + if (d[i] > 0.0) *rang = *rang + 1; + } + freevec(s); +} /* DiagoCompbg */ + -Et8: v = q / xp; -/* t = sqrt(1 + v * v); */ - dble = 1.0 + v * v; - dble = sqrt(dble); - t = dble; - - s[i+1] = t * xp; - u = 1 / t; - v = v * u; - -Et9: - q = d[i+1] - h; - t = (d[i] - q) * u + 2.0 * v * b; - h = u * t; - d[i+1] = q + h; - q = v * t - b; - for (l=1;l<=n0;l++) { - xp = w[l][i+1]; - w[l][i+1] = u * w[l][i] + v * xp; - w[l][i] = v * w[l][i] - u * xp; - } - } - d[k] = d[k] - h; - s[k] = q; - s[j] = 0.0; - - goto Et6; -Eta:; - } /* for (k=1;k<=n0;k++) */ - - for (ij=2;ij<=n0;ij++) { - - i = ij - 1; - l = i; - h = d[i]; - for (m=ij;m<=n0;m++) { - if (d[m] >= h) { - l = m; - h = d[m]; - } - } - if (l == i) { - goto Etb; - } else { - d[l] = d[i]; - d[i] = h; - } - for (m=1;m<=n0;m++) { - h = w[m][i]; - w[m][i] = w[m][l]; - w[m][l] = h; - } -Etb:; - } /* for (ij=2;ij<=n0;ij++) */ - /* final:; */ - *rang = 0; - for (i=1;i<=n0;i++) { - /* - if (d[i] / d[1] < 0.00001) d[i] = 0.0; - if (d[i] != 0.0) *rang = *rang + 1; - */ - if (d[i] > 0.0) *rang = *rang + 1; - } - freevec(s); -} /* DiagoCompbg */ /***********************************************************************/ void prodmatABC (double **a, double **b, double **c) /*-------------------------------------------------- -* Produit matriciel AB +* Matrix product AB --------------------------------------------------*/ { - int j, k, i, lig, col, col2; - double s; - - lig = a[0][0]; - col = a[1][0]; - - col2 = b[1][0]; - - for (i=1;i<=lig;i++) { - for (k=1;k<=col2;k++) { - s = 0; - for (j=1;j<=col;j++) { - s = s + a[i][j] * b[j][k]; - } - c[i][k] = s; - } - } + int j, k, i, lig, col, col2; + double s; + + lig = a[0][0]; + col = a[1][0]; + + col2 = b[1][0]; + + for (i=1;i<=lig;i++) { + for (k=1;k<=col2;k++) { + s = 0; + for (j=1;j<=col;j++) { + s = s + a[i][j] * b[j][k]; + } + c[i][k] = s; + } + } } /***********************************************************************/ void prodmatAtAB (double **a, double **b) /*-------------------------------------------------- -* Produit matriciel AtA +* Matrix product AtA --------------------------------------------------*/ { - int j, k, i, lig, col; - double s; - - lig = a[0][0]; - col = a[1][0]; - - for (j=1;j<=col;j++) { - for (k=j;k<=col;k++) { - s = 0; - for (i=1;i<=lig;i++) { - s = s + a[i][k] * a[i][j]; - } - b[j][k] = s; - b[k][j] = s; - } - } + int j, k, i, lig, col; + double s; + + lig = a[0][0]; + col = a[1][0]; + + for (j=1;j<=col;j++) { + for (k=j;k<=col;k++) { + s = 0; + for (i=1;i<=lig;i++) { + s = s + a[i][k] * a[i][j]; + } + b[j][k] = s; + b[k][j] = s; + } + } } /***********************************************************************/ void prodmatAtBC (double **a, double **b, double **c) /*-------------------------------------------------- -* Produit matriciel AtB ---------------------------------------------------*/ + * Matrix product AtB + --------------------------------------------------*/ { - int j, k, i, lig, col, col2; - double s; - - lig = a[0][0]; - col = a[1][0]; - - col2 = b[1][0]; - - for (j=1;j<=col;j++) { - for (k=1;k<=col2;k++) { - s = 0; - for (i=1;i<=lig;i++) { - s = s + a[i][j] * b[i][k]; - } - c[j][k] = s; - } - } + int j, k, i, lig, col, col2; + double s; + + lig = a[0][0]; + col = a[1][0]; + + col2 = b[1][0]; + + for (j=1;j<=col;j++) { + for (k=1;k<=col2;k++) { + s = 0; + for (i=1;i<=lig;i++) { + s = s + a[i][j] * b[i][k]; + } + c[j][k] = s; + } + } } /***********************************************************************/ void prodmatAAtB (double **a, double **b) /*-------------------------------------------------- -* Produit matriciel B = AAt ---------------------------------------------------*/ + * Matrix product B = AAt + --------------------------------------------------*/ { - int j, k, i, lig, col; - double s; - - lig = a[0][0]; - col = a[1][0]; - - for (j=1;j<=lig;j++) { - for (k=j;k<=lig;k++) { - s = 0; - for (i=1;i<=col;i++) { - s = s + a[j][i] * a[k][i]; - } - b[j][k] = s; - b[k][j] = s; - } - } + int j, k, i, lig, col; + double s; + + lig = a[0][0]; + col = a[1][0]; + + for (j=1;j<=lig;j++) { + for (k=j;k<=lig;k++) { + s = 0; + for (i=1;i<=col;i++) { + s = s + a[j][i] * a[k][i]; + } + b[j][k] = s; + b[k][j] = s; + } + } } /*******************/ void prodmatAtBrandomC (double **a, double **b, double **c, int*permut) /*-------------------------------------------------- -* Produit matriciel AtB -* les lignes de B sont permutÚes par la permutation permut ---------------------------------------------------*/ + * Produit matriciel AtB + * les lignes de B sont permutÚes par la permutation permut + --------------------------------------------------*/ { - int j, k, i, i0, lig, col, col2; - double s; - - lig = a[0][0]; - col = a[1][0]; - - col2 = b[1][0]; - - for (j=1;j<=col;j++) { - for (k=1;k<=col2;k++) { - s = 0; - for (i=1;i<=lig;i++) { - i0 = permut[i]; - s = s + a[i][j] * b[i0][k]; - } - c[j][k] = s; - } - } + int j, k, i, i0, lig, col, col2; + double s; + + lig = a[0][0]; + col = a[1][0]; + + col2 = b[1][0]; + + for (j=1;j<=col;j++) { + for (k=1;k<=col2;k++) { + s = 0; + for (i=1;i<=lig;i++) { + i0 = permut[i]; + s = s + a[i][j] * b[i0][k]; + } + c[j][k] = s; + } + } } /***********************************************************************/ void taballoc (double ***tab, int l1, int c1) /*-------------------------------------------------- -* Allocation de memoire dynamique pour un tableau (l1, c1) ---------------------------------------------------*/ + * Dynamic Memory Allocation for a table (l1, c1) + --------------------------------------------------*/ { - int i, j; - - if ( (*tab = (double **) calloc(l1+1, sizeof(double *))) != 0) { - for (i=0;i<=l1;i++) { - if ( (*(*tab+i)=(double *) calloc(c1+1, sizeof(double))) == 0 ) { - return; - for (j=0;j= (j-1)/lv)&&(tmp < j/lv)) - vec[(int) j]++; + +/* Declaration of local variables */ + double tmp, i, j, n, lv; + + n = *no; + lv = vec[0]; + + /* The random distribution of points in the elements of the vector */ + for (i=1; i<=n; i++) { + tmp = alea(); + for (j=1; j<=lv; j++) { + if ((tmp >= (j-1)/lv)&&(tmp < j/lv)) + vec[(int) j]++; + } } - } } @@ -1149,385 +1246,396 @@ void aleadistrivec(double *vec, double *no) /* ***************************************************** - Va faire de même, mais avec les structures de données - utilisées par la K-select (i.e., par animal) - ***************************************************** */ + +Randomly distributes the points within the home range +of animals (used for K-select analysis) + +***************************************************** */ void randksel(int *fac, double *pu, int *nani, int *ni) { - /* Déclaration de variables locales */ - int i, j, k, l; - double su, *tmp; - - l=1; - - for (k=1; k<=*nani; k++) { - vecalloc(&tmp, ni[k]); - su = 0; - - for (i=1; i<=ni[k];i++) { - su = su+pu[l]; - l++; - } + /* Declaration of local variables */ + int i, j, k, l; + double su, *tmp; - aleadistrivec(tmp, &su); + l=1; - j=1; - for (i=(l-ni[k]); i 0.000000001) { - idna[i] = 1; /* = 1 si non NA */ + idna[i] = 1; /* = 1 if non NA */ } } - /* Et enfin, tableau de sortie */ + /* And finally, the output table */ l=0; for (i=1; i<=np; i++) { - for (j=1; j<=na; j++) { - if ((idna[i]==1)&&(((int) HR[i][j])==1)) { - l++; - for (k=1; k<=nh; k++) { - sortie[l][k] = SA[i][k]; /* Que l'on passera à dud après */ - fac[l-1] = j; - pu [l-1] = LOCS[i][j]; - } + for (j=1; j<=na; j++) { + if ((idna[i]==1)&&(((int) HR[i][j])==1)) { + l++; + for (k=1; k<=nh; k++) { + sortie[l][k] = SA[i][k]; /* We will pass it to dud after */ + fac[l-1] = j; + pu [l-1] = LOCS[i][j]; + } + } } - } } - - /* On repasse sortie sous R */ + + /* One returns the output to R */ k = 0; for (i=1; i<=nl; i++) { - for (j=1; j<=nh; j++) { - dud[k] = sortie[i][j]; - k++; - } + for (j=1; j<=nh; j++) { + dud[k] = sortie[i][j]; + k++; + } } - /* Libération de mémoire */ + /* Free memory */ freetab(SA); freetab(HR); freetab(LOCS); freetab(sortie); freeintvec(idna); - } + + + /* **************************************************************** * * - * Calcul du nombre de ligne du tableau de sorties * + * Computation of the number of rows of the output table * * * **************************************************************** */ + void nls2k(double *Usa, double *Uhr, int *nhab, int *npix, int *nani) { - /* déclaration des variables */ + /* Declaration of local variables */ int i,j,k,na,nh,np,nl; double **SA, **HR; - int *ni; /* nombre de pixels pour chaque animal */ + int *ni; /* number of pixels for each animal */ int *idna; - /* idna contiendra 1 pour les pixels non-NA sur SA */ + /* idna will content 1 for the pixels non-NA on the SA */ - /* Allocation de mémoire */ + /* Allocation of memory */ na = *nani; nh = *nhab; np = *npix; @@ -1659,34 +1772,34 @@ void nls2k(double *Usa, double *Uhr, int *nhab, vecintalloc(&ni, na); vecintalloc(&idna, np); - /* Recopiage dans les variables C locales */ + /* Copies R objects into the local C variables */ k = 0; for (i=1; i<=np; i++) { - for (j=1; j<=nh; j++) { - SA[i][j] = Usa[k]; - k = k + 1; - } - idna[i] = 1; + for (j=1; j<=nh; j++) { + SA[i][j] = Usa[k]; + k = k + 1; + } + idna[i] = 1; } - + k=0; for (i=1; i<=np; i++) { - for (j=1; j<=na; j++) { - HR[i][j] = Uhr[k]; - k = k + 1; - } + for (j=1; j<=na; j++) { + HR[i][j] = Uhr[k]; + k = k + 1; + } } - - /* Calculs */ - /* Calcul du nombre de lignes du tableau de sortie */ + + /* Computation */ + /* Number of rows of the output table */ for (i=1; i<=np; i++) { if (fabs(SA[i][1] + 9999) < 0.000000001) { - idna[i] = 0; /* = 1 si non NA */ + idna[i] = 0; /* = 1 if non NA */ } } - /* Calcul de ni */ + /* Computation of ni */ for (j=1; j<=na; j++) { ni[j] = 0; } @@ -1702,7 +1815,7 @@ void nls2k(double *Usa, double *Uhr, int *nhab, } - /* Nombre de lignes total du tableau de sortie */ + /* Total number of lines in the output table */ nl=0; for (i=1; i<=na; i++) { nl = nl + ni[i]; @@ -1710,7 +1823,7 @@ void nls2k(double *Usa, double *Uhr, int *nhab, *nani = nl; - /* libération de la mémoire */ + /* Free Memory */ freetab(SA); freetab(HR); freeintvec(ni); @@ -1720,124 +1833,123 @@ void nls2k(double *Usa, double *Uhr, int *nhab, + + /* **************************************************************** * * - * rotxy pour faire tourner de façon aléatoire un couple (x,y) * + * rotxy to rotate randomly a un couple (x,y) * * * **************************************************************** */ void rotxy(double *x, double *y, int k) { - /* Déclaration des variables */ - int i, n, *numero; - double mx, my, *angle, *angleb, ang, co, si, xt, yt; - - /* Calcul de la moyenne */ - mx=0; - my=0; - n=x[0]; - - vecalloc(&angle, 360); - vecalloc(&angleb, 360); - vecintalloc(&numero, 360); - - for (i=1; i<=n; i++) { - mx = mx + x[i]; - my = my + y[i]; - } - - mx = mx / n; - my = my / n; - - /* Centrage */ - for (i=1; i<=n; i++) { - x[i] = x[i]-mx; - y[i] = y[i]-my; - } - - /* Tirage au sort d'un angle entre 0 et 2pi */ - for (i=1; i<=360; i++) { - angle[i] = (((double) i)*3.14159265359)/180; - } - - /* et zou */ - getpermutation(numero, k); - vecpermut(angle, numero, angleb); - ang = angleb[1]; - co = cos(ang); - si = sin(ang); - - for (i=1; i<=n; i++) { - xt = x[i]; - yt = y[i]; + /* Declaration of local variables */ + int i, n, *numero; + double mx, my, *angle, *angleb, ang, co, si, xt, yt; - x[i]= co * xt - si * yt + mx; - y[i]= si * xt + co * yt + my; - } - - /* libé de la mémoire */ - - freevec(angle); - freevec(angleb); - freeintvec(numero); + /* Computation of the mean */ + mx=0; + my=0; + n=x[0]; + + vecalloc(&angle, 360); + vecalloc(&angleb, 360); + vecintalloc(&numero, 360); + + for (i=1; i<=n; i++) { + mx = mx + x[i]; + my = my + y[i]; + } + + mx = mx / n; + my = my / n; + + /* Centring */ + for (i=1; i<=n; i++) { + x[i] = x[i]-mx; + y[i] = y[i]-my; + } + + /* Draws a random number between 0 and 2pi */ + for (i=1; i<=360; i++) { + angle[i] = (((double) i)*3.14159265359)/180; + } + + /* GO */ + getpermutation(numero, k); + vecpermut(angle, numero, angleb); + ang = angleb[1]; + co = cos(ang); + si = sin(ang); + + for (i=1; i<=n; i++) { + xt = x[i]; + yt = y[i]; + + x[i]= co * xt - si * yt + mx; + y[i]= si * xt + co * yt + my; + } + + /* Free the memory */ + freevec(angle); + freevec(angleb); + freeintvec(numero); } -/* **************************************************************** - * * - * shifthr pour placer un DV de facon aléatoire sur une zone. * - * entrée: asc qui décrit quoi dispo, et sous matrice * - * qui décrit cellules ou au moins une loc * - * * - **************************************************************** */ +/* ************************************************************** + * * + * shifthr randomly shifts a home range on an area * + * * + **************************************************************** */ void shifthr(double **dispo, double **util, int *idl, int *idc) { - /* Déclaration variables locales */ - int i, j, l, ncgr, nlgr, ncpe, nlpe; - int *idlgr, *idcgr, crand, lrand; - - /* Allocation de mémoire */ - nlgr = dispo[0][0]; - ncgr = dispo[1][0]; - nlpe = util[0][0]; - ncpe = util[1][0]; - - vecintalloc(&idcgr, ncgr-ncpe+1); - vecintalloc(&idlgr, nlgr-nlpe+1); - - /* ************** Tirage au sort x et y DV *********** - Deux conditions: - 1. carré DV tient dans ZE - 2. pas de 0 où locs - */ - l=0; - - while (l==0) { - getpermutation(idcgr, *idc); /* tirage au sort colonne */ - getpermutation(idlgr, *idl); /* tirage au sort ligne */ - crand = idcgr[1]; - lrand = idlgr[1]; + /* Declaration of local variables */ + int i, j, l, ncgr, nlgr, ncpe, nlpe; + int *idlgr, *idcgr, crand, lrand; - l=1; - for (i=1; i<=nlpe; i++) { - for (j=1; j<=ncpe; j++) { - if (util[i][j]>0) { - if (fabs(dispo[i+lrand-1][j+crand-1] + 9999) < 0.000000001) { - l=0; - } - } - } + /* Memory Allocation */ + nlgr = dispo[0][0]; + ncgr = dispo[1][0]; + nlpe = util[0][0]; + ncpe = util[1][0]; + + vecintalloc(&idcgr, ncgr-ncpe+1); + vecintalloc(&idlgr, nlgr-nlpe+1); + + /* ************** Random drawing of the HR position *********** + Two conditions: + 1. The square describing the HR is included in the study area + 2. No 0 where relocations + */ + l=0; + + while (l==0) { + getpermutation(idcgr, *idc); /* Random draw column */ + getpermutation(idlgr, *idl); /* Random draw row */ + crand = idcgr[1]; + lrand = idlgr[1]; + + l=1; + for (i=1; i<=nlpe; i++) { + for (j=1; j<=ncpe; j++) { + if (util[i][j]>0) { + if (fabs(dispo[i+lrand-1][j+crand-1] + 9999) < 0.000000001) { + l=0; + } + } + } + } } - } - - *idl=lrand; - *idc=crand; - - /* Libé de la mémoire */ - freeintvec(idcgr); - freeintvec(idlgr); - + + *idl=lrand; + *idc=crand; + + /* Memory free */ + freeintvec(idcgr); + freeintvec(idlgr); + } @@ -1845,98 +1957,98 @@ void shifthr(double **dispo, double **util, int *idl, int *idc) /* **************************************************************** * * - * shr pour placer un DV de facon aléatoire sur une zone. * - * entrée: asc qui décrit quoi dispo, et sous matrice * - * qui décrit cellules ou au moins une loc * + * shr places the Homr range randomly on the study area * * * **************************************************************** */ void shr(double **carte, double **ze) { - /* Déclaration des variables */ - int i, j, l, m, idci, idli, idls, idcs, *ligne, *colonne, nlsc, ncsc, nlg, ncg; - double **souscar; - - idli = 0; - idci = 0; - idls = 0; - idcs = 0; - nlg = carte[0][0]; - ncg = carte[1][0]; - - vecintalloc(&ligne, nlg); - vecintalloc(&colonne, ncg); - - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - ligne[i] = ligne[i] + carte[i][j]; - colonne[j] = colonne[j] + carte[i][j]; + /* Declaration of local variables */ + int i, j, l, m, idci, idli, idls, idcs; + int *ligne, *colonne, nlsc, ncsc, nlg, ncg; + double **souscar; + + idli = 0; + idci = 0; + idls = 0; + idcs = 0; + nlg = carte[0][0]; + ncg = carte[1][0]; + + vecintalloc(&ligne, nlg); + vecintalloc(&colonne, ncg); + + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + ligne[i] = ligne[i] + carte[i][j]; + colonne[j] = colonne[j] + carte[i][j]; + } } - } - - /* Puis on calcule l'indice inférieur et supérieur des lignes - et des colonnes contenant les locs rastérisées */ - for (i=1; i<=nlg; i++) { - if ((idli==0)&&(ligne[i]!=0)) idli = i; - } - for (i=nlg; i>=1; i--) { - if ((idls==0)&&(ligne[i]!=0)) idls = i; - } - for (i=1; i<=ncg; i++) { - if ((idci==0)&&(colonne[i]!=0)) idci = i; - } - for (i=ncg; i>=1; i--) { - if ((idcs==0)&&(colonne[i]!=0)) idcs = i; - } - - /* Enfin, calcul du nombre de lignes et de colonnes de souscar */ - nlsc = idls - idli + 1; - ncsc = idcs - idci + 1; - - /* Allocation de mémoire pour souscar */ - taballoc(&souscar, nlsc, ncsc); - - /* attribution des valeurs aux cellules de souscar */ - l = 1; - m = 1; - for (i=idli; i<=idls; i++) { - for (j=idci; j<=idcs; j++) { - souscar[l][m] = carte[i][j]; - m++; + + /* One computes the "min" and "max" indices of the + rows and columns containing the rasterized locs */ + for (i=1; i<=nlg; i++) { + if ((idli==0)&&(ligne[i]!=0)) idli = i; } + for (i=nlg; i>=1; i--) { + if ((idls==0)&&(ligne[i]!=0)) idls = i; + } + for (i=1; i<=ncg; i++) { + if ((idci==0)&&(colonne[i]!=0)) idci = i; + } + for (i=ncg; i>=1; i--) { + if ((idcs==0)&&(colonne[i]!=0)) idcs = i; + } + + /* Finally, computation of the number of rows and columns of souscar */ + nlsc = idls - idli + 1; + ncsc = idcs - idci + 1; + + /* Memory Allocation for souscar */ + taballoc(&souscar, nlsc, ncsc); + + /* attributes values to cells of souscar */ + l = 1; m = 1; - l++; - } - - /* Randomisation de la position des locs sur la ZE */ - shifthr(ze, souscar, &idli, &idci); - /* idli et idci contiennent resp. les indices de lignes - et des colonnes pour la carte utilisée randomisée - - Comme carte contient déjà les locs dont l'orientation est randomisée - On va se servir de ze pour stocker la position randomisée des locs */ - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - ze[i][j] = 0; + for (i=idli; i<=idls; i++) { + for (j=idci; j<=idcs; j++) { + souscar[l][m] = carte[i][j]; + m++; + } + m = 1; + l++; } - } - - /* donc on recalcule la carte complete randomisée */ - l = 1; - m = 1; - for (i=idli; i<=(idli+nlsc-1); i++) { - for (j=idci; j<=(idci+ncsc-1); j++) { - ze[i][j] = souscar[l][m]; - m++; + + /* Randomisation of the position of the locs on the SA */ + shifthr(ze, souscar, &idli, &idci); + /* idli et idci coontain resp. row and column indices for + the randomized map + + As "carte" already contain the locs with a randomized orientation, we + use ze to store the randomized position of the locs */ + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + ze[i][j] = 0; + } } + + /* We recompute the complete randomized map */ + l = 1; m = 1; - l++; - } - - /* libé locale de la mémoire */ - freetab(souscar); - freeintvec(ligne); - freeintvec(colonne); + for (i=idli; i<=(idli+nlsc-1); i++) { + for (j=idci; j<=(idci+ncsc-1); j++) { + ze[i][j] = souscar[l][m]; + m++; + } + m = 1; + l++; + } + + + /* Free memory */ + freetab(souscar); + freeintvec(ligne); + freeintvec(colonne); } @@ -1944,43 +2056,47 @@ void shr(double **carte, double **ze) /* **************************************************************** * * - * sr = version interactive avec R de shr * + * sr = interactive version of shr with R * * * **************************************************************** */ void sr(double *carter, double *zer, int *nlgr, int *ncgr) { - double **carte, **ze; - int i,j,k,nlg,ncg; - nlg = *nlgr; - ncg = *ncgr; - taballoc(&carte,nlg,ncg); - taballoc(&ze,nlg,ncg); - - k = 0; - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - ze[i][j] = zer[k] ; - carte[i][j] = carter[k]; - k++; + /* Declaration of local variables and memory allocation */ + double **carte, **ze; + int i,j,k,nlg,ncg; + nlg = *nlgr; + ncg = *ncgr; + taballoc(&carte,nlg,ncg); + taballoc(&ze,nlg,ncg); + + /* Copies the values from the R objects to the C objects */ + k = 0; + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + ze[i][j] = zer[k] ; + carte[i][j] = carter[k]; + k++; + } } - } - - shr(carte, ze); - - k = 0; - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - zer[k] = ze[i][j]; - carter[k] = carte[i][j]; - k++; + + /* Use of shr */ + shr(carte, ze); + + /* Copies the result from C objects to R objects */ + k = 0; + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + zer[k] = ze[i][j]; + carter[k] = carte[i][j]; + k++; + } } - } - - - freetab(carte); - freetab(ze); - + + /* Free memory */ + freetab(carte); + freetab(ze); + } @@ -1990,229 +2106,238 @@ void sr(double *carter, double *zer, int *nlgr, int *ncgr) /* **************************************************************** * * - * locrast permet la rastérisation des locs * - * * + * locrast allows the rasterization of the relocations * * * **************************************************************** */ void locrast(double *xgr, double *ygr, double *x, double *y, double **carte) { - /* Déclaration de variables */ - int i, j, k, n, nc, nl; - double res; - - /* allocation de mémoire */ - res = xgr[2]-xgr[1]; - n = x[0]; - nl = carte[0][0]; - nc = carte[1][0]; - - /* carte */ - for (i=1; i<=nl; i++) { - for (j=1; j<=nc; j++) { - carte[i][j] = 0; - } - } - - - /* rastérisation des locs */ - for (k=1; k<=n; k++) { + /* Declaration of local variables */ + int i, j, k, n, nc, nl; + double res; + + /* Memory allocation */ + res = xgr[2]-xgr[1]; + n = x[0]; + nl = carte[0][0]; + nc = carte[1][0]; + + /* Map */ for (i=1; i<=nl; i++) { - if (((xgr[i]-(res / 2)) < x[k])&&(x[k]<= (xgr[i]+(res / 2)))) { for (j=1; j<=nc; j++) { - if (((ygr[j]-(res / 2)) < y[k])&&(y[k]<= (ygr[j]+(res / 2)))) { - carte[i][j]++; - } + carte[i][j] = 0; + } + } + + + /* rasterisation of the locs */ + for (k=1; k<=n; k++) { + for (i=1; i<=nl; i++) { + if (((xgr[i]-(res / 2)) < x[k])&&(x[k]<= (xgr[i]+(res / 2)))) { + for (j=1; j<=nc; j++) { + if (((ygr[j]-(res / 2)) < y[k])&&(y[k]<= (ygr[j]+(res / 2)))) { + carte[i][j]++; + } + } + } } - } } - } } -/* **************************************************************** - * * - * lr = version interactive avec R de locrast * - * * - * * - **************************************************************** */ +/* ************************************************************** + * * + * lr = R interactive version of locrast * + * * + **************************************************************** */ void lr(double *xgri, double *ygri, double *xr, double *yr, double *carter, int *nco, int *nli, int *nlixy) { - int i,j,k, ncg, nlg, nlxy; - double *xgr, *x, *y, *ygr, **carte; - - ncg = *nco; - nlg = *nli; - nlxy = *nlixy; - - vecalloc(&xgr, nlg); - vecalloc(&ygr, ncg); - vecalloc(&x, nlxy); - vecalloc(&y, nlxy); - taballoc(&carte, nlg, ncg); - - for (i=1; i<=nlxy; i++) { - x[i] = xr[i-1]; - y[i] = yr[i-1]; - } - - for (i=1; i<=nlg; i++) { - xgr[i] = xgri[i-1]; - } - - for (i=1; i<=ncg; i++) { - ygr[i] = ygri[i-1]; - } - - - locrast(xgr, ygr, x, y, carte); - - k=0; - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - carter[k] = carte[i][j]; - k++; - } - } - freetab(carte); - freevec(xgr); - freevec(ygr); - freevec(x); - freevec(y); - + /* Declaration of local variables, + and memory allocation */ + int i,j,k, ncg, nlg, nlxy; + double *xgr, *x, *y, *ygr, **carte; + + ncg = *nco; + nlg = *nli; + nlxy = *nlixy; + + vecalloc(&xgr, nlg); + vecalloc(&ygr, ncg); + vecalloc(&x, nlxy); + vecalloc(&y, nlxy); + taballoc(&carte, nlg, ncg); + + /* Copy from R -> C variables */ + for (i=1; i<=nlxy; i++) { + x[i] = xr[i-1]; + y[i] = yr[i-1]; + } + + for (i=1; i<=nlg; i++) { + xgr[i] = xgri[i-1]; + } + + for (i=1; i<=ncg; i++) { + ygr[i] = ygri[i-1]; + } + + /* Use of locrast */ + locrast(xgr, ygr, x, y, carte); + + /* Copy from C -> R variables */ + k=0; + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + carter[k] = carte[i][j]; + k++; + } + } + + /* Free memory */ + freetab(carte); + freevec(xgr); + freevec(ygr); + freevec(x); + freevec(y); } /* **************************************************************** * * - * getcarte est l'équivalent C de getkasc * - * * + * getcarte is the C equivalent of getkasc * * * **************************************************************** */ void getcarte(double **carte, double **kasc, int *indicecarte) { - /* Définition des variables */ - int i,j,k, ic, lgr, cgr; - - /* Allocation de mémoire */ - lgr = carte[0][0]; - cgr = carte[1][0]; - ic = *indicecarte; - - k = 1; - for (j=1; j<=cgr; j++) { - for (i=1; i<=lgr; i++) { - carte[i][j] = kasc[k][ic]; - k++; + + /* Definition of local variables */ + int i,j,k, ic, lgr, cgr; + + /* Memory Allocation */ + lgr = carte[0][0]; + cgr = carte[1][0]; + ic = *indicecarte; + + /* Copy from R -> C variables */ + k = 1; + for (j=1; j<=cgr; j++) { + for (i=1; i<=lgr; i++) { + carte[i][j] = kasc[k][ic]; + k++; + } } - } } /* **************************************************************** * * - * gc pour test sous R * - * * + * gc is for the interactive version with R, just for a test * * * **************************************************************** */ -void gc(double *carter, double *kascr, int *nlgr, int *ncgr, int *nhab) +void gc(double *carter, double *kascr, int *nlgr, + int *ncgr, int *nhab) { - int i,j,k, nlg, ncg, nh, nl; - double **carte, **kasc; - nlg = *nlgr; - ncg = *ncgr; - nh = *nhab; - nl = nlg*ncg; - - taballoc(&carte, nlg, ncg); - taballoc(&kasc, nl, nh); - - k=0; - for (i=1; i<=nl; i++) { - for (j=1; j<=nh; j++) { - kasc[i][j] = kascr[k]; - k++; + /* Declaration of local variables */ + int i,j,k, nlg, ncg, nh, nl; + double **carte, **kasc; + nlg = *nlgr; + ncg = *ncgr; + nh = *nhab; + nl = nlg*ncg; + + /* Memory allocation */ + taballoc(&carte, nlg, ncg); + taballoc(&kasc, nl, nh); + + /* Copy from R -> C variables */ + k=0; + for (i=1; i<=nl; i++) { + for (j=1; j<=nh; j++) { + kasc[i][j] = kascr[k]; + k++; + } } - } - - i=1; - getcarte(carte, kasc, &i); - - k=0; - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - carter[k] = carte[i][j]; - k++; + + /* Use of getcarte */ + i=1; + getcarte(carte, kasc, &i); + + /* Copy from C -> R variables */ + k=0; + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + carter[k] = carte[i][j]; + k++; + } } - } - - - freetab(carte); - freetab(kasc); - + + /* Free memory */ + freetab(carte); + freetab(kasc); + } /* **************************************************************** * * - * comptepasNA compte le nombre de lignes d'un tableau pas NA * - * * + * comptepasNA counts the number of rows of a table which do * + * contain missing values * * * **************************************************************** */ void comptePasNA(double **tab, int *nombre) { - int i,nb, nc,nl; - nb = 0; - nc = tab[1][0]; - nl = tab[0][0]; - - for (i=1; i<=nl; i++) { - if (fabs(tab[i][1] + 9999) > 0.000000001) { - nb++; + int i,nb, nc,nl; + nb = 0; + nc = tab[1][0]; + nl = tab[0][0]; + + for (i=1; i<=nl; i++) { + if (fabs(tab[i][1] + 9999) > 0.000000001) { + nb++; + } } - } - - *nombre = nb; + + *nombre = nb; } /* **************************************************************** * * - * videNA supprime les lignes NA d'un tableau * - * * + * videNA deletes the rows with missing values in a table * + * (equivalent with kasc2df of R) * * * **************************************************************** */ void videNA(double **entree, double **sortie, int *idcons) { - /* Déclaration des variables */ - int i,j,k, nc, nl; - - nl = entree[0][0]; - nc = entree[1][0]; - - k=1; - for (i=1; i<=nl; i++) { - if (fabs(entree[i][1] + 9999) > 0.000000001) { - idcons[k] = i; - for (j=1; j<=nc; j++) { - sortie[k][j] = entree[i][j]; - } - k++; + /* Declaration of local variables */ + int i,j,k, nc, nl; + nl = entree[0][0]; + nc = entree[1][0]; + + /* Computation */ + k=1; + for (i=1; i<=nl; i++) { + if (fabs(entree[i][1] + 9999) > 0.000000001) { + idcons[k] = i; + for (j=1; j<=nc; j++) { + sortie[k][j] = entree[i][j]; + } + k++; + } } - } } @@ -2222,95 +2347,95 @@ void videNA(double **entree, double **sortie, int *idcons) /* **************************************************************** * * - * niche pour appliquer l'analyse de niche * + * niche to apply OMI analysis * * * **************************************************************** */ void niche(double **X, double **Y, double *eig, double **mar) { - /* Déclaration de variables */ - int i, j, k, nl, nh, na, rang; - double **ut, **dis, *poidsli, *poidsani, solo, *ni, **inertie; - - /* Allocation de mémoire */ - nh = X[1][0]; - na = Y[1][0]; - nl = Y[0][0]; - - taballoc(&ut, na, nh); - taballoc(&dis, na, nh); - taballoc(&inertie, nh, nh); - vecalloc(&ni, na); - vecalloc(&poidsli, nl); - vecalloc(&poidsani, na); - - /* Centrage et réduction */ - for (i=1; i<=nl; i++) { - poidsli[i] = (double) 1/nl; - } - matmodifcn(X, poidsli); - - /* calcul du nombre de locs par animal */ - for (i=1; i<=nl; i++) { - for (j=1; j<=na; j++) { - ni[j] = ni[j] + Y[i][j]; + /* Declaration of local variables */ + int i, j, k, nl, nh, na, rang; + double **ut, **dis, *poidsli, *poidsani, solo, *ni, **inertie; + + /* Memory Allocation */ + nh = X[1][0]; + na = Y[1][0]; + nl = Y[0][0]; + + taballoc(&ut, na, nh); + taballoc(&dis, na, nh); + taballoc(&inertie, nh, nh); + vecalloc(&ni, na); + vecalloc(&poidsli, nl); + vecalloc(&poidsani, na); + + /* Centring and reduction */ + for (i=1; i<=nl; i++) { + poidsli[i] = (double) 1/nl; } - } - - /* Calcul de poidsani */ - solo = 0; - for (j=1; j<=na; j++) { - solo = ni[j] + solo; /* somme des locs */ - } - for (j=1; j<=na; j++) { - poidsani[j] = ni[j] / solo; - } - - - - /* Calcul de la moyenne utilisée et dispo */ - for (k=1; k<=na; k++) { + matmodifcn(X, poidsli); + + /* Numbering of the relocations per animal */ for (i=1; i<=nl; i++) { - for (j=1; j<=nh; j++) { - dis[k][j] = dis[k][j] + ((double) X[i][j]/nl); - ut[k][j] = ut[k][j] + (X[i][j]*Y[i][k]/ni[k]); - } + for (j=1; j<=na; j++) { + ni[j] = ni[j] + Y[i][j]; + } } - } - - /* Calcul de la marginalité */ - for (i=1; i<=na; i++) { - for (j=1; j<=nh; j++) { - mar[i][j] = ut[i][j] - dis[i][j]; + + /* Computation of poidsani */ + solo = 0; + for (j=1; j<=na; j++) { + solo = ni[j] + solo; /* sums of the locs */ } - } - - - /* Calcul de l'inertie */ - sqrvec(poidsani); - for (i=1; i<=na; i++) { - for (j=1; j<=nh; j++) { - mar[i][j] = mar[i][j] * poidsani[i]; + for (j=1; j<=na; j++) { + poidsani[j] = ni[j] / solo; } - } - - prodmatAtAB(mar, inertie); - DiagobgComp(nh, inertie, eig, &rang); + - /* Pour les sorties: la marginalité */ - for (i=1; i<=na; i++) { - for (j=1; j<=nh; j++) { - mar[i][j] = mar[i][j] / poidsani[i]; + /* mean of use and availability */ + for (k=1; k<=na; k++) { + for (i=1; i<=nl; i++) { + for (j=1; j<=nh; j++) { + dis[k][j] = dis[k][j] + ((double) X[i][j]/nl); + ut[k][j] = ut[k][j] + (X[i][j]*Y[i][k]/ni[k]); + } + } } - } - - - /* libé de mémoire */ - freetab(ut); - freetab(dis); - freetab(inertie); - freevec(poidsli); - freevec(poidsani); + + /* Marginality */ + for (i=1; i<=na; i++) { + for (j=1; j<=nh; j++) { + mar[i][j] = ut[i][j] - dis[i][j]; + } + } + + + /* Computation of the inertia */ + sqrvec(poidsani); + for (i=1; i<=na; i++) { + for (j=1; j<=nh; j++) { + mar[i][j] = mar[i][j] * poidsani[i]; + } + } + + /* eigenstructure */ + prodmatAtAB(mar, inertie); + DiagobgComp(nh, inertie, eig, &rang); + + /* Marginality for the output */ + for (i=1; i<=na; i++) { + for (j=1; j<=nh; j++) { + mar[i][j] = mar[i][j] / poidsani[i]; + } + } + + + /* Free Memory */ + freetab(ut); + freetab(dis); + freetab(inertie); + freevec(poidsli); + freevec(poidsani); } @@ -2320,38 +2445,37 @@ void niche(double **X, double **Y, double *eig, double **mar) /* **************************************************************** * * - * mvtfreeman: on rentre indice ligne et indice colonne départ * - * (in et jn), la direction de freeman (dir), et on récupère * - * les indices lignes et colonnes (dans le vecteur np) après * - * mouvement. * + * mvtfreeman: arguments = indices of the rows and columns * + * (in et jn), of the freeman direction (dir), and we get * + * the indices of rows and columns (in the vector np) after the * + * move. * * * **************************************************************** */ - void mvtfreeman(int *in, int *jn, int *dir, int *np) { - int i,j; - i=*in; - j=*jn; - - if ((*dir == 0) | (*dir == 1) | (*dir == 7)) - i++; - if ((*dir == 3) | (*dir == 4) | (*dir == 5)) - i--; - if ((*dir == 1) | (*dir == 2) | (*dir == 3)) - j++; - if ((*dir == 5) | (*dir == 6) | (*dir == 7)) - j--; - - np[1]=i; - np[2]=j; + int i,j; + i=*in; + j=*jn; + + if ((*dir == 0) | (*dir == 1) | (*dir == 7)) + i++; + if ((*dir == 3) | (*dir == 4) | (*dir == 5)) + i--; + if ((*dir == 1) | (*dir == 2) | (*dir == 3)) + j++; + if ((*dir == 5) | (*dir == 6) | (*dir == 7)) + j--; + + np[1]=i; + np[2]=j; } /* **************************************************************** * * - * algorithme de suivi de contour pour récupe des coordonnées du* - * polygone de contour * + * algorithm of contour monitoring (suivi de contour) to get * + * contour polygon * * * **************************************************************** */ @@ -2359,383 +2483,383 @@ void mvtfreeman(int *in, int *jn, int *dir, int *np) void getcontour(double *grille, int *nlig, int *ncol, int *indicelig, int *indicecol, int *lcont) { - /* Déclaration des variables*/ - int i, j, k, nl, nc, *idlig, *idcol, *P0, *P1, fini, *np, dirprec, dir; - int lidlig; - double **x; - - nl=*nlig; - nc=*ncol; - vecintalloc(&P0,2); - vecintalloc(&P1,2); - vecintalloc(&np,2); - taballoc(&x, nl,nc); - vecintalloc(&idlig, *lcont); - vecintalloc(&idcol, *lcont); - - - k=0; - for (i=1; i<=nl; i++) { - for(j=1; j<=nc; j++) { - x[i][j] = grille[k]; - k++; - } - } - - - /* recherche des indices lignes et colonnes - du premiere cellule pas na */ - k=0; - i=0; - j=1; - - - while (k==0) { - if (i != nl) { - i++; - } - else { - i=1; - j++; + /* Declaration of local variables */ + int i, j, k, nl, nc, *idlig, *idcol, *P0, *P1, fini, *np, dirprec, dir; + int lidlig; + double **x; + + /* Memory allocation */ + nl=*nlig; + nc=*ncol; + vecintalloc(&P0,2); + vecintalloc(&P1,2); + vecintalloc(&np,2); + taballoc(&x, nl,nc); + vecintalloc(&idlig, *lcont); + vecintalloc(&idcol, *lcont); + + /* Copy from R -> C variables */ + k=0; + for (i=1; i<=nl; i++) { + for(j=1; j<=nc; j++) { + x[i][j] = grille[k]; + k++; + } } - k = (int) x[i][j]; - } - - - idlig[1] = i; - idcol[1] = j; - lidlig = 1; - P0[1] = i; - P0[2] = j; - dir = 4; - - fini = 0; - k = 0; - - while (fini==0) { + + /* Search the indices of the rows and columns + of the first cell with a non-missing value */ + k=0; + i=0; + j=1; + while (k==0) { - dir = (dir + 1)%8; - mvtfreeman(&i, &j, &dir, np); - dirprec = (dir + 5)%8; - k = (int) x[np[1]][np[2]]; - } - if (lidlig == 1) { - P1[1] = np[1]; - P1[2] = np[2]; - } - else { - if ((i==P0[1])&&(j==P0[2])&&(np[1]==P1[1])&&(np[2]==P1[2])) - fini =1; - } - - if (fini==0) { - lidlig++; - idlig[lidlig] = np[1]; - idcol[lidlig] = np[2]; - i = np[1]; - j = np[2]; - mvtfreeman(&i, &j, &dirprec, np); - k = (int) x[np[1]][np[2]]; - dir = dirprec; + if (i != nl) { + i++; + } + else { + i=1; + j++; + } + k = (int) x[i][j]; } - } - - - - for (i=1; i<=lidlig; i++) { - indicelig[i-1]=idlig[i]; - indicecol[i-1]=idcol[i]; - } - + + /* When it is found, the algorithm begins */ + idlig[1] = i; + idcol[1] = j; + lidlig = 1; + P0[1] = i; + P0[2] = j; + dir = 4; + + fini = 0; + k = 0; - freeintvec(idlig); - freeintvec(idcol); - freeintvec(P0); - freeintvec(P1); - freeintvec(np); - freetab(x); + while (fini==0) { + + /* finds the next direction */ + while (k==0) { + dir = (dir + 1)%8; + mvtfreeman(&i, &j, &dir, np); + dirprec = (dir + 5)%8; + k = (int) x[np[1]][np[2]]; + } + /* once found, stores the new coordinate */ + if (lidlig == 1) { + P1[1] = np[1]; + P1[2] = np[2]; + } + else { + /* P0 is the first point of the contour and P1, the last + Is the contour closed? */ + if ((i==P0[1])&&(j==P0[2])&&(np[1]==P1[1])&&(np[2]==P1[2])) + fini =1; + } + + /* If it is not, then stores the result, and perform the move + in the found direction */ + if (fini==0) { + lidlig++; + idlig[lidlig] = np[1]; + idcol[lidlig] = np[2]; + i = np[1]; + j = np[2]; + mvtfreeman(&i, &j, &dirprec, np); + k = (int) x[np[1]][np[2]]; + dir = dirprec; + } + } + + /* Copy from C -> R variables */ + for (i=1; i<=lidlig; i++) { + indicelig[i-1]=idlig[i]; + indicecol[i-1]=idcol[i]; + } + + /* Free Memory */ + freeintvec(idlig); + freeintvec(idcol); + freeintvec(P0); + freeintvec(P1); + freeintvec(np); + freetab(x); } /* **************************************************************** * * - * algorithme de suivi de contour pour récupe des coordonnées du* - * polygone de contour: calcul du nombre de points de ce * - * polygone. * + * Interactive version of getcontour for R * * * **************************************************************** */ void lcontour(double *grille, int *nlig, int *ncol, int *lcont) { - /* Déclaration des variables*/ - int i, j, k, l, m,n, nl, nc, *P0, *P1, fini, *np, dirprec, dir; - int lidlig; - double **x, **vois; - - nl=*nlig; - nc=*ncol; - vecintalloc(&P0,2); - vecintalloc(&P1,2); - vecintalloc(&np,2); - taballoc(&vois, 3,3); - taballoc(&x, nl,nc); - - - k=0; - for (i=1; i<=nl; i++) { - for(j=1; j<=nc; j++) { - x[i][j] = grille[k]; - k++; - } - } - - - /* recherche des indices lignes et colonnes - du premiere cellule pas na */ - k=0; - i=0; - j=1; - - - while (k==0) { - if (i != nl) { - i++; - } - else { - i=1; - j++; - } - k = (int) x[i][j]; - } - - - lidlig = 1; - P0[1] = i; - P0[2] = j; - dir = 4; - - m=1; - n=1; - l=1; - - /* ca c'est juste au cas ou un seul pixel sur la carte */ - /* m=1; - - for (k=i-1; k<=i+1; k++) { - n=1; - for (l=j-1; l<=j+1; l++) { - vois[m][n] = x[k][l]; - n++; + /* Declaration of local variables*/ + int i, j, k, l, m,n, nl, nc, *P0, *P1, fini, *np, dirprec, dir; + int lidlig; + double **x, **vois; + + /* Memory allocation */ + nl=*nlig; + nc=*ncol; + vecintalloc(&P0,2); + vecintalloc(&P1,2); + vecintalloc(&np,2); + taballoc(&vois, 3,3); + taballoc(&x, nl,nc); + + /* R objects -> C objects */ + k=0; + for (i=1; i<=nl; i++) { + for(j=1; j<=nc; j++) { + x[i][j] = grille[k]; + k++; + } } - m++; - } - - vois[2][2] = 0; - */ - fini = 0; - k = 0; - - while (fini==0) { + + + /* Search of the first cell for which the value is not NA */ + k=0; + i=0; + j=1; + while (k==0) { - dir = (dir + 1)%8; - mvtfreeman(&i, &j, &dir, np); - dirprec = (dir + 5)%8; - k = (int) x[np[1]][np[2]]; - } - if (lidlig == 1) { - P1[1] = np[1]; - P1[2] = np[2]; - } - else { - if ((i==P0[1])&&(j==P0[2])&&(np[1]==P1[1])&&(np[2]==P1[2])) - fini = 1; + if (i != nl) { + i++; + } + else { + i=1; + j++; + } + k = (int) x[i][j]; } - if (fini==0) { - lidlig++; - i = np[1]; - j = np[2]; - mvtfreeman(&i, &j, &dirprec, np); - k = (int) x[np[1]][np[2]]; - dir = dirprec; + + /* When found, performs the algorithm */ + lidlig = 1; + P0[1] = i; + P0[2] = j; + dir = 4; + + m=1; + n=1; + l=1; + + fini = 0; + k = 0; + + /* Same algorithm as in the previous function */ + + while (fini==0) { + while (k==0) { + dir = (dir + 1)%8; + mvtfreeman(&i, &j, &dir, np); + dirprec = (dir + 5)%8; + k = (int) x[np[1]][np[2]]; + } + if (lidlig == 1) { + P1[1] = np[1]; + P1[2] = np[2]; + } + else { + if ((i==P0[1])&&(j==P0[2])&&(np[1]==P1[1])&&(np[2]==P1[2])) + fini = 1; + } + + if (fini==0) { + lidlig++; + i = np[1]; + j = np[2]; + mvtfreeman(&i, &j, &dirprec, np); + k = (int) x[np[1]][np[2]]; + dir = dirprec; + } } - } - - - *lcont = lidlig; - freeintvec(P0); - freeintvec(P1); - freeintvec(np); - freetab(vois); - freetab(x); + + /* and return to R */ + *lcont = lidlig; + + /* Free Memory */ + freeintvec(P0); + freeintvec(P1); + freeintvec(np); + freetab(vois); + freetab(x); } + + /* **************************************************************** * * - * récupération des niveaux d'un facteur * - * * + * Gets the levels of a factor * * * **************************************************************** */ void levels(double *vec, double *lev, int *lvec) { - int i,j,k,n, l; - lev[1] = vec[1]; - k=1; - n=*lvec; - - for (i=2; i<=n; i++) { - l=0; - for (j=1; j<=k; j++) { - if (fabs(vec[i] - lev[j]) < 0.000000001) - l=1; - } - if (l==0) { - k++; - lev[k] = vec[i]; + /* Declaration of local variables */ + int i,j,k,n, l; + lev[1] = vec[1]; + k=1; + n=*lvec; + + /* gets the levels */ + for (i=2; i<=n; i++) { + l=0; + for (j=1; j<=k; j++) { + if (fabs(vec[i] - lev[j]) < 0.000000001) + l=1; + } + if (l==0) { + k++; + lev[k] = vec[i]; + } } - } - *lvec = k; + *lvec = k; } /* **************************************************************** * * - * algorithme d'étiquetage séquentiel des composantes connexes * + * Sequential labelling of connex components * * * **************************************************************** */ void seqeticorr(double *grille, int *nlig, int *ncol) - { +{ + /* Declaration of local variables */ int i, j, k, l, m, n, o, nl, nc, pr, beta, nniv, eticour; double **x, *Tc, *prec, *tmp, *tmp1, *tmp2, *etcons, *lf; + /* Memory allocation */ nl=*nlig; nc=*ncol; taballoc(&x, nl, nc); vecalloc(&Tc, nl*nc); + /* R objects -> C objects */ k=0; for (i=1; i<=nl; i++) { - for (j=1; j<=nc; j++) { - x[i][j]=grille[k]; - k++; - } + for (j=1; j<=nc; j++) { + x[i][j]=grille[k]; + k++; + } } Tc[1]=1; eticour=1; for (j=2; j<=nc; j++) { - for (i=2; i<=nl; i++) { - if (((int) x[i][j])!=0) { - vecalloc(&prec, 4); - prec[1] = x[i-1][j-1]; - prec[2] = x[i][j-1]; - prec[3] = x[i+1][j-1]; - prec[4] = x[i-1][j]; - - k=0; - for (l=1; l<=4; l++) { - if (((int) prec[l])!=0) - k++; - } - - /* k contient le nombre de prédecesseurs non nuls */ - if (k!=0) { - vecalloc(&tmp, k); /* tmp contient les pred non nuls */ - m=1; - for (l=1; l<=4; l++) { - if (((int) prec[l])>0) { - tmp[m] = prec[l]; - m++; - } - } - - freevec(prec); - vecalloc(&prec, k); - for (l=1; l<=k; l++) - prec[l] = tmp[l]; - freevec(tmp); - /* Maintenant, c'est prec qui contient les pred non nuls */ - - - - /* Nombre de niveaux du facteur prec */ - vecalloc(&tmp1, 4); - m=k; - levels(prec, tmp1, &m); - /* m contient le nombre de niveaux */ - vecalloc(&tmp2, m); - /* tmp2 contient les niveaux de prec - equivalent de etiprec dans R */ - for (l=1; l<=m; l++) - tmp2[l]=tmp1[l]; - freevec(tmp1); - - if (m == 1) { - x[i][j] = tmp2[1]; - } else { - /* calcul du niveau minimum et stockage dans xij */ - x[i][j] = tmp2[1]; - for (l = 1; l <= m; l++) { - if (tmp2[l] 0.000000001) { - etcons[n] = tmp2[l]; - n++; + for (i=2; i<=nl; i++) { + if (((int) x[i][j])!=0) { + vecalloc(&prec, 4); + prec[1] = x[i-1][j-1]; + prec[2] = x[i][j-1]; + prec[3] = x[i+1][j-1]; + prec[4] = x[i-1][j]; + + k=0; + for (l=1; l<=4; l++) { + if (((int) prec[l])!=0) + k++; } - } - - /* boucle de remplissage de la table des correspondances */ - for (l=1; l<=(m-1); l++) { - pr = (int) etcons[l]; - beta = pr; - while (((int) Tc[beta])!=beta) { - o = (int) Tc[beta]; - Tc[beta] = Tc[(int) x[i][j]]; - beta = o; + + /* k contains the number of non null predecessors */ + if (k!=0) { + vecalloc(&tmp, k); /* tmp contains the non null pred */ + m=1; + for (l=1; l<=4; l++) { + if (((int) prec[l])>0) { + tmp[m] = prec[l]; + m++; + } + } + + freevec(prec); + vecalloc(&prec, k); + for (l=1; l<=k; l++) + prec[l] = tmp[l]; + freevec(tmp); + /* Now, prec contains the non null preds */ + + + + /* Number of levels of the factor prec */ + vecalloc(&tmp1, 4); + m=k; + levels(prec, tmp1, &m); + /* m contains the number of levels */ + vecalloc(&tmp2, m); + /* tmp2 contains the levels of prec + (equivalent of etiprec in R) */ + for (l=1; l<=m; l++) + tmp2[l]=tmp1[l]; + freevec(tmp1); + + if (m == 1) { + x[i][j] = tmp2[1]; + } else { + /* computation of the minimum + level and storage in xij */ + x[i][j] = tmp2[1]; + for (l = 1; l <= m; l++) { + if (tmp2[l] 0.000000001) { + etcons[n] = tmp2[l]; + n++; + } + } + + /* loop to fill the correspondence table */ + for (l=1; l<=(m-1); l++) { + pr = (int) etcons[l]; + beta = pr; + while (((int) Tc[beta])!=beta) { + o = (int) Tc[beta]; + Tc[beta] = Tc[(int) x[i][j]]; + beta = o; + } + Tc[beta] = Tc[(int) x[i][j]]; + } + freevec(prec); + freevec(tmp2); + freevec(etcons); + } + } else { + Tc[eticour] = eticour; + x[i][j]= eticour; + eticour++; } - Tc[beta] = Tc[(int) x[i][j]]; - } - freevec(prec); - freevec(tmp2); - freevec(etcons); } - } else { - Tc[eticour] = eticour; - x[i][j]= eticour; - eticour++; - } - } - } + } } - + eticour--; - /* Actualisation de la table */ + /* Actualisation of the correspondence table */ for (i=1; i<=eticour; i++) { - j = i; - while (((int) Tc[j])!=j) - j = (int) Tc[j]; - Tc[i] = j; + j = i; + while (((int) Tc[j])!=j) + j = (int) Tc[j]; + Tc[i] = j; } j=eticour; vecalloc(&tmp1, j); vecalloc(&tmp2, eticour); for (i=1; i<=eticour; i++) { - tmp2[i]=Tc[i]; + tmp2[i]=Tc[i]; } levels(tmp2, tmp1, &j); @@ -2743,20 +2867,20 @@ void seqeticorr(double *grille, int *nlig, int *ncol) vecalloc(&lf, j); for (i=1; i<=j; i++) - lf[i]=tmp1[i]; + lf[i]=tmp1[i]; freevec(tmp1); nniv=j; - /* Deuxième passage */ + /* Second pass */ for (i=1; i<=nl; i++) { - for (j=1; j<=nc; j++) { - if (fabs(x[i][j]) > 0.000000001) { - x[i][j] = Tc[(int) x[i][j]]; + for (j=1; j<=nc; j++) { + if (fabs(x[i][j]) > 0.000000001) { + x[i][j] = Tc[(int) x[i][j]]; + } } - } } - /* Dernier passage: niveaux variant de 1 à p */ + /* Last pass: levels varying from 1 to p */ k = 1; for (j=1; j<=nniv; j++) { i = (int) lf[j]; @@ -2771,7 +2895,7 @@ void seqeticorr(double *grille, int *nlig, int *ncol) k++; } - /* grille */ + /* grid */ k=0; for (i=1; i<=nl; i++) { for (j=1; j<=nc; j++) { @@ -2796,24 +2920,27 @@ void seqeticorr(double *grille, int *nlig, int *ncol) void epa(double *X, double *Y, double *xl, double *yl, double *val, double *fen) { - int k,nl; - double *xy, kx, di2, h; - - nl = (int) xl[0]; - vecalloc(&xy, 2); - *val = 0; - h = *fen; - kx = 0; - - for (k=1; k<=nl; k++) { - xy[1] = (xl[k] - *X); - xy[2] = (yl[k] - *Y); - di2 = xy[1]*xy[1] + xy[2]*xy[2]; - kx = exp(-di2/(2*h*h)); - *val = *val + kx; - } - *val = *val * (1/(((double) nl)*h*h*2*3.14159265359)); - freevec(xy); + /* Declaration of local variables */ + int k,nl; + double *xy, kx, di2, h; + + /* Bases */ + nl = (int) xl[0]; + vecalloc(&xy, 2); + *val = 0; + h = *fen; + kx = 0; + + /* The bivariate normal kernel */ + for (k=1; k<=nl; k++) { + xy[1] = (xl[k] - *X); + xy[2] = (yl[k] - *Y); + di2 = xy[1]*xy[1] + xy[2]*xy[2]; + kx = exp(-di2/(2*h*h)); + *val = *val + kx; + } + *val = *val * (1/(((double) nl)*h*h*2*3.14159265359)); + freevec(xy); } @@ -2821,7 +2948,7 @@ void epa(double *X, double *Y, double *xl, double *yl, /* **************************************************************** * * - * estimation du DV par kernel * + * Kernel home range * * * **************************************************************** */ @@ -2829,61 +2956,62 @@ void epa(double *X, double *Y, double *xl, double *yl, void kernelhr(double *grille, double *xgri, double *ygri, int *ncolgri, int *nliggri, int *nloc, double *fen, double *xlo, double *ylo) { - int i, j, k, ncg, nlg, nlo; - double **gri, *xg, *yg, *xl, *yl, X, Y, tmp; - - /* Allocation de mémoire */ - ncg = *ncolgri; - nlg = *nliggri; - nlo = *nloc; - tmp = 0; - - taballoc(&gri,nlg, ncg); - vecalloc(&xg, nlg); - vecalloc(&yg, ncg); - vecalloc(&xl, nlo); - vecalloc(&yl, nlo); - - /* passage de valeur aux variables C */ - - for (i=1; i<=nlo; i++) { - xl[i] = xlo[i-1]; - yl[i] = ylo[i-1]; - } - - for (i=1; i<=nlg; i++) { - xg[i] = xgri[i-1]; - } - - for (i=1; i<=ncg; i++) { - yg[i] = ygri[i-1]; - } + /* Declaration of local variables */ + int i, j, k, ncg, nlg, nlo; + double **gri, *xg, *yg, *xl, *yl, X, Y, tmp; + + /* Memory Allocation */ + ncg = *ncolgri; + nlg = *nliggri; + nlo = *nloc; + tmp = 0; + + taballoc(&gri,nlg, ncg); + vecalloc(&xg, nlg); + vecalloc(&yg, ncg); + vecalloc(&xl, nlo); + vecalloc(&yl, nlo); + + /* R objects -> C objects */ - /* boucle de calcul sur la grille */ - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - X = xg[i]; - Y = yg[j]; - epa(&X, &Y, xl, yl, &tmp, fen); - gri[i][j] = tmp; + for (i=1; i<=nlo; i++) { + xl[i] = xlo[i-1]; + yl[i] = ylo[i-1]; } - } - - /* retour vers R */ - k = 0; - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - grille[k] = gri[i][j]; - k++; + + for (i=1; i<=nlg; i++) { + xg[i] = xgri[i-1]; + } + + for (i=1; i<=ncg; i++) { + yg[i] = ygri[i-1]; + } + + /* loop on the grid */ + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + X = xg[i]; + Y = yg[j]; + epa(&X, &Y, xl, yl, &tmp, fen); + gri[i][j] = tmp; + } + } + + /* C objects -> R objects */ + k = 0; + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + grille[k] = gri[i][j]; + k++; + } } - } - /* libération de la mémoire */ - freetab(gri); - freevec(xg); - freevec(yg); - freevec(xl); - freevec(yl); + /* Memory Free */ + freetab(gri); + freevec(xg); + freevec(yg); + freevec(xl); + freevec(yl); } @@ -2891,136 +3019,138 @@ void kernelhr(double *grille, double *xgri, double *ygri, int *ncolgri, /* **************************************************************** * * - * estimation du DV par kernel * + * Epanechnikov estimation thanks to a kernel * * * **************************************************************** */ void epanechnikov(double *Xo, double *Yo, double *xg, double *yg, double *fen, double **grille, int nlo) { - int i, j, ncg, nlg, imin, imax, jmin, jmax; - double X, Y, h, *xgb, *ygb, tmp; - - /* Déclaration des variables locales */ - nlg = xg[0]; - ncg = yg[0]; - h = *fen; - X = *Xo; - Y = *Yo; - vecalloc(&xgb, nlg); - vecalloc(&ygb, ncg); - imin=0; - jmin=0; - imax=0; - jmax=0; - - /* recalcul des valeurs de xg et yg */ - for (i=1; i<=nlg; i++) { - xgb[i] = abs(xg[i]-X); - if (xgb[i] < h) { - if (imin == 0) { - imin = i; - } - } - if (xgb[i] > h) { - if (imin != 0) { - imax = i; - } - } - } - for (i=1; i<=ncg; i++) { - ygb[i] = abs(yg[i]-Y); - if (ygb[i] < h) { - if (jmin == 0) { - jmin = i; - } + /* Declaration of local variables */ + + int i, j, ncg, nlg, imin, imax, jmin, jmax; + double X, Y, h, *xgb, *ygb, tmp; + + nlg = xg[0]; + ncg = yg[0]; + h = *fen; + X = *Xo; + Y = *Yo; + vecalloc(&xgb, nlg); + vecalloc(&ygb, ncg); + imin=0; + jmin=0; + imax=0; + jmax=0; + + /* Computes again the values xg and yg */ + for (i=1; i<=nlg; i++) { + xgb[i] = abs(xg[i]-X); + if (xgb[i] < h) { + if (imin == 0) { + imin = i; + } + } + if (xgb[i] > h) { + if (imin != 0) { + imax = i; + } + } } - if (ygb[i] > h) { - if (jmin != 0) { - jmax = i; - } + for (i=1; i<=ncg; i++) { + ygb[i] = abs(yg[i]-Y); + if (ygb[i] < h) { + if (jmin == 0) { + jmin = i; + } + } + if (ygb[i] > h) { + if (jmin != 0) { + jmax = i; + } + } } - } - - for (i=imin; i<=imax; i++) { - for (j=jmin; j<=jmax; j++) { - tmp = ( (xgb[i] / h) * (xgb[i] / h) ) + ( (ygb[j] / h) * (ygb[j] / h) ); - if (tmp < 1) { - grille[i][j] = grille[i][j] + - 2 * (1 - tmp) / (3.14159265359 * nlo * h * h); - } + + for (i=imin; i<=imax; i++) { + for (j=jmin; j<=jmax; j++) { + tmp = ( (xgb[i] / h) * (xgb[i] / h) ) + ( (ygb[j] / h) * (ygb[j] / h) ); + if (tmp < 1) { + grille[i][j] = grille[i][j] + + 2 * (1 - tmp) / (3.14159265359 * nlo * h * h); + } + } } - } - - freevec(xgb); - freevec(ygb); + + freevec(xgb); + freevec(ygb); } - +/* For R */ void kernepan(double *grille, double *xgri, double *ygri, int *ncolgri, int *nliggri, int *nloc, double *fen, double *xlo, double *ylo) { - int i, j, k, ncg, nlg, nlo; - double **gri, *xg, *yg, *xl, *yl, X, Y, tmp; - - /* Allocation de mémoire */ - ncg = *ncolgri; - nlg = *nliggri; - nlo = *nloc; - tmp = 0; - - taballoc(&gri,nlg, ncg); - vecalloc(&xg, nlg); - vecalloc(&yg, ncg); - vecalloc(&xl, nlo); - vecalloc(&yl, nlo); - - /* passage de valeur aux variables C */ - - for (i=1; i<=nlo; i++) { - xl[i] = xlo[i-1]; - yl[i] = ylo[i-1]; - } - - for (i=1; i<=nlg; i++) { - xg[i] = xgri[i-1]; - } - - for (i=1; i<=ncg; i++) { - yg[i] = ygri[i-1]; - } - - /* boucle de calcul sur les locs */ - for (i=1; i<=nlo; i++) { - X = xl[i]; - Y = yl[i]; - epanechnikov(&X, &Y, xg, yg, fen, gri, nlo); - } + /* Declaration */ + int i, j, k, ncg, nlg, nlo; + double **gri, *xg, *yg, *xl, *yl, X, Y, tmp; + + /* Memory Allocation */ + ncg = *ncolgri; + nlg = *nliggri; + nlo = *nloc; + tmp = 0; + + taballoc(&gri,nlg, ncg); + vecalloc(&xg, nlg); + vecalloc(&yg, ncg); + vecalloc(&xl, nlo); + vecalloc(&yl, nlo); - /* retour vers R */ - k = 0; - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - grille[k] = gri[i][j]; - k++; + /* R to C */ + + for (i=1; i<=nlo; i++) { + xl[i] = xlo[i-1]; + yl[i] = ylo[i-1]; } - } - - /* libération de la mémoire */ - freetab(gri); - freevec(xg); - freevec(yg); - freevec(xl); - freevec(yl); -} + + for (i=1; i<=nlg; i++) { + xg[i] = xgri[i-1]; + } + + for (i=1; i<=ncg; i++) { + yg[i] = ygri[i-1]; + } + + /* Loop on the relocations */ + for (i=1; i<=nlo; i++) { + X = xl[i]; + Y = yl[i]; + epanechnikov(&X, &Y, xg, yg, fen, gri, nlo); + } + + /* C to R */ + k = 0; + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + grille[k] = gri[i][j]; + k++; + } + } + + /* Free memory */ + freetab(gri); + freevec(xg); + freevec(yg); + freevec(xl); + freevec(yl); +} /* **************************************************************** * * - * Minimisation de la LSCV * + * Find Minimum LSCV * * * **************************************************************** */ @@ -3028,40 +3158,43 @@ void kernepan(double *grille, double *xgri, double *ygri, int *ncolgri, void CVmise(int *nloc, double *xlo, double *ylo, double *hvec, double *CV, int *nhteste) { - int i, j, k, nlo, nh; - double *xl, *yl, h, di2; - - /* Allocation de mémoire */ - nlo = *nloc; - nh = *nhteste; + /* Declaration */ + int i, j, k, nlo, nh; + double *xl, *yl, h, di2; - vecalloc(&xl, nlo); - vecalloc(&yl, nlo); - - /* passage de valeur aux variables C */ - - for (i=1; i<=nlo; i++) { - xl[i] = xlo[i-1]; - yl[i] = ylo[i-1]; - } - - /* boucle de calcul de la fenetre */ - for (k=1; k<=nh; k++) { - h = hvec[k-1]; - CV[k-1] = 0; + /* Allocation de mémoire */ + nlo = *nloc; + nh = *nhteste; + + vecalloc(&xl, nlo); + vecalloc(&yl, nlo); + + /* R to C */ for (i=1; i<=nlo; i++) { - for (j=1; j<=nlo; j++) { - di2 = (xl[i]-xl[j])*(xl[i]-xl[j]) + (yl[i]-yl[j])*(yl[i]-yl[j]); - CV[k-1] = CV[k-1] + (exp(-(di2/(4*h*h)))-4*exp(-di2/(2*h*h))); - } + xl[i] = xlo[i-1]; + yl[i] = ylo[i-1]; } - CV[k-1] = CV[k-1]*(1/(4*3.14159265359*h*h*((double) nlo)*((double) nlo))); - CV[k-1] = CV[k-1] + (1/(3.14159265359*h*h*nlo)); - } - freevec(xl); - freevec(yl); + /* Loop on the window of h */ + for (k=1; k<=nh; k++) { + h = hvec[k-1]; + CV[k-1] = 0; + + for (i=1; i<=nlo; i++) { + for (j=1; j<=nlo; j++) { + di2 = (xl[i]-xl[j])*(xl[i]-xl[j]) + (yl[i]-yl[j])*(yl[i]-yl[j]); + CV[k-1] = CV[k-1] + (exp(-(di2/(4*h*h)))-4*exp(-di2/(2*h*h))); + } + } + CV[k-1] = CV[k-1]*(1/(4*3.14159265359*h*h*((double) nlo)*((double) nlo))); + CV[k-1] = CV[k-1] + (1/(3.14159265359*h*h*nlo)); + + } + + /* Free Memory */ + freevec(xl); + freevec(yl); } @@ -3070,51 +3203,51 @@ void CVmise(int *nloc, double *xlo, double *ylo, /* **************************************************************** * * - * Calcul du volume sous l'UD * + * Computation of the volume under the UD * * * **************************************************************** */ void calcvolume(double *grille, int *ncolgri, int *nliggri, double *cellsize) { - int i, j, k, nl, nc; - double cs, **gri; + /* Declaration */ + int i, j, k, nl, nc; + double cs, **gri; - /* Allocation de mémoire */ - nl = *nliggri; - nc = *ncolgri; - cs = *cellsize; - - taballoc(&gri, nl, nc); - - /* copie de la grille */ - k = 0; - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - gri[i][j] = grille[k]; - k++; + /* Memory Allocation */ + nl = *nliggri; + nc = *ncolgri; + cs = *cellsize; + + taballoc(&gri, nl, nc); + + /* R to C */ + k = 0; + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + gri[i][j] = grille[k]; + k++; + } } - } - - /* Calcul du volume de la grille */ - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - gri[i][j] = gri[i][j]*cs*cs; + + /* Volume of the grid */ + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + gri[i][j] = gri[i][j]*cs*cs; + } } - } - - - /* Retour vers R */ - k = 0; - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - grille[k] = gri[i][j]; - k++; + + /* C to R */ + k = 0; + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + grille[k] = gri[i][j]; + k++; + } } - } - - freetab(gri); + /* Free Memory */ + freetab(gri); } @@ -3123,488 +3256,491 @@ void calcvolume(double *grille, int *ncolgri, int *nliggri, double *cellsize) /* **************************************************************** * * - * DOMAIN: estimation de l'aire de répartition potentielle * + * DOMAIN: estimation of the potential distribution range * * * **************************************************************** */ void calcsim(double *pix, double **pts, double *rg, int *nvar, int *npts, double *similarite) { - /* Déclarations de variables */ - int no,nv, i, j; - double *vecqual, *temp, nib; - - no = *npts; - nv = *nvar; - - vecalloc(&vecqual, no); - vecalloc(&temp, nv); - - /* Calcul de la similarité: boucle */ - for (i=1; i<=no; i++) { - nib = 0; - for (j=1; j<=nv; j++) { - temp[j] = abs(pix[j]-pts[i][j])/rg[j]; - nib = nib + temp[j]; - } - vecqual[i] = 1 - (1/((double) nv))*nib; - } - - /* calcul de la qualité de l'habitat - par le max de la similarité */ - *similarite = vecqual[1]; - - for (i=2; i<=no; i++) { - if (vecqual[i]>*similarite) - *similarite = vecqual[i]; - } - - - /* libération de la mémoire */ - freevec(vecqual); - freevec(temp); - + /* Declarations of variables */ + int no,nv, i, j; + double *vecqual, *temp, nib; + + no = *npts; + nv = *nvar; + + vecalloc(&vecqual, no); + vecalloc(&temp, nv); + + /* Computation of the similarity */ + for (i=1; i<=no; i++) { + nib = 0; + for (j=1; j<=nv; j++) { + temp[j] = abs(pix[j]-pts[i][j])/rg[j]; + nib = nib + temp[j]; + } + vecqual[i] = 1 - (1/((double) nv))*nib; + } + + /* Computation of the habitat quality + using the max of the similarity */ + *similarite = vecqual[1]; + + for (i=2; i<=no; i++) { + if (vecqual[i]>*similarite) + *similarite = vecqual[i]; + } + + + /* Free memory */ + freevec(vecqual); + freevec(temp); + } -void fctdomain(double *kascmod, double *ptsmod, double *range, int *npts, int *npix, +/* For interaction with R */ + +void fctdomain(double *kascmod, double *ptsmod, + double *range, int *npts, int *npix, int *nvar, double *qualhab) { - /* Déclarations de variables */ - int no,np,nv, i, j, k; - double **kasc, **pts, *rg, *pix, sim; - - /* Copie dans les variables locales */ - no = *npts; - np = *npix; - nv = *nvar; - - taballoc(&kasc, np, nv); - taballoc(&pts, no, nv); - vecalloc(&rg, nv); - vecalloc(&pix, nv); - + /* Declarations of variables */ + int no,np,nv, i, j, k; + double **kasc, **pts, *rg, *pix, sim; - k = 0; - for (i = 1; i <= np; i++) { - for (j = 1; j <= nv; j++) { - kasc[i][j] = kascmod[k]; - k++; + /* Memory allocation */ + no = *npts; + np = *npix; + nv = *nvar; + + taballoc(&kasc, np, nv); + taballoc(&pts, no, nv); + vecalloc(&rg, nv); + vecalloc(&pix, nv); + + /* R to C*/ + k = 0; + for (i = 1; i <= np; i++) { + for (j = 1; j <= nv; j++) { + kasc[i][j] = kascmod[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= no; i++) { - for (j = 1; j <= nv; j++) { - pts[i][j] = ptsmod[k]; - k++; + + k = 0; + for (i = 1; i <= no; i++) { + for (j = 1; j <= nv; j++) { + pts[i][j] = ptsmod[k]; + k++; + } } - } - - for (i=1; i<=nv; i++) { - rg[i] = range[i-1]; - } - - - /* Le coeur de la fonction */ - for (i=1; i<=np; i++) { - for (j=1; j<=nv; j++) { - pix[j] = kasc[i][j]; + + for (i=1; i<=nv; i++) { + rg[i] = range[i-1]; } - calcsim(pix, pts, rg, &nv, &no, &sim); - qualhab[i-1] = sim; - } - - /* Libération de la mémoire */ - freetab(kasc); - freetab(pts); - freevec(pix); - freevec(rg); - + + + /* The core of the function */ + for (i=1; i<=np; i++) { + for (j=1; j<=nv; j++) { + pix[j] = kasc[i][j]; + } + calcsim(pix, pts, rg, &nv, &no, &sim); + qualhab[i-1] = sim; + } + + /* Free memory */ + freetab(kasc); + freetab(pts); + freevec(pix); + freevec(rg); + } -/************************************************************************************** - ************** L'analyse compositionelle ************* - *************************************************************************************/ +/*********************************************************************** + ********* Compositional analysis ****** + ***********************************************************************/ -/* Le weighted mean lambda: analyse compo sous R */ +/* weighted mean lambda: compo analysis with R */ void wml(double **used, double **avail, double *wmla, int na, int nh, double **proj1, double **proj2, double *nbassocie, int krep) { - /* Déclaration de variables */ - double **dlr, *moydlr, *nadlr, **dlrtmp, **mod1, **mod2, **res1, **res2; - double **SCEres1, **SCEres2, *vp1, *vp2, det1, det2, *vecalea, *aleamu; - int i, j, k, idcol, *vecindice, rg1, rg2; - int jb; - - /* allocation de mémoire */ - taballoc(&dlr, na, (nh*(nh-1))); - taballoc(&mod1, na, (nh-1)); - taballoc(&mod2, na, (nh-1)); - taballoc(&SCEres1, (nh-1), (nh-1)); - taballoc(&SCEres2, (nh-1), (nh-1)); - taballoc(&dlrtmp, na, (nh-1)); - taballoc(&res1, na, (nh-1)); - taballoc(&res2, na, (nh-1)); - vecintalloc(&vecindice, nh-1); - vecalloc(&nadlr, nh -1); - vecalloc(&moydlr, nh-1); - vecalloc(&vp1, nh-1); - vecalloc(&vp2, nh-1); - vecalloc(&aleamu, 2); - vecalloc(&vecalea, na); - - aleamu[1] = 1; - aleamu[2] = -1; - - jb = 0; - - /* tirage au sort de la permutation pour chaque animal */ - for (i = 1; i <= na; i++) { - aleapermutvec(aleamu); - vecalea[i] = aleamu[1]; - } - - /* cas où krep == 1 : première répétition de la - randomisation: on calcule le "vrai" lambda (pas - randomisé) */ - if (krep == 1) { - for (i = 1; i<=na; i++) { - vecalea[i] = 1; - } - } - - - /* vidage de nbassocie */ - for (i = 1; i <= nh; i++) - nbassocie[i] = 0; - - - /* boucle de remplissage des DLR */ - for (k = 1; k <= nh; k++) { - i = 1; - - /* construction du vecteur d'indices */ - for (j = 1; j <= nh; j++) { - if (j != k) { - vecindice[i] = j; - i++; - } - } - - /* remise à 0 de la moyenne et du nombre devaleurs non manquantes */ - for (j = 1; j <= (nh-1); j++) { - moydlr[j] = 0; - nadlr[j] = 0; - } - - /* premier remplissage des DLR */ - for (j = 1; j <= (nh-1); j++) { - jb = vecindice[j]; - idcol = (nh - 1) * (k - 1) + j; - for (i = 1; i <= na; i++) { - if ((fabs(avail[i][jb]) > 0.000000001)&&(fabs(avail[i][k]) > 0.000000001)) { - dlr[i][idcol] = (log(used[i][jb] / used[i][k]) - - log(avail[i][jb] / avail[i][k])) * vecalea[i]; - - /* calcul de la moyenne */ - moydlr[j] = moydlr[j] + dlr[i][idcol]; - nadlr[j]++; - } - } - } + /* Declaration of variables */ + double **dlr, *moydlr, *nadlr, **dlrtmp, **mod1, **mod2, **res1, **res2; + double **SCEres1, **SCEres2, *vp1, *vp2, det1, det2, *vecalea, *aleamu; + int i, j, k, idcol, *vecindice, rg1, rg2; + int jb; - for (j = 1; j <= (nh-1); j++) { - moydlr[j] = moydlr[j] / nadlr[j]; - } + /* Memory allocation */ + taballoc(&dlr, na, (nh*(nh-1))); + taballoc(&mod1, na, (nh-1)); + taballoc(&mod2, na, (nh-1)); + taballoc(&SCEres1, (nh-1), (nh-1)); + taballoc(&SCEres2, (nh-1), (nh-1)); + taballoc(&dlrtmp, na, (nh-1)); + taballoc(&res1, na, (nh-1)); + taballoc(&res2, na, (nh-1)); + vecintalloc(&vecindice, nh-1); + vecalloc(&nadlr, nh -1); + vecalloc(&moydlr, nh-1); + vecalloc(&vp1, nh-1); + vecalloc(&vp2, nh-1); + vecalloc(&aleamu, 2); + vecalloc(&vecalea, na); - /* deuxième boucle: remplacement des valeurs manquantes */ - for (j = 1; j <= (nh-1); j++) { - idcol = (nh - 1) * (k - 1) + j; - jb = vecindice[j]; - for (i = 1; i <= na; i++) { - if ( (fabs(avail[i][jb]) < 0.000000001)||(fabs(avail[i][k])< 0.000000001)) - dlr[i][idcol] = moydlr[j]; - } - } + aleamu[1] = 1; + aleamu[2] = -1; + + jb = 0; - /* extraction de DLRtmp */ + /* Random permutation for each animal */ for (i = 1; i <= na; i++) { - for (j = 1; j <= (nh-1); j++) { - idcol = (nh - 1) * (k - 1) + j; - dlrtmp[i][j] = dlr[i][idcol]; - } + aleapermutvec(aleamu); + vecalea[i] = aleamu[1]; } - /* Calcul des modèles */ - prodmatABC(proj1, dlrtmp, mod1); - prodmatABC(proj2, dlrtmp, mod2); - - /* Calcul des résidus */ - for (i = 1; i <= na; i++) { - for (j = 1; j <= nh-1; j++) { - res1[i][j] = dlrtmp[i][j] - mod1[i][j]; - res2[i][j] = dlrtmp[i][j] - mod2[i][j]; - } + /* When krep == 1 : First repetition of the process: + Computation of the observed lambda */ + if (krep == 1) { + for (i = 1; i<=na; i++) { + vecalea[i] = 1; + } } - /* calcul des sommes des carrés */ - prodmatAtAB(res1, SCEres1); - prodmatAtAB(res2, SCEres2); - /* calcul du déterminant */ - DiagobgComp(nh-1, SCEres1, vp1, &rg1); - DiagobgComp(nh-1, SCEres2, vp2, &rg2); - det1 = 1; - det2 = 1; - - for (i = 1; i <= rg1; i++) { - det1 = det1 * vp1[i]; - } - - for (i = 1; i <= rg2; i++) { - det2 = det2 * vp2[i]; + /* empty nbassocie */ + for (i = 1; i <= nh; i++) + nbassocie[i] = 0; + + + /* loop to fill the DLR */ + for (k = 1; k <= nh; k++) { + i = 1; + + /* build the vectors of indices */ + for (j = 1; j <= nh; j++) { + if (j != k) { + vecindice[i] = j; + i++; + } + } + + /* Set the mean and the number of non-missing values to 0 */ + for (j = 1; j <= (nh-1); j++) { + moydlr[j] = 0; + nadlr[j] = 0; + } + + /* First fill of the DLR */ + for (j = 1; j <= (nh-1); j++) { + jb = vecindice[j]; + idcol = (nh - 1) * (k - 1) + j; + for (i = 1; i <= na; i++) { + if ((fabs(avail[i][jb]) > 0.000000001)&&(fabs(avail[i][k]) > 0.000000001)) { + dlr[i][idcol] = (log(used[i][jb] / used[i][k]) - + log(avail[i][jb] / avail[i][k])) * vecalea[i]; + + /* computes the mean */ + moydlr[j] = moydlr[j] + dlr[i][idcol]; + nadlr[j]++; + } + } + } + + for (j = 1; j <= (nh-1); j++) { + moydlr[j] = moydlr[j] / nadlr[j]; + } + + /* Second loop: replace missing values */ + for (j = 1; j <= (nh-1); j++) { + idcol = (nh - 1) * (k - 1) + j; + jb = vecindice[j]; + for (i = 1; i <= na; i++) { + if ( (fabs(avail[i][jb]) < 0.000000001)||(fabs(avail[i][k])< 0.000000001)) + dlr[i][idcol] = moydlr[j]; + } + } + + /* extraction of DLRtmp */ + for (i = 1; i <= na; i++) { + for (j = 1; j <= (nh-1); j++) { + idcol = (nh - 1) * (k - 1) + j; + dlrtmp[i][j] = dlr[i][idcol]; + } + } + + /* Computes the models */ + prodmatABC(proj1, dlrtmp, mod1); + prodmatABC(proj2, dlrtmp, mod2); + + /* Computes the residuals */ + for (i = 1; i <= na; i++) { + for (j = 1; j <= nh-1; j++) { + res1[i][j] = dlrtmp[i][j] - mod1[i][j]; + res2[i][j] = dlrtmp[i][j] - mod2[i][j]; + } + } + + /* The sum of squares */ + prodmatAtAB(res1, SCEres1); + prodmatAtAB(res2, SCEres2); + + /* The determinant */ + DiagobgComp(nh-1, SCEres1, vp1, &rg1); + DiagobgComp(nh-1, SCEres2, vp2, &rg2); + det1 = 1; + det2 = 1; + + for (i = 1; i <= rg1; i++) { + det1 = det1 * vp1[i]; + } + + for (i = 1; i <= rg2; i++) { + det2 = det2 * vp2[i]; + } + + wmla[k] = det1 / det2; + for (i = 1; i <= (nh-1); i++) + nbassocie[k] = nbassocie[k] + nadlr[i]; } - - wmla[k] = det1 / det2; - for (i = 1; i <= (nh-1); i++) - nbassocie[k] = nbassocie[k] + nadlr[i]; - } - - /* libération de la mémoire */ - freetab(dlr); - freetab(mod1); - freetab(mod2); - freetab(SCEres1); - freetab(SCEres2); - freetab(dlrtmp); - freetab(res1); - freetab(res2); - freeintvec(vecindice); - freevec(nadlr); - freevec(moydlr); - freevec(vp1); - freevec(vp2); - freevec(aleamu); - freevec(vecalea); - + + /* free memory */ + freetab(dlr); + freetab(mod1); + freetab(mod2); + freetab(SCEres1); + freetab(SCEres2); + freetab(dlrtmp); + freetab(res1); + freetab(res2); + freeintvec(vecindice); + freevec(nadlr); + freevec(moydlr); + freevec(vp1); + freevec(vp2); + freevec(aleamu); + freevec(vecalea); + } -/* aclambda permet le calcul de lambda dans l'analyse compositionnelle */ +/* aclambda allows the computation of lambda in compositional analysis */ void aclambda(double *util, double *dispo, int *nani, int *nhab, double *xxtxxtmod1, double *xxtxxtmod2, double *rnv, double *wmla, int *nrep, double *wm, double *nb) { - /* Déclarations de variables */ - int na, nh, i, j, k, nr; - double **ut, **di, **proj1, **proj2, *lilamb, *linb, sumnb; - - /* allocation de mémoire */ - na = *nani; - nr = *nrep; - nh = *nhab; - - taballoc(&ut, na, nh); - taballoc(&di, na, nh); - taballoc(&proj1, na, na); - taballoc(&proj2, na, na); - vecalloc(&lilamb, nh); - vecalloc(&linb, nh); - - - /* Copie dans les variables locales */ - /* utilise */ - k = 0; - for (i = 1; i <= na; i++) { - for (j = 1; j <= nh; j++) { - ut[i][j] = util[k]; - if (fabs(ut[i][j]) < 0.000000001) - ut[i][j] = *rnv; - k++; + /* Declarations of variables */ + int na, nh, i, j, k, nr; + double **ut, **di, **proj1, **proj2, *lilamb, *linb, sumnb; + + /* Memory allocation */ + na = *nani; + nr = *nrep; + nh = *nhab; + + taballoc(&ut, na, nh); + taballoc(&di, na, nh); + taballoc(&proj1, na, na); + taballoc(&proj2, na, na); + vecalloc(&lilamb, nh); + vecalloc(&linb, nh); + + + /* From R to C */ + /* use */ + k = 0; + for (i = 1; i <= na; i++) { + for (j = 1; j <= nh; j++) { + ut[i][j] = util[k]; + if (fabs(ut[i][j]) < 0.000000001) + ut[i][j] = *rnv; + k++; + } } - } - - /* disponible */ - k = 0; - for (i = 1; i <= na; i++) { - for (j = 1; j <= nh; j++) { - di[i][j] = dispo[k]; - k++; + + /* availability */ + k = 0; + for (i = 1; i <= na; i++) { + for (j = 1; j <= nh; j++) { + di[i][j] = dispo[k]; + k++; + } } - } - - /* projecteur 1 */ - k = 0; - for (i = 1; i <= na; i++) { - for (j = 1; j <= na; j++) { - proj1[i][j] = xxtxxtmod1[k]; - k++; + + /* projector 1 */ + k = 0; + for (i = 1; i <= na; i++) { + for (j = 1; j <= na; j++) { + proj1[i][j] = xxtxxtmod1[k]; + k++; + } } - } - - /* projecteur 2 */ - k = 0; - for (i = 1; i <= na; i++) { - for (j = 1; j <= na; j++) { - proj2[i][j] = xxtxxtmod2[k]; - k++; + + /* projector 2 */ + k = 0; + for (i = 1; i <= na; i++) { + for (j = 1; j <= na; j++) { + proj2[i][j] = xxtxxtmod2[k]; + k++; + } } - } - - /* Début de la boucle */ - for (k = 1; k <= nr; k++) { - /* calcul du weighted mean lambda */ - wml(ut, di, lilamb, na, nh, - proj1, proj2, linb, k); - sumnb = 0; - for (i = 1; i <= nh; i++) - sumnb = sumnb + linb[i]; - for (i = 1; i <= nh; i++) - wmla[k-1] = wmla[k-1] + ((lilamb[i] * linb[i]) / sumnb); - - /* retour des composantes de lambda et du - nombre de valeurs non manquantes */ - if (k == 1) { - for (i = 1; i <= nh; i++) { - wm[i-1] = lilamb[i]; - nb[i-1] = linb[i]; - } + + + /* Beginning of the loop */ + for (k = 1; k <= nr; k++) { + /* weighted mean lambda */ + wml(ut, di, lilamb, na, nh, + proj1, proj2, linb, k); + sumnb = 0; + for (i = 1; i <= nh; i++) + sumnb = sumnb + linb[i]; + for (i = 1; i <= nh; i++) + wmla[k-1] = wmla[k-1] + ((lilamb[i] * linb[i]) / sumnb); + + /* C to R */ + if (k == 1) { + for (i = 1; i <= nh; i++) { + wm[i-1] = lilamb[i]; + nb[i-1] = linb[i]; + } + } } - } - - - /* Libération de la mémoire */ - freetab(ut); - freetab(di); - freetab(proj1); - freetab(proj2); - freevec(lilamb); - freevec(linb); - + + + /* Free memory */ + freetab(ut); + freetab(di); + freetab(proj1); + freetab(proj2); + freevec(lilamb); + freevec(linb); + } -/* Calcul de la ranking matrix pour l'analyse compositionelle */ +/* The ranking matrix for compositional analysis */ void rankma(double *used, double *avail, double *rankmap, double *rankmam, - double *rankmav, double *rankmanb, int *nhab, int *nani, int *nrep, double *rnv) + double *rankmav, double *rankmanb, int *nhab, + int *nani, int *nrep, double *rnv) { - /* Déclarations de variables */ - int i, j, k, nh, na, nr, r; - double **u, **a, **rmp, **rmm, **rmv, **rmnb, *dlrtmp, *vecalea, pp, val, moy; - double *aleamu, **tabani; - - - /* Allocation de mémoire */ - nh = *nhab; - na = *nani; - nr = *nrep; - r = 0; - - taballoc(&u, na, nh); - taballoc(&a, na, nh); - taballoc(&rmv, nh, nh); - taballoc(&rmp, nh, nh); - taballoc(&rmm, nh, nh); - taballoc(&rmnb, nh, nh); - vecalloc(&dlrtmp, na); - vecalloc(&vecalea, nr); - vecalloc(&aleamu, 2); - taballoc(&tabani, nr, na); - aleamu[1] = -1; - aleamu[2] = 1; - - /* Remplissage des tableaux */ - k = 0; - for (i = 1; i <= na; i++) { - for (j = 1; j <= nh; j++) { - u[i][j] = used[k]; - a[i][j] = avail[k]; - if (fabs(u[i][j]) < 0.000000001) - u[i][j] = *rnv; - k++; + /* Declarations of variables */ + int i, j, k, nh, na, nr, r; + double **u, **a, **rmp, **rmm, **rmv, **rmnb; + double *dlrtmp, *vecalea, pp, val, moy; + double *aleamu, **tabani; + + /* Memory Allocation */ + nh = *nhab; + na = *nani; + nr = *nrep; + r = 0; + + taballoc(&u, na, nh); + taballoc(&a, na, nh); + taballoc(&rmv, nh, nh); + taballoc(&rmp, nh, nh); + taballoc(&rmm, nh, nh); + taballoc(&rmnb, nh, nh); + vecalloc(&dlrtmp, na); + vecalloc(&vecalea, nr); + vecalloc(&aleamu, 2); + taballoc(&tabani, nr, na); + aleamu[1] = -1; + aleamu[2] = 1; + + /* Fill the table */ + k = 0; + for (i = 1; i <= na; i++) { + for (j = 1; j <= nh; j++) { + u[i][j] = used[k]; + a[i][j] = avail[k]; + if (fabs(u[i][j]) < 0.000000001) + u[i][j] = *rnv; + k++; + } } - } - - /* Remplissage du tablea tabani */ - for (i = 1; i <= nr; i++) { - for (j = 1; j <= na; j++) { - aleapermutvec(aleamu); - tabani[i][j] = aleamu[1]; + + /* Fill the table tabani */ + for (i = 1; i <= nr; i++) { + for (j = 1; j <= na; j++) { + aleapermutvec(aleamu); + tabani[i][j] = aleamu[1]; + } } - } - for (i = 1; i<=na; i++) { - tabani[1][i] = 1; - } - - /* Début de la boucle */ - for (k = 1; k <= nh; k++) { - for (j = 1; j <= nh; j++) { - for (r = 1; r <= nr; r++) { - moy = 0; - /* premier remplissage des dlr par ani */ - for (i = 1; i <= na; i++) { - if ((fabs(a[i][j])> 0.000000001)&&(fabs(a[i][k]) > 0.000000001)) { - dlrtmp[i] = (log(u[i][j]/u[i][k]) - log(a[i][j]/a[i][k])) * tabani[r][i]; - moy = moy + dlrtmp[i]; - if (r == 1) - rmnb[j][k]++; - } + for (i = 1; i<=na; i++) { + tabani[1][i] = 1; + } + + /* Beginning of the loop */ + for (k = 1; k <= nh; k++) { + for (j = 1; j <= nh; j++) { + for (r = 1; r <= nr; r++) { + moy = 0; + /* Fills first the DLR per animal */ + for (i = 1; i <= na; i++) { + if ((fabs(a[i][j])> 0.000000001)&&(fabs(a[i][k]) > 0.000000001)) { + dlrtmp[i] = (log(u[i][j]/u[i][k]) - log(a[i][j]/a[i][k])) * tabani[r][i]; + moy = moy + dlrtmp[i]; + if (r == 1) + rmnb[j][k]++; + } + } + + /* Computes the mean */ + moy = moy / rmnb[j][k]; + if (r==1) + rmv[j][k] = moy; + vecalea[r] = moy; + } + + /* Computes P */ + val = rmv[j][k]; + pp = 0; + for (r = 1; r <= nr; r++) { + if (val < vecalea[r]) + rmm[j][k]++; + if (val > vecalea[r]) + rmp[j][k]++; + } } - - /* Calcul de la moyenne */ - moy = moy / rmnb[j][k]; - if (r==1) - rmv[j][k] = moy; - vecalea[r] = moy; - } - - /* Calcul de P */ - val = rmv[j][k]; - pp = 0; - for (r = 1; r <= nr; r++) { - if (val < vecalea[r]) - rmm[j][k]++; - if (val > vecalea[r]) - rmp[j][k]++; - } } - } - - /* retour vers R */ - k = 0; - for (i=1; i<=nh; i++) { - for (j=1; j<=nh; j++) { - rankmap[k] = rmp[i][j]; - rankmam[k] = rmm[i][j]; - rankmav[k] = rmv[i][j]; - rankmanb[k] = rmnb[i][j]; - k++; + + /* C to R */ + k = 0; + for (i=1; i<=nh; i++) { + for (j=1; j<=nh; j++) { + rankmap[k] = rmp[i][j]; + rankmam[k] = rmm[i][j]; + rankmav[k] = rmv[i][j]; + rankmanb[k] = rmnb[i][j]; + k++; + } } - } - - - /* libération de la mémoire */ - freetab(rmv); - freetab(rmp); - freetab(rmm); - freetab(rmnb); - freevec(dlrtmp); - freetab(u); - freetab(a); - freevec(vecalea); - freevec(aleamu); - freetab(tabani); + + + /* Free memory */ + freetab(rmv); + freetab(rmp); + freetab(rmm); + freetab(rmnb); + freevec(dlrtmp); + freetab(u); + freetab(a); + freevec(vecalea); + freevec(aleamu); + freetab(tabani); } @@ -3613,89 +3749,95 @@ void rankma(double *used, double *avail, double *rankmap, double *rankmam, /* **************************************************************** * * - * dilatation et érosion morphologique * + * Morphological dilatation and erosion * * * **************************************************************** */ void erodil(double *grille, int *nlig, int *ncol, int *ntour, int *oper) { - int i,j,k,l,nl,nc, nt, etat0, etat1; - double **x, **xm, *voisin; - - nl = *nlig; - nc = *ncol; - nt = *ntour; - etat0 = 0; - etat1 = 0; - - taballoc(&x,nl,nc); - taballoc(&xm,nl,nc); - vecalloc(&voisin, 9); + /* declaration */ + int i,j,k,l,nl,nc, nt, etat0, etat1; + double **x, **xm, *voisin; - k=0; - for (i=1; i<=nl; i++) { - for (j=1; j<=nc; j++) { - x[i][j]=grille[k]; - k++; + nl = *nlig; + nc = *ncol; + nt = *ntour; + etat0 = 0; + etat1 = 0; + + /* Memory alloocation */ + taballoc(&x,nl,nc); + taballoc(&xm,nl,nc); + vecalloc(&voisin, 9); + + /* R to C */ + k=0; + for (i=1; i<=nl; i++) { + for (j=1; j<=nc; j++) { + x[i][j]=grille[k]; + k++; + } } - } - - for (k=1; k<=nt; k++) { - for (i=2; i<= (nl-1); i++) { - for (j=2; j<= (nc-1); j++) { - voisin[1] = x[i-1][j-1]; - voisin[2] = x[i-1][j]; - voisin[3] = x[i-1][j+1]; - voisin[4] = x[i][j-1]; - voisin[5] = x[i][j+1]; - voisin[6] = x[i+1][j-1]; - voisin[7] = x[i+1][j]; - voisin[8] = x[i+1][j+1]; - voisin[9] = x[i][j]; - for (l=1;l<=9; l++) { - if (((int) voisin[l])==0) { - etat0 = etat0 + 1; - } else { - etat1 = etat1 + 1; - } + + /* Morphology */ + for (k=1; k<=nt; k++) { + for (i=2; i<= (nl-1); i++) { + for (j=2; j<= (nc-1); j++) { + voisin[1] = x[i-1][j-1]; + voisin[2] = x[i-1][j]; + voisin[3] = x[i-1][j+1]; + voisin[4] = x[i][j-1]; + voisin[5] = x[i][j+1]; + voisin[6] = x[i+1][j-1]; + voisin[7] = x[i+1][j]; + voisin[8] = x[i+1][j+1]; + voisin[9] = x[i][j]; + for (l=1;l<=9; l++) { + if (((int) voisin[l])==0) { + etat0 = etat0 + 1; + } else { + etat1 = etat1 + 1; + } + } + if (*oper==1) { + if (etat1 > 0) + xm[i][j] = 1; + if (etat1 == 0) + xm[i][j] = 0; + } else { + if (etat0 == 0) + xm[i][j] =1; + if (etat0 > 0) + xm[i][j] =0; + } + etat1 = 0; + etat0 = 0; + } } - if (*oper==1) { - if (etat1 > 0) - xm[i][j] = 1; - if (etat1 == 0) - xm[i][j] = 0; - } else { - if (etat0 == 0) - xm[i][j] =1; - if (etat0 > 0) - xm[i][j] =0; + + + for (i=1; i<=nl; i++) { + for (j=1; j<=nc; j++) { + x[i][j]=xm[i][j]; + } } - etat1 = 0; - etat0 = 0; - } } + /* C to R */ + k=0; for (i=1; i<=nl; i++) { - for (j=1; j<=nc; j++) { - x[i][j]=xm[i][j]; - } - } - } - - /* grille */ - k=0; - for (i=1; i<=nl; i++) { - for (j=1; j<=nc; j++) { - grille[k]=xm[i][j]; - k++; + for (j=1; j<=nc; j++) { + grille[k]=xm[i][j]; + k++; + } } - } - - freetab(x); - freetab(xm); - freevec(voisin); - + + /* Memory */ + freetab(x); + freetab(xm); + freevec(voisin); + } @@ -3703,244 +3845,253 @@ void erodil(double *grille, int *nlig, int *ncol, int *ntour, int *oper) /******************************************************** - x et y sont les coordonnées des points, xp et yp - les coordonnées des sommets du polygone (le premier - et le dernier sommet doivent être identiques). deds est - un vecteur de même longueur que x et y: prend la valeur 1 - si le point est dans le polygone et 0 sinon. + x and y are the coordinates of the points, xp and yp + the coordinates of the vertices of the polygon (first and + last vertices should be the same). deds is a vector of the + same length as x and y: deds take the value 1 if the point is + in the polygon and 0 otherwise ********************************************************/ void inout(double *x, double *y, double *xp, double *yp, int *deds) { - /* Déclaration des variables */ - int i, j, n, wm, np; - double *xpc, *ypc, sig, a, b, x0; - - /* allocation d'espace et valeurs des variables */ - n = x[0]; - np = xp[0]; - - vecalloc(&xpc, np); - vecalloc(&ypc, np); - - for (i = 1; i <= n; i++) { - deds[i] = 1; - } - - for (j = 1; j <= n; j++) { - - /* Centrage autour du point */ - for (i = 1; i <= np; i++) { - xpc[i] = xp[i] - x[j]; - ypc[i] = yp[i] - y[j]; - } - - /* mesure du nombre d'intersections avec l'axe des X , pour X >0 */ - wm = 0; - for (i = 1; i <= (np-1); i++) { - sig = ypc[i] * ypc[i+1]; - if (sig < 0) { - /* calcul de la pente et ord ori */ - /* Cas 1: on n'a pas de pente infinie */ - if (fabs(xpc[i+1] - xpc[i]) > 0.000000001) - { - a = (ypc[i+1] - ypc[i]) / (xpc[i+1] - xpc[i]); - b = (ypc[i]- a * xpc[i]); - /* calcul de x à y = 0 */ - /* ayant un sens seulement si a != 0 */ - if ((fabs(ypc[i+1] - ypc[i]) > 0.000000001)) { - x0 = - b / a; - if (x0 >= 0) - wm = abs(wm - 1); - } - } - /* Cas 2: On a une pente infinie - il faut alors vérifier que à droite du point, soit - xi >0 */ - if ((fabs(xpc[i+1] - xpc[i]) < 0.000000001)) - { - if (xpc[i] >= 0) - wm = abs(wm - 1); - } - } + /* Declaration of variables */ + int i, j, n, wm, np; + double *xpc, *ypc, sig, a, b, x0; + + /* Memory allocation */ + n = x[0]; + np = xp[0]; + + vecalloc(&xpc, np); + vecalloc(&ypc, np); + + for (i = 1; i <= n; i++) { + deds[i] = 1; } - /* Si nombre pair: dehors, sinon, dedans */ - if (wm == 0) - deds[j] = 0; - } - - - /* libération de la mémoire */ - freevec(xpc); - freevec(ypc); + for (j = 1; j <= n; j++) { + + /* Centring on the point */ + for (i = 1; i <= np; i++) { + xpc[i] = xp[i] - x[j]; + ypc[i] = yp[i] - y[j]; + } + + /* Number of intersections with X axis, for X >0 */ + wm = 0; + for (i = 1; i <= (np-1); i++) { + sig = ypc[i] * ypc[i+1]; + if (sig < 0) { + /* The slope and intercept */ + /* Case 1: The slope is not infinite */ + if (fabs(xpc[i+1] - xpc[i]) > 0.000000001) + { + a = (ypc[i+1] - ypc[i]) / (xpc[i+1] - xpc[i]); + b = (ypc[i]- a * xpc[i]); + /* value of x for y = 0 */ + /* makes sense only if a != 0 */ + if ((fabs(ypc[i+1] - ypc[i]) > 0.000000001)) { + x0 = - b / a; + if (x0 >= 0) + wm = abs(wm - 1); + } + } + /* Case 2: Infinite slope + verify on the right of the point, i.e. + xi >0 */ + if ((fabs(xpc[i+1] - xpc[i]) < 0.000000001)) + { + if (xpc[i] >= 0) + wm = abs(wm - 1); + } + } + } + + /* If even number: outside. Inside otherwise */ + if (wm == 0) + deds[j] = 0; + } + + + /* Free memory */ + freevec(xpc); + freevec(ypc); } -/* vérif de inout sous R */ + +/* verification of inout with R */ + void inoutr(double *xr, double *yr, double *xpr, double *ypr, int *dedsr, int *nxr, int *npr) { - int i, nx, np, *deds; - double *x, *y, *xp, *yp; - - /* allocation d'espace */ - nx = *nxr; - np = *npr; - vecalloc(&x, nx); - vecalloc(&y, nx); - vecalloc(&xp, np); - vecalloc(&yp, np); - vecintalloc(&deds, nx); - - for (i = 1; i <= nx; i++) { - x[i] = xr[i-1]; - y[i] = yr[i-1]; - } - - for (i = 1; i <= np; i++) { - xp[i] = xpr[i-1]; - yp[i] = ypr[i-1]; - } - - inout(x, y, xp, yp, deds); - - for (i=1; i<=nx; i++) { - dedsr[i-1] = deds[i]; - } - - /* libération de la mémoire */ - freevec(x); - freevec(y); - freevec(xp); - freevec(yp); - freeintvec(deds); + /* Declaration */ + int i, nx, np, *deds; + double *x, *y, *xp, *yp; + + /* Memory allocation */ + nx = *nxr; + np = *npr; + vecalloc(&x, nx); + vecalloc(&y, nx); + vecalloc(&xp, np); + vecalloc(&yp, np); + vecintalloc(&deds, nx); + + /* R to C */ + for (i = 1; i <= nx; i++) { + x[i] = xr[i-1]; + y[i] = yr[i-1]; + } + + for (i = 1; i <= np; i++) { + xp[i] = xpr[i-1]; + yp[i] = ypr[i-1]; + } + + /* test of inout */ + inout(x, y, xp, yp, deds); + + /* C to R */ + for (i=1; i<=nx; i++) { + dedsr[i-1] = deds[i]; + } + + /* Free memory */ + freevec(x); + freevec(y); + freevec(xp); + freevec(yp); + freeintvec(deds); } /*********************************************************** - Rasterisation d'un polygone: xp et yp sont les coordonnées - du polygone, xg et yg (pas la même longueur) sont les - coordonnées des lignes et des colones de la grille, et - carte est une matrice raster. + Rasterization of a polygon: xp and yp are the coordinates + of the polygon, xg and yg (not of the same length) are the + coordinates of the rows and columns of the grid and + carte is a raster map. *************************************************************/ void rastpol(double *xp, double *yp, double *xg, double *yg, double **carte) { - /* Déclaration des variables */ - int i, j, nl, nc, k, *deds; - double *nxc, *nyc; - - /* allocation de mémoire */ - nl = xg[0]; - nc = yg[0]; - vecalloc(&nxc, nl*nc); - vecalloc(&nyc, nl*nc); - vecintalloc(&deds, nl*nc); - - /* Vidage de la carte */ - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - carte[i][j] = 0; + /* Declaration of variables */ + int i, j, nl, nc, k, *deds; + double *nxc, *nyc; + + /* Memory allocation */ + nl = xg[0]; + nc = yg[0]; + vecalloc(&nxc, nl*nc); + vecalloc(&nyc, nl*nc); + vecintalloc(&deds, nl*nc); + + /* Empties the map */ + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + carte[i][j] = 0; + } } - } - - /* Sortie des coordonnées des pixels de la grille */ - k = 1; - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - nxc[k] = xg[i]; - nyc[k] = yg[j]; - k++; + + /* Output of the coordinates of the pixels of the grid */ + k = 1; + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + nxc[k] = xg[i]; + nyc[k] = yg[j]; + k++; + } } - } - - /* inout de ces pixels */ - inout(nxc, nyc, xp, yp, deds); - - /* et remplissage de la carte */ - k = 1; - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - carte[i][j] = (double) deds[k]; - k++; + + /* inout on these pixels */ + inout(nxc, nyc, xp, yp, deds); + + /* Fills the grid */ + k = 1; + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + carte[i][j] = (double) deds[k]; + k++; + } } - } - - /* libération de la mémoire */ - freevec(nxc); - freevec(nyc); - freeintvec(deds); + + /* Free memory */ + freevec(nxc); + freevec(nyc); + freeintvec(deds); } /* **************************************************************** * * - * Vérif de rastpol sous R * + * Verification of rastpol with R * * * **************************************************************** */ void rastpolaire(double *xpr, double *ypr, double *xgr, double *ygr, double *carter, int *nlg, int *ncg, int *nvp) { - /* allocation de mémoire */ - int i, j, k, nl, nc, nv; - double *xp, *yp, *xg, *yg, **carte; - - /* remplissage des tableaux */ - nl = *nlg; - nc = *ncg; - nv = *nvp; - vecalloc(&xp, nv); - vecalloc(&yp, nv); - vecalloc(&xg, nl); - vecalloc(&yg, nc); - taballoc(&carte, nl, nc); + /* Declaration */ + int i, j, k, nl, nc, nv; + double *xp, *yp, *xg, *yg, **carte; - for (i = 1; i <= nv; i++) { - xp[i] = xpr[i-1]; - yp[i] = ypr[i-1]; - } - - for (i = 1; i <= nl; i++) { - xg[i] = xgr[i-1]; - } - - for (i = 1; i <= nc; i++) { - yg[i] = ygr[i-1]; - } - - k=0; - for (i=1; i<=nl; i++) { - for(j=1; j<=nc; j++) { - carte[i][j] = carter[k]; - k++; + /* Memory allocation */ + nl = *nlg; + nc = *ncg; + nv = *nvp; + vecalloc(&xp, nv); + vecalloc(&yp, nv); + vecalloc(&xg, nl); + vecalloc(&yg, nc); + taballoc(&carte, nl, nc); + + /* R to C */ + for (i = 1; i <= nv; i++) { + xp[i] = xpr[i-1]; + yp[i] = ypr[i-1]; } - } - - rastpol(xp, yp, xg, yg, carte); - - k=0; - for (i=1; i<=nl; i++) { - for (j=1; j<=nc; j++) { - carter[k] = carte[i][j]; - k++; + + for (i = 1; i <= nl; i++) { + xg[i] = xgr[i-1]; } - } - - /* libération de la mémoire */ - freevec(xp); - freevec(yp); - freevec(xg); - freevec(yg); - freetab(carte); + + for (i = 1; i <= nc; i++) { + yg[i] = ygr[i-1]; + } + + k=0; + for (i=1; i<=nl; i++) { + for(j=1; j<=nc; j++) { + carte[i][j] = carter[k]; + k++; + } + } + + /* call to rastpol */ + rastpol(xp, yp, xg, yg, carte); + + /* C to R */ + k=0; + for (i=1; i<=nl; i++) { + for (j=1; j<=nc; j++) { + carter[k] = carte[i][j]; + k++; + } + } + + /* Free memory */ + freevec(xp); + freevec(yp); + freevec(xg); + freevec(yg); + freetab(carte); } @@ -3948,7 +4099,7 @@ void rastpolaire(double *xpr, double *ypr, double *xgr, double *ygr, /* **************************************************************** * * - * Calcul de marginalité et tolérance (par variable) * + * Computation of the marginality and tolérance (by variable) * * * **************************************************************** */ @@ -3956,117 +4107,117 @@ void rastpolaire(double *xpr, double *ypr, double *xgr, double *ygr, void calcniche(double **kasc, int *nvar, int *nlg, int *ncg, double *margvar, double *tolvar, double **carte) { - /* définition des variables */ - int i, j, l, np, nv, nc, nl, npixpol; - double **cartevar; - - /* allocation de mémoire */ - nc = *ncg; - nl = *nlg; - nv = *nvar; - np = nc*nl; - npixpol = 0; - - taballoc(&cartevar, nl, nc); - - /* Marginalité et tolérance posées à 0 */ - for (l = 1; l <= nv; l++) { - margvar[l] = 0; - tolvar[l] = 0; - } - - /* boucle pour chaque variable */ - for (l = 1; l <= nv; l++) { + /* definition of the variables */ + int i, j, l, np, nv, nc, nl, npixpol; + double **cartevar; - /* récupération de la carte */ - getcarte(cartevar, kasc, &l); + /* Memory allocation */ + nc = *ncg; + nl = *nlg; + nv = *nvar; + np = nc*nl; npixpol = 0; - /* calcul de la moyenne utilisée */ - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - if (fabs(carte[i][j] - 1) < 0.000000001) { - if (fabs(cartevar[i][j] + 9999) > 0.000000001) { - margvar[l] = margvar[l] + cartevar[i][j]; - npixpol++; - } - } - } + taballoc(&cartevar, nl, nc); + + /* Marginality and tolerance set to 0 */ + for (l = 1; l <= nv; l++) { + margvar[l] = 0; + tolvar[l] = 0; } - margvar[l] = margvar[l] / ((double) npixpol); - /* Calcul de la tolérance */ - for (i = 1; i <= nl; i++) { - for (j = 1; j <= nc; j++) { - if (fabs(carte[i][j] - 1) < 0.000000001) { - if (fabs(cartevar[i][j] + 9999) > 0.000000001) { - tolvar[l] = tolvar[l] + (cartevar[i][j] - margvar[l])*(cartevar[i][j] - margvar[l]); - } + /* loop for each variable */ + for (l = 1; l <= nv; l++) { + + /* récupération de la carte */ + getcarte(cartevar, kasc, &l); + npixpol = 0; + + /* The "used" mean */ + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + if (fabs(carte[i][j] - 1) < 0.000000001) { + if (fabs(cartevar[i][j] + 9999) > 0.000000001) { + margvar[l] = margvar[l] + cartevar[i][j]; + npixpol++; + } + } + } } - } + margvar[l] = margvar[l] / ((double) npixpol); + + /* The tolerance */ + for (i = 1; i <= nl; i++) { + for (j = 1; j <= nc; j++) { + if (fabs(carte[i][j] - 1) < 0.000000001) { + if (fabs(cartevar[i][j] + 9999) > 0.000000001) { + tolvar[l] = tolvar[l] + (cartevar[i][j] - margvar[l])*(cartevar[i][j] - margvar[l]); + } + } + } + } + tolvar[l] = tolvar[l] / ((double) npixpol); } - tolvar[l] = tolvar[l] / ((double) npixpol); - } - - /* libération de la mémoire */ - freetab(cartevar); + + /* Free memory */ + freetab(cartevar); } /* **************************************************************** * * - * Vérification sous R * + * Test with R * * * **************************************************************** */ void calcnicher(double *kascr, int *nvar, int *nlg, int *ncg, double *margvar, double *tolvar, double *carter) { - /* Déclaration de variables */ - int i, j, k, nv, nl, nc; - double *marg, *tol, **carte, **kasc; - - /* Allocation de mémoire */ - nv = *nvar; - nl = *nlg; - nc = *ncg; - vecalloc(&marg, nv); - vecalloc(&tol, nv); - taballoc(&carte, nl,nc); - taballoc(&kasc, nl*nc,nv); - - /* Remplissage des variables */ - k = 0; - for (i = 1; i <= (nl*nc); i++) { - for (j = 1; j<=nv; j++) { - kasc[i][j] = kascr[k]; - k++; + /* Declaration of variables */ + int i, j, k, nv, nl, nc; + double *marg, *tol, **carte, **kasc; + + /* Memory Allocation */ + nv = *nvar; + nl = *nlg; + nc = *ncg; + vecalloc(&marg, nv); + vecalloc(&tol, nv); + taballoc(&carte, nl,nc); + taballoc(&kasc, nl*nc,nv); + + /* R to C */ + k = 0; + for (i = 1; i <= (nl*nc); i++) { + for (j = 1; j<=nv; j++) { + kasc[i][j] = kascr[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= nl; i++) { - for (j = 1; j<=nc; j++) { - carte[i][j] = carter[k]; - k++; + + k = 0; + for (i = 1; i <= nl; i++) { + for (j = 1; j<=nc; j++) { + carte[i][j] = carter[k]; + k++; + } } - } - - - /* Fonction C */ - calcniche(kasc, &nv, &nl, &nc, marg, tol, carte); - - /* Sorties vers R */ - for (i=1; i<=nv; i++) { - margvar[i-1] = marg[i]; - tolvar[i-1] = tol[i]; - } - /* libération de la mémoire */ - freevec(marg); - freevec(tol); - freetab(carte); - freetab(kasc); + + /* Call to calcniche */ + calcniche(kasc, &nv, &nl, &nc, marg, tol, carte); + + /* C to R */ + for (i=1; i<=nv; i++) { + margvar[i-1] = marg[i]; + tolvar[i-1] = tol[i]; + } + + /* Free memory */ + freevec(marg); + freevec(tol); + freetab(carte); + freetab(kasc); } @@ -4076,9 +4227,8 @@ void calcnicher(double *kascr, int *nvar, int *nlg, int *ncg, /* **************************************************************** * * - * Fonction permettant de randomiser l'orientation et * - * la position d'un polygone (coordonnées xpr et ypr) * - * sur la zone d'étude représentée par kascr * + * Function to randomize orientation and position of the * + * (coordinates xpr et ypr) on the study area (kascr) * * * **************************************************************** */ @@ -4088,123 +4238,123 @@ void randompol(double *xpr, double *ypr, double *kascr, double *xgr, double *ygr, int *nlr, int *ncr, int *nvpr, int *nrep) { - /* définition des variables */ - int i, j, k, l, r, np, nv, nc, nl, nvp, nr; - double *xp, *yp, *xr, *yr, **kasc, **carte, *xg, *yg, *moyut; - double *tolvar, **margb, **tolb, **ze; - - /* allocation de mémoire */ - nc = *ncr; - nl = *nlr; - nv = *nvar; - np = nc*nl; - nvp = *nvpr; - nr = *nrep; - r=1; - - vecalloc(&xp, nvp); - vecalloc(&yp, nvp); - vecalloc(&xr, nvp); - vecalloc(&yr, nvp); - vecalloc(&xg, nl); - vecalloc(&yg, nc); - vecalloc(&moyut, nv); - vecalloc(&tolvar, nv); - taballoc(&kasc, np, nv); - taballoc(&carte, nl, nc); - taballoc(&ze, nl, nc); - taballoc(&margb, (nr+1), nv); - taballoc(&tolb, (nr+1), nv); - - /* remplissage des variables et tableaux C */ - for (i=1; i<=nvp; i++) { - xp[i] = xpr[i-1]; - yp[i] = ypr[i-1]; - } - for (i=1; i<=nl; i++) { - xg[i] = xgr[i-1]; - } - for (i=1; i<=nc; i++) { - yg[i] = ygr[i-1]; - } - k=0; - for (i=1; i<=np; i++) { - for(j=1; j<=nv; j++) { - kasc[i][j] = kascr[k]; - k++; - } - } - - /* Rastérisation du polygone */ - rastpol(xp, yp, xg, yg, carte); - - /* Calcul de la moyenne utilisée et tolérance */ - calcniche(kasc, &nv, &nl, &nc, moyut, - tolvar, carte); - - for (l = 1; l <= nv; l++) { - margb[1][l] = moyut[l]; - tolb[1][l] = tolvar[l]; - } - - for (i = 1; i <= nvp; i++) { - xr[i] = xp[i]; - yr[i] = yp[i]; - } - - for (r =1; r <= nr; r++) { + /* definition of the variables */ + int i, j, k, l, r, np, nv, nc, nl, nvp, nr; + double *xp, *yp, *xr, *yr, **kasc, **carte, *xg, *yg, *moyut; + double *tolvar, **margb, **tolb, **ze; - rotxy(xr, yr, r); - rastpol(xr, yr, xg, yg, carte); - l=1; - getcarte(ze, kasc, &l); + /* Memory allocation */ + nc = *ncr; + nl = *nlr; + nv = *nvar; + np = nc*nl; + nvp = *nvpr; + nr = *nrep; + r=1; - shr(carte, ze); + vecalloc(&xp, nvp); + vecalloc(&yp, nvp); + vecalloc(&xr, nvp); + vecalloc(&yr, nvp); + vecalloc(&xg, nl); + vecalloc(&yg, nc); + vecalloc(&moyut, nv); + vecalloc(&tolvar, nv); + taballoc(&kasc, np, nv); + taballoc(&carte, nl, nc); + taballoc(&ze, nl, nc); + taballoc(&margb, (nr+1), nv); + taballoc(&tolb, (nr+1), nv); + + /* R to C */ + for (i=1; i<=nvp; i++) { + xp[i] = xpr[i-1]; + yp[i] = ypr[i-1]; + } + for (i=1; i<=nl; i++) { + xg[i] = xgr[i-1]; + } + for (i=1; i<=nc; i++) { + yg[i] = ygr[i-1]; + } + k=0; + for (i=1; i<=np; i++) { + for(j=1; j<=nv; j++) { + kasc[i][j] = kascr[k]; + k++; + } + } + + /* Rasterisation of the polygon */ + rastpol(xp, yp, xg, yg, carte); + + /* used mean and tolerance */ calcniche(kasc, &nv, &nl, &nc, moyut, - tolvar, ze); - + tolvar, carte); + for (l = 1; l <= nv; l++) { - margb[r+1][l] = moyut[l]; - tolb[r+1][l] = tolvar[l]; + margb[1][l] = moyut[l]; + tolb[1][l] = tolvar[l]; } - } - - /* sortie des résultats sous R */ - k=0; - for (i=1; i<=(nr+1); i++) { - for (j=1; j<=nv; j++) { - marg[k]=margb[i][j]; - tol[k]=tolb[i][j]; - k++; + /* C to R */ + for (i = 1; i <= nvp; i++) { + xr[i] = xp[i]; + yr[i] = yp[i]; } - } - - /* libération de la mémoire */ - freevec(xp); - freevec(yp); - freevec(xg); - freevec(yg); - freetab(kasc); - freetab(carte); - freevec(xr); - freevec(yr); - freevec(moyut); - freevec(tolvar); - freetab(ze); - freetab(margb); - freetab(tolb); + + /* Randomization process */ + for (r =1; r <= nr; r++) { + + rotxy(xr, yr, r); + rastpol(xr, yr, xg, yg, carte); + l=1; + getcarte(ze, kasc, &l); + shr(carte, ze); + calcniche(kasc, &nv, &nl, &nc, moyut, + tolvar, ze); + + for (l = 1; l <= nv; l++) { + margb[r+1][l] = moyut[l]; + tolb[r+1][l] = tolvar[l]; + } + + } + + /* C to R */ + k=0; + for (i=1; i<=(nr+1); i++) { + for (j=1; j<=nv; j++) { + marg[k]=margb[i][j]; + tol[k]=tolb[i][j]; + k++; + } + } + + /* Free memory */ + freevec(xp); + freevec(yp); + freevec(xg); + freevec(yg); + freetab(kasc); + freetab(carte); + freevec(xr); + freevec(yr); + freevec(moyut); + freevec(tolvar); + freetab(ze); + freetab(margb); + freetab(tolb); } /* **************************************************************** * * - * On donne un vecteur point, un objet asc et les coordonnées * - * des lignes et des colonnes de la carte, et la taille de la * - * de la cellule, et on obtient dans na la valeur sous le * - * point * + * Spatial join: given a vector, an asc object the * + * rows and columns coordinates of the map, and the cell size * + * the function returns the value at the point * * * **************************************************************** */ @@ -4212,72 +4362,81 @@ void randompol(double *xpr, double *ypr, double *kascr, void dedans(double *pts, double *xc, double *yc, double *na, double cs, double **asc) { - int nl, nc, i, ligne, colo; - double x, y; - - x = pts[1]; - y = pts[2]; - - nl = xc[0]; - nc = yc[0]; - - ligne = 0; - colo = 0; + int nl, nc, i, ligne, colo; + double x, y; - for (i = 1; i <= nl; i++) { - if (((xc[i] - cs/2) <= x) && ((xc[i] + cs/2) > x)) - ligne = i; - } - - for (i = 1; i <= nc; i++) { - if (((yc[i] - cs/2) <= y) && ((yc[i] + cs/2) > y)) - colo = i; - } - *na = asc[ligne][colo]; + x = pts[1]; + y = pts[2]; + + nl = xc[0]; + nc = yc[0]; + + ligne = 0; + colo = 0; + + for (i = 1; i <= nl; i++) { + if (((xc[i] - cs/2) <= x) && ((xc[i] + cs/2) > x)) + ligne = i; + } + + for (i = 1; i <= nc; i++) { + if (((yc[i] - cs/2) <= y) && ((yc[i] + cs/2) > y)) + colo = i; + } + *na = asc[ligne][colo]; } -/* dedans pour vérification sous R */ + +/* Test of dedans in R */ void dedansr(double *ptsr, double *xcr, double *ycr, double *na, double *cs, double *ascr, int *nl, int *nc, int *nlocs) { - int i,j,k; - double *pts, *xc, *yc, **asc; - vecalloc(&pts, *nlocs); - vecalloc(&xc, *nl); - vecalloc(&yc, *nc); - taballoc(&asc, *nl, *nc); - - pts[1] = ptsr[0]; - pts[2] = ptsr[1]; - - for (i = 1; i <= *nl; i++) { - xc[i] = xcr[i-1]; - } - for (i = 1; i <= *nc; i++) { - yc[i] = ycr[i-1]; - } - k = 0; - for (i = 1; i <= *nl; i++) { - for (j = 1; j <= *nc; j++) { - asc[i][j] = ascr[k]; - k++; + /* Declaration */ + int i,j,k; + double *pts, *xc, *yc, **asc; + + /* Memory allocation */ + vecalloc(&pts, *nlocs); + vecalloc(&xc, *nl); + vecalloc(&yc, *nc); + taballoc(&asc, *nl, *nc); + + /* R to C */ + pts[1] = ptsr[0]; + pts[2] = ptsr[1]; + + for (i = 1; i <= *nl; i++) { + xc[i] = xcr[i-1]; } - } - dedans(pts, xc, yc, na, *cs, asc); - - freevec(pts); - freevec(xc); - freevec(yc); - freetab(asc); + for (i = 1; i <= *nc; i++) { + yc[i] = ycr[i-1]; + } + k = 0; + for (i = 1; i <= *nl; i++) { + for (j = 1; j <= *nc; j++) { + asc[i][j] = ascr[k]; + k++; + } + } + + /* Call to dedans */ + dedans(pts, xc, yc, na, *cs, asc); + + /* free memory */ + freevec(pts); + freevec(xc); + freevec(yc); + freetab(asc); } + /* **************************************************************** * * - * Fonction permettant de randomiser un trajet, sur la base * - * de distances interlocs, et de temps entre les locs, * - * ainsi que d'angles tirés de façon indépendante * + * Randomization of a traject, based on the distances between * + * successive relocations and the time lag, as well as the * + * angles between successive steps * * * **************************************************************** */ @@ -4286,198 +4445,204 @@ void rpath(double **xp, double *rcx, double *rcy, double **asc, double *angles, double *xc, double *yc, double *cs, int r) { - int i, j, k, l, m, nsam, nltd, *index, *indangles, nlocs; - double *pts, na, interv, *dobs, dech, anglech, ang; - - vecalloc(&pts, 2); - nltd = tabdist[0][0]; - nlocs = xp[0][0]; - vecintalloc(&indangles, (nlocs-2)); - - /* remplissage du vecteur indangle */ - for (i = 1; i <= (nlocs - 2); i++) { - indangles[i] = i; - } + /* Declaration */ + int i, j, k, l, m, nsam, nltd, *index, *indangles, nlocs; + double *pts, na, interv, *dobs, dech, anglech, ang; - /* 1. Première localisation du trajet */ - k = 0; - ang = 0; - - while (k==0) { + /* Memory allocation */ + vecalloc(&pts, 2); + nltd = tabdist[0][0]; + nlocs = xp[0][0]; + vecintalloc(&indangles, (nlocs-2)); + + /* fills the vector indangle */ + for (i = 1; i <= (nlocs - 2); i++) { + indangles[i] = i; + } - /* Tirage au sort des coordonnées de la locs */ - xp[1][1] = (alea())*(rcx[2]-rcx[1]) + rcx[1]; - xp[1][2] = (alea())*(rcy[2]-rcy[1]) + rcy[1]; + /* 1. First loc of the traject */ + k = 0; + ang = 0; - pts[1] = xp[1][1]; - pts[2] = xp[1][2]; + while (k==0) { + + /* Random draw of relocations coordinates */ + xp[1][1] = (alea())*(rcx[2]-rcx[1]) + rcx[1]; + xp[1][2] = (alea())*(rcy[2]-rcy[1]) + rcy[1]; + + pts[1] = xp[1][1]; + pts[2] = xp[1][2]; + + /* Verifies that the loc is inside the study area */ + dedans(pts, xc, yc, &na, *cs, asc); + if (fabs(na + 9999) > 0.000000001) + k = 1; + + } - /* Vérifie que la loc tombe bien dans la zone d'étude */ - dedans(pts, xc, yc, &na, *cs, asc); - if (fabs(na + 9999) > 0.000000001) - k = 1; - } - - - /* Boucle pour les localisations suivantes */ - for (i = 1; i <= (nlocs-1); i++) { - interv = dt[i]; - - /* combien y-a-t-il de distances pour l'intervalle observé ? */ - nsam = 0; - for (j = 1; j <= nltd; j++) { - if (fabs(tabdist[j][1] - interv) < 0.000000001) - nsam++; - } - - /* construction du tableau de distances */ - vecalloc(&dobs, nsam); - - /* le vecteur index servira à tirer une loc de façon aléatoire */ - vecintalloc(&index, nsam); - for (l = 1; l <= nsam; l++) { - index[l] = l; - } - - /* mais dans un premier temps, - on récupère les distances correspondantes */ - m = 1; - for (j = 1; j <= nltd; j++) { - if (fabs(tabdist[j][1] - interv) < 0.000000001) { - dobs[m] = tabdist[j][2]; - m++; - } + /* loop for the following relocations */ + for (i = 1; i <= (nlocs-1); i++) { + interv = dt[i]; + + /* How many distances for the observed time lag ? */ + nsam = 0; + for (j = 1; j <= nltd; j++) { + if (fabs(tabdist[j][1] - interv) < 0.000000001) + nsam++; + } + + /* Table of distances */ + vecalloc(&dobs, nsam); + + /* the vector index will be used to draw a random relocation */ + vecintalloc(&index, nsam); + for (l = 1; l <= nsam; l++) { + index[l] = l; + } + + /* In a first time, gets the corresponding distances */ + m = 1; + for (j = 1; j <= nltd; j++) { + if (fabs(tabdist[j][1] - interv) < 0.000000001) { + dobs[m] = tabdist[j][2]; + m++; + } + } + + k = 0; + while (k == 0) { + /* Sampled Distance */ + r = (int) (alea() * 100); + getpermutation(index, j * r); + dech = dobs[index[1]]; + + /* Sampled Angles */ + getpermutation(indangles, j * r); + anglech = angles[indangles[1]]; + + /* update the angles */ + ang = (ang + anglech); + + /* The new coordinates */ + xp[i+1][1] = xp[i][1] + dech * cos(ang); + xp[i+1][2] = xp[i][2] + dech * sin(ang); + + pts[1] = xp[i+1][1]; + pts[2] = xp[i+1][2]; + + dedans(pts, xc, yc, &na, *cs, asc); + if (fabs(na + 9999) > 0.000000001) + k = 1; + } + freevec(dobs); + freeintvec(index); } - k = 0; - while (k == 0) { - /* Distance échantillonnée */ - r = (int) (alea() * 100); - getpermutation(index, j * r); - dech = dobs[index[1]]; - - /* Angles échantillonnés */ - getpermutation(indangles, j * r); - anglech = angles[indangles[1]]; - - /* mise à jour des angles */ - ang = (ang + anglech); - - /* calcul des nouvelles coordonnées */ - xp[i+1][1] = xp[i][1] + dech * cos(ang); - xp[i+1][2] = xp[i][2] + dech * sin(ang); - - pts[1] = xp[i+1][1]; - pts[2] = xp[i+1][2]; - - dedans(pts, xc, yc, &na, *cs, asc); - if (fabs(na + 9999) > 0.000000001) - k = 1; - } - freevec(dobs); - freeintvec(index); - } - - freeintvec(indangles); - freevec(pts); + /* Free memory */ + freeintvec(indangles); + freevec(pts); } -/* Vérification de rpath sous R */ + + + +/* Test of rpath with R */ void randpath(double *xpr, double *rcrx, double *rcry, double *ascr, double *xcr, double *ycr, double *csr, double *tabdistr, double *dtr, double *anglesr, int *nlasc, int *ncasc, int *nltdr, int *nlocsr) { - /* déclaration de variables */ - int i, j, k, r, nlocs, nltd; - double **xp, *rcx, *rcy, **asc, **tabdist, *dt, *angles; - double *xc,*yc, cs; - - /* allocation de mémoire et définition des constantes */ - nlocs = *nlocsr; - nltd = *nltdr; - cs = *csr; - - taballoc(&xp, nlocs, 2); - vecalloc(&rcx, 2); - vecalloc(&rcy, 2); - taballoc(&asc, *nlasc, *ncasc); - vecalloc(&xc, *nlasc); - vecalloc(&yc, *ncasc); - taballoc(&tabdist, nltd, 2); - vecalloc(&dt, nlocs-1); - vecalloc(&angles, nlocs-2); - - /* remplissage des variables locales */ - k = 0; - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= 2; j++) { - xp[i][j] = xpr[k]; - k++; + /* declaration of the variables */ + int i, j, k, r, nlocs, nltd; + double **xp, *rcx, *rcy, **asc, **tabdist, *dt, *angles; + double *xc,*yc, cs; + + /* Memory allocation */ + nlocs = *nlocsr; + nltd = *nltdr; + cs = *csr; + + taballoc(&xp, nlocs, 2); + vecalloc(&rcx, 2); + vecalloc(&rcy, 2); + taballoc(&asc, *nlasc, *ncasc); + vecalloc(&xc, *nlasc); + vecalloc(&yc, *ncasc); + taballoc(&tabdist, nltd, 2); + vecalloc(&dt, nlocs-1); + vecalloc(&angles, nlocs-2); + + /* R to C */ + k = 0; + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= 2; j++) { + xp[i][j] = xpr[k]; + k++; + } } - } - rcx[1] = rcrx[0]; - rcx[2] = rcrx[1]; - rcy[1] = rcry[0]; - rcy[2] = rcry[1]; - - k = 0; - for (i = 1; i <= *nlasc; i++) { - for (j = 1; j <= *ncasc; j++) { - asc[i][j] = ascr[k]; - k++; + rcx[1] = rcrx[0]; + rcx[2] = rcrx[1]; + rcy[1] = rcry[0]; + rcy[2] = rcry[1]; + + k = 0; + for (i = 1; i <= *nlasc; i++) { + for (j = 1; j <= *ncasc; j++) { + asc[i][j] = ascr[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= nltd; i++) { - for (j = 1; j <= 2; j++) { - tabdist[i][j] = tabdistr[k]; - k++; + + k = 0; + for (i = 1; i <= nltd; i++) { + for (j = 1; j <= 2; j++) { + tabdist[i][j] = tabdistr[k]; + k++; + } } - } - - for (i = 1; i <= (nlocs - 1); i++) { - dt[i] = dtr[i-1]; - } - for (i = 1; i <= *nlasc; i++) { - xc[i] = xcr[i-1]; - } - for (i = 1; i <= *ncasc; i++) { - yc[i] = ycr[i-1]; - } - for (i = 1; i <= (nlocs - 2); i++) { - angles[i] = anglesr[i-1]; - } - - r = 1; - rpath(xp, rcx, rcy, asc, tabdist, dt, angles, - xc, yc, &cs, r); - - /* sortie de xp vers r */ - k = 0; - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= 2; j++) { - xpr[k] = xp[i][j]; - k++; + + for (i = 1; i <= (nlocs - 1); i++) { + dt[i] = dtr[i-1]; } - } - - /* vidage de la mémoire */ - freetab(xp); - freevec(rcx); - freevec(rcy); - freetab(asc); - freetab(tabdist); - freevec(dt); - freevec(angles); - freevec(xc); - freevec(yc); + for (i = 1; i <= *nlasc; i++) { + xc[i] = xcr[i-1]; + } + for (i = 1; i <= *ncasc; i++) { + yc[i] = ycr[i-1]; + } + for (i = 1; i <= (nlocs - 2); i++) { + angles[i] = anglesr[i-1]; + } + + /* test of randpath */ + r = 1; + rpath(xp, rcx, rcy, asc, tabdist, dt, angles, + xc, yc, &cs, r); + + /* R to C */ + k = 0; + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= 2; j++) { + xpr[k] = xp[i][j]; + k++; + } + } + + /* Free memory */ + freetab(xp); + freevec(rcx); + freevec(rcy); + freetab(asc); + freetab(tabdist); + freevec(dt); + freevec(angles); + freevec(xc); + freevec(yc); } @@ -4485,10 +4650,10 @@ void randpath(double *xpr, double *rcrx, double *rcry, double *ascr, /* **************************************************************** * * - * joinkasc est l'équivalent de join.kasc sous R. * - * On donne un tableau de points, un objet kasc, et on * - * obtient un tableau qui donne la composition des cartes * - * sous chaque point (dans res). * + * joinkasc is the equivalent of join.kasc in R. * + * Given a tableau of points, an object kasc, and one obtains * + * a table giving the composition of the map inder each point * + * (in res). * * * **************************************************************** */ @@ -4524,68 +4689,74 @@ void joinkascr(double *xpr, double *kascr, int *nlasc, int *ncasc, double *xcr, double *ycr, double *cs, int *nlocs, int *nvar, double *resr) { - int i,j,k; - double **xp, **kasc, **res, *xc, *yc, cellsize; - - taballoc(&xp, *nlocs, 2); - taballoc(&res, *nlocs, *nvar); - taballoc(&kasc, (*nlasc) * (*ncasc), *nvar); - vecalloc(&xc, *nlasc); - vecalloc(&yc, *ncasc); - cellsize = *cs; - - for (i = 1; i <= *nlasc; i++) { - xc[i] = xcr[i-1]; - } - for (i = 1; i <= *ncasc; i++) { - yc[i] = ycr[i-1]; - } - k = 0; - for (i = 1; i <= ((*nlasc) * (*ncasc)); i++) { - for (j = 1; j <= *nvar; j++) { - kasc[i][j] = kascr[k]; - k++; + /* Declaration */ + int i,j,k; + double **xp, **kasc, **res, *xc, *yc, cellsize; + + /* Memory allocation */ + taballoc(&xp, *nlocs, 2); + taballoc(&res, *nlocs, *nvar); + taballoc(&kasc, (*nlasc) * (*ncasc), *nvar); + vecalloc(&xc, *nlasc); + vecalloc(&yc, *ncasc); + cellsize = *cs; + + /* R to C */ + for (i = 1; i <= *nlasc; i++) { + xc[i] = xcr[i-1]; } - } - k = 0; - for (i = 1; i <= *nlocs; i++) { - for (j = 1; j <= 2; j++) { - xp[i][j] = xpr[k]; - k++; + for (i = 1; i <= *ncasc; i++) { + yc[i] = ycr[i-1]; } - } - - joinkasc(xp, kasc, res, *nlasc, *ncasc, - xc, yc, &cellsize); - - k = 0; - for (i = 1; i <= *nlocs; i++) { - for (j = 1; j <= *nvar; j++) { - resr[k] = res[i][j]; - k++; + k = 0; + for (i = 1; i <= ((*nlasc) * (*ncasc)); i++) { + for (j = 1; j <= *nvar; j++) { + kasc[i][j] = kascr[k]; + k++; + } } - } - - freetab(xp); - freetab(res); - freetab(kasc); - freevec(xc); - freevec(yc); + k = 0; + for (i = 1; i <= *nlocs; i++) { + for (j = 1; j <= 2; j++) { + xp[i][j] = xpr[k]; + k++; + } + } + + /* Call to joinkasc */ + joinkasc(xp, kasc, res, *nlasc, *ncasc, + xc, yc, &cellsize); + + /* R to C */ + k = 0; + for (i = 1; i <= *nlocs; i++) { + for (j = 1; j <= *nvar; j++) { + resr[k] = res[i][j]; + k++; + } + } + + /* Free memory */ + freetab(xp); + freetab(res); + freetab(kasc); + freevec(xc); + freevec(yc); } + /* **************************************************************** * * - * Fonction permettant de randomiser un trajet, sur la base * - * de distances interlocs, et de temps entre les locs, * - * ainsi que d'angles tirés de façon indépendante. * - * Randomisation dans l'espace écologique (retourne * - * marginalité et tolérance. * + * Function allowing the randomization of a traject, based on * + * The distance and time lag between successive relocations * + * and angles between successive steps, randomly drawn * + * Randomization in the ecological space (measure marginality * + * and tolerance) * * * **************************************************************** */ - void randmargtol(double *xpr, double *rcrx, double *rcry, double *ascr, double *cwr, double *kascr, double *xcr, double *ycr, double *csr, @@ -4593,216 +4764,221 @@ void randmargtol(double *xpr, double *rcrx, double *rcry, double *ascr, double *tolr, int *nrepr, int *nlasc, int *ncasc, int *nvarr, int *nltdr, int *nlocsr) { - /* déclaration de variables */ - int i, j, k, nr, r, nlocs, nltd, nvar; - double **xp, *rcx, *rcy, **asc, **kasc, **tabdist, *dt, *angles; - double *cw, *xc,*yc, cellsize, **res, *mar, *tol; - - /* allocation de mémoire et définition des constantes */ - nr = *nrepr; - nlocs = *nlocsr; - nltd = *nltdr; - nvar = *nvarr; - cellsize = *csr; - - taballoc(&xp, nlocs, 2); - taballoc(&res, nlocs, nvar); - vecalloc(&rcx, 2); - vecalloc(&rcy, 2); - vecalloc(&mar, nvar); - vecalloc(&tol, nvar); - taballoc(&asc, *nlasc, *ncasc); - taballoc(&kasc, (*nlasc)*(*ncasc), nvar); - vecalloc(&cw, nvar); - vecalloc(&xc, *nlasc); - vecalloc(&yc, *ncasc); - taballoc(&tabdist, nltd, 2); - vecalloc(&dt, nlocs-1); - vecalloc(&angles, nlocs-2); - - /* remplissage des variables locales */ - k = 0; - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= 2; j++) { - xp[i][j] = xpr[k]; - k++; + /* declaration of variables */ + int i, j, k, nr, r, nlocs, nltd, nvar; + double **xp, *rcx, *rcy, **asc, **kasc, **tabdist, *dt, *angles; + double *cw, *xc,*yc, cellsize, **res, *mar, *tol; + + /* Memory allocation */ + nr = *nrepr; + nlocs = *nlocsr; + nltd = *nltdr; + nvar = *nvarr; + cellsize = *csr; + + taballoc(&xp, nlocs, 2); + taballoc(&res, nlocs, nvar); + vecalloc(&rcx, 2); + vecalloc(&rcy, 2); + vecalloc(&mar, nvar); + vecalloc(&tol, nvar); + taballoc(&asc, *nlasc, *ncasc); + taballoc(&kasc, (*nlasc)*(*ncasc), nvar); + vecalloc(&cw, nvar); + vecalloc(&xc, *nlasc); + vecalloc(&yc, *ncasc); + taballoc(&tabdist, nltd, 2); + vecalloc(&dt, nlocs-1); + vecalloc(&angles, nlocs-2); + + /* R to C */ + k = 0; + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= 2; j++) { + xp[i][j] = xpr[k]; + k++; + } } - } - rcx[1] = rcrx[0]; - rcx[2] = rcrx[1]; - rcy[1] = rcry[0]; - rcy[2] = rcry[1]; - - k = 0; - for (i = 1; i <= *nlasc; i++) { - for (j = 1; j <= *ncasc; j++) { - asc[i][j] = ascr[k]; - k++; + rcx[1] = rcrx[0]; + rcx[2] = rcrx[1]; + rcy[1] = rcry[0]; + rcy[2] = rcry[1]; + + k = 0; + for (i = 1; i <= *nlasc; i++) { + for (j = 1; j <= *ncasc; j++) { + asc[i][j] = ascr[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= ((*nlasc)*(*ncasc)); i++) { - for (j = 1; j <= nvar; j++) { - kasc[i][j] = kascr[k]; - k++; + + k = 0; + for (i = 1; i <= ((*nlasc)*(*ncasc)); i++) { + for (j = 1; j <= nvar; j++) { + kasc[i][j] = kascr[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= nltd; i++) { - for (j = 1; j <= 2; j++) { - tabdist[i][j] = tabdistr[k]; - k++; + + k = 0; + for (i = 1; i <= nltd; i++) { + for (j = 1; j <= 2; j++) { + tabdist[i][j] = tabdistr[k]; + k++; + } } - } - - for (i = 1; i <= (nlocs - 1); i++) { - dt[i] = dtr[i-1]; - } - for (i = 1; i <= nvar; i++) { - cw[i] = cwr[i-1]; - } - for (i = 1; i <= *nlasc; i++) { - xc[i] = xcr[i-1]; - } - for (i = 1; i <= *ncasc; i++) { - yc[i] = ycr[i-1]; - } - for (i = 1; i <= (nlocs - 2); i++) { - angles[i] = anglesr[i-1]; - } - - /* Calcul des valeurs observées pour la marginalité et la tolérance */ - /* on fait une jointure sur les cartes */ - joinkasc(xp, kasc, res, *nlasc, *ncasc, - xc, yc, &cellsize); - - /* remise à 0 des vecteurs mar et tol */ - for (j = 1; j <= nvar; j++) { - mar[j] = 0; - tol[j] = 0; - } - - /* 1. Calcul des moyennes */ - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; + + for (i = 1; i <= (nlocs - 1); i++) { + dt[i] = dtr[i-1]; } - } - /* 2. Centrage du tableau res */ - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - res[i][j] = res[i][j] - mar[j]; + for (i = 1; i <= nvar; i++) { + cw[i] = cwr[i-1]; } - } - /* 3. Calcul des variances */ - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; + for (i = 1; i <= *nlasc; i++) { + xc[i] = xcr[i-1]; } - } - /* 4. Calcul de la tolérance et de la marginalité */ - for (j = 1; j <= nvar; j++) { - marr[0] = marr[0] + (mar[j] * mar[j] * cw[j]); - tolr[0] = tolr[0] + (tol[j] * cw[j]); - } - - /* Début de la boucle des répétitions */ - for (r = 2; r <= nr; r++) { - /* on génère le trajet */ - rpath(xp, rcx, rcy, asc, tabdist, dt, angles, xc, yc, - &cellsize, r); - /* on fait une jointure sur les cartes */ + for (i = 1; i <= *ncasc; i++) { + yc[i] = ycr[i-1]; + } + for (i = 1; i <= (nlocs - 2); i++) { + angles[i] = anglesr[i-1]; + } + + /* observed marginality and tolerance */ + /* spatial join */ joinkasc(xp, kasc, res, *nlasc, *ncasc, xc, yc, &cellsize); - /* remise à 0 des vecteurs mar et tol */ + /* sets to 0 the vectors mar and tol */ for (j = 1; j <= nvar; j++) { - mar[j] = 0; - tol[j] = 0; + mar[j] = 0; + tol[j] = 0; } - /* 1. Calcul des moyennes */ + /* 1. the means */ for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; - } + for (j = 1; j <= nvar; j++) { + mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; + } } - /* 2. Centrage du tableau res */ + /* 2. Centring of the table res */ for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - res[i][j] = res[i][j] - mar[j]; - } + for (j = 1; j <= nvar; j++) { + res[i][j] = res[i][j] - mar[j]; + } } - /* 3. Calcul des variances */ + /* 3. The variances */ for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; - } + for (j = 1; j <= nvar; j++) { + tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; + } } - /* 4. Calcul de la tolérance et de la marginalité */ + /* 4. the tolerance and marginality */ for (j = 1; j <= nvar; j++) { - marr[r-1] = marr[r-1] + (mar[j] * mar[j] * cw[j]); - tolr[r-1] = tolr[r-1] + (tol[j] * cw[j]); + marr[0] = marr[0] + (mar[j] * mar[j] * cw[j]); + tolr[0] = tolr[0] + (tol[j] * cw[j]); } - } - - - - - /* vidage de la mémoire */ - freetab(xp); - freevec(rcx); - freevec(rcy); - freevec(mar); - freevec(tol); - freetab(asc); - freetab(kasc); - freetab(tabdist); - freevec(dt); - freevec(angles); - freevec(cw); - freevec(xc); - freevec(yc); + + /* Beginning of the randomization process */ + for (r = 2; r <= nr; r++) { + /* creates a traject */ + rpath(xp, rcx, rcy, asc, tabdist, dt, angles, xc, yc, + &cellsize, r); + /* spatial join */ + joinkasc(xp, kasc, res, *nlasc, *ncasc, + xc, yc, &cellsize); + + /* sets to 0 the vectors mar and tol */ + for (j = 1; j <= nvar; j++) { + mar[j] = 0; + tol[j] = 0; + } + + /* 1. The means */ + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= nvar; j++) { + mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; + } + } + /* 2. Centring of the table res */ + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= nvar; j++) { + res[i][j] = res[i][j] - mar[j]; + } + } + /* 3. The variances */ + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= nvar; j++) { + tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; + } + } + /* 4. tolerance and marginality */ + for (j = 1; j <= nvar; j++) { + marr[r-1] = marr[r-1] + (mar[j] * mar[j] * cw[j]); + tolr[r-1] = tolr[r-1] + (tol[j] * cw[j]); + } + } + + + + + /* Free memory */ + freetab(xp); + freevec(rcx); + freevec(rcy); + freevec(mar); + freevec(tol); + freetab(asc); + freetab(kasc); + freetab(tabdist); + freevec(dt); + freevec(angles); + freevec(cw); + freevec(xc); + freevec(yc); } /* **************************************************************** * * - * Fonction permettant de randomiser la position de locs * - * sur une zone de façon indépendantes * + * Function allowing the randomization of the relocations on * + * on an area independently * * * **************************************************************** */ void rpoint(double **xp, double *rcx, double *rcy, double **asc, double *xc, double *yc, double *cs) { - int i, k, nlocs; - double *pts, na; - - vecalloc(&pts, 2); - nlocs = xp[0][0]; - - for (i = 1; i <= nlocs; i++) { - k=0; - while (k==0) { - - /* Tirage au sort des coordonnées de la locs */ - xp[i][1] = (alea())*(rcx[2]-rcx[1]) + rcx[1]; - xp[i][2] = (alea())*(rcy[2]-rcy[1]) + rcy[1]; - - pts[1] = xp[i][1]; - pts[2] = xp[i][2]; - - /* Vérifie que la loc tombe bien dans la zone d'étude */ - dedans(pts, xc, yc, &na, *cs, asc); - if (fabs(na + 9999) > 0.000000001) - k = 1; - + /* Declaration */ + int i, k, nlocs; + double *pts, na; + + /* Memory allocation */ + vecalloc(&pts, 2); + nlocs = xp[0][0]; + + /* For each loc */ + for (i = 1; i <= nlocs; i++) { + k=0; + while (k==0) { + + /* Random draw of the coordinates of the locs */ + xp[i][1] = (alea())*(rcx[2]-rcx[1]) + rcx[1]; + xp[i][2] = (alea())*(rcy[2]-rcy[1]) + rcy[1]; + + pts[1] = xp[i][1]; + pts[2] = xp[i][2]; + + /* Is the loc in the study area? */ + dedans(pts, xc, yc, &na, *cs, asc); + if (fabs(na + 9999) > 0.000000001) + k = 1; + + } } - } + + /* Free memory */ freevec(pts); } @@ -4811,396 +4987,401 @@ void rpoint(double **xp, double *rcx, double *rcy, double **asc, /* **************************************************************** * * - * Fonction identique à randmargtol, mais au lieu de * - * randomiser des trajets, on randomise des locs. * + * Function similar to randmargtol, but randomises locs * + * instead of trajects * * * **************************************************************** */ void randmargtolpts(double *xpr, double *rcrx, double *rcry, double *ascr, double *cwr, double *kascr, double *xcr, double *ycr, - double *csr, double *marr, double *tolr, int *nrepr, int *nlasc, + double *csr, double *marr, double *tolr, + int *nrepr, int *nlasc, int *ncasc, int *nvarr, int *nlocsr) { - /* déclaration de variables */ - int i, j, k, nr, r, nlocs, nvar; - double **xp, *rcx, *rcy, **asc, **kasc; - double *cw, *xc,*yc, cellsize, **res, *mar, *tol; - - /* allocation de mémoire et définition des constantes */ - nr = *nrepr; - nlocs = *nlocsr; - nvar = *nvarr; - cellsize = *csr; - - taballoc(&xp, nlocs, 2); - taballoc(&res, nlocs, nvar); - vecalloc(&rcx, 2); - vecalloc(&rcy, 2); - vecalloc(&mar, nvar); - vecalloc(&tol, nvar); - taballoc(&asc, *nlasc, *ncasc); - taballoc(&kasc, (*nlasc)*(*ncasc), nvar); - vecalloc(&cw, nvar); - vecalloc(&xc, *nlasc); - vecalloc(&yc, *ncasc); - - /* remplissage des variables locales */ - k = 0; - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= 2; j++) { - xp[i][j] = xpr[k]; - k++; + /* declaration of variables */ + int i, j, k, nr, r, nlocs, nvar; + double **xp, *rcx, *rcy, **asc, **kasc; + double *cw, *xc,*yc, cellsize, **res, *mar, *tol; + + /* Memory allocation */ + nr = *nrepr; + nlocs = *nlocsr; + nvar = *nvarr; + cellsize = *csr; + + taballoc(&xp, nlocs, 2); + taballoc(&res, nlocs, nvar); + vecalloc(&rcx, 2); + vecalloc(&rcy, 2); + vecalloc(&mar, nvar); + vecalloc(&tol, nvar); + taballoc(&asc, *nlasc, *ncasc); + taballoc(&kasc, (*nlasc)*(*ncasc), nvar); + vecalloc(&cw, nvar); + vecalloc(&xc, *nlasc); + vecalloc(&yc, *ncasc); + + /* R to C */ + k = 0; + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= 2; j++) { + xp[i][j] = xpr[k]; + k++; + } } - } - rcx[1] = rcrx[0]; - rcx[2] = rcrx[1]; - rcy[1] = rcry[0]; - rcy[2] = rcry[1]; - - k = 0; - for (i = 1; i <= *nlasc; i++) { - for (j = 1; j <= *ncasc; j++) { - asc[i][j] = ascr[k]; - k++; + rcx[1] = rcrx[0]; + rcx[2] = rcrx[1]; + rcy[1] = rcry[0]; + rcy[2] = rcry[1]; + + k = 0; + for (i = 1; i <= *nlasc; i++) { + for (j = 1; j <= *ncasc; j++) { + asc[i][j] = ascr[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= ((*nlasc)*(*ncasc)); i++) { - for (j = 1; j <= nvar; j++) { - kasc[i][j] = kascr[k]; - k++; + + k = 0; + for (i = 1; i <= ((*nlasc)*(*ncasc)); i++) { + for (j = 1; j <= nvar; j++) { + kasc[i][j] = kascr[k]; + k++; + } } - } - - for (i = 1; i <= nvar; i++) { - cw[i] = cwr[i-1]; - } - for (i = 1; i <= *nlasc; i++) { - xc[i] = xcr[i-1]; - } - for (i = 1; i <= *ncasc; i++) { - yc[i] = ycr[i-1]; - } - - /* Calcul des valeurs observées pour la marginalité et la tolérance */ - /* on fait une jointure sur les cartes */ - joinkasc(xp, kasc, res, *nlasc, *ncasc, - xc, yc, &cellsize); - - /* remise à 0 des vecteurs mar et tol */ - for (j = 1; j <= nvar; j++) { - mar[j] = 0; - tol[j] = 0; - } - - /* 1. Calcul des moyennes */ - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; + + for (i = 1; i <= nvar; i++) { + cw[i] = cwr[i-1]; } - } - /* 2. Centrage du tableau res */ - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - res[i][j] = res[i][j] - mar[j]; + for (i = 1; i <= *nlasc; i++) { + xc[i] = xcr[i-1]; } - } - /* 3. Calcul des variances */ - for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; + for (i = 1; i <= *ncasc; i++) { + yc[i] = ycr[i-1]; } - } - /* 4. Calcul de la tolérance et de la marginalité */ - for (j = 1; j <= nvar; j++) { - marr[0] = marr[0] + (mar[j] * mar[j] * cw[j]); - tolr[0] = tolr[0] + (tol[j] * cw[j]); - } - - /* Début de la boucle des répétitions */ - for (r = 2; r <= nr; r++) { - /* on génère le trajet */ - rpoint(xp, rcx, rcy, asc, xc, yc, &cellsize); - /* on fait une jointure sur les cartes */ + + /* Computation of observed values for maginality and tolerance */ + /* spatial join */ joinkasc(xp, kasc, res, *nlasc, *ncasc, xc, yc, &cellsize); - /* remise à 0 des vecteurs mar et tol */ + /* sets to 0 the vectors mar and tol */ for (j = 1; j <= nvar; j++) { - mar[j] = 0; - tol[j] = 0; + mar[j] = 0; + tol[j] = 0; } - /* 1. Calcul des moyennes */ + /* 1. the means */ for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; - } + for (j = 1; j <= nvar; j++) { + mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; + } } - /* 2. Centrage du tableau res */ + /* 2. Centring of the table res */ for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - res[i][j] = res[i][j] - mar[j]; - } + for (j = 1; j <= nvar; j++) { + res[i][j] = res[i][j] - mar[j]; + } } - /* 3. Calcul des variances */ + /* 3. The variances */ for (i = 1; i <= nlocs; i++) { - for (j = 1; j <= nvar; j++) { - tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; - } + for (j = 1; j <= nvar; j++) { + tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; + } } - /* 4. Calcul de la tolérance et de la marginalité */ + /* 4. tolerance and marginality */ for (j = 1; j <= nvar; j++) { - marr[r-1] = marr[r-1] + (mar[j] * mar[j] * cw[j]); - tolr[r-1] = tolr[r-1] + (tol[j] * cw[j]); + marr[0] = marr[0] + (mar[j] * mar[j] * cw[j]); + tolr[0] = tolr[0] + (tol[j] * cw[j]); } - } - - /* vidage de la mémoire */ - freetab(xp); - freevec(rcx); - freevec(rcy); - freevec(mar); - freevec(tol); - freetab(asc); - freetab(kasc); - freevec(cw); - freevec(xc); - freevec(yc); + + /* Beginning of the randomization process */ + for (r = 2; r <= nr; r++) { + /* creates the locs */ + rpoint(xp, rcx, rcy, asc, xc, yc, &cellsize); + /* spatial join */ + joinkasc(xp, kasc, res, *nlasc, *ncasc, + xc, yc, &cellsize); + + /* sets to 0 the vectors mar and tol */ + for (j = 1; j <= nvar; j++) { + mar[j] = 0; + tol[j] = 0; + } + + /* 1. the means */ + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= nvar; j++) { + mar[j] = mar[j] + (1 /((double) nlocs)) * res[i][j]; + } + } + /* 2. Centring of the table res */ + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= nvar; j++) { + res[i][j] = res[i][j] - mar[j]; + } + } + /* 3. The variances */ + for (i = 1; i <= nlocs; i++) { + for (j = 1; j <= nvar; j++) { + tol[j] = tol[j] + (1 /((double) nlocs)) * res[i][j] * res[i][j]; + } + } + /* 4. The tolerance and the marginality */ + for (j = 1; j <= nvar; j++) { + marr[r-1] = marr[r-1] + (mar[j] * mar[j] * cw[j]); + tolr[r-1] = tolr[r-1] + (tol[j] * cw[j]); + } + } + + /* Free memory */ + freetab(xp); + freevec(rcx); + freevec(rcy); + freevec(mar); + freevec(tol); + freetab(asc); + freetab(kasc); + freevec(cw); + freevec(xc); + freevec(yc); } /* ******************************************************************** * * - * Diminution de la résolution d'une carte * + * Diminish the resolution of a map * * * * ******************************************************************** */ -/* Pour les cartes facteurs */ +/* For factor maps */ void regroufacasc(double **asce, double **ascs, int *np, int *nlev) { - /* déclaration de variables */ - int i, j, k, l, m, dr, fr, dc, fc, nre, nrs, nce, ncs, nl, *ll, max, vm, na, *vecmax; - nre = asce[0][0]; - nrs = ascs[0][0]; - nce = asce[1][0]; - ncs = ascs[1][0]; - nl = *nlev; - vecintalloc(&ll, nl); - - /* boucle de gommage */ - for (i = 1; i <= nrs; i++) { - for (j = 1; j <= ncs; j++) { - - /* extraction du sous - tableau correspondant */ - dr = (i-1)*(*np) + 1; - fr = i*(*np); - dc = (j-1)*(*np) + 1; - fc = j*(*np); - - /* On vide ll */ - for (m = 1; m <= nl; m++) { - ll[m] = 0; - } - - /* On compte le nombre de niveaux */ - na = 0; - for (k = dr; k <= fr; k++) { - for (l = dc; l <= fc; l++) { - if (fabs(asce[k][l] + 9999) > 0.000000001) - ll[(int) asce[k][l]]++; - if (fabs(asce[k][l] + 9999) < 0.000000001) - na++; - } - } - - if (na != (*np)*(*np)) { - /* On calcule le nombre max */ - vm = ll[1]; - for (k = 2; k <= nl; k++) { - if (ll[k] >= vm) { - vm = ll[k]; - } - } - - /* ... et le nombre DE max */ - max = 0; - for (k = 1; k <= nl; k++) { - if (ll[k] == vm) { - max++; - } - } - - /* on isole les niveaux dont le nombre est max */ - vecintalloc(&vecmax, max); - l = 1; - for (k = 1; k<=nl; k++) { - if (ll[k] == vm) { - vecmax[1] = k; - } - } - - /* Echantillonnage aléatoire - des niveaux en cas d'égalité */ - if (max > 1) { - getpermutation(vecmax, i*j); /* tirage au sort ligne */ + /* declaration of variables */ + int i, j, k, l, m, dr, fr, dc, fc, nre, nrs; + int nce, ncs, nl, *ll, max, vm, na, *vecmax; + + /* Memory allocation */ + nre = asce[0][0]; + nrs = ascs[0][0]; + nce = asce[1][0]; + ncs = ascs[1][0]; + nl = *nlev; + vecintalloc(&ll, nl); + + /* loop to delete */ + for (i = 1; i <= nrs; i++) { + for (j = 1; j <= ncs; j++) { + + /* extracts the corresponding subtable */ + dr = (i-1)*(*np) + 1; + fr = i*(*np); + dc = (j-1)*(*np) + 1; + fc = j*(*np); + + /* empty ll */ + for (m = 1; m <= nl; m++) { + ll[m] = 0; + } + + /* One numbers the levels */ + na = 0; + for (k = dr; k <= fr; k++) { + for (l = dc; l <= fc; l++) { + if (fabs(asce[k][l] + 9999) > 0.000000001) + ll[(int) asce[k][l]]++; + if (fabs(asce[k][l] + 9999) < 0.000000001) + na++; + } + } + + if (na != (*np)*(*np)) { + /* One computes the maximum number */ + vm = ll[1]; + for (k = 2; k <= nl; k++) { + if (ll[k] >= vm) { + vm = ll[k]; + } + } + + /* ... and the number OF max */ + max = 0; + for (k = 1; k <= nl; k++) { + if (ll[k] == vm) { + max++; + } + } + + /* one identifies the levels for which the number is max */ + vecintalloc(&vecmax, max); + l = 1; + for (k = 1; k<=nl; k++) { + if (ll[k] == vm) { + vecmax[1] = k; + } + } + + /* Random sample of the levels in case of equality */ + if (max > 1) { + getpermutation(vecmax, i*j); /* random row */ + } + ascs[i][j] = (double) vecmax[1]; + freeintvec(vecmax); + } else { + ascs[i][j] = -9999; + } + } - ascs[i][j] = (double) vecmax[1]; - freeintvec(vecmax); - } else { - ascs[i][j] = -9999; - } - } - } - freeintvec(ll); + /* free memory */ + freeintvec(ll); } -/* Regroufacasc version R */ +/* Regroufacasc version for R */ void regroufacascr(double *ascer, double *ascsr, int *npr, int *nlevr, int *nle, int *nce, int *nls, int *ncs) { - /* Déclaration des variables */ - int i,j,k, np, nlev; - double **asce, **ascs; - - /* Allocation de mémoire */ - np = *npr; - nlev = *nlevr; - taballoc(&asce, *nle, *nce); - taballoc(&ascs, *nls, *ncs); - - /* remplissage des tableaux */ - k =0; - for (i = 1; i <= *nle; i++) { - for (j = 1; j <= *nce; j++) { - asce[i][j] = ascer[k]; - k++; + /* Declaration of the variables */ + int i,j,k, np, nlev; + double **asce, **ascs; + + /* Memory Allocation */ + np = *npr; + nlev = *nlevr; + taballoc(&asce, *nle, *nce); + taballoc(&ascs, *nls, *ncs); + + /* R to C */ + k =0; + for (i = 1; i <= *nle; i++) { + for (j = 1; j <= *nce; j++) { + asce[i][j] = ascer[k]; + k++; + } } - } - - /* fonction */ - regroufacasc(asce, ascs, &np, &nlev); - - k =0; - for (i = 1; i <= *nls; i++) { - for (j = 1; j <= *ncs; j++) { - ascsr[k] = ascs[i][j]; - k++; + + /* function */ + regroufacasc(asce, ascs, &np, &nlev); + + k =0; + for (i = 1; i <= *nls; i++) { + for (j = 1; j <= *ncs; j++) { + ascsr[k] = ascs[i][j]; + k++; + } } - } - - /* libération de la mémoire */ - freetab(asce); - freetab(ascs); + + /* Free memory */ + freetab(asce); + freetab(ascs); } -/* regrouascnum pour les cartes numériques */ +/* regrouascnum for numeric maps */ void regrouascnum(double **ascent, double **ascso) { - int i, j, k, l, n, nle, nls, nce, ncs, nreg; - double moy, tmp; - - /* définition des variables */ - nle = ascent[0][0]; - nce = ascent[1][0]; - nls = ascso[0][0]; - ncs = ascso[1][0]; - nreg = nle/nls; - - for (i = 1; i <= nls; i++) { - for (j = 1; j <= ncs; j++) { - moy = 0; - n = 0; - for (k = 1; k <= nreg; k++) { - for (l = 1; l <= nreg; l++) { - tmp = ascent[((i - 1) * nreg) + k][((j - 1) * nreg) + l]; - if (fabs(tmp + 9999) > 0.000000001) { - moy = tmp + moy; - } - if (fabs(tmp + 9999) < 0.000000001) { - n++; - } + /* Declaration */ + int i, j, k, l, n, nle, nls, nce, ncs, nreg; + double moy, tmp; + + /* Definition of the variables */ + nle = ascent[0][0]; + nce = ascent[1][0]; + nls = ascso[0][0]; + ncs = ascso[1][0]; + nreg = nle/nls; + + /* Computes the mean */ + for (i = 1; i <= nls; i++) { + for (j = 1; j <= ncs; j++) { + moy = 0; + n = 0; + for (k = 1; k <= nreg; k++) { + for (l = 1; l <= nreg; l++) { + tmp = ascent[((i - 1) * nreg) + k][((j - 1) * nreg) + l]; + if (fabs(tmp + 9999) > 0.000000001) { + moy = tmp + moy; + } + if (fabs(tmp + 9999) < 0.000000001) { + n++; + } + } + } + if (n == (nreg * nreg)) { + ascso[i][j] = -9999; + } else { + ascso[i][j] = moy / (((double) (nreg * nreg))- ((double) n)); + + } } - } - if (n == (nreg * nreg)) { - ascso[i][j] = -9999; - } else { - ascso[i][j] = moy / (((double) (nreg * nreg))- ((double) n)); - - } } - } - } -/* Version pour R */ +/* Version for R */ void regrouascnumr(double *ascentr, double *ascsor, double *nler, double *ncer, double *nlsr, double *ncsr) { - /* Définition de variables */ - int i, j, k, nle, nce, nls, ncs; - double **ascent, **ascso; - - /* Allocation de mémoire */ - nle = *nler; - nce = *ncer; - nls = *nlsr; - ncs = *ncsr; - - taballoc(&ascent, nle, nce); - taballoc(&ascso, nls, ncs); + /* Declaration of variables */ + int i, j, k, nle, nce, nls, ncs; + double **ascent, **ascso; + + /* Memory Allocation */ + nle = *nler; + nce = *ncer; + nls = *nlsr; + ncs = *ncsr; + + taballoc(&ascent, nle, nce); + taballoc(&ascso, nls, ncs); - /* remplissage des variables locales C */ - k = 0; - for (i = 1; i <= nle; i++) { - for (j = 1; j <= nce; j++) { - ascent[i][j] = ascentr[k]; - k++; + + /* R to C */ + k = 0; + for (i = 1; i <= nle; i++) { + for (j = 1; j <= nce; j++) { + ascent[i][j] = ascentr[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= nls; i++) { - for (j = 1; j <= ncs; j++) { - ascso[i][j] = ascsor[k]; - k++; + + k = 0; + for (i = 1; i <= nls; i++) { + for (j = 1; j <= ncs; j++) { + ascso[i][j] = ascsor[k]; + k++; + } } - } - - /* procédure C */ - regrouascnum(ascent, ascso); - - /* Retour vers R */ - k = 0; - for (i = 1; i <= nls; i++) { - for (j = 1; j <= ncs; j++) { - ascsor[k] = ascso[i][j]; - k++; + + /* procedure C */ + regrouascnum(ascent, ascso); + + /* C to R */ + k = 0; + for (i = 1; i <= nls; i++) { + for (j = 1; j <= ncs; j++) { + ascsor[k] = ascso[i][j]; + k++; + } } - } - - /* On vide la mémoire */ - freetab(ascso); - freetab(ascent); + + /* Free memory */ + freetab(ascso); + freetab(ascent); } @@ -5210,9 +5391,8 @@ void regrouascnumr(double *ascentr, double *ascsor, double *nler, double *ncer, /* - Toutes les variables facteurs doivent - être étiquetées de 1 à n sans valeur manquantes - Version pour les objets kasc + All the factors should be labelled from 1 to n, without missing + values. Version for the objects of class kasc */ @@ -5220,82 +5400,81 @@ void regroukasc(double *kascr, double *kascniou, int *nrow, int *ncol, int *nvar, int *npix, int *typer, int *nrniou, int *ncniou) { - /* déclaration de variables */ - double **kasc, **asc, **ascn, **kascn; - int i, j, k, l, nr, nc, nv, *typ, np, nrn, ncn, nl; - - - /* allocation de mémoire */ - nr = *nrow; - nc = *ncol; - nv = *nvar; - np = *npix; - nrn = *nrniou; - ncn = *ncniou; - - taballoc(&kasc, nr*nc, nv); - taballoc(&kascn, nrn*ncn, nv); - taballoc(&asc, nr, nc); - taballoc(&ascn, nrn, ncn); - vecintalloc(&typ, nv); - - /* passage de R à C */ - for (i = 1; i<=nv; i++) { - typ[i] = typer[i-1]; - } - - k = 0; - for (i=1; i<= (nc*nr); i++) { - for (j = 1; j<=nv; j++) { - kasc[i][j]=kascr[k]; - k++; + /* declaration of variables */ + double **kasc, **asc, **ascn, **kascn; + int i, j, k, l, nr, nc, nv, *typ, np, nrn, ncn, nl; + + + /* Memory allocation */ + nr = *nrow; + nc = *ncol; + nv = *nvar; + np = *npix; + nrn = *nrniou; + ncn = *ncniou; + + taballoc(&kasc, nr*nc, nv); + taballoc(&kascn, nrn*ncn, nv); + taballoc(&asc, nr, nc); + taballoc(&ascn, nrn, ncn); + vecintalloc(&typ, nv); + + /* R to C */ + for (i = 1; i<=nv; i++) { + typ[i] = typer[i-1]; } - } - - - /* boucle pour chaque carte */ - for (k=1; k<=nv; k++) { - getcarte(asc, kasc, &k); - if (typ[k] == 0) - regrouascnum(asc, ascn); - nl = 0; - if (typ[k] == 1) { - nl = (int) asc[1][1]; - /* On compte le nombre de niveaux du facteur */ - for (i = 1; i <= nr; i++) { - for (j = 1; j <= nc; j++) { - if (((int) asc[i][j]) > nl) - nl = (int) asc[i][j]; + + k = 0; + for (i=1; i<= (nc*nr); i++) { + for (j = 1; j<=nv; j++) { + kasc[i][j]=kascr[k]; + k++; } - } - - regroufacasc(asc, ascn, &np, &nl); } - l = 1; - for (j = 1; j <= nc; j++) { - for (i = 1; i <= nr; j++) { - kascn[l][k] = ascn[i][j]; - } + /* loop for each map */ + for (k=1; k<=nv; k++) { + getcarte(asc, kasc, &k); + if (typ[k] == 0) + regrouascnum(asc, ascn); + nl = 0; + if (typ[k] == 1) { + nl = (int) asc[1][1]; + /* One counts the number of levels of the factor */ + for (i = 1; i <= nr; i++) { + for (j = 1; j <= nc; j++) { + if (((int) asc[i][j]) > nl) + nl = (int) asc[i][j]; + } + } + regroufacasc(asc, ascn, &np, &nl); + } + + + l = 1; + for (j = 1; j <= nc; j++) { + for (i = 1; i <= nr; j++) { + kascn[l][k] = ascn[i][j]; + } + } } - } - - /* repassage sous R */ - k=0; - for (i = 1; i <= (nrn*ncn); i++) { - for (j = 1; j <= nv; j++) { - kascniou[k] = kascn[i][j]; - k++; + + /* C to R */ + k=0; + for (i = 1; i <= (nrn*ncn); i++) { + for (j = 1; j <= nv; j++) { + kascniou[k] = kascn[i][j]; + k++; + } } - } - - /* Libération de la mémoire */ - freetab(kasc); - freetab(asc); - freetab(kascn); - freetab(ascn); - freeintvec(typ); + + /* Free memory */ + freetab(kasc); + freetab(asc); + freetab(kascn); + freetab(ascn); + freeintvec(typ); } @@ -5305,93 +5484,96 @@ void regroukasc(double *kascr, double *kascniou, int *nrow, /* ******************************************* - Transformation d'une matrice carrée - symétrique en matrice à la puissance -1/2 - + Transformation of a square symetric matrix + into a matrix at the power -1/2 + ******************************************* */ void matmudemi(double **X, double **Y) { - /* Déclaration des variables */ - int i, j, nc, rg; - double **U, **L, *lambda, **Ubis, **Uter; - - /* Allocation de mémoire */ - nc = X[0][0]; - taballoc(&U, nc, nc); - taballoc(&Ubis, nc, nc); - taballoc(&Uter, nc, nc); - taballoc(&L, nc, nc); - vecalloc(&lambda, nc); - - /* Remplissage de Xtmp */ - for (i = 1; i <= nc; i++) { - for (j = 1; j <= nc; j++) { - U[i][j] = X[i][j]; + /* Declaration of the variables */ + int i, j, nc, rg; + double **U, **L, *lambda, **Ubis, **Uter; + + /* Memory Allocation */ + nc = X[0][0]; + taballoc(&U, nc, nc); + taballoc(&Ubis, nc, nc); + taballoc(&Uter, nc, nc); + taballoc(&L, nc, nc); + vecalloc(&lambda, nc); + + /* Fill Xtmp */ + for (i = 1; i <= nc; i++) { + for (j = 1; j <= nc; j++) { + U[i][j] = X[i][j]; + } } - } - - /* Diagonalisation de X */ - DiagobgComp(nc, U, lambda, &rg); - - /* Calcul de la matrice lambda -1/2 */ - for (i = 1; i<=nc; i++) { - L[i][i] = 1 / sqrt(lambda[i]); - } - - /* Résultat */ - prodmatABC(U, L, Ubis); - for (i = 1; i <= nc; i++) { - for (j = 1; j <= nc; j++) { - Uter[i][j] = U[j][i]; + + /* Eigenstructure of X */ + DiagobgComp(nc, U, lambda, &rg); + + /* Matrix lambda -1/2 */ + for (i = 1; i<=nc; i++) { + L[i][i] = 1 / sqrt(lambda[i]); } - } - prodmatABC(Ubis, Uter, Y); - - freetab(U); - freetab(Ubis); - freetab(Uter); - freetab(L); - freevec(lambda); + + /* Result */ + prodmatABC(U, L, Ubis); + for (i = 1; i <= nc; i++) { + for (j = 1; j <= nc; j++) { + Uter[i][j] = U[j][i]; + } + } + prodmatABC(Ubis, Uter, Y); + + /* Free memory */ + freetab(U); + freetab(Ubis); + freetab(Uter); + freetab(L); + freevec(lambda); } -/* La même, mais sous R */ +/* The same, for R */ void matmudemir(double *Xr, double *Yr, int *ncr) { - /* définition de variables et allocation de mémoire */ - int i, j, k, nc; - double **X, **Y; - nc = *ncr; - taballoc(&X, nc, nc); - taballoc(&Y, nc, nc); - - /* remplissage des variables */ - k = 0; - for (i=1; i <= nc; i++) { - for (j = 1; j <= nc; j++) { - X[i][j] = Xr[k]; - k++; + /* Declaration of variables */ + int i, j, k, nc; + double **X, **Y; + + /* Memory allocation */ + nc = *ncr; + taballoc(&X, nc, nc); + taballoc(&Y, nc, nc); + + /* R to C */ + k = 0; + for (i=1; i <= nc; i++) { + for (j = 1; j <= nc; j++) { + X[i][j] = Xr[k]; + k++; + } } - } - - /* Inversion de matrice */ - matmudemi(X, Y); - - /* Retour vers R */ - k = 0; - for (i=1; i <= nc; i++) { - for (j = 1; j <= nc; j++) { - Yr[k] = Y[i][j]; - k++; + + /* matmudemi */ + matmudemi(X, Y); + + /* C to R */ + k = 0; + for (i=1; i <= nc; i++) { + for (j = 1; j <= nc; j++) { + Yr[k] = Y[i][j]; + k++; + } } - } - - /* Libération de la mémoire */ - freetab(X); - freetab(Y); + + /* Free memory */ + freetab(X); + freetab(Y); } @@ -5400,473 +5582,479 @@ void matmudemir(double *Xr, double *Yr, int *ncr) /* ******************************************* - Enfa sous C + Enfa ****************************************** */ void enfa(double **Z, double *p, int *nvar, int *npix, double *vp) { - /* déclaration de variables */ - double *m, *z, *y, **W, **Rs, **Rg, **Zbis, **Rsm12, norz; - double **Wtmp, **H, **Iv, **yyt, **Ivmyyt, **Htmp; - int i, j, nv, np, rg; - - /* allocation de mémoire */ - np = *npix; - nv = *nvar; - norz = 0; - rg = 0; - - taballoc(&Zbis, np, nv); - vecalloc(&m, nv); - vecalloc(&z, nv); - vecalloc(&y, nv); - taballoc(&W, nv, nv); - taballoc(&Iv, nv, nv); - taballoc(&Ivmyyt, nv, nv); - taballoc(&Htmp, nv, nv); - taballoc(&yyt, nv, nv); - taballoc(&H, nv, nv); - taballoc(&Wtmp, nv, nv); - taballoc(&Rg, nv, nv); - taballoc(&Rs, nv, nv); - taballoc(&Rsm12, nv, nv); - - /* Calcul de la marginalité */ - for (j = 1; j<=nv; j++) { - for (i = 1; i <= np; i++){ - m[j] = m[j] + p[i] * Z[i][j]; + /* Declaration of local variables */ + double *m, *z, *y, **W, **Rs, **Rg, **Zbis, **Rsm12, norz; + double **Wtmp, **H, **Iv, **yyt, **Ivmyyt, **Htmp; + int i, j, nv, np, rg; + + /* Memory allocation */ + np = *npix; + nv = *nvar; + norz = 0; + rg = 0; + + taballoc(&Zbis, np, nv); + vecalloc(&m, nv); + vecalloc(&z, nv); + vecalloc(&y, nv); + taballoc(&W, nv, nv); + taballoc(&Iv, nv, nv); + taballoc(&Ivmyyt, nv, nv); + taballoc(&Htmp, nv, nv); + taballoc(&yyt, nv, nv); + taballoc(&H, nv, nv); + taballoc(&Wtmp, nv, nv); + taballoc(&Rg, nv, nv); + taballoc(&Rs, nv, nv); + taballoc(&Rsm12, nv, nv); + + /* Marginality */ + for (j = 1; j<=nv; j++) { + for (i = 1; i <= np; i++){ + m[j] = m[j] + p[i] * Z[i][j]; + } } - } - - /* Calcul de Rs et Rg */ - for (i = 1; i<=np; i++) { - for (j = 1; j <= nv; j++) { - Zbis[i][j] = Z[i][j] * sqrt(p[i]); + + /* Rs and Rg */ + for (i = 1; i<=np; i++) { + for (j = 1; j <= nv; j++) { + Zbis[i][j] = Z[i][j] * sqrt(p[i]); + } } - } - prodmatAtAB(Zbis, Rs); - for (i = 1; i<=np; i++) { - for (j = 1; j <= nv; j++) { - Zbis[i][j] = Z[i][j] * sqrt((1/ ((double) np))); + prodmatAtAB(Zbis, Rs); + for (i = 1; i<=np; i++) { + for (j = 1; j <= nv; j++) { + Zbis[i][j] = Z[i][j] * sqrt((1/ ((double) np))); + } } - } - prodmatAtAB(Zbis, Rg); - - /* Calcul de Rs -1/2 */ - matmudemi(Rs,Rsm12); - - /* Calcul de z */ - for (i = 1; i <= nv; i++) { - for (j = 1; j <= nv; j++) { - z[i] = z[i] + Rsm12[i][j] * m[j]; + prodmatAtAB(Zbis, Rg); + + /* Rs^-1/2 */ + matmudemi(Rs,Rsm12); + + /* z */ + for (i = 1; i <= nv; i++) { + for (j = 1; j <= nv; j++) { + z[i] = z[i] + Rsm12[i][j] * m[j]; + } } - } - - /* Calcul de la norme de z */ - for (i = 1; i <= nv; i++) { - norz = norz + (z[i] * z[i]); - } - norz = sqrt(norz); - - /* Calcul de y */ - for (i = 1 ; i <= nv; i++) { - y[i] = z[i] / norz; - } - - /* Calcul de W */ - prodmatABC(Rsm12, Rg, Wtmp); - prodmatABC(Wtmp, Rsm12, W); - - - /* **************************** */ - /* Le gros morceau: calcul de H */ - /* **************************** */ - - /* Calcul de yyt */ - - for (i = 1; i<= nv; i++) { - for (j = 1; j <= nv; j++) { - yyt[i][j] = y[i] * y[j]; + + /* norm of z */ + for (i = 1; i <= nv; i++) { + norz = norz + (z[i] * z[i]); } - } - - - /* Remplissage de Iv */ - - for (i = 1; i <= nv; i++) { - Iv[i][i] = 1; - } - - - /* Calcul de Ivmyyt */ - - for (i = 1; i <= nv; i++) { - for (j = 1; j <= nv; j++) { - Ivmyyt[i][j] = Iv[i][j] - yyt[i][j]; + norz = sqrt(norz); + + /* y */ + for (i = 1 ; i <= nv; i++) { + y[i] = z[i] / norz; } - } - - - /* calcul de H */ - - prodmatABC(Ivmyyt, W, Htmp); - prodmatABC(Htmp, Ivmyyt, H); - - /* Diagonalisation de H */ - DiagobgComp(nv, H, vp, &rg); - + /* W */ + prodmatABC(Rsm12, Rg, Wtmp); + prodmatABC(Wtmp, Rsm12, W); + + + /* **************************** */ + /* The large part: H */ + /* **************************** */ + + /* yyt */ - /* Libération de la mémoire */ - freevec(m); - freevec(z); - freevec(y); - freetab(W); - freetab(Iv); - freetab(Ivmyyt); - freetab(Htmp); - freetab(yyt); - freetab(H); - freetab(Wtmp); - freetab(Rg); - freetab(Rs); - freetab(Rsm12); - freetab(Zbis); + for (i = 1; i<= nv; i++) { + for (j = 1; j <= nv; j++) { + yyt[i][j] = y[i] * y[j]; + } + } + + + /* Iv */ + + for (i = 1; i <= nv; i++) { + Iv[i][i] = 1; + } + + + /* Ivmyyt */ + + for (i = 1; i <= nv; i++) { + for (j = 1; j <= nv; j++) { + Ivmyyt[i][j] = Iv[i][j] - yyt[i][j]; + } + } + + + /* And finally, H */ + + prodmatABC(Ivmyyt, W, Htmp); + prodmatABC(Htmp, Ivmyyt, H); + + + /* Eigenstructure of H */ + DiagobgComp(nv, H, vp, &rg); + + + /* Free memory */ + freevec(m); + freevec(z); + freevec(y); + freetab(W); + freetab(Iv); + freetab(Ivmyyt); + freetab(Htmp); + freetab(yyt); + freetab(H); + freetab(Wtmp); + freetab(Rg); + freetab(Rs); + freetab(Rsm12); + freetab(Zbis); } /* ***************************************************** - Vérif de l'ENFA sous R +ENFA with R - ***************************************************** */ +***************************************************** */ void enfar(double *Zr, double *pr, int *nvar, int *npix, double *vpr) { - /* Déclaration de variables */ - int i, j, k, np, nv; - double **Z, *p, *vp; - - /* Allocation de mémoire */ - taballoc(&Z, *npix, *nvar); - vecalloc(&p, *npix); - vecalloc(&vp, *nvar); - - np = *npix; - nv = *nvar; - - /* remplissage des variables locales */ - k = 0; - for (i=1; i <= np; i++) { - for (j = 1; j <= nv; j++) { - Z[i][j] = Zr[k]; - k++; + /* Declaration of variables */ + int i, j, k, np, nv; + double **Z, *p, *vp; + + /* Memory allocation */ + taballoc(&Z, *npix, *nvar); + vecalloc(&p, *npix); + vecalloc(&vp, *nvar); + + np = *npix; + nv = *nvar; + + /* R to C */ + k = 0; + for (i=1; i <= np; i++) { + for (j = 1; j <= nv; j++) { + Z[i][j] = Zr[k]; + k++; + } } - } - - for (i = 1; i <= np; i++) { - p[i] = pr[i-1]; - } - - /* ENFA ...*/ - enfa(Z, p, &nv, &np, vp); - - - /* ... Sorties vers R ... */ - for (i = 1; i <= nv; i++) { - vpr[i-1] = vp[i]; - } - - /* ... et enfin libération de la mémoire */ - freetab(Z); - freevec(p); - freevec(vp); - + + for (i = 1; i <= np; i++) { + p[i] = pr[i-1]; + } + + /* ENFA ...*/ + enfa(Z, p, &nv, &np, vp); + + + /* ... C to R ... */ + for (i = 1; i <= nv; i++) { + vpr[i-1] = vp[i]; + } + + /* ... Free memory */ + freetab(Z); + freevec(p); + freevec(vp); + } /* ******************************************************** - Randomisation dans l'ENFA: test de la première valeur - propre de spécialisation +Randomization in the ENFA: test of the first eigenvalue of specialization - ******************************************************** */ +******************************************************** */ void randenfa(double **Z, double *p, int *nrep, double *res) { - /* Définition de variables */ - int i, j, k, nr, nv, np, ntot; - double *psim, *vp; - - /* Allocation de mémoire */ - np = Z[0][0]; - nv = Z[1][0]; - ntot = 0; - nr = *nrep; - vecalloc(&psim, np); - vecalloc(&vp, nv); - - /* Décompte du nombre total de localisations */ - for (i = 1; i <= np; i++) { - ntot = ntot + p[i]; - } - - /* Début du processus de randomisation */ - for (k = 1; k <= *nrep; k++) { + /* Declaration of variables */ + int i, j, k, nr, nv, np, ntot; + double *psim, *vp; - /* On commence par vider le vecteur psim */ - for (i = 1; i <= np; i++) { - psim[i] = 0; - } + /* Memory Allocation */ + np = Z[0][0]; + nv = Z[1][0]; + ntot = 0; + nr = *nrep; + vecalloc(&psim, np); + vecalloc(&vp, nv); - /* randomisation des locs dans le vecteur psim */ - for (i = 1; i <= ntot; i++) { - j = (int) (np * alea()); - psim[j]++; + /* Counts the total number of points */ + for (i = 1; i <= np; i++) { + ntot = ntot + p[i]; } - /* construction du vecteur de ponderation... */ - for (i = 1; i <= np; i++) { - psim[i] = psim[i] / ((double) ntot); + /* Beginning of the randomization porocess */ + for (k = 1; k <= *nrep; k++) { + + /* empty vector psim */ + for (i = 1; i <= np; i++) { + psim[i] = 0; + } + + /* randomization of locs in the vector psim */ + for (i = 1; i <= ntot; i++) { + j = (int) (np * alea()); + psim[j]++; + } + + /* vector of weight */ + for (i = 1; i <= np; i++) { + psim[i] = psim[i] / ((double) ntot); + } + + /* ... and ENFA */ + enfa(Z, psim, &nv, &np, vp); + + /* storage in res... */ + res[k] = vp[1]; + + /* ... and end of the loop */ } - /* ... et ENFA */ - enfa(Z, psim, &nv, &np, vp); - - /* stockage dans res... */ - res[k] = vp[1]; - - /* ... et fin de la boucle */ - } - - /* Et enfin, libération de la mémoire */ - freevec(psim); - freevec(vp); + /* Free memory */ + freevec(psim); + freevec(vp); } -/* Le même, mais pour R */ +/* The same but for external call from R */ void randenfar(double *Zr, double *pr, int *nvar, int *npix, int *nrep, double *resr) { - /* Définition des variables locales */ - int i, j, k, nv, np, nr; - double **Z, *p, *res; - - /* Allocation de mémoire */ - np = *npix; - nv = *nvar; - nr = *nrep; - taballoc(&Z, np, nv); - vecalloc(&p, np); - vecalloc(&res, nr); - - /* remplissage des variables locales */ - k = 0; - for (i=1; i <= np; i++) { - for (j = 1; j <= nv; j++) { - Z[i][j] = Zr[k]; - k++; + /* Declaration of local variables */ + int i, j, k, nv, np, nr; + double **Z, *p, *res; + + /* Memory Allocation */ + np = *npix; + nv = *nvar; + nr = *nrep; + taballoc(&Z, np, nv); + vecalloc(&p, np); + vecalloc(&res, nr); + + /* R to C */ + k = 0; + for (i=1; i <= np; i++) { + for (j = 1; j <= nv; j++) { + Z[i][j] = Zr[k]; + k++; + } } - } - - for (i = 1; i <= np; i++) { - p[i] = pr[i-1]; - } - - /* Fonction C */ - randenfa(Z, p, &nr, res); - - /* Retour vers R */ - for (i = 1; i <= nr; i++) { - resr[i-1] = res[i]; - } - - /* libération de la mémoire */ - freevec(p); - freevec(res); - freetab(Z); - + + for (i = 1; i <= np; i++) { + p[i] = pr[i-1]; + } + + /* C Function */ + randenfa(Z, p, &nr, res); + + /* C to R */ + for (i = 1; i <= nr; i++) { + resr[i-1] = res[i]; + } + + /* free memory */ + freevec(p); + freevec(res); + freetab(Z); + } /* ********************************************************************* * * - * Brownian bridge pour kernel * + * Brownian bridge kernel * * * ***********************************************************************/ -/* Fonction normale 2D pour brownian bridge */ +/* Function normal 2D for brownian bridge */ void norm2d(double x1, double y1, double moyx, double moyy, double var, double *res) { - double cste; - cste = (1 / (2.0 * 3.141592653589793238 * var)); - cste = cste * exp( (-1.0 / (2.0 * var)) * (((x1 - moyx) * (x1 - moyx))+((y1 - moyy) * (y1 - moyy)))); - *res = cste; + double cste; + cste = (1 / (2.0 * 3.141592653589793238 * var)); + cste = cste * exp( (-1.0 / (2.0 * var)) * (((x1 - moyx) * (x1 - moyx))+((y1 - moyy) * (y1 - moyy)))); + *res = cste; } -/* Intégrale de norm2d sur alpha */ + +/* Integral of norm2d on alpha */ void integrno(double *XG, double *X1, double *X2, double *T, double *sig1, double *sig2, double *alpha, double *res) { - /* allocation de mémoire */ - int i, na; - double *val, tmp, *XX, var, nx1, ny1, nx2, ny2, ny, moyx, moyy, al; - - na = alpha[0]; - vecalloc(&val, na); - vecalloc(&XX, 2); - - XX[1] = X2[1] - X1[1]; - XX[2] = X2[2] - X1[2]; - *res = 0; + /* Declaration */ + int i, na; + double *val, tmp, *XX, var, nx1, ny1, nx2, ny2, ny, moyx, moyy, al; + /* Memory allocation */ + na = alpha[0]; + vecalloc(&val, na); + vecalloc(&XX, 2); - /* boucle de calcul de la valeur */ - for (i = 1; i<= na; i++) { - al = alpha[i]; + XX[1] = X2[1] - X1[1]; + XX[2] = X2[2] - X1[2]; + *res = 0; - var = (*T) * al * (1.0 - al) * (*sig1); - var = var + (((al * al) + ((1.0 - al) * (1.0 - al))) * (*sig2)); - - moyx = X1[1] + al * XX[1]; - moyy = X1[2] + al * XX[2]; - norm2d(XG[1], XG[2], moyx, moyy, var, &tmp); + /* loop for the computation of the value */ + for (i = 1; i<= na; i++) { + al = alpha[i]; + + var = (*T) * al * (1.0 - al) * (*sig1); + var = var + (((al * al) + ((1.0 - al) * (1.0 - al))) * (*sig2)); + + moyx = X1[1] + al * XX[1]; + moyy = X1[2] + al * XX[2]; + + norm2d(XG[1], XG[2], moyx, moyy, var, &tmp); + + val[i] = tmp; + } + + /* loop for the computation of the integral */ + for (i = 2; i<= na; i++) { + nx1 = alpha[i-1]; + ny1 = val[i-1]; + nx2 = alpha[i]; + ny2 = val[i]; + ny = ny1; + if (ny2 <= ny1) + ny = ny2; + *res = *res + (nx2 - nx1) * (ny + (abs(ny2 - ny1) / 2)); + } - val[i] = tmp; - } - - /* boucle de calcul de l'intégrale */ - for (i = 2; i<= na; i++) { - nx1 = alpha[i-1]; - ny1 = val[i-1]; - nx2 = alpha[i]; - ny2 = val[i]; - ny = ny1; - if (ny2 <= ny1) - ny = ny2; - *res = *res + (nx2 - nx1) * (ny + (abs(ny2 - ny1) / 2)); - } - - freevec(val); - freevec(XX); + /* Free memory */ + freevec(val); + freevec(XX); } -/* Calcul de l'UD à un noeud de la grille */ +/* Computes UD at a node of the grid */ void udbbnoeud(double *XG, double **XY, double *T, double *sig1, double *sig2, double *alpha, double *res) { - int i, nlo; - double *Xtmp1, *Xtmp2, dt, poids, dttot, tmp; - - vecalloc(&Xtmp1, 2); - vecalloc(&Xtmp2, 2); - nlo = XY[0][0]; - dttot = T[nlo] - T[1]; - *res = 0; - - for (i = 1; i <= (nlo - 1); i++) { + /* Declaration */ + int i, nlo; + double *Xtmp1, *Xtmp2, dt, poids, dttot, tmp; - /* Calcul des poids et différences de temps */ - dt = T[i+1] - T[i]; - poids = dt / dttot; + /* Memory allocation */ + vecalloc(&Xtmp1, 2); + vecalloc(&Xtmp2, 2); + nlo = XY[0][0]; + dttot = T[nlo] - T[1]; + *res = 0; - /* Sortie des valeurs des locs à i, et passage à integrno */ - Xtmp1[1] = XY[i][1]; - Xtmp1[2] = XY[i][2]; - Xtmp2[1] = XY[i+1][1]; - Xtmp2[2] = XY[i+1][2]; - - integrno(XG, Xtmp1, Xtmp2, &dt, sig1, sig2, alpha, &tmp); - *res = *res + (poids * tmp); - } + /* for each step */ + for (i = 1; i <= (nlo - 1); i++) { + + /* Computes weights and time lags */ + dt = T[i+1] - T[i]; + poids = dt / dttot; + + /* Output of the relocation values at i, and use of the function integrno */ + Xtmp1[1] = XY[i][1]; + Xtmp1[2] = XY[i][2]; + Xtmp2[1] = XY[i+1][1]; + Xtmp2[2] = XY[i+1][2]; + + integrno(XG, Xtmp1, Xtmp2, &dt, sig1, sig2, alpha, &tmp); + *res = *res + (poids * tmp); + } } -/* Fonction principale */ +/* Main Function */ void kernelbb(double *grille, double *xgri, double *ygri, int *ncolgri, int *nliggri, int *nloc, double *sig1, double *sig2, double *xlo, double *ylo, double *Tr) { - int i, j, k, ncg, nlg, nlo; - double **gri, *xg, *yg, **XY, tmp, *alpha, *Xgr, *T; - - /* Allocation de mémoire */ - ncg = *ncolgri; - nlg = *nliggri; - nlo = *nloc; - tmp = 0; - - taballoc(&gri,nlg, ncg); - taballoc(&XY, nlo, 2); - vecalloc(&xg, nlg); - vecalloc(&T, nlo); - vecalloc(&yg, ncg); - vecalloc(&Xgr, 2); - vecalloc(&alpha, 50); - - /* passage de valeur aux variables C */ - - for (i=1; i<=nlo; i++) { - XY[i][1] = xlo[i-1]; - XY[i][2] = ylo[i-1]; - T[i] = Tr[i-1]; - } - - for (i=1; i<=nlg; i++) { - xg[i] = xgri[i-1]; - } - - for (i=1; i<=ncg; i++) { - yg[i] = ygri[i-1]; - } - - /* construction du vecteur alpha */ - alpha[1] = 0; - for (i = 2; i <= 50; i++) { - alpha[i] = ((double) i) / ((double) 50); - } - - /* boucle de calcul sur la grille */ - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - Xgr[1] = xg[i]; - Xgr[2] = yg[j]; - udbbnoeud(Xgr, XY, T, sig1, sig2, alpha, &tmp); - gri[i][j] = tmp; + /* Declaration */ + int i, j, k, ncg, nlg, nlo; + double **gri, *xg, *yg, **XY, tmp, *alpha, *Xgr, *T; + + /* Memory Allocation */ + ncg = *ncolgri; + nlg = *nliggri; + nlo = *nloc; + tmp = 0; + + taballoc(&gri,nlg, ncg); + taballoc(&XY, nlo, 2); + vecalloc(&xg, nlg); + vecalloc(&T, nlo); + vecalloc(&yg, ncg); + vecalloc(&Xgr, 2); + vecalloc(&alpha, 50); + + /* R to C */ + + for (i=1; i<=nlo; i++) { + XY[i][1] = xlo[i-1]; + XY[i][2] = ylo[i-1]; + T[i] = Tr[i-1]; } - } - - /* retour vers R */ - k = 0; - for (i=1; i<=nlg; i++) { - for (j=1; j<=ncg; j++) { - grille[k] = gri[i][j]; - k++; + + for (i=1; i<=nlg; i++) { + xg[i] = xgri[i-1]; } - } - - /* libération de la mémoire */ - freetab(gri); - freevec(xg); - freevec(yg); - freevec(T); - freetab(XY); - freevec(Xgr); - freevec(alpha); + + for (i=1; i<=ncg; i++) { + yg[i] = ygri[i-1]; + } + + /* Build the vector alpha */ + alpha[1] = 0; + for (i = 2; i <= 50; i++) { + alpha[i] = ((double) i) / ((double) 50); + } + + /* Loop on the grid */ + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + Xgr[1] = xg[i]; + Xgr[2] = yg[j]; + udbbnoeud(Xgr, XY, T, sig1, sig2, alpha, &tmp); + gri[i][j] = tmp; + } + } + + /* C to R */ + k = 0; + for (i=1; i<=nlg; i++) { + for (j=1; j<=ncg; j++) { + grille[k] = gri[i][j]; + k++; + } + } + + /* Free memory */ + freetab(gri); + freevec(xg); + freevec(yg); + freevec(T); + freetab(XY); + freevec(Xgr); + freevec(alpha); } @@ -5874,254 +6062,284 @@ void kernelbb(double *grille, double *xgri, double *ygri, int *ncolgri, /* ********************************************************************* * * - * Buffer ligne * + * Buffer on a line * * * ***********************************************************************/ +/* given a line, ligpoly returns a buffer polygon containing the line */ void ligpoly(double *x, double *y, double r, double *xp, double *yp) { - double x1, x2, y1, y2, xx, yy, alpha, beta, xim, xsm, yim, ysm, gamma; - double xip, xsp, yip, ysp; - - x1 = x[1]; - x2 = x[2]; - y1 = y[1]; - y2 = y[2]; - xx = x2 - x1; - yy = y2 - y1; - - alpha = atan(yy/xx); - beta = alpha - (3.1415926/2); - xim = x1 + r * (cos(beta)); - xsm = x2 + r * (cos(beta)); - yim = y1 + r * (sin(beta)); - ysm = y2 + r * (sin(beta)); - - gamma = alpha + (3.1415926/2); - xip = x1 + r * (cos(gamma)); - xsp = x2 + r * (cos(gamma)); - yip = y1 + r * (sin(gamma)); - ysp = y2 + r * (sin(gamma)); - - xp[1] = xim; - xp[2] = xsm; - xp[3] = xsp; - xp[4] = xip; - xp[5] = xim; - - yp[1] = yim; - yp[2] = ysm; - yp[3] = ysp; - yp[4] = yip; - yp[5] = yim; - + /* Declaration */ + double x1, x2, y1, y2, xx, yy, alpha, beta, xim, xsm, yim, ysm, gamma; + double xip, xsp, yip, ysp; + + x1 = x[1]; + x2 = x[2]; + y1 = y[1]; + y2 = y[2]; + xx = x2 - x1; + yy = y2 - y1; + + alpha = atan(yy/xx); + beta = alpha - (3.1415926/2); + xim = x1 + r * (cos(beta)); + xsm = x2 + r * (cos(beta)); + yim = y1 + r * (sin(beta)); + ysm = y2 + r * (sin(beta)); + + gamma = alpha + (3.1415926/2); + xip = x1 + r * (cos(gamma)); + xsp = x2 + r * (cos(gamma)); + yip = y1 + r * (sin(gamma)); + ysp = y2 + r * (sin(gamma)); + + xp[1] = xim; + xp[2] = xsm; + xp[3] = xsp; + xp[4] = xip; + xp[5] = xim; + + yp[1] = yim; + yp[2] = ysm; + yp[3] = ysp; + yp[4] = yip; + yp[5] = yim; + } +/* main function */ void buflig(double **x, double r, double **carte, double *xg, double *yg) { - int i, j, k, nloc, nr, nc; - double **x1, **x2, *xl, *yl, *xp, *yp, **cartebis; - - /* allocation de mémoire */ - nloc = x[0][0]; - k = 0; - nr = carte[0][0]; - nc = carte[1][0]; - - vecalloc(&xl, 2); - vecalloc(&yl, 2); - vecalloc(&xp, 5); - vecalloc(&yp, 5); - taballoc(&x1, nloc-1, 2); - taballoc(&x2, nloc-1, 2); - taballoc(&cartebis, nr, nc); - - /* on crée les deux tableaux */ - for (i = 1; i <= nloc; i++) { - if (i > 1) { - x2[i-1][1] = x[i][1]; - x2[i-1][2] = x[i][2]; - } - if (i < nloc) { - x1[i][1] = x[i][1]; - x1[i][2] = x[i][2]; + /* Declaration */ + int i, j, k, nloc, nr, nc; + double **x1, **x2, *xl, *yl, *xp, *yp, **cartebis; + + /* Memory allocation */ + nloc = x[0][0]; + k = 0; + nr = carte[0][0]; + nc = carte[1][0]; + + vecalloc(&xl, 2); + vecalloc(&yl, 2); + vecalloc(&xp, 5); + vecalloc(&yp, 5); + taballoc(&x1, nloc-1, 2); + taballoc(&x2, nloc-1, 2); + taballoc(&cartebis, nr, nc); + + /* Creates the two tables */ + for (i = 1; i <= nloc; i++) { + if (i > 1) { + x2[i-1][1] = x[i][1]; + x2[i-1][2] = x[i][2]; + } + if (i < nloc) { + x1[i][1] = x[i][1]; + x1[i][2] = x[i][2]; + } } - } - - /* Remise à 0 de la carte */ - for (i = 1; i <= nr; i++) { - for (j = 1; j <= nc; j++) { - carte[i][j] = 0; + + /* Sets the map to 0 */ + for (i = 1; i <= nr; i++) { + for (j = 1; j <= nc; j++) { + carte[i][j] = 0; + } } - } - - - /* Buffer autour de la ligne */ - for (i = 1; i <= (nloc-1); i++) { - xl[1] = x1[i][1]; - xl[2] = x2[i][1]; - yl[1] = x1[i][2]; - yl[2] = x2[i][2]; - ligpoly(xl, yl, r, xp, yp); - - rastpol(xp, yp, xg, yg, cartebis); - for (j = 1; j <= nr; j++) { - for (k = 1; k <= nc; k++) { - carte[j][k] = cartebis[j][k] + carte[j][k]; - } + /* Buffer around the line */ + for (i = 1; i <= (nloc-1); i++) { + xl[1] = x1[i][1]; + xl[2] = x2[i][1]; + yl[1] = x1[i][2]; + yl[2] = x2[i][2]; + + ligpoly(xl, yl, r, xp, yp); + + rastpol(xp, yp, xg, yg, cartebis); + + for (j = 1; j <= nr; j++) { + for (k = 1; k <= nc; k++) { + carte[j][k] = cartebis[j][k] + carte[j][k]; + } + } } - } - - freevec(xl); - freevec(yl); - freevec(xp); - freevec(yp); - freetab(x1); - freetab(x2); - freetab(cartebis); - + + /* Free memory */ + freevec(xl); + freevec(yl); + freevec(xp); + freevec(yp); + freetab(x1); + freetab(x2); + freetab(cartebis); + } +/* For external call from xithin R */ void bufligr(double *xr, double *rr, double *carter, double *xgr, double *ygr, int *nlr, int *ncr, int *nlocr) { - /* déclaration et allocation de mémoire */ - int i, j, k, nc, nl, nloc; - double **x, r, **carte, *xg, *yg; - - nc = *ncr; - nl = *nlr; - nloc = *nlocr; - r = *rr; - - taballoc(&x, nloc, 2); - taballoc(&carte, nl, nc); - vecalloc(&xg, nl); - vecalloc(&yg, nc); - - - /* variables locales */ - k = 0; - for (i=1; i<= nl; i++) { - for (j = 1; j<=nc; j++) { - carte[i][j]=carter[k]; - k++; + /* Declaration */ + int i, j, k, nc, nl, nloc; + double **x, r, **carte, *xg, *yg; + + /* Memory allocation */ + nc = *ncr; + nl = *nlr; + nloc = *nlocr; + r = *rr; + + taballoc(&x, nloc, 2); + taballoc(&carte, nl, nc); + vecalloc(&xg, nl); + vecalloc(&yg, nc); + + + /* R to C */ + k = 0; + for (i=1; i<= nl; i++) { + for (j = 1; j<=nc; j++) { + carte[i][j]=carter[k]; + k++; + } } - } - - k = 0; - for (i=1; i<= nloc; i++) { - for (j = 1; j<=2; j++) { - x[i][j]=xr[k]; - k++; + + k = 0; + for (i=1; i<= nloc; i++) { + for (j = 1; j<=2; j++) { + x[i][j]=xr[k]; + k++; + } } - } - - for (i = 1; i <= nl; i++) { - xg[i] = xgr[i-1]; - } - - for (i = 1; i <= nc; i++) { - yg[i] = ygr[i-1]; - } - - - buflig(x, r, carte, xg, yg); - - k = 0; - for (i=1; i<= nl; i++) { - for (j = 1; j<=nc; j++) { - carter[k]=carte[i][j]; - k++; + + for (i = 1; i <= nl; i++) { + xg[i] = xgr[i-1]; } - } - freetab(x); - freetab(carte); - freevec(xg); - freevec(yg); - + for (i = 1; i <= nc; i++) { + yg[i] = ygr[i-1]; + } + + /* Main function */ + buflig(x, r, carte, xg, yg); + + /* C to R */ + k = 0; + for (i=1; i<= nl; i++) { + for (j = 1; j<=nc; j++) { + carter[k]=carte[i][j]; + k++; + } + } + + /* Free memory */ + freetab(x); + freetab(carte); + freevec(xg); + freevec(yg); + } -/* Calcul de distances euclidiennes à partir d'une carte asc */ +/* Computes Euclidean distances from a map of class asc */ void distxy(double **xy1, double **xy2, double *di) { - int i, j, n1, n2; - double *dib, mi; - - n1 = xy1[0][0]; - n2 = xy2[0][0]; - - vecalloc(&dib, n2); - - for (i = 1; i <= n1; i++) { - for (j = 1; j <= n2; j++) { - dib[j] = sqrt( ((xy1[i][1] - xy2[j][1]) * (xy1[i][1] - xy2[j][1])) + - ((xy1[i][2] - xy2[j][2]) * (xy1[i][2] - xy2[j][2]))); - } - mi = dib[1]; - for (j = 2; j <= n2; j++) { - if (mi > dib[j]) { - mi = dib[j]; - } + /* Declaration */ + int i, j, n1, n2; + double *dib, mi; + + /* Memory allocation */ + n1 = xy1[0][0]; + n2 = xy2[0][0]; + + vecalloc(&dib, n2); + + /* Euclidean distances */ + for (i = 1; i <= n1; i++) { + for (j = 1; j <= n2; j++) { + dib[j] = sqrt( ((xy1[i][1] - xy2[j][1]) * (xy1[i][1] - xy2[j][1])) + + ((xy1[i][2] - xy2[j][2]) * (xy1[i][2] - xy2[j][2]))); + } + mi = dib[1]; + for (j = 2; j <= n2; j++) { + if (mi > dib[j]) { + mi = dib[j]; + } + } + di[i] = mi; } - di[i] = mi; - } - freevec(dib); + + /* Free memory */ + freevec(dib); } +/* For external call from R */ void distxyr(double *xy1r, double *xy2r, int *n1r, int *n2r, double *dire) { - int i, j, k, n1, n2; - double **xy1, **xy2, *di; - - n1 = *n1r; - n2 = *n2r; - - taballoc(&xy1, n1, 2); - taballoc(&xy2, n2, 2); - vecalloc(&di, n1); - - k = 0; - for (i = 1; i <= n1; i++) { - for (j = 1; j <= 2; j++) { - xy1[i][j] = xy1r[k]; - k++; + /* Declaration */ + int i, j, k, n1, n2; + double **xy1, **xy2, *di; + + /* Memory allocation */ + n1 = *n1r; + n2 = *n2r; + + taballoc(&xy1, n1, 2); + taballoc(&xy2, n2, 2); + vecalloc(&di, n1); + + /* R to C */ + k = 0; + for (i = 1; i <= n1; i++) { + for (j = 1; j <= 2; j++) { + xy1[i][j] = xy1r[k]; + k++; + } } - } - - k = 0; - for (i = 1; i <= n2; i++) { - for (j = 1; j <= 2; j++) { - xy2[i][j] = xy2r[k]; - k++; + + k = 0; + for (i = 1; i <= n2; i++) { + for (j = 1; j <= 2; j++) { + xy2[i][j] = xy2r[k]; + k++; + } } - } - - distxy(xy1, xy2, di); - - for (i = 1; i <= n1; i++) { - dire[i-1] = di[i]; - } - - freetab(xy1); - freetab(xy2); - freevec(di); + + /* The function */ + distxy(xy1, xy2, di); + + /* C to R */ + for (i = 1; i <= n1; i++) { + dire[i-1] = di[i]; + } + + /* Free memory */ + freetab(xy1); + freetab(xy2); + freevec(di); } + + +/* ********************************************************************* + * * + * First passage time * + * * + ***********************************************************************/ + +/* compute the distance cetween two points */ void dtmp(double x1, double x2, double y1, double y2, double *di) { @@ -6129,567 +6347,615 @@ void dtmp(double x1, double x2, double y1, double y2, } + +/* compute the FPT for ONE relocation */ void fptt(double *x, double *y, double *t, int pos, double radius, double *fptto, int nlo) { - int ok, pos2, naar, naav, na; - double di, dt, dt2, di2, fptar, fptav; - - ok = 0; - di = 0; - di2 = 0; - dt = 0; - dt2 = 0; - naar = 1; - naav = 1; - fptar = 0; - fptav = 0; + /* Declaration */ + int ok, pos2, naar, naav, na; + double di, dt, dt2, di2, fptar, fptav; + + ok = 0; + di = 0; + di2 = 0; + dt = 0; + dt2 = 0; + naar = 1; + naav = 1; + fptar = 0; + fptav = 0; - /* recherche de la première loc qui sort du cercle en arrière*/ - pos2 = pos; - while (ok == 0) { - pos2 = pos2 - 1; - if (pos2 > 0) { - dtmp(x[pos2], x[pos], y[pos2], y[pos], &di); - if (di >= radius) - ok = 1; - } else { - ok = 1; - naar = 0; + /* Search of the first loc outside the circle (before) */ + pos2 = pos; + while (ok == 0) { + pos2 = pos2 - 1; + if (pos2 > 0) { + dtmp(x[pos2], x[pos], y[pos2], y[pos], &di); + if (di >= radius) + ok = 1; + } else { + ok = 1; + naar = 0; + } } - } - - /* calcul de l'approximation linéaire */ - if (naar > 0) { - dt = abs(t[pos] - t[pos2]); - dt2 = abs(t[pos] - t[(pos2+1)]); - dtmp(x[(pos2+1)], x[pos], y[(pos2+1)], y[pos], &di2); - fptar = dt2 + ( (dt - dt2) * (radius - di2) / (di - di2) ); - } - - - /* recherche de la première loc qui sort du cercle en avant*/ - pos2 = pos; - ok = 0; - while (ok == 0) { - pos2 = pos2 + 1; - if (pos2 <= nlo) { - dtmp(x[pos2], x[pos], y[pos2], y[pos], &di); - if (di >= radius) - ok = 1; + + /* computes the linear approximation */ + if (naar > 0) { + dt = abs(t[pos] - t[pos2]); + dt2 = abs(t[pos] - t[(pos2+1)]); + dtmp(x[(pos2+1)], x[pos], y[(pos2+1)], y[pos], &di2); + fptar = dt2 + ( (dt - dt2) * (radius - di2) / (di - di2) ); + } + + + /* Search of the first loc outside the circle (after) */ + pos2 = pos; + ok = 0; + while (ok == 0) { + pos2 = pos2 + 1; + if (pos2 <= nlo) { + dtmp(x[pos2], x[pos], y[pos2], y[pos], &di); + if (di >= radius) + ok = 1; + } else { + ok = 1; + naav = 0; + } + } + + /* Computes linear approximation */ + if (naav > 0) { + dt = abs(t[pos2] - t[pos]); + dt2 = abs(t[(pos2-1)] - t[pos]); + dtmp(x[(pos2-1)], x[pos], y[(pos2-1)], y[pos], &di2); + fptav = dt2 + ( (dt - dt2) * (radius - di2) / (di - di2) ); + } + + na = naar * naav; + if (na > 0) { + *fptto = fptar + fptav; } else { - ok = 1; - naav = 0; + *fptto = -1; } - } - - /* calcul de l'approximation linéaire */ - if (naav > 0) { - dt = abs(t[pos2] - t[pos]); - dt2 = abs(t[(pos2-1)] - t[pos]); - dtmp(x[(pos2-1)], x[pos], y[(pos2-1)], y[pos], &di2); - fptav = dt2 + ( (dt - dt2) * (radius - di2) / (di - di2) ); - } - - na = naar * naav; - if (na > 0) { - *fptto = fptar + fptav; - } else { - *fptto = -1; - } - + } + +/* Computes the FPT for all relocations */ void fipati(double *x, double *y, double *t, - int nlo, int nra, double *rad, - double **fpt) + int nlo, int nra, double *rad, + double **fpt) { - int i, j; - double val; - - - - /* Calcul de la matrice de distances et dtime */ - for (i=1; i<=nra; i++) { - for (j=1; j<=nlo; j++) { - fptt(x, y, t, j, rad[i], &val, nlo); - fpt[j][i] = val; + /* Declaration */ + int i, j; + double val; + + /* Computes the FPT */ + for (i=1; i<=nra; i++) { + for (j=1; j<=nlo; j++) { + fptt(x, y, t, j, rad[i], &val, nlo); + fpt[j][i] = val; + } } - } } - +/* for external call from within R */ void fipatir(double *xr, double *yr, double *tr, int *nlocs, double *radius, int *nrad, double *fptr) { - int i, j, k, nlo, nra; - double *x, *y, *t, *rad, **fpt; - - nlo = *nlocs; - nra = *nrad; - - vecalloc(&x, nlo); - vecalloc(&y, nlo); - vecalloc(&t, nlo); - vecalloc(&rad, nra); - taballoc(&fpt, nlo, nra); - - for (i = 1; i <= nlo; i++) { - x[i] = xr[i-1]; - y[i] = yr[i-1]; - t[i] = tr[i-1]; - } - - for (i = 1; i <= nra; i++) { - rad[i] = radius[i-1]; - } - - fipati(x,y,t, nlo, nra, rad, fpt); - k = 0; - for (i=1; i<= nlo; i++) { - for (j = 1; j<=nra; j++) { - fptr[k]=fpt[i][j]; - k++; + /* Declaration */ + int i, j, k, nlo, nra; + double *x, *y, *t, *rad, **fpt; + + /* Memory allocation */ + nlo = *nlocs; + nra = *nrad; + + vecalloc(&x, nlo); + vecalloc(&y, nlo); + vecalloc(&t, nlo); + vecalloc(&rad, nra); + taballoc(&fpt, nlo, nra); + + /* R to C */ + for (i = 1; i <= nlo; i++) { + x[i] = xr[i-1]; + y[i] = yr[i-1]; + t[i] = tr[i-1]; } - } - - - freetab(fpt); - freevec(x); - freevec(y); - freevec(t); - freevec(rad); + + for (i = 1; i <= nra; i++) { + rad[i] = radius[i-1]; + } + + /* main function */ + fipati(x,y,t, nlo, nra, rad, fpt); + + /* C to R */ + k = 0; + for (i=1; i<= nlo; i++) { + for (j = 1; j<=nra; j++) { + fptr[k]=fpt[i][j]; + k++; + } + } + + /* free memory */ + freetab(fpt); + freevec(x); + freevec(y); + freevec(t); + freevec(rad); } + + +/* ********************************************************************* + * * + * Percolation cluster * + * * + ***********************************************************************/ + + void perclu(double **map, int nr, int nc, double *x, double *y, int nmax, int *nreel, double *pm) { - int i,j, encore, k, l, dir, *vois, *rvois, *cvois, choix, xt, yt, cons, *reord, len; - double **rr, **cc, *cs, ptir; - - xt = (int) x[1]; - yt = (int) y[1]; - len = nr; - if (nc < nr) - len = nc; - encore = 1; - i = 1; - j = 1; - l = 0; - k = 2; - ptir = 0; - dir = 1; - choix = 1; - cons = 0; - - taballoc(&rr, nr, nc); - taballoc(&cc, nr, nc); - vecintalloc(&vois, 4); - vecintalloc(&reord, 4); - vecintalloc(&rvois, 4); - vecintalloc(&cvois, 4); - vecalloc(&cs, 4); - - - - for (i = 1; i <= nr; i++) { - for (j = 1; j <= nc; j++) { - rr[i][j] = (double) i; - cc[i][j] = (double) j; - } - } - - cs[1] = pm[1]; - for (i = 2; i <= 4; i++) { - cs[i] = cs[i-1] + pm[i]; - } - - while (encore == 1) { - - /* Stockage du voisinage */ - vois[1] = (int) map[xt][yt+1]; - vois[2] = (int) map[xt+1][yt]; - vois[3] = (int) map[xt][yt-1]; - vois[4] = (int) map[xt-1][yt]; - - rvois[1] = (int) rr[xt][yt+1]; - rvois[2] = (int) rr[xt+1][yt]; - rvois[3] = (int) rr[xt][yt-1]; - rvois[4] = (int) rr[xt-1][yt]; - - cvois[1] = (int) cc[xt][yt+1]; - cvois[2] = (int) cc[xt+1][yt]; - cvois[3] = (int) cc[xt][yt-1]; - cvois[4] = (int) cc[xt-1][yt]; - - /* Réordonnons le voisinage en fonction de - la direction */ - l = 1; - for (i = dir; i <= 4; i++) { - reord[l] = i; - l++; - } + /* Declaration */ + int i,j, encore, k, l, dir, *vois, *rvois, *cvois, choix, xt, yt, cons, *reord, len; + double **rr, **cc, *cs, ptir; + + /* Memory allocation */ + xt = (int) x[1]; + yt = (int) y[1]; + len = nr; + if (nc < nr) + len = nc; + encore = 1; i = 1; - while (l != 4) { - reord[l] = i; - l++; - i++; - } + j = 1; + l = 0; + k = 2; + ptir = 0; + dir = 1; + choix = 1; + cons = 0; - /* tirage aléatoire de la direction */ - ptir = alea(); - choix = 4; - if (ptir <= pm[1]) { - choix = 1; - } - if ((ptir > pm[1])&&(ptir <= pm[2])) { - choix = 2; - } - if ((ptir > pm[2])&&(ptir <= pm[3])) { - choix = 3; - } + taballoc(&rr, nr, nc); + taballoc(&cc, nr, nc); + vecintalloc(&vois, 4); + vecintalloc(&reord, 4); + vecintalloc(&rvois, 4); + vecintalloc(&cvois, 4); + vecalloc(&cs, 4); - /* Et re, jusqu'à ce qu'on aille dans une zone accessible */ - cons = reord[choix]; - while (vois[cons] == 1) { - ptir = alea(); - choix = 4; - if (ptir <= pm[1]) { - choix = 1; - } - if ((ptir > pm[1])&&(ptir <= pm[2])) { - choix = 2; - } - if ((ptir > pm[2])&&(ptir <= pm[3])) { - choix = 3; - } - cons = reord[choix]; + /* Rows and columns matrices */ + for (i = 1; i <= nr; i++) { + for (j = 1; j <= nc; j++) { + rr[i][j] = (double) i; + cc[i][j] = (double) j; + } } - /* Stockage de toutes les infos */ - xt = (int) (rvois[choix]); - yt = (int) (cvois[choix]); - x[k] = (double) xt; - y[k] = (double) yt; + cs[1] = pm[1]; + for (i = 2; i <= 4; i++) { + cs[i] = cs[i-1] + pm[i]; + } - if ((xt==1)|(xt==len)|(yt==1)|(yt==len)) - encore = 0; - if (k==nmax) - encore = 0; + /* Beginning of the loop */ + while (encore == 1) { - for (i = 1; i <= 4; i++) { - if ( ((int) rvois[i]) == xt) { - if ( ((int) cvois[i]) == yt) { - dir = i; + /* Storage of the neighbouring */ + vois[1] = (int) map[xt][yt+1]; + vois[2] = (int) map[xt+1][yt]; + vois[3] = (int) map[xt][yt-1]; + vois[4] = (int) map[xt-1][yt]; + + rvois[1] = (int) rr[xt][yt+1]; + rvois[2] = (int) rr[xt+1][yt]; + rvois[3] = (int) rr[xt][yt-1]; + rvois[4] = (int) rr[xt-1][yt]; + + cvois[1] = (int) cc[xt][yt+1]; + cvois[2] = (int) cc[xt+1][yt]; + cvois[3] = (int) cc[xt][yt-1]; + cvois[4] = (int) cc[xt-1][yt]; + + /* Re-order of the neighbouring according to the direction */ + l = 1; + for (i = dir; i <= 4; i++) { + reord[l] = i; + l++; } - } + i = 1; + while (l != 4) { + reord[l] = i; + l++; + i++; + } + + /* random draw of a direction */ + ptir = alea(); + choix = 4; + if (ptir <= pm[1]) { + choix = 1; + } + if ((ptir > pm[1])&&(ptir <= pm[2])) { + choix = 2; + } + if ((ptir > pm[2])&&(ptir <= pm[3])) { + choix = 3; + } + + /* And again, until the direction lead us into an accessible area */ + cons = reord[choix]; + + while (vois[cons] == 1) { + ptir = alea(); + choix = 4; + if (ptir <= pm[1]) { + choix = 1; + } + if ((ptir > pm[1])&&(ptir <= pm[2])) { + choix = 2; + } + if ((ptir > pm[2])&&(ptir <= pm[3])) { + choix = 3; + } + cons = reord[choix]; + } + + /* Stores all information */ + xt = (int) (rvois[choix]); + yt = (int) (cvois[choix]); + + x[k] = (double) xt; + y[k] = (double) yt; + + if ((xt==1)|(xt==len)|(yt==1)|(yt==len)) + encore = 0; + if (k==nmax) + encore = 0; + + for (i = 1; i <= 4; i++) { + if ( ((int) rvois[i]) == xt) { + if ( ((int) cvois[i]) == yt) { + dir = i; + } + } + } + + *nreel = k; + k++; } - *nreel = k; - k++; - } - - freeintvec(vois); - freeintvec(rvois); - freeintvec(cvois); - freeintvec(reord); - freevec(cs); - freetab(rr); - freetab(cc); + /* free memory */ + freeintvec(vois); + freeintvec(rvois); + freeintvec(cvois); + freeintvec(reord); + freevec(cs); + freetab(rr); + freetab(cc); } - +/* For external call from within R */ void perclur(double *mapr, int *nrm, int *ncm, double *probamr, double *xr, double *yr, int *nmaxr, int *nreel) { - double **map, *pm, *x, *y; - int i, j, k, nr, nc, nmax; - - nr = *nrm; - nc = *ncm; - nmax = *nmaxr; - - taballoc(&map, nr, nc); - vecalloc(&x, nmax); - vecalloc(&y, nmax); - vecalloc(&pm, 4); - - x[1] = xr[0]; - y[1] = yr[0]; - - k = 0; - for (i = 1; i <= nr; i++) { - for (j = 1; j <= nc; j++) { - map[i][j] = mapr[k]; - k++; + /* Declaration */ + double **map, *pm, *x, *y; + int i, j, k, nr, nc, nmax; + + /* Memory allocation */ + nr = *nrm; + nc = *ncm; + nmax = *nmaxr; + + taballoc(&map, nr, nc); + vecalloc(&x, nmax); + vecalloc(&y, nmax); + vecalloc(&pm, 4); + + /* R to C */ + x[1] = xr[0]; + y[1] = yr[0]; + + k = 0; + for (i = 1; i <= nr; i++) { + for (j = 1; j <= nc; j++) { + map[i][j] = mapr[k]; + k++; + } } - } - - for (i = 1; i <= 4; i++) { - pm[i] = probamr[i-1]; - } - - perclu(map, nr, nc, x, y, nmax, nreel, pm); - - for (i = 1; i <= *nreel; i++) { - xr[i-1] = x[i]; - yr[i-1] = y[i]; - } - - freevec(x); - freevec(y); - freevec(pm); - freetab(map); + + for (i = 1; i <= 4; i++) { + pm[i] = probamr[i-1]; + } + + /* Main function */ + perclu(map, nr, nc, x, y, nmax, nreel, pm); + + /* C to R */ + for (i = 1; i <= *nreel; i++) { + xr[i-1] = x[i]; + yr[i-1] = y[i]; + } + + /* free memory */ + freevec(x); + freevec(y); + freevec(pm); + freetab(map); } +/* ********************************************************************* + * * + * Rediscretization algorithm for a traject * + * * + ***********************************************************************/ + + + +/* Resolves a quadratic equation of the type + */ + void resolpol(double a, double b, double c, double *x1, double *x2, int *warn) { - double delta; - delta = (b * b) - 4 * a * c; - *warn = 0; - if (delta > 0) { - *x1 = (-b - sqrt(delta)) / (2 * a); - *x2 = (-b + sqrt(delta)) / (2 * a); - } else { - *warn = 1; - } + double delta; + delta = (b * b) - 4 * a * c; + *warn = 0; + if (delta > 0) { + *x1 = (-b - sqrt(delta)) / (2 * a); + *x2 = (-b + sqrt(delta)) / (2 * a); + } else { + *warn = 1; + } } + + + void discretraj(double *x, double *y, double *dat, double *xn, double *yn, int n, int nn, double *datn, double u, int *neff) { - double R, xt, yt, a, b, c, pente, ori, x1, x2, di1, di2; - int k, m, p, fini, ok, warn, *dedans, lo, new, pp; - - fini = 0; - k = 1; - p = 2; - m = 1; - ok = 0; - a = 0; - b = 0; - c = 0; - pente = 0; - ori = 0; - x1 = 0; - x2 = 0; - lo = 0; - di1 = 0; - di2 = 0; - *neff = 0; - new = 0; - pp = 1; - - - vecintalloc(&dedans,2); - - while (fini == 0) { + /* Declaration */ + double R, xt, yt, a, b, c, pente, ori, x1, x2, di1, di2; + int k, m, p, fini, ok, warn, *dedans, lo, new, pp; - dedans[1] = 0; - dedans[2] = 0; + /* memory allocation */ + fini = 0; + k = 1; + p = 2; + m = 1; ok = 0; - xt = xn[k]; - yt = yn[k]; - k++; + a = 0; + b = 0; + c = 0; + pente = 0; + ori = 0; + x1 = 0; + x2 = 0; + lo = 0; + di1 = 0; + di2 = 0; + *neff = 0; new = 0; + pp = 1; - /* Détermination de la loc supérieure */ - while (ok == 0) { - if (new == 1) - p++; - R = sqrt((((x[p] - xt) * (x[p] - xt)) + ((y[p] - yt) * (y[p] - yt)))); - if (R > u) { - ok = 1; - } else { - if (p == n) { - fini = 1; - ok = 1; + + vecintalloc(&dedans,2); + + /* Main algorithm */ + while (fini == 0) { + + dedans[1] = 0; + dedans[2] = 0; + ok = 0; + xt = xn[k]; + yt = yn[k]; + k++; + new = 0; + + /* Determines the "upper" point */ + while (ok == 0) { + if (new == 1) + p++; + R = sqrt((((x[p] - xt) * (x[p] - xt)) + ((y[p] - yt) * (y[p] - yt)))); + if (R > u) { + ok = 1; + } else { + if (p == n) { + fini = 1; + ok = 1; + } + } + new = 1; } - } - new = 1; - } - m = p-1; + m = p-1; if (fini == 0) { - /* Calcul de la pente entre m et p */ - pente = (y[p] - y[m]) / (x[p] - x[m]); - /* Calcul de l'ordonnée à l'origine */ - ori = y[p] - (pente * x[p]); - /* Calcul des paramètres du polynôme */ - a = 1 + (pente * pente); - b = (-2 * xt) + (2 * pente * ori) - (2 * pente * yt); - c = (xt * xt) + (yt * yt) + (ori * ori) - (2 * ori * yt) - (u * u); - resolpol(a, b, c, &x1, &x2, &warn); - - /* - Une droite intersecte un cercle de rayon u - en deux points, il faut déterminer - 1. quel point est le plus proche de m - 2. conserver celui qui est sur le segment m-p - */ - - - /* lesquels sont dans l'intervalle ? */ - if (x1 >= x[m]) { - if (x1 < x[p]) { - dedans[1] = 1; - lo = 1; + /* Computes the slope between m and p */ + pente = (y[p] - y[m]) / (x[p] - x[m]); + /* The intercept */ + ori = y[p] - (pente * x[p]); + /* The parameters of the polynomial equation */ + a = 1 + (pente * pente); + b = (-2 * xt) + (2 * pente * ori) - (2 * pente * yt); + c = (xt * xt) + (yt * yt) + (ori * ori) - (2 * ori * yt) - (u * u); + resolpol(a, b, c, &x1, &x2, &warn); + + /* + A line cut a circle with radius u at two points. One has + (i) to identify the point the closest from m,n and + (ii) to keep the one on the segment m-p + */ + + + /* Which one are in the interval ? */ + if (x1 >= x[m]) { + if (x1 < x[p]) { + dedans[1] = 1; + lo = 1; + } } - } - if (x1 >= x[p]) { - if (x1 < x[m]) { - dedans[1] = 1; - lo = 1; + if (x1 >= x[p]) { + if (x1 < x[m]) { + dedans[1] = 1; + lo = 1; + } } - } - if (x2 >= x[m]) { - if (x2 < x[p]) { - dedans[2] = 1; - lo = 2; + if (x2 >= x[m]) { + if (x2 < x[p]) { + dedans[2] = 1; + lo = 2; + } } - } - if (x2 >= x[p]) { - if (x2 < x[m]) { - dedans[2] = 1; - lo = 2; + if (x2 >= x[p]) { + if (x2 < x[m]) { + dedans[2] = 1; + lo = 2; + } } - } - - /* quelle est la distance minimale a m ? */ - if ((dedans[1] + dedans[2]) > 1) { - di1 = fabs((double) (x[p] - x1)); - di2 = fabs((double) (x[p] - x2)); - - /* vérifier que xk-1 pas dans le même - intervalle, sinon, on augmente d'un cran */ - if (di1 < di2) { - lo = 2; - } else { - lo = 1; + + /* What is the minimum distance to m ? */ + if ((dedans[1] + dedans[2]) > 1) { + di1 = fabs((double) (x[p] - x1)); + di2 = fabs((double) (x[p] - x2)); + + /* verify that xk-1 is not in the same interval. Otherwise one increase of 1 */ + if (di1 < di2) { + lo = 2; + } else { + lo = 1; + } + if (pp == p) { + if (di1 < di2) { + lo = 1; + } + if (di2 < di1) { + lo = 2; + } + } } - if (pp == p) { - if (di1 < di2) { - lo = 1; - } - if (di2 < di1) { - lo = 2; - } + + /* storage of the coordinates */ + if (lo == 1) { + xn[k] = x1; + yn[k] = (pente * x1) + ori; } - } - - /* stockage des coordonnées */ - if (lo == 1) { - xn[k] = x1; - yn[k] = (pente * x1) + ori; - } - if (lo == 2) { - xn[k] = x2; - yn[k] = (pente * x2) + ori; - } - - /* Calcul de la nouvelle date */ - di1 = sqrt((((xn[k] - x[m]) * (xn[k] - x[m])) + ((yn[k] - y[m]) * (yn[k] - y[m])))); - R = sqrt((((x[p] - x[m]) * (x[p] - x[m])) + ((y[p] - y[m]) * (y[p] - y[m])))); - di2 = dat[p] - dat[m]; - datn[k] = dat[m] + (di1 * di2 / R); + if (lo == 2) { + xn[k] = x2; + yn[k] = (pente * x2) + ori; + } + + /* Computes the nnew date (linear approximation) */ + di1 = sqrt((((xn[k] - x[m]) * (xn[k] - x[m])) + ((yn[k] - y[m]) * (yn[k] - y[m])))); + R = sqrt((((x[p] - x[m]) * (x[p] - x[m])) + ((y[p] - y[m]) * (y[p] - y[m])))); + di2 = dat[p] - dat[m]; + datn[k] = dat[m] + (di1 * di2 / R); } if (k == nn) { - fini = 1; + fini = 1; } pp = p; - } - - *neff = k; - freeintvec(dedans); + } + + /* Free memory */ + *neff = k; + freeintvec(dedans); } - +/* For external Call from within R */ void discretrajr(double *xr, double *yr, double *datr, double *xnr, double *ynr, int *nr, int *nnr, double *datnr, double *xdeb, double *ydeb, double *ur, double *dat0, int *neff) { - int i, n, nn; - double *x, *y, *xn, *yn, *dat, *datn, u; - - n = *nr; - nn = *nnr; - u = *ur; - - vecalloc(&x, n); - vecalloc(&y, n); - vecalloc(&xn, nn); - vecalloc(&yn, nn); - vecalloc(&dat, n); - vecalloc(&datn, nn); - - /* passage aux variables locales */ - for (i = 1; i <= n; i++) { - x[i] = xr[i-1]; - y[i] = yr[i-1]; - dat[i] = datr[i-1]; - } - - xn[1] = *xdeb; - yn[1] = *ydeb; - datn[1] = *dat0; - - /* passage a discretraj */ - discretraj(x, y, dat, xn, yn, n, nn, datn, u, neff); - - for (i = 1; i <= nn; i++) { - xnr[i-1] = xn[i]; - ynr[i-1] = yn[i]; - datnr[i-1] = datn[i]; - } + /* Declaration */ + int i, n, nn; + double *x, *y, *xn, *yn, *dat, *datn, u; + + /* Memory allocation */ + n = *nr; + nn = *nnr; + u = *ur; + + vecalloc(&x, n); + vecalloc(&y, n); + vecalloc(&xn, nn); + vecalloc(&yn, nn); + vecalloc(&dat, n); + vecalloc(&datn, nn); + + /* R to C */ + for (i = 1; i <= n; i++) { + x[i] = xr[i-1]; + y[i] = yr[i-1]; + dat[i] = datr[i-1]; + } + + xn[1] = *xdeb; + yn[1] = *ydeb; + datn[1] = *dat0; + + /* Main function */ + discretraj(x, y, dat, xn, yn, n, nn, datn, u, neff); + + /* C to R */ + for (i = 1; i <= nn; i++) { + xnr[i-1] = xn[i]; + ynr[i-1] = yn[i]; + datnr[i-1] = datn[i]; + } - freevec(x); - freevec(y); - freevec(xn); - freevec(yn); - freevec(dat); - freevec(datn); + /* Free memory */ + freevec(x); + freevec(y); + freevec(xn); + freevec(yn); + freevec(dat); + freevec(datn); } - - - - - /* ********************************************************************* * * - * Home range par Clustering (Kenward) * + * Home range by Clustering (Kenward et al. 2001) * * * ***********************************************************************/ +/* finds the cluster with the minimum average distance between the 3 points + not assigned to a cluster */ void trouveclustmin(double **xy, int *clust, int *lo1, int *lo2, int *lo3, double *dist) { + /* Declaration */ int i, j, k, m, npas, nr, *indice; double **xy2, di1, di2, di3, ditmp; + /* Memory allocation */ nr = (int) xy[0][0]; npas = 0; di1 = 0; @@ -6697,6 +6963,7 @@ void trouveclustmin(double **xy, int *clust, int *lo1, int *lo2, di3 = 0; ditmp = 0; + /* Number of non assigned points */ for (i = 1; i <= nr; i++) { if (clust[i] == 0) { npas++; @@ -6704,6 +6971,8 @@ void trouveclustmin(double **xy, int *clust, int *lo1, int *lo2, } taballoc(&xy2, npas, 2); vecintalloc(&indice, npas); + + /* The non assigned points are stored in xy2 */ k = 1; for (i = 1; i <= nr; i++) { if (clust[i] == 0) { @@ -6714,6 +6983,7 @@ void trouveclustmin(double **xy, int *clust, int *lo1, int *lo2, } } + /* Computes the distane between the relocations */ *dist = 0; m=0; for (i = 1; i <= (npas-2); i++) { @@ -6725,8 +6995,9 @@ void trouveclustmin(double **xy, int *clust, int *lo1, int *lo2, (xy2[i][2] - xy2[k][2]) * (xy2[i][2] - xy2[k][2])); di3 = sqrt((xy2[k][1] - xy2[j][1]) * (xy2[k][1] - xy2[j][1]) + (xy2[k][2] - xy2[j][2]) * (xy2[k][2] - xy2[j][2])); - + /* average distance */ ditmp = (di1 + di2 + di3) / 3; + /* minimum distance */ if ((m == 0) || (ditmp < *dist)) { *dist = ditmp; *lo1 = indice[i]; @@ -6737,19 +7008,25 @@ void trouveclustmin(double **xy, int *clust, int *lo1, int *lo2, } } } + /* free memory */ freeintvec(indice); freetab(xy2); } +/* For external call from within R */ void trouveclustminr(double *xyr, int *nr, int *clustr, int *lo1, int *lo2, int *lo3, double *dist) { + /* Declaration */ double **xy; int i, j, k, *clust; + + /* Memory allocation */ taballoc(&xy, *nr, 2); vecintalloc(&clust, *nr); + /* R to C */ k = 0; for (i = 1; i <= *nr; i++) { for (j = 1; j <= 2; j++) { @@ -6761,21 +7038,28 @@ void trouveclustminr(double *xyr, int *nr, int *clustr, int *lo1, int *lo2, clust[i] = clustr[i-1]; } + /* main function */ trouveclustmin(xy, clust, lo1, lo2, lo3, dist); + /* Free memory */ freetab(xy); freeintvec(clust); } +/* Finds the distance between a cluster of points and the nearest point*/ void nndistclust(double **xy, double *xyp, double *dist) { + /* Declaration */ int n, i, m; double di; + m = 0; di =0; n = (int) xy[0][0]; *dist = 0; + + /* finds the distance and the corresponding point */ for (i = 1; i <= n; i++) { di = sqrt( (xy[i][1] - xyp[1]) * (xy[i][1] - xyp[1]) + (xy[i][2] - xyp[2]) * (xy[i][2] - xyp[2]) ); @@ -6787,21 +7071,30 @@ void nndistclust(double **xy, double *xyp, double *dist) } +/* The function nndistclust is applied for all available clusters */ void parclust(double **xy, int *clust, int *noclust, int *noloc, double *dist) { + /* Declaration */ int i, k, m, nr2, nr, nocl; double **xy2, *xyp, di, di2; + + /* Memory allocation */ nocl = *noclust; nr = xy[0][0]; nr2 = 0; + + /* The number of available clusters */ for (i = 1; i <= nr; i++) { if (clust[i] == nocl) { nr2++; } } + taballoc(&xy2, nr2, 2); vecalloc(&xyp, 2); + + /* stores the non assigned points in xy2 */ k = 1; for (i = 1; i <= nr; i++) { if (clust[i] == nocl) { @@ -6811,6 +7104,8 @@ void parclust(double **xy, int *clust, int *noclust, } } + /* Finds the minimum distance between a point and a cluster, + performed for all clusters */ di = 0; di2 = 0; m = 0; @@ -6827,27 +7122,37 @@ void parclust(double **xy, int *clust, int *noclust, m = 1; } } + + /* Free memory */ freetab(xy2); freevec(xyp); } +/* The function trouveminclust identifies the cluster for which the nearest + point is the closest */ void trouveminclust(double **xy, int *liclust, int *clust, int *noclust, int *noloc, double *dist) { + /* Declaration */ int i, nr, nc, m, labclust, nolo; double di; + nr = (int) xy[0][0]; nc = 0; di = 0; labclust = 0; nolo = 0; + /* Assigned clusters */ for (i = 1; i <= nr; i++) { if (liclust[i] > 0) { nc++; } } + + /* finds the minimum distance between a cluster and its nearest point + (the cluster name and the point ID are searched) */ m = 0; *dist = 0; for (i = 1; i <= nc; i++) { @@ -6863,11 +7168,17 @@ void trouveminclust(double **xy, int *liclust, int *clust, } +/* What should be done: create a new cluster or add a relocation + to an existing one ? */ + void choisnvclust(double **xy, int *liclust, int *clust, int *ordre) { + /* Declaration */ int i, k, nr, noloat, cluat, nolo1, nolo2, nolo3, maxclust; int maxindiceclust, clu1, *liclub, nz; double dmoyclust, dminloc; + + /* Memory allocation */ nz = 0; i = 0; k = 0; @@ -6882,6 +7193,7 @@ void choisnvclust(double **xy, int *liclust, int *clust, int *ordre) clu1 = 0; vecintalloc(&liclub, nr); + /* finds the max label for the cluster */ for (i = 1; i <= nr; i++) { if (clust[i] != 0) { if (clust[i] > maxclust) { @@ -6892,12 +7204,12 @@ void choisnvclust(double **xy, int *liclust, int *clust, int *ordre) } } } - - /* Calcul de la distance min à la locs la plus proche */ + + /* Finds the min distance between 3 relocations */ trouveminclust(xy, liclust, clust, &cluat, &noloat, &dminloc); - /* Calcul de la distance moyenne entre les locs du plus petit cluster */ - /* On vérifie tout d'abord qu'il reste au moins trois locs vides */ + /* Computes the average distance between the locs of the smaller cluster */ + /* First, one verifies that there is at least Three non assigned locs */ dmoyclust = dminloc +1; for (i = 1; i <= nr; i++) { if (clust[i] == 0) { @@ -6909,7 +7221,7 @@ void choisnvclust(double **xy, int *liclust, int *clust, int *ordre) trouveclustmin(xy, clust, &nolo1, &nolo2, &nolo3, &dmoyclust); } - /* Premier cas: on a un nouveau cluster indépendant des autres */ + /* First case: A new cluster independent from the others */ if (dmoyclust < dminloc) { ordre[nolo1] = 1; ordre[nolo2] = 1; @@ -6920,17 +7232,17 @@ void choisnvclust(double **xy, int *liclust, int *clust, int *ordre) clust[nolo3] = maxclust + 1; liclust[maxindiceclust+1] = maxclust + 1; - + } else { - /* Deuxième cas: on a une loc qui s'ajoute à un cluster */ + /* Second case: one loc is added to a cluster */ - /* Cas 2.1: la loc n'appartient pas à un cluster */ + /* Case 2.1: the loc does not belong to one cluster */ if (clust[noloat] == 0) { ordre[noloat] = 1; clust[noloat] = cluat; } else { - /* Cas 2.2: la loc appartient à un cluster: fusion */ + /* Case 2.2: the loc belong to one cluster: fusion */ clu1 = clust[noloat]; for (i = 1; i <= nr; i++) { if (clust[i] == clu1) { @@ -6941,7 +7253,7 @@ void choisnvclust(double **xy, int *liclust, int *clust, int *ordre) liclust[i] = 0; } } - /* Et nettoyage de liclust */ + /* and cleaning of liclust */ k = 1; for (i = 1; i <= nr; i++) { if (liclust[i] != 0) { @@ -6958,12 +7270,15 @@ void choisnvclust(double **xy, int *liclust, int *clust, int *ordre) } +/* The main function for home range computation */ void clusterhr(double **xy, int *facso, int *nolocso, int *cluso) { - + /* Declaration */ int i, nr, lo1, lo2, lo3, *clust, len, con, *ordre, *liclust, courant; double di; + + /* Memory allocation */ courant = 1; nr = (int) xy[0][0]; vecintalloc(&clust, nr); @@ -6976,7 +7291,7 @@ void clusterhr(double **xy, int *facso, int *nolocso, int *cluso) con = 1; len = 0; - /* debut: recherche du premier cluster */ + /* Begin: Search for the first cluster */ trouveclustmin(xy, clust, &lo1, &lo2, &lo3, &di); @@ -6986,7 +7301,7 @@ void clusterhr(double **xy, int *facso, int *nolocso, int *cluso) liclust[1] = 1; len = 3; - /* qu'on stocke dans les sorties */ + /* We store it in the output */ cluso[1] = 1; cluso[2] = 1; cluso[3] = 1; @@ -6997,7 +7312,7 @@ void clusterhr(double **xy, int *facso, int *nolocso, int *cluso) facso[2] = 1; facso[3] = 1; - + /* Then repeat until all relocations belong to the same cluster */ while (con == 1) { courant++; @@ -7024,8 +7339,9 @@ void clusterhr(double **xy, int *facso, int *nolocso, int *cluso) if (con == 0) { con = 0; } - } + + /* Free memory */ freeintvec(clust); freeintvec(ordre); freeintvec(liclust); @@ -7033,10 +7349,15 @@ void clusterhr(double **xy, int *facso, int *nolocso, int *cluso) +/* Finds the length of the output for the table containing the home range */ + void longfacclust(double **xy, int *len2) { + /* Declaration */ int i, nr, lo1, lo2, lo3, *clust, len, con, *ordre, *liclust, courant; double di; + + /* Memory allocation */ courant = 1; nr = (int) xy[0][0]; vecintalloc(&clust, nr); @@ -7049,8 +7370,7 @@ void longfacclust(double **xy, int *len2) con = 1; len = 0; - /* debut: recherche du premier cluster */ - + /* Begin: search for the first cluster */ trouveclustmin(xy, clust, &lo1, &lo2, &lo3, &di); clust[lo1] = 1; @@ -7059,6 +7379,7 @@ void longfacclust(double **xy, int *len2) liclust[1] = 1; len = 3; + /* Counts the number of rows needed for the table, which will contain the results */ while (con == 1) { courant++; @@ -7082,40 +7403,60 @@ void longfacclust(double **xy, int *len2) con = 0; } } + *len2 = len; + + /* Free memory */ freeintvec(clust); freeintvec(ordre); freeintvec(liclust); } - +/* For external call from within R */ void longfacclustr(double *xyr, int *nr, int *len2) { + /* Declaration */ double **xy; int i, j, k; + + /* Memory allocation */ taballoc(&xy, *nr, 2); + /* R to C */ k = 0; for (i = 1; i <= *nr; i++) { for (j = 1; j <= 2; j++) { xy[i][j] = xyr[k]; k++; - } } + } + } + + /* Main function */ longfacclust(xy, len2); + + /* Free memory */ freetab(xy); } + + +/* For external call of clusterhrr from within R */ + void clusterhrr(double *xyr, int *nr, int *facsor, int *nolocsor, int *clusor, int *len) { + /* Declaration */ double **xy; int i, j, k, *facso, *nolocso, *cluso; + + /* Memory allocation */ taballoc(&xy, *nr, 2); vecintalloc(&facso, *len); vecintalloc(&nolocso, *len); vecintalloc(&cluso, *len); - + + /* R to C */ k = 0; for (i = 1; i <= *nr; i++) { for (j = 1; j <= 2; j++) { @@ -7124,14 +7465,17 @@ void clusterhrr(double *xyr, int *nr, int *facsor, } } + /* Main function */ clusterhr(xy, facso, nolocso, cluso); + /* C to R */ for (i = 1; i <= *len; i++) { facsor[i-1] = facso[i]; nolocsor[i-1] = nolocso[i]; clusor[i-1] = cluso[i]; } + /* Free memory */ freetab(xy); freeintvec(facso); freeintvec(nolocso);