diff --git a/CONTENTS b/CONTENTS index 665a367..8e628c5 100644 --- a/CONTENTS +++ b/CONTENTS @@ -11,7 +11,7 @@ Description: Exportation of Areas URL: ../../../library/habitat/html/area2dxf.html Entry: as.area -Aliases: as.area +Aliases: as.area, area Keywords: spatial Description: Objects of Class "area" URL: ../../../library/habitat/html/as.area.html @@ -29,7 +29,7 @@ Description: Exploratory Analysis of Habitat Selection URL: ../../../library/habitat/html/as.sahrlocs.html Entry: as.traj -Aliases: as.traj, print.traj, plot.traj, summary.traj, getburst, traj2df, df2traj +Aliases: as.traj, print.traj, plot.traj, summary.traj, getburst, traj2df, df2traj, area Keywords: spatial Description: Working with Trajectories in 2D Space URL: ../../../library/habitat/html/as.traj.html @@ -53,13 +53,13 @@ Description: Radio-Tracking of Bighorn Sheeps URL: ../../../library/habitat/html/bighorn.html Entry: biv.test -Aliases: biv.test +Aliases: biv.test, biv.plot Keywords: multivariate Description: Bivariate Test URL: ../../../library/habitat/html/biv.test.html Entry: buffer -Aliases: buffer, buffer.ani +Aliases: buffer, buffer.ani, buffer.line Keywords: spatial Description: Compute Buffers URL: ../../../library/habitat/html/buffer.html @@ -94,6 +94,12 @@ Keywords: spatial Description: Number of Points in Each Pixel of a Raster Map URL: ../../../library/habitat/html/count.points.id.html +Entry: distfacmap +Aliases: distfacmap +Keywords: spatial +Description: Compute distances to the different levels of a factor map +URL: ../../../library/habitat/html/distfacmap.html + Entry: domain Aliases: domain Keywords: spatial @@ -101,7 +107,7 @@ Description: Estimation of the Potential Distribution of a Species URL: ../../../library/habitat/html/domain.html Entry: enfa -Aliases: enfa, hist.enfa, print.enfa +Aliases: enfa, hist.enfa, print.enfa, data2enfa, print.dataenfa Keywords: multivariate Description: Ecological-Niche Factor Analysis URL: ../../../library/habitat/html/enfa.html @@ -173,6 +179,12 @@ Keywords: multivariate Description: Multivariate analyses of objects of class "kasc" URL: ../../../library/habitat/html/df2kasc.html +Entry: kasc2spixdf +Aliases: kasc2spixdf, asc2spixdf, spixdf2kasc, area2sr, sr2area, attsr2area, traj2spdf, traj2sldf +Keywords: hplot +Description: Conversion of maps from/to the package "sp" +URL: ../../../library/habitat/html/kasc2sgdf.html + Entry: kernelUD Aliases: kernelUD, print.khr, image.khr, plotLSCV, getvolumeUD, kernel.area, getverticeshr, kernelbb, plot.kver Keywords: spatial diff --git a/DESCRIPTION b/DESCRIPTION index 2eaa818..59490ef 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: adehabitat -Version: 1.2-1 -Date: 2005/02/07 +Version: 1.3 +Date: 2005/05/10 Title: Analysis of habitat selection by animals Author: Clément Calenge, contributions from Mathieu Basille Maintainer: Clément Calenge @@ -8,4 +8,4 @@ Depends: R (>= 1.8.0), ade4 Suggests: gpclib Description: A collection of tools for the analysis of habitat selection by animals License: GPL version 2 or newer -Packaged: Mon Feb 7 15:49:00 2005; cnrs +Packaged: Wed May 11 10:31:46 2005; hornik diff --git a/INDEX b/INDEX old mode 100644 new mode 100755 index 4c6978f..7ae7a1f --- a/INDEX +++ b/INDEX @@ -18,6 +18,8 @@ compana Compositional Analysis of Habitat Use convnum Conversion from Factor to Numeric for Raster Map count.points.id Number of Points in Each Pixel of a Raster Map +distfacmap Compute distances to the different levels of a + factor map domain Estimation of the Potential Distribution of a Species enfa Ecological-Niche Factor Analysis @@ -28,8 +30,7 @@ getcontour Computes the Contour Polygon of a Raster getXYcoords Computes the X and Y Coordinates of the Pixels of a Raster Map hist.kasc Histograms of Mapped Variables -histniche Histograms of the Ecological Niche of a - Species +histniche Histograms of the Ecological Niche hr.rast Rasterisation of Objects of Class 'area' image.asc Displays a Color Image of an Object of Class 'asc' @@ -41,6 +42,7 @@ import.asc Arcview ASCII Raster File Importation And join.asc Finds the Value of Mapped Variables at some Specified Locations (Spatial Join) kasc2df Conversion of Objects of Class kasc +kasc2spixdf Conversion of maps from/to the package "sp" kernelUD Estimation of Kernel Home-Range kselect K-Select Analysis: a Method to Analyse the Habitat Selection by Animals diff --git a/R/adehabitat.r b/R/adehabitat.r old mode 100644 new mode 100755 index 5e8bae8..c6c0537 --- a/R/adehabitat.r +++ b/R/adehabitat.r @@ -578,8 +578,7 @@ 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 + ## 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)) @@ -1145,7 +1144,7 @@ kasc2df<-function(x, var=names(x)) } cons<-apply(w, 1, abenner) indcons<-index[cons] - wcons<-w[cons,] + wcons<-data.frame(w[cons,]) output<-list(index=indcons, tab=wcons) } @@ -2486,8 +2485,11 @@ plot.wi<-function(x, caxis=0.7, clab=1, ylog=FALSE, errbar=c("CI", "SE"), ### ### DV par la méthode kernel + + + kernelUD<-function(xy, id=NULL, h="href", grid=40, same4all=FALSE, - hlim=c(0.1, 1.5)) + hlim=c(0.1, 1.5), kern = "bivnorm") { if (ncol(xy)!=2) stop("xy should have 2 columns") @@ -2495,7 +2497,8 @@ kernelUD<-function(xy, id=NULL, h="href", grid=40, same4all=FALSE, stop("id should have the same length as xy") if ((!is.numeric(h))&(h!="href")&(h!="LSCV")) stop("h should be numeric or equal to either \"href\" or \"LSCV\"") - + if ((h == "LSCV")&(kern == "epa")) + stop("LSCV is not implemented with an Epanechnikov kernel") if (is.null(id)) id<-rep(1, nrow(xy)) id<-factor(id) @@ -2560,6 +2563,8 @@ kernelUD<-function(xy, id=NULL, h="href", grid=40, same4all=FALSE, n<-nrow(df) ex<-(-1/6) href<-sdxy*(n^ex) + if (kern=="epa") + href <- href*1.77 if (h=="href") { htmp<-href @@ -2617,12 +2622,21 @@ kernelUD<-function(xy, id=NULL, h="href", grid=40, same4all=FALSE, xylo<-getXYcoords(grid) xg<-xylo$x yg<-xylo$y - 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=="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") { @@ -2838,56 +2852,46 @@ plot.hrsize<-function(x, ...) -kernel.area<-function(xy, id, h = "href", grid=40, - same4all=FALSE, hlim=c(0.1,1.5), - 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) - x<-getvolumeUD(x) - area<-rep(0,length(levels)) - contours<-list() - - for (j in names(x)) { - tmpsurf<-rep(0,length(levels)) - for (i in 1:length(levels)) { - asc<-x[[j]]$UD - tmp<-asc 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")) li<-lapply(li, foo) ## Vérification que pas de doublons au niveau des dates @@ -3895,23 +3904,46 @@ convnum<-function(kasc) { #### Calcul des angles -angles<-function (x, id = levels(x$id), burst = levels(x$burst), date = NULL) +angles<-function (x, id = levels(x$id), burst = levels(x$burst), + date = NULL, slsp = c("remove", "missing")) { if (!inherits(x, "traj")) stop("x should be of class \"traj\"") + slsp <- match.arg(slsp) + + prepangles <- function(x) + { + if (!inherits(x, "traj")) + stop("x should be of class \"traj\"") + li <- split(x, x$burst) + 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,] + } + res <- do.call("rbind", lapply(li, foo)) + return(res) + } + x <- getburst(x, burst = burst, id = id, date = date) + if (slsp=="remove") + x <- prepangles(x) li <- split(x, x$burst) 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] @@ -3919,7 +3951,12 @@ angles<-function (x, id = levels(x$id), burst = levels(x$burst), date = NULL) ## 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], @@ -4123,201 +4160,367 @@ storemapattr<-function(x) ##### L'enfa ##### -biv.test<-function (dfxy, point, cbreaks = 8, h, - colD = "blue", colP = "orange", - o.include = FALSE, rem = NULL, ...) +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)) + 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) + lay <- layout(matrix(c(2,4,1,3),2,2, byrow = TRUE), c(3,1), + c(1,3), TRUE) layout.show(lay) - - x <- c(point[1], dfxy[, 1]) - y <- c(point[2], dfxy[, 2]) - pX <- as.randtest(x[-1], x[1])$pvalue - pY <- as.randtest(y[-1], y[1])$pvalue - x1 <- c(x - diff(range(x))/10, x + diff(range(x))/10) - y1 <- c(y - diff(range(y))/10, y + diff(range(y))/10) - + + 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) { - if (0 < min(x) && 0 > min(x1)) - xlim <- c(0, max(x1)) - else if (0 > max(x) && 0 < max(x1)) - xlim <- c(min(x1), 0) - else xlim <- range(0, x1) - if (0 < min(y) && 0 > min(y1)) - ylim <- c(0, max(y1)) - else if (0 > max(y) && 0 < max(y1)) - ylim <- c(min(y1), 0) - else ylim <- range(0, y1) + 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 <- range(x1) - ylim <- range(y1) + 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(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", - yaxt = "n", xlim = xlim, ylim = ylim, xaxs = "i", yaxs = "i", - frame.plot = FALSE) - col <- "lightgray" - lty <- 1 - xmin <- par("xaxp")[1] - xmax <- par("xaxp")[2] - xampli <- par("xaxp")[3] - ax <- (xmax - xmin)/xampli/cbreaks - ymin <- par("yaxp")[1] - ymax <- par("yaxp")[2] - yampli <- par("yaxp")[3] - ay <- (ymax - ymin)/yampli/cbreaks - while ((xmin - ax) > par("usr")[1]) xmin <- xmin - ax - while ((xmax + ax) < par("usr")[2]) xmax <- xmax + ax - while ((ymin - ay) > par("usr")[3]) ymin <- ymin - ay - while ((ymax + ay) < par("usr")[4]) ymax <- ymax + ay - v0 <- seq(xmin, xmax, by = ax) - h0 <- seq(ymin, ymax, by = ay) - if (par("usr")[1] < xmin) - v0 <- c(par("usr")[1], v0) - if (par("usr")[2] > xmax) - v0 <- c(v0, par("usr")[2]) - if (par("usr")[3] < ymin) - h0 <- c(par("usr")[3], h0) - if (par("usr")[4] > ymax) - h0 <- c(h0, par("usr")[4]) - abline(v = v0[v0 != 0], col = col, lty = lty) - abline(h = h0[h0 != 0], col = col, lty = lty) - points(0, 0, pch = 13, cex = 2) - abline(v = 0) + 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) - para <- par("usr") + 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) + } + if (side == "bottom") { + rect(xl, yd + ht, xl + wt, yd, col = "white", border = 0) + text(xl + wt/2, yd + ht/2, tra, cex = 1) + } + } + points(point[1], point[2], pch = 18, cex = cex*4, col = Pcol) box() - points(x[-1], y[-1]) - points(x[1], y[1], pch = 18, col = colP, cex = 2) - if (missing(h)) - h <- c(bandwidth.nrd(x[-1]), bandwidth.nrd(y[-1])) - dens <- kde2d(x[-1], y[-1], h = h, lims = c(xlim, ylim)) - contour(dens, drawlabels = FALSE, col = colD, lwd = 2, - levels = pretty(dens$z, 10), add = TRUE, ...) - xhist <- hist(x[-1], breaks = v0, plot = FALSE) - yhist <- hist(y[-1], breaks = h0, plot = FALSE) - topx <- max(xhist$counts) - topy <- max(yhist$counts) - legx <- pretty(0:topx) - legx <- legx[-c(1, length(legx))] - legy <- pretty(0:topy) - legy <- legy[-c(1, length(legy))] - plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", - yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = TRUE) - par(usr = c(para[1:2], c(0, topx + topx/10))) - abline(h = legx, lty = 2) - rect(xhist$mids - ax/2, rep(0, length(xhist$mids)), xhist$mids + - ax/2, xhist$counts, col = grey(0.8)) - lines(c(x[1], x[1]), c(max(xhist$counts/2), 0), col = colP, - lwd = 2) - points(x[1], max(xhist$counts/2), pch = 18, cex = 2, - col = colP) - mtext(text = paste("p=", signif(pX, 3)), side = 3, adj = 1, + + 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) - plot.default(0, 0, type = "n", xlab = "", ylab = "", xaxt = "n", - yaxt = "n", xaxs = "i", yaxs = "i", frame.plot = TRUE) - par(usr = c(c(0, topy + topy/10), para[3:4])) - abline(v = legy, lty = 2) - rect(rep(0, length(yhist$mids)), yhist$mids - ay/2, yhist$counts, - yhist$mids + ay/2, col = grey(0.8)) - lines(c(0, max(yhist$counts/2)), c(point[2], point[2]), col = colP, - lwd = 2) - points(max(yhist$counts/2), point[2], pch = 18, cex = 2, - col = colP) - mtext(text = paste("p=", signif(pY, 3)), side = 3, adj = 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 (!is.null(rem)) - mtext(text = paste(rem), adj = 0.5, line = -6) + if (missing(sub)) + sub <- "Biplot and\n univariate\ntests" + mtext(text = paste(sub), adj = 0.5, line = -8, cex = 1.5) } -enfa <- function (kasc, pts, scannf = TRUE, nf = 1) -{ - if (!inherits(kasc, "kasc")) - stop("should be an object of class \"kasc\"") - if (ncol(pts) != 2) - stop("pts should have 2 columns") - attr <- storemapattr(kasc) - call <- match.call() - tab <- kasc2df(kasc) - index <- tab$index - tab <- tab$tab - row.w <- rep(1, nrow(tab))/nrow(tab) - f1 <- function(v) sum(v * row.w)/sum(row.w) - f2 <- function(v) sqrt(sum(v * v * row.w)/sum(row.w)) - center <- apply(tab, 2, f1) - tab <- sweep(tab, 2, center) - norm <- apply(tab, 2, f2) - norm[norm < 1e-08] <- 1 - tab <- as.matrix(sweep(tab, 2, norm, "/")) - pr <- as.vector(count.points(pts, kasc))[index] - lw <- pr/sum(pr) - Rg <- crossprod(tab)/nrow(tab) - ZtQ <- apply(tab, 2, function(x) x * lw) - Rs <- crossprod(ZtQ, tab) - mar <- apply(ZtQ, 2, sum) - m <- sum(mar^2) - eRs <- eigen(Rs) - Rs12 <- eRs$vectors %*% diag(eRs$values^(-1/2)) %*% t(eRs$vectors) - z <- Rs12 %*% mar - y <- z/as.numeric(sqrt(crossprod(z))) - W <- Rs12 %*% Rg %*% Rs12 - H <- (diag(ncol(tab)) - y %*% t(y)) %*% W %*% (diag(ncol(tab)) - - y %*% t(y)) - s <- eigen(H)$values[-ncol(tab)] - if (scannf) { - barplot(s) - cat("Select the number of specialization axes: ") - nf <- as.integer(readLines(n = 1)) - } - if (nf <= 0 | nf > (ncol(tab) - 1)) - nf <- 1 - co <- matrix(nrow = ncol(tab), ncol = nf + 1) - co[, 1] <- mar - co[, 2:(nf + 1)] <- (Rs12 %*% eigen(H)$vectors)[, 1:nf] - f3 <- function(i) co[, i]/sqrt(crossprod(co[, i])/length(co[, - i])) - c1 <- matrix(unlist(lapply(1:(nf + 1), f3)), ncol(tab)) - li <- data.frame(tab %*% c1[, 1:(nf + 1)]) - f3 <- function(i) li[, i]/sqrt(crossprod(li[, i])/length(li[, - i])) - l1 <- matrix(unlist(lapply(1:(nf + 1), f3)), nrow(tab)) - co <- data.frame(co) - c1 <- data.frame(c1) - l1 <- data.frame(l1) - names(co) <- c("Mar", paste("Spe", (1:nf), sep = "")) - row.names(co) <- dimnames(tab)[[2]] - names(c1) <- c("Mar", paste("Spe", (1:nf), sep = "")) - row.names(c1) <- dimnames(tab)[[2]] - names(li) <- c("Mar", paste("Spe", (1:nf), sep = "")) - names(l1) <- c("Mar", paste("Spe", (1:nf), sep = "")) - enfa <- list(call = call, tab = data.frame(tab), pr = pr, - nf = nf, m = m, s = s, lw = lw, li = li, l1 = l1, co = co, - c1 = c1, mar = mar, index = index, attr = attr) - class(enfa) <- "enfa" - return(invisible(enfa)) -} +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"), ...) +{ + 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.7) + 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) + xp <- seq(0, max(x)+xby, by = xby) + if (max(y)>0) + yp <- seq(0, max(y)+yby, by = yby) + if (min(x)<0) + xn <- seq(0, min(x)-xby, by = -xby) + if (min(y)<0) + yn <- seq(0, min(y)-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)-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) + } + 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) + } + 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) + } + } + 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) + + 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) + + 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" + mtext(text = paste(sub), adj = 0.5, line = -8, cex = 1.5) + } + +enfa <- function (tab, pr, scannf = TRUE, nf = 1) +{ + call <- match.call() + if (any(is.na(tab))) + stop("na entries in table") + if (!is.vector(pr)) + stop("pr should be a vector") + row.w <- rep(1, nrow(tab))/nrow(tab) + f1 <- function(v) sum(v * row.w)/sum(row.w) + f2 <- function(v) sqrt(sum(v * v * row.w)/sum(row.w)) + center <- apply(tab, 2, f1) + tab <- sweep(tab, 2, center) + norm <- apply(tab, 2, f2) + norm[norm < 1e-08] <- 1 + tab <- as.matrix(sweep(tab, 2, norm, "/")) + lw <- pr/sum(pr) + Rg <- crossprod(tab)/nrow(tab) + ZtQ <- apply(tab, 2, function(x) x * lw) + Rs <- crossprod(ZtQ, tab) + mar <- colSums(ZtQ) + m <- sum(mar^2) + eRs <- eigen(Rs) + Rs12 <- eRs$vectors %*% diag(eRs$values^(-1/2)) %*% t(eRs$vectors) + z <- Rs12 %*% mar + y <- z/as.numeric(sqrt(crossprod(z))) + W <- Rs12 %*% Rg %*% Rs12 + H <- (diag(ncol(tab)) - y %*% t(y)) %*% W %*% (diag(ncol(tab)) - + y %*% t(y)) + s <- eigen(H)$values[-ncol(tab)] + if (scannf) { + barplot(s) + cat("Select the number of specialization axes: ") + nf <- as.integer(readLines(n = 1)) + } + if (nf <= 0 | nf > (ncol(tab) - 1)) + nf <- 1 + co <- matrix(nrow = ncol(tab), ncol = nf + 1) + co[, 1] <- mar + co[, 2:(nf + 1)] <- (Rs12 %*% eigen(H)$vectors)[, 1:nf] + f3 <- function(i) co[, i]/sqrt(crossprod(co[, i])/length(co[, + i])) + c1 <- matrix(unlist(lapply(1:(nf + 1), f3)), ncol(tab)) + li <- data.frame(tab %*% c1[, 1:(nf + 1)]) + f3 <- function(i) li[, i]/sqrt(crossprod(li[, i])/length(li[, + i])) + l1 <- matrix(unlist(lapply(1:(nf + 1), f3)), nrow(tab)) + co <- data.frame(co) + c1 <- data.frame(c1) + l1 <- data.frame(l1) + names(co) <- c("Mar", paste("Spe", (1:nf), sep = "")) + row.names(co) <- dimnames(tab)[[2]] + names(c1) <- c("Mar", paste("Spe", (1:nf), sep = "")) + row.names(c1) <- dimnames(tab)[[2]] + names(li) <- c("Mar", paste("Spe", (1:nf), sep = "")) + names(l1) <- c("Mar", paste("Spe", (1:nf), sep = "")) + enfa <- list(call = call, tab = data.frame(tab), pr = pr, + nf = nf, m = m, s = s, lw = lw, li = li, l1 = l1, co = co, + c1 = c1, mar = mar) + class(enfa) <- "enfa" + return(invisible(enfa)) +} +data2enfa <- function (kasc, pts) +{ + if (!inherits(kasc, "kasc")) + stop("should be an object of class \"kasc\"") + if (ncol(pts) != 2) + stop("pts should have 2 columns") + 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, + index = index, attr = attr) + class(dataenfa) <- "dataenfa" + return(invisible(dataenfa)) +} -hist.enfa <- function (x, scores = TRUE, type = c("h", "l"), adjust = 1, - Acol, Ucol, Aborder, Uborder, ...) +hist.enfa <- 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, "enfa")) @@ -4360,12 +4563,12 @@ hist.enfa <- function (x, scores = TRUE, type = c("h", "l"), adjust = 1, par(mar = c(0.5, 0.5, 2, 0.5)) par(mfrow = rev(n2mfrow(ncol(tab)))) f1 <- function(j) { - tmpS <- rep(tab[, j], pr) - tmpZ <- tab[, 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(tmpZ), table(tmpS))) + mat <- t(cbind(table(tmpA), table(tmpU))) mat <- lapply(1:2, function(i) mat[i, ]/sum(mat[i, ])) mat <- rbind(mat[[1]], mat[[2]]) @@ -4379,34 +4582,34 @@ hist.enfa <- function (x, scores = TRUE, type = c("h", "l"), adjust = 1, } else { if (type == "h") { - xrange <- range(tmpZ) - H <- hist(tmpS, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) - G <- hist(tmpZ, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) + 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) } - else { - densZ <- density(tmpZ, adjust = adjust) - densS <- density(tmpS, adjust = adjust, from = min(densZ$x), - to = max(densZ$x)) - max <- max(densS$y, densZ$y) + 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(densS, col = Ucol, ylim = ylim, type = "l", - lwd = 2, main = name, xlab = NULL, ylab = "Density", + plot(densU, col = Ucol, ylim = ylim, type = "l", + lwd = Ulwd, main = name, xlab = NULL, ylab = "Density", axes = FALSE, ...) - lines(rep(mean(tmpS), 2), c(0, densS$y[512 - sum(densS$x > - mean(tmpS))]), - col = Ucol, lty = 2, lwd = 2) - lines(densZ, col = Acold, lwd = 2) - lines(rep(mean(tmpZ), 2), c(0, densZ$y[512 - sum(densZ$x > - mean(tmpZ))]), - col = Acold, lty = 2, lwd = 2) + 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() @@ -4416,23 +4619,15 @@ hist.enfa <- function (x, scores = TRUE, type = c("h", "l"), adjust = 1, } - - -hist.kasc <- function (x, type = c("h", "l"), adjust = 1, col, border, ...) +hist.kasc <- function (x, type = c("h", "l"), adjust = 1, col = "blue", ...) { type <- match.arg(type) if (!inherits(x, "kasc")) stop("should be an object of class \"kasc\"") old.par <- par(no.readonly = TRUE) on.exit(par(old.par)) - if (missing(col)) { - col <- NULL - cold <- "black" - } - else - cold <- col - if (missing(border)) - border <- "black" + par(mar = c(0.5,0.5,2,0.5)) + tab <- x clas <- rep("", ncol(tab)) for (j in 1:ncol(tab)) { @@ -4441,61 +4636,62 @@ hist.kasc <- function (x, type = c("h", "l"), adjust = 1, col, border, ...) w1 <- "f" clas[j] <- w1 } - par(mar = c(0.5, 0.5, 2, 0.5)) + par(mfrow = rev(n2mfrow(ncol(tab)))) + f1 <- function(j) { - tmpZ <- tab[, j] + tmpZ <- tab[,j] name <- names(tab)[j] if (clas[j] == "f") { - par(mar = c(3, 0.5, 2, 0.5)) + par(mar = c(3,0.5,2,0.5)) max <- max(table(tmpZ)) max <- max + max/20 ylim <- c(0, max) - barplot(unclass(summary(tmpZ[!is.na(tmpZ)])), ylim = ylim, - border = border, col = col, main = name, ylab = NULL, - axes = FALSE, ...) - par(mar = c(0.5, 0.5, 2, 0.5)) + + barplot(unclass(summary(tmpZ[!is.na(tmpZ)])), ylim = ylim, border = col, + main = name, ylab = NULL, axes = FALSE, ...) + par(mar = c(0.5,0.5,2,0.5)) } else { xrange <- range(tmpZ) G <- hist(tmpZ, plot = FALSE) - plot(G, freq = FALSE, border = border, col = col, - main = name, xlab = NULL, ylab = NULL, axes = FALSE, - ...) + plot(G, freq = FALSE, border = col, main = name, + xlab = NULL, ylab = NULL, axes = FALSE, ...) } box() } + f2 <- function(j) { - tmpZ <- tab[, j] + tmpZ <- tab[,j] name <- names(tab)[j] if (clas[j] == "f") { - par(mar = c(3, 0.5, 2, 0.5)) + par(mar = c(3,0.5,2,0.5)) max <- max(table(tmpZ)) max <- max + max/20 ylim <- c(0, max) - barplot(unclass(summary(tmpZ[!is.na(tmpZ)])), ylim = ylim, - border = border, col = col, main = name, ylab = NULL, - axes = FALSE, ...) - par(mar = c(0.5, 0.5, 2, 0.5)) + barplot(unclass(summary(tmpZ[!is.na(tmpZ)])), ylim = ylim, border = col, + main = name, ylab = NULL, axes = FALSE, ...) + par(mar = c(0.5,0.5,2,0.5)) } else { dens <- density(tmpZ, adjust = adjust, na.rm = TRUE) - plot(dens, col = cold, type = "l", lwd = 2, main = name, - xlab = NULL, ylab = "Density", axes = FALSE, - ...) + plot(dens, col = col, type = "l", lwd = 2, + main = name, xlab = NULL, ylab = "Density", + axes = FALSE, ...) mean <- mean(tmpZ, na.rm = TRUE) - lines(rep(mean, 2), c(0, dens$y[512 - sum(dens$x > - mean)]), - col = cold, lty = 2, lwd = 2) + lines(rep(mean,2), + c(0,dens$y[512-sum(dens$x>mean)]), + col = col, lty = 2, lwd = 2) } box() } - if (type == "h") - lapply(1:ncol(tab), f1) + + if (type == "h") + lapply (1:ncol(tab), f1) if (type == "l") { - if (any(clas == "f")) + if (any(clas == "f")) warning("Type = 'l' is not possible for factors, type = 'h' used instead.\n") - lapply(1:ncol(tab), f2) + lapply (1:ncol(tab), f2) } return(invisible(NULL)) } @@ -4503,14 +4699,15 @@ hist.kasc <- function (x, type = c("h", "l"), adjust = 1, col, border, ...) + histniche <- function (kasc, pts, type = c("h", "l"), adjust = 1, Acol, Ucol, - Aborder, Uborder, ...) + 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") + if (ncol(pts) != 2) + stop("pts should have 2 columns") tab <- kasc2df(kasc) index <- tab$index tab <- tab$tab @@ -4548,14 +4745,13 @@ histniche <- function (kasc, pts, type = c("h", "l"), adjust = 1, Acol, Ucol, par(mar = c(0.5, 0.5, 2, 0.5)) par(mfrow = rev(n2mfrow(ncol(tab)))) f1 <- function(j) { - tmpS <- rep(tab[, j], pr) - tmpZ <- tab[, 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(tmpZ), table(tmpS))) - mat <- lapply(1:2, function(i) mat[i, ]/sum(mat[i, - ])) + 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 @@ -4567,34 +4763,34 @@ histniche <- function (kasc, pts, type = c("h", "l"), adjust = 1, Acol, Ucol, } else { if (type == "h") { - xrange <- range(tmpZ) - H <- hist(tmpS, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) - G <- hist(tmpZ, plot = FALSE, br = seq(min(xrange), - max(xrange), length = 15)) + 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) } - else { - densZ <- density(tmpZ, adjust = adjust) - densS <- density(tmpS, adjust = adjust, from = min(densZ$x), - to = max(densZ$x)) - max <- max(densS$y, densZ$y) + 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(densS, col = Ucol, ylim = ylim, type = "l", - lwd = 2, main = name, xlab = NULL, ylab = "Density", + plot(densU, col = Ucol, ylim = ylim, type = "l", + lwd = Ulwd, main = name, xlab = NULL, ylab = "Density", axes = FALSE, ...) - lines(rep(mean(tmpS), 2), c(0, densS$y[512 - sum(densS$x > - mean(tmpS))]), - col = Ucol, lty = 2, lwd = 2) - lines(densZ, col = Acold, lwd = 2) - lines(rep(mean(tmpZ), 2), c(0, densZ$y[512 - sum(densZ$x > - mean(tmpZ))]), - col = Acold, lty = 2, lwd = 2) + 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() @@ -4605,72 +4801,80 @@ histniche <- function (kasc, pts, type = c("h", "l"), adjust = 1, Acol, Ucol, -niche.test <- function (kasc, points, nrep = 999, h, o.include = FALSE, - colZ = "blue", colS = "orange", ...) + +niche.test <- function (kasc, points, nrep = 999, o.include = TRUE, ...) { - if (!inherits(kasc, "kasc")) - stop("should be an object of class \"kasc\"") - 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) - stop("points outside the study area") - - litab<-kasc2df(kasc) - dude<-dudi.mix(litab$tab, scannf = FALSE) - cw<-dude$cw - kasc <- df2kasc(dude$tab, litab$index, kasc) - asc<-getkasc(kasc, names(kasc)[1]) - coo<-getXYcoords(kasc) - rc<-lapply(coo, range) - kasc<-as.matrix(kasc) - 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") - mar <- toto[[10]] - tol <- toto[[11]] - dfxy <- data.frame(marginalite = mar, tolerance = tol)[-1,] - obs <- c(mar[1], tol[1]) - - if (missing(h)) - h <- c(bandwidth.nrd(dfxy[,1]), bandwidth.nrd(dfxy[,2])) - biv.test(dfxy, obs, h=h, colD = colZ, colP = colS, - o.include = o.include, ...) - return(invisible(list(dfxy = dfxy, obs = obs))) + if (!inherits(kasc, "kasc")) + stop("should be an object of class \"kasc\"") + 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) + stop("points outside the study area") + litab <- kasc2df(kasc) + dude <- dudi.mix(litab$tab, scannf = FALSE) + cw <- dude$cw + kasc <- df2kasc(dude$tab, litab$index, kasc) + asc <- getkasc(kasc, names(kasc)[1]) + coo <- getXYcoords(kasc) + rc <- lapply(coo, range) + kasc <- as.matrix(kasc) + 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") + 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", + o.include = o.include, ...) + return(invisible(list(dfxy = dfxy, obs = obs))) } +predict.enfa <- function (object, index, attr, nf, ...) +{ + if (!inherits(object, "enfa")) + stop("should be an object of class \"enfa\"") + if ((missing(nf)) || (nf > object$nf)) + nf <- object$nf + Zli <- object$li[, 1:(nf + 1)] + 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) + map <- getkasc(df2kasc(data.frame(toto = maha, tutu = maha), + index, attr), "toto") + return(invisible(map)) +} -predict.enfa <- function (object, nf, ...) +print.dataenfa <- function (x, ...) { - if (!inherits(object, "enfa")) - stop("should be an object of class \"enfa\"") - - if ((missing(nf)) || (nf > object$nf)) - nf <- object$nf - - Zli <- object$li[,1:(nf+1)] - 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) - - map <- getkasc(df2kasc(data.frame(toto=maha, tutu=maha), - object$index, object$attr), "toto") - return(invisible(map)) + 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", + "content"))) + sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "table of pixels") + class(sumry) <- "table" + print(sumry) + cat("\n") + sumry <- array("", c(2, 3), list(1:2, c("vector", "length", "content"))) + sumry[1, ] <- c("$pr", length(x$pr), "vector of presence") + sumry[2, ] <- c("$index", length(x$index), "position of the rows") + class(sumry) <- "table" + print(sumry) + cat("\n$attr: attributes of the initial kasc\n") } @@ -4711,8 +4915,10 @@ print.enfa <- function (x, ...) sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores") class(sumry) <- "table" print(sumry) - cat("\nother elements: ") - cat(names(x)[(11 + 2):(length(x))], "\n") + if (length(names(x)) > 12) { + cat("\nother elements: ") + cat(names(x)[13:(length(x))], "\n") + } } @@ -4730,13 +4936,13 @@ randtest.enfa<-function(xtest, nrepet=999, ...) } -scatter.enfa <- function(x, xax = 1, yax = 2, pts = FALSE, - nc = TRUE, percent = 95, - clabel = 1, side = c("top", "bottom", "none"), - csub = 1, Adensity, Udensity, Aangle, Uangle, - Aborder, Uborder, Acol, - Ucol, Alty, Ulty, Apch, Upch, - Abg, Ubg, Acex, Ucex, ...) + +scatter.enfa <- function(x, xax = 1, yax = 2, pts = FALSE, nc = TRUE, + percent = 95, 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) if (!inherits(x, "enfa")) @@ -4753,32 +4959,32 @@ scatter.enfa <- function(x, xax = 1, yax = 2, pts = FALSE, pmar <- t(x$mar) %*% as.matrix(x$c1[, 1:(x$nf + 1)]) scatterutil.base(dfxy = x$li[, 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, + 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 (Apch)) - Apch <- 19 - if (missing (Upch)) - Upch <- 19 if (missing (Acol)) Acol <- gray(0.8) - if (missing (Ucol)) - Ucol <- "black" + if (missing (Ucol)) + Ucol <- "black" if (missing (Abg)) - Abg <- NA + Abg <- gray(0.8) if (missing (Ubg)) - Ubg <- NA - if (missing (Acex)) - Acex <- 1 - if (missing (Ucex)) - Ucex <- 1 - points(x$li[, c(xax, yax)], pch = Apch, col = Acol, bg = Abg, cex = Acex) - points(x$li[rep(1:length(x$pr), x$pr), c(xax, yax)], pch = Upch, col = Ucol, bg = Ubg, cex = Ucex) + Ubg <- "black" + if (missing (Ainch)) + Ainch <- 0.03 + if (missing (Uinch)) + Uinch <- Ainch*max(x$pr) + symbols(x$li[, c(xax, yax)], circles = rep(1, length(x$pr)), + fg = Acol, bg = Abg, inches = Ainch, add = TRUE) + symbols(x$li[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) if (nc) - points(pmar, pch = 21, bg = "white", cex = Ucex+0.2) + symbols(pmar, circles = 1, fg = "black", bg = "white", + inches = Ainch*2, add = TRUE) } else { if (missing(Adensity)) @@ -4801,16 +5007,20 @@ scatter.enfa <- function(x, xax = 1, yax = 2, pts = FALSE, Alty <- NULL if (missing(Ulty)) Ulty <- NULL - if (missing (Ucex)) - Ucex <- 1 - mcpA <- mcp(x$li[, c(xax, yax)], id = rep(1, dim(x$li)[1]), percent = percent) - mcpU <- mcp(x$li[rep(1:length(x$pr), x$pr), c(xax, yax)], id = rep(1, sum(enfa1$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) + # if (missing (Ucex)) + # Ucex <- 1 + mcpA <- mcp(x$li[, c(xax, yax)], id = rep(1, dim(x$li)[1]), + percent = percent) + mcpU <- mcp(x$li[rep(1:length(x$pr), x$pr), c(xax, yax)], + id = rep(1, sum(enfa1$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 (nc) - points(pmar, pch = 21, bg = "white", cex = Ucex+0.2) + points(pmar, pch = 21, bg = "white", cex = 1.5) } dfarr <- x$c1[, c(xax, yax)] born <- par("usr") @@ -4827,19 +5037,29 @@ scatter.enfa <- function(x, xax = 1, yax = 2, pts = FALSE, if (yax == 1) yax <- "mar" else yax <- paste("sp", yax - 1) - if (side == "none") - return(invisible()) - if (side == "top") - mtext(text = paste(" xax =", xax, "\n yax =", yax), side = 3, - line = -2 * csub, adj = 0, cex = csub) - else mtext(text = paste(" xax =", xax, "\n yax =", yax), - side = 1, line = -2, adj = 0, cex = csub) + 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() } - ## fit the nearest-neighbor convex hull NNCH<-function(xy, id=NULL, k=10, unin = c("m", "km"), @@ -5084,9 +5304,7 @@ plot.NNCHver<-function(x, which = names(x), if (!add) plot(xt, yt, asp=1, ty = "n", ...) - res<-list() - for (i in which) - res[[i]]<-x[[which]] + res<-x[which] lapply(1:length(res), function(x) plot(res[[x]], poly.args = list(col = colpol[x], @@ -5125,11 +5343,13 @@ NNCH.rast<-function(y, w) } else { ee <- rr[[1]] } - for (j in 2:length(rr)) { - if (hol[[i]][j]) - ee <- ee - rr[[j]] - if (!hol[[i]][j]) - ee <- ee + rr[[j]] + if (length(rr) >1){ + for (j in 2:length(rr)) { + if (hol[[i]][j]) + ee <- ee - rr[[j]] + if (!hol[[i]][j]) + ee <- ee + rr[[j]] + } } ee[ee==0] <- NA res[[i]] <- getascattr(w, ee) @@ -5385,3 +5605,350 @@ schoener.rtest <- function(tr, keep, byburst=TRUE, nrep=500) +### Buffer autour des lignes + +buffer.line <- function(xy, x, dist) + { + if (inherits(x, "kasc")) + x <- getkasc(x, 1) + if (!inherits(x, "asc")) + stop("x should be an object of class asc") + ra<- attr(x, "cellsize")/100 + xy[,1]<-jitter(xy[,1], amount=ra) + xy[,2]<-jitter(xy[,2], amount=ra) + bu <- buffer(xy, x, dist) + bu[is.na(bu)]<-0 + + carter <- matrix(0, nrow=nrow(x), ncol = ncol(x)) + xyg <- getXYcoords(x) + xgr<-xyg$x + ygr<-xyg$y + + 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]] + + output <- matrix(toto, nrow = nrow(x), byrow = TRUE) + output <- output + bu + output[output>0]<-1 + + output[output == 0] <- NA + attr(output, "xll") <- attr(x, "xll") + attr(output, "yll") <- attr(x, "yll") + attr(output, "cellsize") <- attr(x, "cellsize") + attr(output, "type") <- "numeric" + class(output) <- "asc" + return(output) +} + + + +############################################################################################## +############################################################################################## +##### +##### Interface vers "sp" + + +kasc2spixdf <- function(ka) + { + if (!inherits(ka, "kasc")) + stop("ka should be of class \"kasc\"") + if (!require(sp)) + stop("the package sp is required for this function") + 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) + ka <- managNAkasc(ka) + cons <- (1:nrow(ka))[!is.na(ka[,1])] + df <- ka[cons,] + class(df) <- "data.frame" + xyc <- xyc[cons,] + names(xyc) <- c("x","y") + df1 <- data.frame(xyc, df) + coordinates(df1) <- c("x","y") + gridded(df1) <- TRUE + return(df1) + } + +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) + } + +spixdf2kasc <- function(sg) + { + if (!require(sp)) + stop("the package sp is required for this function") + if (inherits(sg, "SpatialPixelsDataFrame")) + sg <- as(sg, "SpatialGridDataFrame") + if (!inherits(sg, "SpatialGridDataFrame")) + stop(paste("sg should be of class \"SpatialPixelsDataFrame\"", + "\nor \"SpatialGridDataFrame\"")) + gr <- gridparameters(sg) + if (nrow(gr)>2) + 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") + fullgrid(sg) <- TRUE + xy <- coordinates(sg) + 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) + ka <- ka[,is.na(match(names(ka), nxy))] + 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 (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 + } + return(ka) + } + +area2sr <- function(ar) + { + if (!inherits(ar, "area")) + stop("ka should be of class \"area\"") + if (!require(sp)) + stop("the package sp is required for this function") + class(ar) <- "data.frame" + li <- split(ar[,2:3],ar[,1]) + res <- lapply(li, function(x) { + if (!all(unlist(x[1,]==x[nrow(x),]))) + x <- rbind(x,x[1,]) + x <- as.matrix(x) + y <- Sring(x, hole=FALSE) + if (y@ringDir<0) + y <- Sring(x[nrow(x):1,], hole=FALSE) + return(y) + }) + resb <- SpatialRings(lapply(1:length(res), + function(i) Srings(list(res[[i]]), + names(res)[i]))) + return(resb) + } + + +sr2area <- function(sr) + { + if (!require(sp)) + stop("the package sp is required for this function") + if (inherits(sr, "SpatialRingsDataFrame")) + sr <- rings(sr) + if (!inherits(sr, "SpatialRings")) + stop("sr should be of class \"SpatialRings\" or \"SpatialRingsDataFrame\"") + pol <- sr@polygons + warh <- 0 + warh2 <- 0 + warz <- 0 + res <- lapply(pol, function(x) { + y <- x@Srings + 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) + })) + } + 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) + })) + } + } + return(list(re,warh2, warh, warz)) + }) + 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) + 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")) + } +## if (warz>0) { +## warning(paste("Some spatial rings contained several polygons.\n", +## "Labels have therefore been changed for", warz, "objects")) +## } + return(res) + } + + +attsr2area <- function(srdf) + { + if (!inherits(srdf, "SpatialRingsDataFrame")) + stop("sr should be of class \"SpatialRingsDataFrame\"") + dat <- srdf@data + sr <- rings(srdf) + + res <- lapply(1:length(sr@polygons), function(i) { + x <- sr@polygons[[i]] + y <- x@Srings + 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) + } + + + +traj2spdf <- function(tr) + { + if (!inherits(tr, "traj")) + stop("tr should be of class \"traj\"") + class(tr) <- "data.frame" + xy <- tr[,c("x","y")] + tr$y <- tr$x <- NULL + res <- SpatialPointsDataFrame(xy, tr) + return(res) + } + + +traj2sldf <- function(tr, byid = FALSE) + { + if (!inherits(tr, "traj")) + stop("tr should be of class \"traj\"") + class(tr) <- "data.frame" + lixy <- lapply(split(tr[,c("x","y")], tr$burst), function(x) Sline(as.matrix(x))) + id <- unlist(lapply(split(tr$id, tr$burst), function(x) x[1])) + bu <- unlist(lapply(split(tr$burst, tr$burst), function(x) x[1])) + + if (byid) { + lev <- as.numeric(levels(factor(id))) + re1 <- lapply(lev, function(x) Slines(lixy[id==x])) + res <- SpatialLines(re1) + df <- data.frame(id=lev) + } else { + res <- lapply(lixy, function(x) Slines(list(x))) + res <- SpatialLines(res) + df <- data.frame(id=id, burst=bu) + } + res <- SpatialLinesDataFrame(res, data=df) + return(res) + } + + + +############################################################################################## +############################################################################################## +##### +##### Calcul de distances aux patchs d'habitat + +distfacmap <- function(x) + { + if (!inherits(x, "asc")) + stop("x should be of class \"asc\"") + if (attr(x, "type")!="factor") + stop("x should be of type \"factor\"") + 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 (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]] + } + 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/inst/doc/classes.R b/inst/doc/classes.R index 0cc40fa..caa318d 100644 --- a/inst/doc/classes.R +++ b/inst/doc/classes.R @@ -6,30 +6,35 @@ options("width"=80) ow <- getOption("warn") options("warn"=-1) .PngNo <- 0 +argX11<-formals(x11) ################################################### -### chunk number 2: afig +### chunk number 2: afig eval=FALSE ################################################### -.PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") -png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") -opar <- par(no.readonly = TRUE) +## if (!is.null(argX11$colortype)) { +## graphics.off() +## x11(colortype="gray") +## } +## .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") +## png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") +## opar <- par(no.readonly = TRUE) ################################################### -### chunk number 3: zfig +### chunk number 3: zfig eval=FALSE ################################################### -par(opar) -dev.null <- dev.off() -cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") +## par(opar) +## dev.null <- dev.off() +## cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 4: zfigkasc +### chunk number 4: zfigkasc eval=FALSE ################################################### -par(opar) -dev.null <- dev.off() -cat("\\includegraphics[height=12cm,keepaspectratio]{", file, "}\n\n", sep="") +## par(opar) +## dev.null <- dev.off() +## cat("\\includegraphics[height=12cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### @@ -39,26 +44,30 @@ library(adehabitat) ################################################### -### chunk number 6: rand +### chunk number 6: rand eval=FALSE ################################################### -mat <- matrix(rnorm(10000), 100, 100) -asc <- as.asc(mat) -image(asc) -box() +## mat <- matrix(rnorm(10000), 100, 100) +## asc <- as.asc(mat) +## image(asc) +## box() ################################################### -### chunk number 7: +### chunk number 7: eval=FALSE ################################################### -mat <- matrix(rnorm(10000), 100, 100) -asc <- as.asc(mat) -image(asc) -box() +## mat <- matrix(rnorm(10000), 100, 100) +## asc <- as.asc(mat) +## image(asc) +## box() ################################################### ### chunk number 8: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -79,22 +88,26 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 10: elev +### chunk number 10: elev eval=FALSE ################################################### -el <- import.asc(path.to.file) -image(el, main = "Elevation") +## el <- import.asc(path.to.file) +## image(el, main = "Elevation") ################################################### -### chunk number 11: +### chunk number 11: eval=FALSE ################################################### -el <- import.asc(path.to.file) -image(el, main = "Elevation") +## el <- import.asc(path.to.file) +## image(el, main = "Elevation") ################################################### ### chunk number 12: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -140,22 +153,26 @@ co <- colasc(asp, North = "blue", East = "yellow", ################################################### -### chunk number 17: asp +### chunk number 17: asp eval=FALSE ################################################### -image(asp, clfac = co) -legend(696662, 3166028, legend = levels(asp), fill = co) +## image(asp, clfac = co) +## legend(696662, 3166028, legend = levels(asp), fill = co) ################################################### -### chunk number 18: +### chunk number 18: eval=FALSE ################################################### -image(asp, clfac = co) -legend(696662, 3166028, legend = levels(asp), fill = co) +## image(asp, clfac = co) +## legend(696662, 3166028, legend = levels(asp), fill = co) ################################################### ### chunk number 19: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -167,24 +184,28 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 20: kasc +### chunk number 20: kasc eval=FALSE ################################################### -data(puechabon) -kasc <- puechabon$kasc -image(kasc) +## data(puechabon) +## kasc <- puechabon$kasc +## image(kasc) ################################################### -### chunk number 21: +### chunk number 21: eval=FALSE ################################################### -data(puechabon) -kasc <- puechabon$kasc -image(kasc) +## data(puechabon) +## kasc <- puechabon$kasc +## image(kasc) ################################################### ### chunk number 22: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -211,36 +232,40 @@ puechabon$locs[1:4,] ################################################### -### chunk number 25: prespuech +### chunk number 25: prespuech eval=FALSE ################################################### -el <- getkasc(puechabon$kasc, "Elevation") -opar <- par(mfrow = c(2,2), mar=c(0,0,4,0)) -for (i in levels(puechabon$locs$Name)) { - image(el, - main = paste("Wild boar named", i), - axes=FALSE) - points(puechabon$locs[puechabon$locs$Name==i,c("X","Y")], pch=16) -} -par(opar) +## el <- getkasc(puechabon$kasc, "Elevation") +## opar <- par(mfrow = c(2,2), mar=c(0,0,4,0)) +## for (i in levels(puechabon$locs$Name)) { +## image(el, +## main = paste("Wild boar named", i), +## axes=FALSE) +## points(puechabon$locs[puechabon$locs$Name==i,c("X","Y")], pch=16) +## } +## par(opar) ################################################### -### chunk number 26: +### chunk number 26: eval=FALSE ################################################### -el <- getkasc(puechabon$kasc, "Elevation") -opar <- par(mfrow = c(2,2), mar=c(0,0,4,0)) -for (i in levels(puechabon$locs$Name)) { - image(el, - main = paste("Wild boar named", i), - axes=FALSE) - points(puechabon$locs[puechabon$locs$Name==i,c("X","Y")], pch=16) -} -par(opar) +## el <- getkasc(puechabon$kasc, "Elevation") +## opar <- par(mfrow = c(2,2), mar=c(0,0,4,0)) +## for (i in levels(puechabon$locs$Name)) { +## image(el, +## main = paste("Wild boar named", i), +## axes=FALSE) +## points(puechabon$locs[puechabon$locs$Name==i,c("X","Y")], pch=16) +## } +## par(opar) ################################################### ### chunk number 27: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -267,24 +292,28 @@ chamois$locs[1:4,] ################################################### -### chunk number 29: preschart +### chunk number 29: preschart eval=FALSE ################################################### -sl <- getkasc(chamois$map, "Slope") -image(sl, main = "Distribution of chamois occurrences in the Chartreuse mountain") -points(chamois$locs, pch=16) +## sl <- getkasc(chamois$map, "Slope") +## image(sl, main = "Distribution of chamois occurrences in the Chartreuse mountain") +## points(chamois$locs, pch=16) ################################################### -### chunk number 30: +### chunk number 30: eval=FALSE ################################################### -sl <- getkasc(chamois$map, "Slope") -image(sl, main = "Distribution of chamois occurrences in the Chartreuse mountain") -points(chamois$locs, pch=16) +## sl <- getkasc(chamois$map, "Slope") +## image(sl, main = "Distribution of chamois occurrences in the Chartreuse mountain") +## points(chamois$locs, pch=16) ################################################### ### chunk number 31: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -304,45 +333,69 @@ kasc <- puechabon$kasc ################################################### -### chunk number 33: +### chunk number 33: disfm eval=FALSE ################################################### -er8 <- morphology(el, operation="erode", nt=8) -di8 <- morphology(el, operation="dilate", nt=8) +## image(distfacmap(getkasc(puechabon$kasc, "Aspect"))) ################################################### -### chunk number 34: morpho +### chunk number 34: eval=FALSE ################################################### -image(di8, col="black") -image(el, col="gray", add=TRUE) -image(er8, col="white", add=TRUE) - -arrows(703530, 3165169, 703530, (3165169-800), code = 3, lwd = 2, length = 0.1) -text(704156, 3164775, "800 m") -arrows(704295, 3159355, 706588, 3157294, col="red", lwd = 2, code = 1) -text(706240, 3156738, "Boundary of the study area") -legend(696000, 3165841, c("Buffer area inside the boundary", -"Buffer area outside the boundary"), fill = c("gray", "black"), cex = 0.7) +## image(distfacmap(getkasc(puechabon$kasc, "Aspect"))) ################################################### ### chunk number 35: ################################################### -image(di8, col="black") -image(el, col="gray", add=TRUE) -image(er8, col="white", add=TRUE) - -arrows(703530, 3165169, 703530, (3165169-800), code = 3, lwd = 2, length = 0.1) -text(704156, 3164775, "800 m") -arrows(704295, 3159355, 706588, 3157294, col="red", lwd = 2, code = 1) -text(706240, 3156738, "Boundary of the study area") -legend(696000, 3165841, c("Buffer area inside the boundary", -"Buffer area outside the boundary"), fill = c("gray", "black"), cex = 0.7) +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} +.PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") +png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") +opar <- par(no.readonly = TRUE) +image(distfacmap(getkasc(puechabon$kasc, "Aspect"))) +par(opar) +dev.null <- dev.off() +cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### ### chunk number 36: ################################################### +er8 <- morphology(el, operation="erode", nt=8) +di8 <- morphology(el, operation="dilate", nt=8) + + +################################################### +### chunk number 37: morpho eval=FALSE +################################################### +## image(di8, col="black") +## image(el, col="gray", add=TRUE) +## image(er8, col="white", add=TRUE) +## +## arrows(704295, 3159355, 706588, 3157294, col="red", lwd = 2, code = 1) +## text(706240, 3156738, "Boundary of the study area") + + +################################################### +### chunk number 38: eval=FALSE +################################################### +## image(di8, col="black") +## image(el, col="gray", add=TRUE) +## image(er8, col="white", add=TRUE) +## +## arrows(704295, 3159355, 706588, 3157294, col="red", lwd = 2, code = 1) +## text(706240, 3156738, "Boundary of the study area") + + +################################################### +### chunk number 39: +################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -350,41 +403,41 @@ image(di8, col="black") image(el, col="gray", add=TRUE) image(er8, col="white", add=TRUE) -arrows(703530, 3165169, 703530, (3165169-800), code = 3, lwd = 2, length = 0.1) -text(704156, 3164775, "800 m") arrows(704295, 3159355, 706588, 3157294, col="red", lwd = 2, code = 1) text(706240, 3156738, "Boundary of the study area") -legend(696000, 3165841, c("Buffer area inside the boundary", -"Buffer area outside the boundary"), fill = c("gray", "black"), cex = 0.7) par(opar) dev.null <- dev.off() cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 37: +### chunk number 40: ################################################### data(puechabon) puechabon$locs[1:4,] ################################################### -### chunk number 38: ptsel +### chunk number 41: ptsel eval=FALSE ################################################### -image(el) -points(puechabon$locs[,c("X","Y")], pch = 16) +## image(el) +## points(puechabon$locs[,c("X","Y")], pch = 16) ################################################### -### chunk number 39: +### chunk number 42: eval=FALSE ################################################### -image(el) -points(puechabon$locs[,c("X","Y")], pch = 16) +## image(el) +## points(puechabon$locs[,c("X","Y")], pch = 16) ################################################### -### chunk number 40: +### chunk number 43: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -396,24 +449,28 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 41: buffel +### chunk number 44: buffel eval=FALSE ################################################### -bu <- buffer(puechabon$locs[,c("X","Y")], el, 500) -image(bu) -points(puechabon$locs[,c("X","Y")], pch = 16) +## bu <- buffer(puechabon$locs[,c("X","Y")], el, 500) +## image(bu) +## points(puechabon$locs[,c("X","Y")], pch = 16) ################################################### -### chunk number 42: +### chunk number 45: eval=FALSE ################################################### -bu <- buffer(puechabon$locs[,c("X","Y")], el, 500) -image(bu) -points(puechabon$locs[,c("X","Y")], pch = 16) +## bu <- buffer(puechabon$locs[,c("X","Y")], el, 500) +## image(bu) +## points(puechabon$locs[,c("X","Y")], pch = 16) ################################################### -### chunk number 43: +### chunk number 46: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -426,7 +483,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 44: +### chunk number 47: ################################################### bubis <- bu * el mean(as.vector(bubis), na.rm = TRUE) @@ -434,20 +491,24 @@ sd(as.vector(bubis), na.rm = TRUE) ################################################### -### chunk number 45: bufbis +### chunk number 48: bufbis eval=FALSE ################################################### -image(bubis) +## image(bubis) ################################################### -### chunk number 46: +### chunk number 49: eval=FALSE ################################################### -image(bubis) +## image(bubis) ################################################### -### chunk number 47: +### chunk number 50: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -458,7 +519,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 48: +### chunk number 51: ################################################### vec <- join.asc(puechabon$locs[,c("X", "Y")], el) length(vec) @@ -467,7 +528,7 @@ vec[1:10] ################################################### -### chunk number 49: +### chunk number 52: ################################################### df <- join.kasc(puechabon$locs[,c("X", "Y")], puechabon$kasc) nrow(df) @@ -476,28 +537,32 @@ df[1:10,] ################################################### -### chunk number 50: +### chunk number 53: ################################################### (cp <- count.points(puechabon$locs[,c("X","Y")], el)) ################################################### -### chunk number 51: countpoints +### chunk number 54: countpoints eval=FALSE ################################################### -image(cp) -box() +## image(cp) +## box() ################################################### -### chunk number 52: +### chunk number 55: eval=FALSE ################################################### -image(cp) -box() +## image(cp) +## box() ################################################### -### chunk number 53: +### chunk number 56: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -509,26 +574,30 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 54: +### chunk number 57: ################################################### (cp <- count.points.id(puechabon$locs[,c("X","Y")], puechabon$locs$Name, el)) ################################################### -### chunk number 55: cpid +### chunk number 58: cpid eval=FALSE ################################################### -image(cp) +## image(cp) ################################################### -### chunk number 56: +### chunk number 59: eval=FALSE ################################################### -image(cp) +## image(cp) ################################################### -### chunk number 57: +### chunk number 60: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -539,24 +608,28 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 58: ascgen +### chunk number 61: ascgen eval=FALSE ################################################### -hihi <- ascgen(xy = puechabon$locs[,c("X","Y")], cellsize = 500) -image(hihi) -box() +## hihi <- ascgen(xy = puechabon$locs[,c("X","Y")], cellsize = 500) +## image(hihi) +## box() ################################################### -### chunk number 59: +### chunk number 62: eval=FALSE ################################################### -hihi <- ascgen(xy = puechabon$locs[,c("X","Y")], cellsize = 500) -image(hihi) -box() +## hihi <- ascgen(xy = puechabon$locs[,c("X","Y")], cellsize = 500) +## image(hihi) +## box() ################################################### -### chunk number 60: +### chunk number 63: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -569,22 +642,26 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 61: cpidvg +### chunk number 64: cpidvg eval=FALSE ################################################### -tmpbis <- count.points.id(xy = puechabon$locs[,c("X","Y")], id = puechabon$locs$Name, hihi) -image(tmpbis) +## tmpbis <- count.points.id(xy = puechabon$locs[,c("X","Y")], id = puechabon$locs$Name, hihi) +## image(tmpbis) ################################################### -### chunk number 62: +### chunk number 65: eval=FALSE ################################################### -tmpbis <- count.points.id(xy = puechabon$locs[,c("X","Y")], id = puechabon$locs$Name, hihi) -image(tmpbis) +## tmpbis <- count.points.id(xy = puechabon$locs[,c("X","Y")], id = puechabon$locs$Name, hihi) +## image(tmpbis) ################################################### -### chunk number 63: +### chunk number 66: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -596,7 +673,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 64: +### chunk number 67: ################################################### el <- getkasc(puechabon$kasc, "Elevation") elcat <- el < 200 @@ -605,28 +682,32 @@ names(attributes(elcat)) ################################################### -### chunk number 65: +### chunk number 68: ################################################### (elcat<-getascattr(el, elcat, type = "factor", lev = c("> 200 m", "< 200 m"))) ################################################### -### chunk number 66: elcat +### chunk number 69: elcat eval=FALSE ################################################### -image(elcat) -legend(698000, 3165000, levels(elcat), fill=rainbow(2)) +## image(elcat) +## legend(698000, 3165000, levels(elcat), fill=rainbow(2)) ################################################### -### chunk number 67: +### chunk number 70: eval=FALSE ################################################### -image(elcat) -legend(698000, 3165000, levels(elcat), fill=rainbow(2)) +## image(elcat) +## legend(698000, 3165000, levels(elcat), fill=rainbow(2)) ################################################### -### chunk number 68: +### chunk number 71: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -638,30 +719,34 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 69: managna +### chunk number 72: managna eval=FALSE ################################################### -kasc <- puechabon$kasc -el <- getkasc(kasc, "Elevation") -sl <- getkasc(kasc, "Slope") -el[el < 200] <- NA -tmp <- as.kasc(list(Elevation = el, Slope = sl)) -image(tmp) +## kasc <- puechabon$kasc +## el <- getkasc(kasc, "Elevation") +## sl <- getkasc(kasc, "Slope") +## el[el < 200] <- NA +## tmp <- as.kasc(list(Elevation = el, Slope = sl)) +## image(tmp) ################################################### -### chunk number 70: +### chunk number 73: eval=FALSE ################################################### -kasc <- puechabon$kasc -el <- getkasc(kasc, "Elevation") -sl <- getkasc(kasc, "Slope") -el[el < 200] <- NA -tmp <- as.kasc(list(Elevation = el, Slope = sl)) -image(tmp) +## kasc <- puechabon$kasc +## el <- getkasc(kasc, "Elevation") +## sl <- getkasc(kasc, "Slope") +## el[el < 200] <- NA +## tmp <- as.kasc(list(Elevation = el, Slope = sl)) +## image(tmp) ################################################### -### chunk number 71: +### chunk number 74: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -677,22 +762,26 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 72: manna +### chunk number 75: manna eval=FALSE ################################################### -tmp <- managNAkasc(tmp) -image(tmp) +## tmp <- managNAkasc(tmp) +## image(tmp) ################################################### -### chunk number 73: +### chunk number 76: eval=FALSE ################################################### -tmp <- managNAkasc(tmp) -image(tmp) +## tmp <- managNAkasc(tmp) +## image(tmp) ################################################### -### chunk number 74: +### chunk number 77: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -704,7 +793,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 75: +### chunk number 78: ################################################### data(puechabon) kasc <- puechabon$kasc @@ -714,7 +803,7 @@ toto ################################################### -### chunk number 76: +### chunk number 79: ################################################### huhu <- kasc2df(kasc) names(huhu) @@ -723,29 +812,33 @@ huhu$tab[1:4,] ################################################### -### chunk number 77: +### chunk number 80: ################################################### huhu$tab$Aspect <- NULL (pc <- dudi.pca(huhu$tab, scannf =FALSE, nf=2)) ################################################### -### chunk number 78: df2kasc +### chunk number 81: df2kasc eval=FALSE ################################################### -map <- df2kasc(pc$li, huhu$index, kasc) -image(map) +## map <- df2kasc(pc$li, huhu$index, kasc) +## image(map) ################################################### -### chunk number 79: +### chunk number 82: eval=FALSE ################################################### -map <- df2kasc(pc$li, huhu$index, kasc) -image(map) +## map <- df2kasc(pc$li, huhu$index, kasc) +## image(map) ################################################### -### chunk number 80: +### chunk number 83: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -757,27 +850,31 @@ cat("\\includegraphics[height=12cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 81: +### chunk number 84: ################################################### (kasc <- chamois$map) (si1 <- object.size(kasc)) ################################################### -### chunk number 82: donncham +### chunk number 85: donncham eval=FALSE ################################################### -image(kasc) +## image(kasc) ################################################### -### chunk number 83: +### chunk number 86: eval=FALSE ################################################### -image(kasc) +## image(kasc) ################################################### -### chunk number 84: +### chunk number 87: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -788,26 +885,30 @@ cat("\\includegraphics[height=12cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 85: +### chunk number 88: ################################################### (m <- lowres(kasc, np = 4)) ################################################### -### chunk number 86: lowres +### chunk number 89: lowres eval=FALSE ################################################### -image(m) +## image(m) ################################################### -### chunk number 87: +### chunk number 90: eval=FALSE ################################################### -image(m) +## image(m) ################################################### -### chunk number 88: +### chunk number 91: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -818,61 +919,65 @@ cat("\\includegraphics[height=12cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 89: +### chunk number 92: ################################################### (si2 <- object.size(m)) (si1 - si2)/si1 ################################################### -### chunk number 90: subset -################################################### -data(chamois) -slope <- getkasc(chamois$map, "Slope") -def.par <- par(no.readonly = TRUE) -layout(matrix(c(1,1,1,1,1,1,1,1,2), ncol = 3, byrow = TRUE)) -par(mar = c(0,0,0,0)) -image(slope, axes=FALSE) -box() - -x <- c(863603.8, 867286.5) -y <- c(2042689, 2045797) -polygon(x = c(x[1], x[2], x[2], x[1]), - y = c(y[1], y[1], y[2], y[2]), lwd=2) - -sl2 <- subsetmap(slope, xlim = x, ylim = y) -par(mar = c(0,0,2,0)) -image(sl2, axes = FALSE, main = "Reduced map") -box() -par(def.par) +### chunk number 93: subset eval=FALSE +################################################### +## data(chamois) +## slope <- getkasc(chamois$map, "Slope") +## def.par <- par(no.readonly = TRUE) +## layout(matrix(c(1,1,1,1,1,1,1,1,2), ncol = 3, byrow = TRUE)) +## par(mar = c(0,0,0,0)) +## image(slope, axes=FALSE) +## box() +## +## x <- c(863603.8, 867286.5) +## y <- c(2042689, 2045797) +## polygon(x = c(x[1], x[2], x[2], x[1]), +## y = c(y[1], y[1], y[2], y[2]), lwd=2) +## +## sl2 <- subsetmap(slope, xlim = x, ylim = y) +## par(mar = c(0,0,2,0)) +## image(sl2, axes = FALSE, main = "Reduced map") +## box() +## par(def.par) + + +################################################### +### chunk number 94: eval=FALSE +################################################### +## data(chamois) +## slope <- getkasc(chamois$map, "Slope") +## def.par <- par(no.readonly = TRUE) +## layout(matrix(c(1,1,1,1,1,1,1,1,2), ncol = 3, byrow = TRUE)) +## par(mar = c(0,0,0,0)) +## image(slope, axes=FALSE) +## box() +## +## x <- c(863603.8, 867286.5) +## y <- c(2042689, 2045797) +## polygon(x = c(x[1], x[2], x[2], x[1]), +## y = c(y[1], y[1], y[2], y[2]), lwd=2) +## +## sl2 <- subsetmap(slope, xlim = x, ylim = y) +## par(mar = c(0,0,2,0)) +## image(sl2, axes = FALSE, main = "Reduced map") +## box() +## par(def.par) ################################################### -### chunk number 91: -################################################### -data(chamois) -slope <- getkasc(chamois$map, "Slope") -def.par <- par(no.readonly = TRUE) -layout(matrix(c(1,1,1,1,1,1,1,1,2), ncol = 3, byrow = TRUE)) -par(mar = c(0,0,0,0)) -image(slope, axes=FALSE) -box() - -x <- c(863603.8, 867286.5) -y <- c(2042689, 2045797) -polygon(x = c(x[1], x[2], x[2], x[1]), - y = c(y[1], y[1], y[2], y[2]), lwd=2) - -sl2 <- subsetmap(slope, xlim = x, ylim = y) -par(mar = c(0,0,2,0)) -image(sl2, axes = FALSE, main = "Reduced map") -box() -par(def.par) - - -################################################### -### chunk number 92: +### chunk number 95: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -900,7 +1005,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 93: +### chunk number 96: ################################################### data(elec88) ar <- elec88$area @@ -908,34 +1013,38 @@ ar[1:5,] ################################################### -### chunk number 94: area +### chunk number 97: area eval=FALSE ################################################### -ar <- as.area(ar) -area.plot(ar) +## ar <- as.area(ar) +## plot(ar) ################################################### -### chunk number 95: +### chunk number 98: eval=FALSE ################################################### -ar <- as.area(ar) -area.plot(ar) +## ar <- as.area(ar) +## plot(ar) ################################################### -### chunk number 96: +### chunk number 99: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) ar <- as.area(ar) -area.plot(ar) +plot(ar) par(opar) dev.null <- dev.off() cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 97: +### chunk number 100: ################################################### data(puechabon) lo <- puechabon$locs @@ -944,33 +1053,37 @@ class(cp) ################################################### -### chunk number 98: convpol +### chunk number 101: convpol eval=FALSE ################################################### -opar <- par(mar=c(0,0,0,0)) -area.plot(cp) -points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) -box() -par(opar) +## opar <- par(mar=c(0,0,0,0)) +## plot(cp, colp=NULL) +## points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) +## box() +## par(opar) ################################################### -### chunk number 99: +### chunk number 102: eval=FALSE ################################################### -opar <- par(mar=c(0,0,0,0)) -area.plot(cp) -points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) -box() -par(opar) +## opar <- par(mar=c(0,0,0,0)) +## plot(cp, colp=NULL) +## points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) +## box() +## par(opar) ################################################### -### chunk number 100: +### chunk number 103: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) opar <- par(mar=c(0,0,0,0)) -area.plot(cp) +plot(cp, colp=NULL) points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) box() par(opar) @@ -980,7 +1093,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 101: +### chunk number 104: ################################################### el <- getkasc(puechabon$kasc, "Elevation") cont.el <- getcontour(el) @@ -989,22 +1102,26 @@ nlevels(cont.el[,1]) ################################################### -### chunk number 102: getcontour +### chunk number 105: getcontour eval=FALSE ################################################### -image(el) -polygon(cont.el[,2:3], lwd = 3) +## image(el) +## polygon(cont.el[,2:3], lwd = 3) ################################################### -### chunk number 103: +### chunk number 106: eval=FALSE ################################################### -image(el) -polygon(cont.el[,2:3], lwd = 3) +## image(el) +## polygon(cont.el[,2:3], lwd = 3) ################################################### -### chunk number 104: +### chunk number 107: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -1016,7 +1133,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 105: +### chunk number 108: ################################################### lo <- puechabon$locs kasc <- puechabon$kasc @@ -1024,55 +1141,59 @@ cp <- mcp(lo[,c("X", "Y")], lo[,"Name"]) ################################################### -### chunk number 106: +### chunk number 109: ################################################### (rast <- hr.rast(cp, kasc)) ################################################### -### chunk number 107: mcprast +### chunk number 110: mcprast eval=FALSE ################################################### -def.par <- par(no.readonly = TRUE) -layout(matrix(c(1,1,2,4,3,5),2,3)) -par(mar=c(0,0,4,0)) -area.plot(cp) -points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) -box() -for (i in names(rast)) { -image(getkasc(rast,i), main = paste("Wild boar named", i), axes=FALSE) -polygon(cont.el[,2:3]) -box() -} -par(def.par) +## def.par <- par(no.readonly = TRUE) +## layout(matrix(c(1,1,2,4,3,5),2,3)) +## par(mar=c(0,0,4,0)) +## plot(cp, colp=NULL) +## points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) +## box() +## for (i in names(rast)) { +## image(getkasc(rast,i), main = paste("Wild boar named", i), axes=FALSE) +## polygon(cont.el[,2:3]) +## box() +## } +## par(def.par) ################################################### -### chunk number 108: +### chunk number 111: eval=FALSE ################################################### -def.par <- par(no.readonly = TRUE) -layout(matrix(c(1,1,2,4,3,5),2,3)) -par(mar=c(0,0,4,0)) -area.plot(cp) -points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) -box() -for (i in names(rast)) { -image(getkasc(rast,i), main = paste("Wild boar named", i), axes=FALSE) -polygon(cont.el[,2:3]) -box() -} -par(def.par) +## def.par <- par(no.readonly = TRUE) +## layout(matrix(c(1,1,2,4,3,5),2,3)) +## par(mar=c(0,0,4,0)) +## plot(cp, colp=NULL) +## points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) +## box() +## for (i in names(rast)) { +## image(getkasc(rast,i), main = paste("Wild boar named", i), axes=FALSE) +## polygon(cont.el[,2:3]) +## box() +## } +## par(def.par) ################################################### -### chunk number 109: +### chunk number 112: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) def.par <- par(no.readonly = TRUE) layout(matrix(c(1,1,2,4,3,5),2,3)) par(mar=c(0,0,4,0)) -area.plot(cp) +plot(cp, colp=NULL) points(puechabon$locs[,c("X", "Y")], pch=16, col = as.numeric(puechabon$locs$Name)) box() for (i in names(rast)) { @@ -1087,28 +1208,32 @@ cat("\\includegraphics[height=12cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 110: polmask +### chunk number 113: polmask eval=FALSE ################################################### -el <- getkasc(puechabon$kasc, "Elevation") -pol <- data.frame(x = c(700658, 699222, 698342, 698643, 700427, 701029), - y = c(3160768, 3160676, 3159402, 3158336, 3158869, 3159657)) -image(el) -polygon(pol, lwd=2) +## el <- getkasc(puechabon$kasc, "Elevation") +## pol <- data.frame(x = c(700658, 699222, 698342, 698643, 700427, 701029), +## y = c(3160768, 3160676, 3159402, 3158336, 3158869, 3159657)) +## image(el) +## polygon(pol, lwd=2) ################################################### -### chunk number 111: +### chunk number 114: eval=FALSE ################################################### -el <- getkasc(puechabon$kasc, "Elevation") -pol <- data.frame(x = c(700658, 699222, 698342, 698643, 700427, 701029), - y = c(3160768, 3160676, 3159402, 3158336, 3158869, 3159657)) -image(el) -polygon(pol, lwd=2) +## el <- getkasc(puechabon$kasc, "Elevation") +## pol <- data.frame(x = c(700658, 699222, 698342, 698643, 700427, 701029), +## y = c(3160768, 3160676, 3159402, 3158336, 3158869, 3159657)) +## image(el) +## polygon(pol, lwd=2) ################################################### -### chunk number 112: +### chunk number 115: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -1123,26 +1248,30 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 113: mask +### chunk number 116: mask eval=FALSE ################################################### -pr <- mcp.rast(pol, el) -masked.kasc <- setmask(puechabon$kasc, pr) -image(masked.kasc, xlim = c(696999, 702373), - ylim = c(3156784, 3162297)) +## pr <- mcp.rast(pol, el) +## masked.kasc <- setmask(puechabon$kasc, pr) +## image(masked.kasc, xlim = c(696999, 702373), +## ylim = c(3156784, 3162297)) ################################################### -### chunk number 114: +### chunk number 117: eval=FALSE ################################################### -pr <- mcp.rast(pol, el) -masked.kasc <- setmask(puechabon$kasc, pr) -image(masked.kasc, xlim = c(696999, 702373), - ylim = c(3156784, 3162297)) +## pr <- mcp.rast(pol, el) +## masked.kasc <- setmask(puechabon$kasc, pr) +## image(masked.kasc, xlim = c(696999, 702373), +## ylim = c(3156784, 3162297)) ################################################### -### chunk number 115: +### chunk number 118: ################################################### +if (!is.null(argX11$colortype)) { + graphics.off() + x11(colortype="gray") +} .PngNo <- .PngNo + 1; file <- paste("Fig-bitmap-", .PngNo, ".png", sep="") png(file=file, width = 700, height = 700, pointsize = 12, bg = "white") opar <- par(no.readonly = TRUE) @@ -1156,7 +1285,7 @@ cat("\\includegraphics[height=7cm,keepaspectratio]{", file, "}\n\n", sep="") ################################################### -### chunk number 116: +### chunk number 119: ################################################### def.pol <- function(x) { toto<-locator(1) diff --git a/inst/doc/classes.pdf b/inst/doc/classes.pdf index a5b05f2..3eff317 100644 Binary files a/inst/doc/classes.pdf and b/inst/doc/classes.pdf differ diff --git a/man/angles.Rd b/man/angles.Rd index 55ffa67..e274cc1 100644 --- a/man/angles.Rd +++ b/man/angles.Rd @@ -7,7 +7,8 @@ for a clearer definition. } \usage{ -angles(x, id = levels(x$id), burst = levels(x$burst), date = NULL) +angles(x, id = levels(x$id), burst = levels(x$burst), + date = NULL, slsp = c("remove", "missing")) } \arguments{ \item{x}{an object of class \code{traj} } @@ -17,6 +18,11 @@ angles(x, id = levels(x$id), burst = levels(x$burst), date = NULL) the angles are to be computed (see \code{as.traj})} \item{date}{a vector of class \code{POSIXct} of length 2 (beginning, end) delimiting the period of interest} + \item{slsp}{a character string. If \code{"remove"}, successive + relocations located at the same place are replaced by a single + relocation, allowing the computation of the angles. If + \code{"missing"}, a missing value is returned for the angles when + successive relocations located at the same place. } } \value{ Returns a data frame with the following components: diff --git a/man/as.area.Rd b/man/as.area.Rd index 11a4569..46d57cb 100644 --- a/man/as.area.Rd +++ b/man/as.area.Rd @@ -1,5 +1,6 @@ \name{as.area} \alias{as.area} +\alias{area} \title{Objects of Class "area"} \description{ Objects of class \code{area} are used to store the information on diff --git a/man/as.traj.Rd b/man/as.traj.Rd index f24796e..e4af67b 100644 --- a/man/as.traj.Rd +++ b/man/as.traj.Rd @@ -1,5 +1,6 @@ \name{as.traj} \alias{as.traj} +\alias{traj} \alias{print.traj} \alias{summary.traj} \alias{plot.traj} diff --git a/man/biv.test.Rd b/man/biv.test.Rd index 0953cb3..7d021d8 100644 --- a/man/biv.test.Rd +++ b/man/biv.test.Rd @@ -1,29 +1,44 @@ \name{biv.test} +\alias{biv.plot} \alias{biv.test} \title{Bivariate Test} \description{ + \code{biv.plot} displays a bivariate plot. \code{biv.test} displays the results of a bivariate randomisation test. } \usage{ -biv.test(dfxy, point, cbreaks = 8, h, colD = "blue", colP = "orange", - o.include = FALSE, rem = NULL, \dots) +biv.plot(dfxy, br = 10, points = TRUE, density = TRUE, + kernel = TRUE, o.include = FALSE, pch, cex, col, h, sub, + side = c("top", "bottom", "none"), \dots) +biv.test(dfxy, point, br = 10, points = TRUE, density = TRUE, + kernel = TRUE, o.include = FALSE, pch, cex, col, Pcol, h, sub, + side = c("top", "bottom", "none"), \dots) } \arguments{ \item{dfxy}{a data frame with N lines (couples of values) and two columns} - \item{point}{a vector of length 2, representing - the observation to be compared with the simulated values of the - randomisation test} - \item{cbreaks}{a parameter used to define the numbers of breaks of the + \item{br}{a parameter used to define the numbers of breaks of the histograms. A larger value leads to a larger number of breaks} + \item{points}{logical. Whether the points should be displayed} + \item{density}{logical. Whether the kernel density estimation should be + displayed for the marginal histograms} + \item{kernel}{logical. Whether the kernel density estimation should be + displayed for the bivariate plot} + \item{o.include}{logical. If \code{TRUE}, the origin is included in + the plot} + \item{pch}{plotting "character", i.e., symbol to use for the points. (see + \code{?points})} + \item{cex}{character expansion for the points} + \item{col}{color code or name for the points, see \code{?par}} \item{h}{vector of bandwidths for x and y directions, used in the function \code{kde2d} of the package \code{MASS}. Defaults to normal reference bandwidth (see \code{?kde2d})} - \item{colD}{a color used for the contours} - \item{colP}{a color used for the observation} - \item{o.include}{logical. If \code{TRUE}, the origin is included in - the plot} - \item{rem}{a character string to be inserted in the plot} + \item{sub}{a character string to be inserted in the plot as a title} + \item{side}{if \code{"top"}, the x and y scales of the grid are upside, + if \code{"bottom"} they are downside, if \code{"none"} no legend} + \item{point}{a vector of length 2, representing the observation to be + compared with the simulated values of the randomisation test} + \item{Pcol}{color code or name for the observed point} \item{\dots}{further arguments passed to or from other methods} } \details{ @@ -40,19 +55,25 @@ biv.test(dfxy, point, cbreaks = 8, h, colD = "blue", colP = "orange", } \author{Mathieu Basille \email{basille@biomserv.univ-lyon1.fr}} \section{Warning}{ - \code{biv.test} uses the function \code{kde2d} of the package - \code{MASS}. + \code{biv.plot} and \code{biv.test} uses the function \code{kde2d} of the + package \code{MASS}. } \seealso{ \code{\link[ade4]{as.randtest}}, \code{\link{niche.test}} } \examples{ + \dontrun{ -if (require(MASS)) { - dfxy <- data.frame(x = rnorm(1000,5), y = rnorm(1000,5)) - p <- c(3.5, 3.5) - biv.test(dfxy, p, rem = "Bivariate\nnormal distribution") -} +x = rnorm(1000,2) +y = 2*x+rnorm(1000,2) +dfxy = data.frame(x, y) + +biv.plot(dfxy) +biv.plot(dfxy, points=F, col="lightblue", br=20) + +p = c(3, 4) +biv.test(dfxy, p) +biv.test(dfxy, p, points=F, Pcol="darkred", col="lightblue", br=20) } } \keyword{multivariate} diff --git a/man/buffer.Rd b/man/buffer.Rd index 76a5760..6b14c24 100644 --- a/man/buffer.Rd +++ b/man/buffer.Rd @@ -1,6 +1,7 @@ \name{buffer} \alias{buffer} \alias{buffer.ani} +\alias{buffer.line} \title{Compute Buffers} \description{ \code{buffer} compute buffers around a set of @@ -8,11 +9,13 @@ \code{buffer.ani} is to be used when the points can be grouped into several categories (e.g. the relocations of several animals monitored using radio-tracking; the function - \code{buffer} is then applied to each animal). + \code{buffer} is then applied to each animal).\cr + \code{buffer.line} compute buffers around a line. } \usage{ buffer(pts, x, dist) buffer.ani(pts, fac, x, dist) +buffer.line(xy, x, dist) } \arguments{ @@ -23,9 +26,12 @@ buffer.ani(pts, fac, x, dist) \code{mapattr} (see \code{storemapattr})} \item{dist}{a value of distance} \item{fac}{a factor defining the categories of the points} + \item{xy}{a data frame containing the coordinates of the vertices of + the lines} } \value{ - \code{buffer} returns an object of class \code{asc}, with 1 for pixels + \code{buffer} and \code{buffer.line} return an object of class + \code{asc}, with 1 for pixels located within a specified distance of given points, and \code{NA} otherwise.\cr \code{buffer.ani} returns a data frame of class \code{kasc}, @@ -57,6 +63,15 @@ image(bu) # of a relocation of each monitored wild boar buani <- buffer.ani(locs[,4:5], locs[,1], sa, 500) image(buani) - + + +## buffer around a trajectory +data(puechcirc) +uu <- getburst(puechcirc, burst = "CH930824") +w <- ascgen(uu[,c("x","y")], nrcol = 100) +out <- buffer.line(uu[,c("x","y")], w, 100) +image(out) +plot(uu, asc = out) + } \keyword{spatial} diff --git a/man/distfacmap.Rd b/man/distfacmap.Rd new file mode 100644 index 0000000..2b509a5 --- /dev/null +++ b/man/distfacmap.Rd @@ -0,0 +1,30 @@ +\name{distfacmap} +\alias{distfacmap} +\title{Compute distances to the different levels of a factor map } +\description{ + This function computes map of distances to patches belonging to the + different levels of a map of class \code{asc} and of type + \code{factor}. +} +\usage{ +distfacmap(x) +} +\arguments{ + \item{x}{an object of class \code{asc} and of type \code{factor} } +} +\value{ + An object of class \code{kasc}. +} +\author{ Clément Calenge \email{calenge@biomserv.univ-lyon1.fr} } +\seealso{ \code{\link{import.asc}} for further info on objects of class + \code{asc}. } +\examples{ +\dontrun{ +data(puechabon) +asp <- getkasc(puechabon$kasc, "Aspect") +image(asp) +sor <- distfacmap(asp) +image(sor) +} +} +\keyword{spatial} diff --git a/man/enfa.Rd b/man/enfa.Rd index 40584c2..f57ea9b 100644 --- a/man/enfa.Rd +++ b/man/enfa.Rd @@ -2,29 +2,32 @@ \alias{enfa} \alias{hist.enfa} \alias{print.enfa} +\alias{data2enfa} +\alias{print.dataenfa} \title{Ecological-Niche Factor Analysis} \description{ - \code{enfa} performs an Ecological-Niche Factor Analysis.\cr + \code{enfa} performs an Ecological-Niche Factor Analysis. \code{hist.enfa} draws histograms of the row scores or of the initial - variables of the ENFA. + variables of the ENFA. + \code{data2enfa} prepares data (kasc and localizations) to be analyzed + by the ENFA. } \usage{ -enfa(kasc, pts, scannf = TRUE, nf = 1) -hist.enfa(x, scores = TRUE, type = c("h", "l"), - adjust = 1, Acol, Ucol, Aborder, Uborder, \dots) +enfa(tab, pr, scannf = TRUE, nf = 1) +hist.enfa(x, scores = TRUE, type = c("h", "l"), adjust = 1, Acol, Ucol, + Aborder, Uborder, Alwd = 1, Ulwd = 1, \dots) +data2enfa(kasc, pts) } \arguments{ - \item{kasc}{a raster map of class \code{kasc}} - \item{pts}{a data frame with two columns, giving the coordinates of - the species locations} - \item{scannf}{logical. Whether the eigenvalues bar plot should be - displayed} - \item{nf}{if \code{scannf = FALSE}, an integer indicating the number of - kept specialization axes } + \item{tab}{a data frame describing the available units} + \item{pr}{a vector giving the utilization weights associated to each unit} + \item{scannf}{logical. Whether the eigenvalues barplot should be displayed} + \item{nf}{an integer indicating the number of kept + specialization axes } \item{x}{an object of class \code{enfa}} \item{scores}{logical. If \code{TRUE}, the histograms display the row scores of the ENFA. If \code{FALSE}, they display the - environmental variables (in this case, this is equivalent to + niche on the environmental variables (in this case, this is equivalent to \code{histniche})} \item{type}{what type of plot should be drawn. Possible types are:\cr * \code{"h"} for histograms,\cr @@ -44,6 +47,13 @@ hist.enfa(x, scores = TRUE, type = c("h", "l"), pixels} \item{Uborder}{color for the border of the histograms of the used pixels} + \item{Alwd}{if \code{type = "l"}, the line width of the kernel density + estimates of the available pixels} + \item{Ulwd}{if \code{type = "l"}, the line width of the kernel density + estimates of the used pixels} + \item{kasc}{a raster map of class \code{kasc}} + \item{pts}{a data frame with two columns, giving the coordinates of + the species locations} \item{\dots}{further arguments passed to or from other methods } } \details{ @@ -54,14 +64,11 @@ hist.enfa(x, scores = TRUE, type = c("h", "l"), Factor Analysis (ENFA) has been developped by Hirzel et al. (2002) to analyse the position of the niche in the ecological space. Nicolas Perrin (1984) described the position of the niche in the n-dimensional - space using two measures: the M-specialization (hereafter termed - marginality) + space using two measures: the M-specialization (hereafter termed marginality) and the S-specialization (hereafter termed specialization). The marginality represents the squared distance of the niche barycentre from the mean available habitat. A large specialization corresponds to a - narrow niche relative to the habitat conditions available to the - species.\cr - + narrow niche relative to the habitat conditions available to the species.\cr The ENFA first extracts an axis of marginality (vector from the average of available habitat conditions to the average used habitat conditions). @@ -85,6 +92,11 @@ hist.enfa(x, scores = TRUE, type = c("h", "l"), \item{co}{column coordinates, data frame with p rows and nf columns.} \item{c1}{column normed scores, data frame with p rows and nf columns.} \item{mar}{coordinates of the marginality vector.} + \code{data2enfa} returns a list of class \code{dataenfa} containing the + following components: + \item{tab}{a data frame with n rows and p columns.} + \item{pr}{a vector of length n containing the number of points in each + pixel of the map.} \item{index}{an integer vector giving the position of the rows of \code{tab} in the initial object of class \code{kasc}.} \item{attr}{an object of class \code{mapattr} with the attributes of the @@ -92,7 +104,7 @@ hist.enfa(x, scores = TRUE, type = c("h", "l"), } \references{ Hutchinson, G.E. (1957) Concluding Remarks. \emph{Cold Spring Harbor - Symposium on Quantitative Biology}, \bold{22}: 415--427. + Symposium on Quantitative Biology}, \bold{22}: 415--427. Perrin, N. (1984) Contribution à l'écologie du genre Cepaea (Gastropoda) : Approche descriptive et expérimentale de l'habitat et @@ -104,6 +116,7 @@ hist.enfa(x, scores = TRUE, type = c("h", "l"), maps without absence data? \emph{Ecology}, \bold{83}, 2027--2036. } \author{Mathieu Basille \email{basille@biomserv.univ-lyon1.fr} } + \seealso{ \code{\link[ade4]{niche}}, \code{\link{kselect}} for other types of analysis of the niche, when several species are under studies, @@ -115,31 +128,29 @@ hist.enfa(x, scores = TRUE, type = c("h", "l"), \dontrun{ data(lynxjura) - map <- lynxjura$map - ## We keep only "wild" indices. tmp <- lynxjura$locs[,4]!="D" locs <- lynxjura$locs[tmp, c("X","Y")] hist(map, type = "l") ## The variable artif is far from symetric - ## We perform a square root transformation ## of this variable ## We therefore normalize the variable 'artif' map[,4] <- sqrt(map[,4]) hist(map, type = "l") +## We prepare the data for the ENFA +(dataenfa1 <- data2enfa(map, locs[tmp, c("X","Y")])) -## We perform the ENFA -(enfa1 <- enfa(map, locs[tmp, c("X","Y")], +## We then perform the ENFA +(enfa1 <- enfa(dataenfa1$tab, dataenfa1$pr, scannf = FALSE)) hist(enfa1) hist(enfa1, scores = FALSE, type = "l") - ## randomization test and scatterplot (renfa <- randtest(enfa1)) plot(renfa) diff --git a/man/hist.kasc.Rd b/man/hist.kasc.Rd index e383fc6..83547e3 100644 --- a/man/hist.kasc.Rd +++ b/man/hist.kasc.Rd @@ -2,11 +2,11 @@ \alias{hist.kasc} \title{Histograms of Mapped Variables} \description{ - \code{hist.kasc} performs histograms of the variables mapped in objects - of class \code{kasc}. +\code{hist.kasc} performs histograms of the variables mapped in objects +of class \code{kasc}. } \usage{ -hist.kasc(x, type = c("h", "l"), adjust = 1, col, border, \dots) +hist.kasc(x, type = c("h", "l"), adjust = 1, col = "blue", \dots) } \arguments{ \item{x}{a raster map of class \code{kasc} } @@ -19,7 +19,6 @@ hist.kasc(x, type = c("h", "l"), adjust = 1, col, border, \dots) \item{adjust}{if \code{type = "l"}, a parameter used to control the bandwidth of the density estimate (see \code{?density})} \item{col}{color for the histogram} - \item{border}{color for the border of the histogram} \item{\dots}{further arguments passed to or from other methods} } \author{Mathieu Basille \email{basille@biomserv.univ-lyon1.fr}} diff --git a/man/histniche.Rd b/man/histniche.Rd index 13891d5..c5d1e58 100644 --- a/man/histniche.Rd +++ b/man/histniche.Rd @@ -1,6 +1,6 @@ \name{histniche} \alias{histniche} -\title{Histograms of the Ecological Niche of a Species} +\title{Histograms of the Ecological Niche} \description{ \code{histniche} draws histograms of the variables mapped in an object of class \code{kasc} (habitat available for the species). The @@ -10,7 +10,7 @@ } \usage{ histniche(kasc, pts, type = c("h", "l"), adjust = 1, - Acol, Ucol, Aborder, Uborder, \dots) + Acol, Ucol, Aborder, Uborder, Alwd = 1, Ulwd = 1, \dots) } \arguments{ \item{kasc}{a raster map of class \code{kasc}} @@ -30,6 +30,10 @@ histniche(kasc, pts, type = c("h", "l"), adjust = 1, histograms of the available pixels (see \code{help(hist.default)})} \item{Uborder}{if \code{type = "h"}, color for the border of the histograms of the used pixels (see \code{help(hist.default)})} + \item{Alwd}{if \code{type = "l"}, line width for the density estimate + of the available pixels} + \item{Ulwd}{if \code{type = "l"}, line width for the density estimate + of the used pixels} \item{\dots}{further arguments passed to or from other methods} } \author{Mathieu Basille \email{basille@biomserv.univ-lyon1.fr} } @@ -38,6 +42,9 @@ histniche(kasc, pts, type = c("h", "l"), adjust = 1, ## Example with factors and numeric variables data(puechabon) histniche(puechabon$kasc, puechabon$locs[, c("X", "Y")]) + +## Aspect is a factor, then it's not possible to use +## kernel density estimates for it : histniche(puechabon$kasc, puechabon$locs[, c("X", "Y")], type = "l") } } diff --git a/man/kasc2spixdf.Rd b/man/kasc2spixdf.Rd new file mode 100755 index 0000000..1f83cff --- /dev/null +++ b/man/kasc2spixdf.Rd @@ -0,0 +1,172 @@ +\name{kasc2spixdf} +\alias{kasc2spixdf} +\alias{asc2spixdf} +\alias{spixdf2kasc} +\alias{area2sr} +\alias{sr2area} +\alias{attsr2area} +\alias{traj2spdf} +\alias{traj2sldf} +\title{ Conversion of maps from/to the package "sp" } +\description{ + These functions convert maps of classes available in adehabitat toward + classes available in the package \code{sp} and conversely.\cr + \cr + \code{kasc2spixdf} converts an object of class \code{kasc} into an + object of class \code{SpatialPixelsDataFrame}.\cr + \cr + \code{asc2spixdf} converts an object of class \code{asc} into an + object of class \code{SpatialGridDataFrame}.\cr + \cr + \code{spixdf2kasc} converts an object of class + \code{SpatialPixelsDataFrame} or \code{SpatialGridDataFrame} into an + object of class \code{asc} or \code{kasc}.\cr + \cr + \code{area2sr} converts an object of class \code{area} into an + object of class \code{SpatialRings}.\cr + \cr + \code{sr2area} converts an object of class \code{SpatialRings} or + \code{SpatialRingsDataFrame} into anobject of class + \code{area}.\cr + \cr + \code{attsr2area} gets the data attribute of an object of class + \code{SpatialRingsDataFrame} and stores is into a data frame.\cr + \cr + \code{traj2spdf} converts an object of class \code{traj} into an + object of class \code{SpatialPointsDataFrame}.\cr + \cr + \code{traj2sldf} converts an object of class \code{traj} into an + object of class \code{SpatialLinesDataFrame}.\cr +} +\usage{ +kasc2spixdf(ka) +asc2spixdf(a) +spixdf2kasc(sg) +area2sr(ar) +sr2area(sr) +attsr2area(srdf) +traj2spdf(tr) +traj2sldf(tr, byid = FALSE) +} +\arguments{ + \item{ka}{an object of class \code{kasc}.} + \item{a}{an object of class \code{asc}.} + \item{sg}{an object of class \code{SpatialPixelsDataFrame} or + \code{SpatialGridDataFrame}.} + \item{ar}{an object of class \code{area}.} + \item{sr}{an object of class \code{SpatialRings} or + \code{SpatialRingsDataFrame}.} + \item{srdf}{an object of class \code{SpatialRingsDataFrame}.} + \item{tr}{an object of class \code{traj}.} + \item{byid}{logical. If \code{TRUE}, one objects of class + \code{Slines} correspond to one animal. if \code{FALSE}, + one object of class \code{Slines} correspond to one burst.} +} +\details{ + We describe here more in detail the functions \code{sr2area} and + \code{attsr2area}. Objects of class \code{area} do not deal with + holes in the polygons, whereas the objects of class + \code{SpatialRings} do. Therefore, when holes are present in the + \code{SpatialRings} object passed as argument, the function + \code{sr2area} ignore them and returns only the external contour of + the polygon (though a warning is returned, see example). +} +\author{ Clément Calenge \email{calenge@biomserv.univ-lyon1.fr} } +\seealso{ \code{\link{import.asc}} for information on objects of + class \code{asc}, \code{\link{as.kasc}} for info on objects of + class \code{kasc}, \code{\link{as.area}} for info on objects of + class \code{area}, \code{\link{as.traj}} for objects of class \code{traj}.} +\examples{ +\dontrun{ +if (require(sp) { + +######################################### +## +## Conversion kasc -> SpatialPixelsDataFrame +## + +data(puechabon) +toto <- kasc2spixdf(puechabon$kasc) +image(toto) +summary(toto) + +#### and conversely +toto <- spixdf2kasc(toto) +image(toto) +hist(toto) + +data(meuse.grid) +m <- SpatialPixelsDataFrame(points = meuse.grid[c("x", "y")], + data = meuse.grid) +i <- spixdf2kasc(m) +image(i) + + +### conversion asc -> SpatialPixelsDataFrame +cuicui <- asc2spixdf(getkasc(toto,1)) +image(cuicui) + + +######################################### +## +## Conversion area -> SpatialRings +## + +data(elec88) +ar <- as.area(elec88$area) +plot(ar) +toto <- area2sr(ar) +plot(toto) + + +######################################### +## +## Conversion SpatialRings -> area +## + +## First create an object of class "SpatialRingsDataFrame" +data(ncshp) +nc1 <- as.SpatialRings.Shapes(nc.shp$Shapes, as.character(nc.shp$att.data$FIPS)) +plotSpatialRings(nc1) +df <- nc.shp$att.data +rownames(df) <- as.character(nc.shp$att.data$FIPS) +ncSRDF <- SpatialRingsDataFrame(nc1, df) + + +## and then conversion: +coincoin <- sr2area(ncSRDF) +## please note the warnings + +plot(coincoin) +## gets the attributes +haha <- attsr2area(ncSRDF) +area.plot(coincoin, values = df$SID74/df$BIR74) + + +######################################### +## +## Conversion traj -> SpatialPointsDataFrame +## + +data(puechcirc) +plot(puechcirc) + +toto <- traj2spdf(puechcirc) +plot(toto) + + +######################################### +## +## Conversion traj -> SpatialLinesDataFrame +## + +data(puechcirc) +plot(puechcirc) + +toto <- traj2sldf(puechcirc) +plot(toto) + +} +} +} +\keyword{hplot} diff --git a/man/kernelUD.Rd b/man/kernelUD.Rd index 364d6d1..99bdef3 100644 --- a/man/kernelUD.Rd +++ b/man/kernelUD.Rd @@ -24,14 +24,14 @@ } \usage{ kernelUD(xy, id = NULL, h = "href", grid = 40, same4all = FALSE, - hlim = c(0.1, 1.5)) + hlim = c(0.1, 1.5), kern = "bivnorm") print.khr(x, \dots) image.khr(x, axes = FALSE, mar = c(0,0,2,0), addcontour = TRUE, addpoints = TRUE, \dots) plotLSCV(x) getvolumeUD(x) kernel.area(xy, id, h = "href", grid=40, - same4all = FALSE, hlim = c(0.1,1.5), + 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")) @@ -51,7 +51,8 @@ kernelbb(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) \item{h}{a character string or a number. If \code{h} is set to \code{"href"}, the ad hoc method is used for the smoothing parameter (see details). If \code{h} is set to - \code{"LSCV"}, the least-square cross validation method is used. + \code{"LSCV"}, the least-square cross validation method is + used. Note that \code{"LSCV"} is not available if \code{kern = "epa"}. Alternatively, \code{h} may be set to any given numeric value} \item{grid}{a number giving the size of the grid on which the UD should be estimated. Alternatively, this parameter may @@ -64,6 +65,9 @@ kernelbb(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) h ranging from \code{hlim[1]*href} to \code{hlim[2]*href}, where \code{href} is the smoothing parameter computed with the ad hoc method (see below)} + \item{kern}{a character string. If \code{"bivnorm"}, a bivariate + normal kernel is used. If \code{"epa"}, an Epanechnikov kernel is + used.} \item{x}{an object of class \code{khr} returned by \code{kernelUD}. For \code{plot.kver}, an object of class \code{kver} returned by \code{getverticeshr} } @@ -106,16 +110,19 @@ kernelbb(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) the home range as the minimum area in which an animal has some specified probability of being located. The functions used here correspond to the approach described in Worton - (1995). \cr + (1995).\cr The kernel method has been recommended by many authors for the estimation of the utilization distribution (e.g. Worton, 1989, 1995). The default method for the estimation of the - smoothing parameter is the \emph{ad hoc} method, i.e. + smoothing parameter is the \emph{ad hoc} method, i.e. for a bivariate + normal kernel \deqn{h = \sigma n^{- \frac{1}{6}}}{h = Sigma*n^(-1/6)} where \deqn{\sigma = 0.5 (\sigma(x)+\sigma(y))}{Sigma = 0.5*(sd(x)+sd(y))} which supposes that the UD is - bivariate normal. Alternatively, the smoothing parameter h may be + bivariate normal. If an Epanechnikov kernel is used, this value is + multiplied by 1.77 (Silverman, 1986, p. 86). + Alternatively, the smoothing parameter h may be computed by Least Square Cross Validation (LSCV). The estimated value then minimizes the Mean Integrated Square Error (MISE), i.e. the difference in volume between the true UD and the estimated UD. Note @@ -129,6 +136,10 @@ kernelbb(tr, sig1, sig2, grid = 40, same4all=FALSE, byburst=FALSE) know whether the minimum of the CV criterion occurs within the scanned range). Finally, the UD is then estimated over a grid.\cr + The default kernel is the bivariate normal kernel, but the + Epanechnikov kernel, which requires less computer time is also + available for the estimation of the UD. \cr + The function \code{getvolumehr} modifies the UD component of the object passed as argument, so that the contour of the UD displayed by the functions \code{contour} diff --git a/man/mcp.Rd b/man/mcp.Rd old mode 100644 new mode 100755 index d0c688a..71c60d1 --- a/man/mcp.Rd +++ b/man/mcp.Rd @@ -14,7 +14,7 @@ } \usage{ mcp(xy, id, percent = 95) -mcp.area(xy, id, percent = seq(20,95, by=5) +mcp.area(xy, id, percent = seq(20,95, by=5), unin = c("m", "km"), unout = c("ha", "km2", "m2")) plot.hrsize(x, \dots) diff --git a/man/niche.test.Rd b/man/niche.test.Rd old mode 100644 new mode 100755 index c9a6472..6b745c8 --- a/man/niche.test.Rd +++ b/man/niche.test.Rd @@ -7,24 +7,16 @@ Monte-Carlo methods. This is a bivariate test. } \usage{ -niche.test(kasc, points, nrep = 999, h, o.include = FALSE, - colZ = "blue", colS = "orange", \dots) +niche.test(kasc, points, nrep = 999, o.include = TRUE, \dots) } \arguments{ \item{kasc}{a raster map of class \code{kasc}} \item{points}{a data frame with two columns, giving the coordinates of the species locations} \item{nrep}{the number of permutations} - \item{h}{vector of bandwidths for x and y directions passed to - \code{biv.test}, used in the function \code{kde2d} of the package - \code{MASS}. Defaults to normal reference bandwidth (see \code{?kde2d}).} \item{o.include}{logical, passed to \code{biv.test}. If \code{TRUE}, the origin is included in the plot} - \item{colZ}{a color passed to \code{biv.test} for the color of the kernel - density estimation of the randomized values} - \item{colS}{a color passed to \code{biv.test} for the actual values of - marginality and tolerance of the object of class \code{enfa}} - \item{\dots}{further arguments passed to or from other methods} + \item{\dots}{further arguments passed to \code{biv.test}} } \details{ \code{niche.test} tests the significance of two parameters describing @@ -57,16 +49,20 @@ components: \section{Warning}{   \code{biv.test} uses the function \code{kde2d} of the package \code{MASS}. } -\seealso{\code{\link{biv.test}} for more details on bivariate tests. } +\seealso{ + \code{\link{biv.test}} for more details on bivariate tests. + \code{\link{histniche}} for the histograms of the variables of the niche. +} \examples{ \dontrun{ data(lynxjura) ## We keep only "wild" indices. tmp=lynxjura$loc[,4]!="D" -if (require(MASS)) - niche=niche.test(lynxjura$map, - lynxjura$locs[tmp, c("X", "Y")]) +niche=niche.test(lynxjura$map, + lynxjura$locs[tmp, c("X", "Y")], + side = "bottom") +names(niche) } } \keyword{multivariate} diff --git a/man/predict.enfa.Rd b/man/predict.enfa.Rd index f4dcfd4..3c40694 100644 --- a/man/predict.enfa.Rd +++ b/man/predict.enfa.Rd @@ -7,10 +7,13 @@ method. } \usage{ -predict.enfa(object, nf, \dots) +predict.enfa(object, index, attr, nf, \dots) } \arguments{ \item{object}{an object of class \code{enfa}} + \item{index}{an integer vector giving the position of the rows of + \code{tab} in the initial object of class \code{kasc}.} + \item{attr}{an object of class \code{kasc} or \code{mapattr}.} \item{nf}{the number of axes of specialization kept for the predictions. By default, all axes kept in \code{object} are used} @@ -49,17 +52,21 @@ computation of habitat suitability maps using the Mahalanobis distances. \dontrun{ data(lynxjura) +map <- lynxjura$map + ## We keep only "wild" indices. tmp <- lynxjura$loc[,4] != "D" -map <- lynxjura$map -pts <- lynxjura$locs[tmp, c("X","Y")] -(enfa1 <- enfa(map, pts, scannf = FALSE)) +locs <- lynxjura$locs[tmp, c("X","Y")] +dataenfa1 <- data2enfa(map, locs[tmp, c("X","Y")]) + +(enfa1 <- enfa(dataenfa1$tab, dataenfa1$pr, + scannf = FALSE)) ## Compute the prediction -pred <- predict(enfa1) +pred <- predict(enfa1, dataenfa1$index, dataenfa1$attr) image(pred) contour(pred, col="green", add=T) -points(pts, col = "red", pch = 16) +points(locs, col = "red", pch = 16) ## Lighter areas are the most preferred areas } } diff --git a/man/scatter.enfa.Rd b/man/scatter.enfa.Rd old mode 100644 new mode 100755 index f0d0dfe..ddc144d --- a/man/scatter.enfa.Rd +++ b/man/scatter.enfa.Rd @@ -1,95 +1,84 @@ -\name{scatter.enfa} -\alias{scatter.enfa} -\title{Scatter Plot of the Results of the ENFA} -\description{ -Performs the scatter diagrams of objects of class \code{enfa}. -} -\usage{ -scatter.enfa(x, xax = 1, yax = 2, pts = FALSE, - nc = TRUE, percent = 95, - clabel = 1, side = c("top", "bottom", "none"), - csub = 1, Adensity, Udensity, Aangle, Uangle, - Aborder, Uborder, Acol, - Ucol, Alty, Ulty, Apch, Upch, - Abg, Ubg, Acex, Ucex, ...) -} -\arguments{ - \item{x}{an object of class \code{enfa}} - \item{xax}{the column number for the x-axis} - \item{yax}{the column number for the y-axis} - \item{pts}{logical. Whether the points should be drawn. If - \code{FALSE}, minimum convex polygons are displayed} - \item{nc}{whether or not the niche center should be displayed} - \item{percent}{100 minus the proportion of outliers to be excluded from the - computation of the minimum convex polygons} - \item{clabel}{a character size for the columns} - \item{side}{if \code{"top"}, the legend of the kept axis is upside, if - \code{"bottom"} it is downside, if \code{"none"} no legend} - \item{csub}{a character size for the legend} - \item{Adensity}{the density of shading lines, in lines per inch, for the - available pixels polygon. See \code{\link{polygon}} for more details} - \item{Udensity}{the density of shading lines, in lines per inch, for the - used pixels polygon. See \code{\link{polygon}} for more details} - \item{Aangle}{the slope of shading lines, given as an angle in degrees - (counter-clockwise), for the available pixels polygon} - \item{Uangle}{the slope of shading lines, given as an angle in degrees - (counter-clockwise), for the used pixels polygon} - \item{Aborder}{the color to draw the border of the available pixels - polygon. See \code{\link{polygon}} for more details} - \item{Uborder}{the color to draw the border of the used pixels polygon. - See \code{\link{polygon}} for more details} - \item{Acol}{the color for filling the available pixels polygon. - if \code{pts==FALSE}, the color for the points corresponding to available - pixels} - \item{Ucol}{the color for filling the used pixels polygon. - if \code{pts==FALSE}, the color for the points corresponding to used - pixels} - \item{Alty}{the line type for the available pixels polygon, as in - \code{par}.} - \item{Ulty}{the line type for the used pixels polygon, as in \code{par}.} - \item{Apch}{if \code{pts==FALSE}, plotting "character", i.e., symbol to use - for the available pixels. See \code{\link{points}} for more details} - \item{Upch}{if \code{pts==FALSE}, plotting "character", i.e., symbol to use - for the used pixels. See \code{\link{points}}} - \item{Abg}{if \code{pts==FALSE}, background color for open plot symbols of - available pixels.} - \item{Ubg}{if \code{pts==FALSE}, background color for open plot symbols of - used pixels.} - \item{Acex}{if \code{pts==FALSE}, character expansion of available pixels: - a numerical vector} - \item{Ucex}{if \code{pts==FALSE}, character expansion of used pixels: - a numerical vector} - \item{\dots}{further arguments passed to or from other methods} -} -\details{ - \code{scatter.enfa} displays a factorial map of pixels, as well as the - projection of the vectors of the canonical basis multiplied by a - constant of rescaling. - The kept axes for the plot are specified in a corner. -} -\author{Mathieu Basille \email{basille@biomserv.univ-lyon1.fr}} -\seealso{\code{\link{enfa}}, \code{\link[ade4]{scatter}}} -\examples{ -\dontrun{ -data(lynxjura) - -map <- lynxjura$map - -## We keep only "wild" indices. -tmp <- lynxjura$locs[,4]!="D" -locs <- lynxjura$locs[tmp, c("X","Y")] - - -## We perform a square root transformation -## of the variable to normalize it -map[,4] <- sqrt(map[,4]) - - -## We perform the ENFA -(enfa1 <- enfa(map, locs[tmp, c("X","Y")], - scannf = FALSE)) -scatter(enfa1) -} -} -\keyword{multivariate} -\keyword{hplot} +\name{scatter.enfa} +\alias{scatter.enfa} +\title{Scatter Plot of the Results of the ENFA} +\description{ +Performs the scatter diagrams of objects of class \code{enfa}. +} +\usage{ +scatter.enfa(x, xax = 1, yax = 2, pts = FALSE, nc = TRUE, + percent = 95, clabel = 1, side = c("top", "bottom", "none"), + Adensity, Udensity, Aangle, Uangle, Aborder, Uborder, + Acol, Ucol, Alty, Ulty, Abg, Ubg, Ainch, Uinch, \dots) + +} +\arguments{ + \item{x}{an object of class \code{enfa}} + \item{xax}{the column number for the x-axis} + \item{yax}{the column number for the y-axis} + \item{pts}{logical. Whether the points should be drawn. If + \code{FALSE}, minimum convex polygons are displayed} + \item{nc}{whether or not the niche center should be displayed} + \item{percent}{100 minus the proportion of outliers to be excluded from the + computation of the minimum convex polygons} + \item{clabel}{a character size for the columns} + \item{side}{if \code{"top"}, the legend of the kept axis is upside, if + \code{"bottom"} it is downside, if \code{"none"} no legend} + \item{Adensity}{the density of shading lines, in lines per inch, for the + available pixels polygon. See \code{\link{polygon}} for more details} + \item{Udensity}{the density of shading lines, in lines per inch, for the + used pixels polygon. See \code{\link{polygon}} for more details} + \item{Aangle}{the slope of shading lines, given as an angle in degrees + (counter-clockwise), for the available pixels polygon} + \item{Uangle}{the slope of shading lines, given as an angle in degrees + (counter-clockwise), for the used pixels polygon} + \item{Aborder}{the color to draw the border of the available pixels + polygon. See \code{\link{polygon}} for more details} + \item{Uborder}{the color to draw the border of the used pixels polygon. + See \code{\link{polygon}} for more details} + \item{Acol}{the color for filling the available pixels polygon. + if \code{pts==FALSE}, the color for the points corresponding to available + pixels} + \item{Ucol}{the color for filling the used pixels polygon. + if \code{pts==FALSE}, the color for the points corresponding to used + pixels} + \item{Alty}{the line type for the available pixels polygon, as in \code{par}.} + \item{Ulty}{the line type for the used pixels polygon, as in \code{par}.} + \item{Abg}{if \code{pts==TRUE}, background color for open plot symbols of + available pixels} + \item{Ubg}{if \code{pts==TRUE}, background color for open plot symbols of + used pixels} + \item{Ainch}{if \code{pts==TRUE}, heigth in inches of the available pixels} + \item{Uinch}{if \code{pts==TRUE}, heigth in inches of the largest used pixels} + \item{\dots}{further arguments passed to or from other methods} +} +\details{ +\code{scatter.enfa} displays a factorial map of pixels, as well as the +projection of the vectors of the canonical basis multiplied by a +constant of rescaling. +The kept axes for the plot are specified in a corner. +} +\author{Mathieu Basille \email{basille@biomserv.univ-lyon1.fr}} +\seealso{\code{\link{enfa}}, \code{\link[ade4]{scatter}}} +\examples{ +\dontrun{ +## Not run: +data(lynxjura) + +map <- lynxjura$map + +## We keep only "wild" indices. +tmp <- lynxjura$locs[,4]!="D" +locs <- lynxjura$locs[tmp, c("X","Y")] + +## We perform a square root transformation +## of the variable to normalize it +map[,4] <- sqrt(map[,4]) + +## We perform the ENFA +(enfa1 <- enfa(map, locs[tmp, c("X","Y")], + scannf = FALSE)) +scatter(enfa1) +} +} +\keyword{multivariate} +\keyword{hplot} diff --git a/src/adehabitat_res.rc b/src/adehabitat_res.rc deleted file mode 100644 index ca32caa..0000000 --- a/src/adehabitat_res.rc +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include "Rversion.h" - -VS_VERSION_INFO VERSIONINFO -FILEVERSION R_FILEVERSION -PRODUCTVERSION 3,0,0,0 -FILEFLAGSMASK 0x3L -FILEOS VOS__WINDOWS32 -FILETYPE VFT_APP -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904E4" - BEGIN - VALUE "FileDescription", "DLL for R package `adehabitat'\0" - VALUE "FileVersion", "1.1-1\0" - VALUE "Compiled under R Version", R_MAJOR "." R_MINOR " (" R_YEAR "-" R_MONTH "-" R_DAY ")\0" - VALUE "Project info", "http://www.r-project.org\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1252 - END -END diff --git a/src/tests.c b/src/tests.c index 436618a..f391a9a 100644 --- a/src/tests.c +++ b/src/tests.c @@ -2775,7 +2775,8 @@ 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) { int k,nl; double *xy, kx, di2, h; @@ -2799,6 +2800,7 @@ void epa(double *X, double *Y, double *xl, double *yl, double *val, double *fen) + /* **************************************************************** * * * estimation du DV par kernel * @@ -2869,6 +2871,133 @@ void kernelhr(double *grille, double *xgri, double *ygri, int *ncolgri, +/* **************************************************************** + * * + * estimation du DV par 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; + } + } + 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); + } + } + } + + freevec(xgb); + freevec(ygb); +} + + + + +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); + } + + /* retour vers R */ + 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); +} + /* **************************************************************** @@ -5718,3 +5847,257 @@ void kernelbb(double *grille, double *xgri, double *ygri, int *ncolgri, freevec(Xgr); freevec(alpha); } + + + + +/* ********************************************************************* + * * + * Buffer ligne * + * * + ***********************************************************************/ + + +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; + +} + + + +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]; + } + } + + /* Remise à 0 de la carte */ + 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]; + } + } + } + + freevec(xl); + freevec(yl); + freevec(xp); + freevec(yp); + freetab(x1); + freetab(x2); + freetab(cartebis); + +} + + +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++; + } + } + + 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++; + } + } + + freetab(x); + freetab(carte); + freevec(xg); + freevec(yg); + +} + + +/* Calcul de distances euclidiennes à partir d'une carte 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]; + } + } + di[i] = mi; + } + freevec(dib); +} + + +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++; + } + } + + 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); +} + + +