diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100755 index 0000000000000000000000000000000000000000..cd85fe73c40878a4e9a92b5f8fb16b6441231818 --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,16 @@ +Package: ads +Type: Package +Title: Spatial point patterns analysis +Version: 1.5-2.2 +Date: 2015-01-13 +Author: R. Pelissier and F. Goreaud +Maintainer: Raphael Pelissier <Raphael.Pelissier@ird.fr> +Imports: ade4, spatstat +Description: Perform first- and second-order multi-scale analyses derived from Ripley K-function, for univariate, + multivariate and marked mapped data in rectangular, circular or irregular shaped sampling windows, with tests of + statistical significance based on Monte Carlo simulations. +License: GPL-2 +Packaged: 2015-01-13 12:09:18 UTC; root +NeedsCompilation: yes +Repository: CRAN +Date/Publication: 2015-01-13 14:49:23 diff --git a/INDEX b/INDEX new file mode 100755 index 0000000000000000000000000000000000000000..18df450a8124d9ed5a277efdd26c719cfb3a68c4 --- /dev/null +++ b/INDEX @@ -0,0 +1,36 @@ +Allogny Spatial pattern of oaks suffering from frost shake in Allogny, France. +BPoirier Tree spatial pattern in Beau Poirier plot, Haye forest, France. +Couepia Spatial pattern of Couepia caryophylloides in Paracou, a canopy tree + species of French Guiana. +demopat Artificial data point pattern from \code{spatstat} package. +Paracou15 Spatial pattern of trees in plot 15 of Paracou experimental station, + French Guiana. +area.swin Area of a sampling window. +dval Multiscale local density of a spatial point pattern. +inside.swin Test wether points are inside a sampling window. +k12fun Multiscale second-order neigbourhood analysis of a bivariate spatial + point pattern. +k12val Multiscale local second-order neighbour density of a bivariate spatial + point pattern. +kdfun Multiscale second-order neigbourhood analysis of phylogentic/functional + spatial structure of a multivariate spatial point pattern. +kfun Multiscale second-order neigbourhood analysis of an univariate spatial + point pattern. +kmfun Multiscale second-order neigbourhood analysis of a marked spatial point + pattern. +kp.fun (Formerly ki.fun) Multiscale second-order neigbourhood analysis of a + multivariate spatial point pattern. +kpqfun (Formerly kijfun) Multiscale second-order neigbourhood analysis of a + multivariate spatial point pattern. +krfun Multiscale second-order neigbourhood analysis of a multivariate spatial + point pattern using Rao quadratic entropy. +ksfun Multiscale second-order neigbourhood analysis of a multivariate spatial + point pattern using Simpson diversity. +kval Multiscale local second-order neighbour density of a spatial point pattern. +mimetic Univariate point pattern replication by mimetic point process. +plot.fads Plot second-order neigbourhood functions. +plot.spp Plot a Spatial Point Pattern object. +plot.vads Plot local density values. +spp Creating a spatial point pattern. +swin Creating a sampling window. +triangulate Triangulate polygon. diff --git a/MD5 b/MD5 new file mode 100644 index 0000000000000000000000000000000000000000..a20da8ff7af0609bc7bce5ffa5b87d1783690d64 --- /dev/null +++ b/MD5 @@ -0,0 +1,55 @@ +2755553481e78a8f5b6ef00d43e983a5 *DESCRIPTION +68a58538a504c7cfa73472d87053be45 *INDEX +7478c6d745db573c9d03ebc59bdc969c *NAMESPACE +f6aac0fb4ef187df6521cbb2d9ffc9cf *R/fads.R +7a71372e86fd8aadfc770b261cd953ca *R/mimetic.R +e87bd01e08a83a7b1c52b2a4a7e5df35 *R/plot.fads.R +95d2bc01bd2779736c826a21c83b62f3 *R/plot.vads.R +6317d29d7e9045d55b1a41906e867462 *R/print.fads.R +d0f79442970e383cf8c3bd1677320b53 *R/print.vads.R +c4b216a6fb57acb020f5e21682f7ed13 *R/spp.R +96dada922fee237e190207f544de8ed3 *R/summary.vads.R +c5d76ac2aa5f6fa68c0cfd08f197989e *R/swin.R +34b15c6ed440f88d868d3ab3b93db3b8 *R/triangulate.R +a322bba8d53aff07f9a8ce9a69c89aef *R/util.R +f2c452832a53eb1ed6d168b59918d52a *R/vads.R +31fa89b542936dac1031133b12ef530c *data/Allogny.rda +5450b84c345240671b3410af7c70bc44 *data/BPoirier.rda +24fea786746fc897f8918300f2f2c544 *data/Couepia.rda +a014cac4bc9abd4f40123a762939c8ca *data/Paracou15.rda +674867657e9a3df07b6eced02aa022a1 *data/demopat.rda +c7cd00087730e79e06e8c0d937d0b1f7 *inst/CITATION +94a8b147b3d2730b0c3869a7e1a2592f *man/Allogny.Rd +1755cf31329228337e0b8039af2b6daf *man/BPoirier.Rd +d912451f743e11a9fbe50c8a6ef13b15 *man/Couepia.Rd +4f272a7a2e7528da43c0d2ef8685921b *man/Paracou15.Rd +b3c89a3bcb5db0d5fc9e93d8305df8c8 *man/area.swin.Rd +d7b568c5332aad81bf4fb9f2bd4efed7 *man/demopat.Rd +9b09cc667ab5d522e4a3a77c8b711159 *man/dval.Rd +cd9ec1a82e0ee4e372e7ebd9c11233e4 *man/inside.swin.Rd +e85df8cba02e1d7ae44b447ef05f0e3f *man/internal.Rd +18f7794bc004e9b9599486a725f7da5b *man/k12fun.Rd +26a82fbf3be668f7c74dd4f1b9fd93e4 *man/k12val.Rd +f4c594ec01933acd9d9cae7e797685fe *man/kdfun.Rd +aa725a3e6b7183290f7dd758d594810c *man/kfun.Rd +ea3edb1e20ecd5aa794f48c9fa5ee0e5 *man/kmfun.Rd +0e606a71b6ec6f730bdd0d1498834dbc *man/kp.fun.Rd +500b63ba993de0b1f8a7d7f92765403b *man/kpqfun.Rd +d388b950333aad22313c76d82f51c749 *man/krfun.Rd +9970f6e4573f2e241de12d62ab201e23 *man/ksfun.Rd +d5d294338860db9a406208f219f05f5e *man/kval.Rd +1037e7421f3a50f15fcb07e88dcc260c *man/mimetic.Rd +5bff5bb53402d742900fe12ed542877b *man/plot.fads.Rd +7e88d95ac70e452257a939a70f9a1a76 *man/plot.spp.Rd +c30babaf1b550ec45fa0f1bd89f967e5 *man/plot.vads.Rd +2c61afcc548ad6440240664252a645a5 *man/spp.Rd +cfe40689a11ec983e9b9bb4b759aaa26 *man/swin.Rd +c04839dd6cd8eb396d512260a23dc7fd *man/triangulate.Rd +22fae7567dd07dddf2ea00cb023c2be5 *src/Zlibs.c +109615f7005a5a6e02b98bcf1a904551 *src/Zlibs.h +3d7a3f0a98ac75ad014cc91fbe2d0579 *src/adssub.c +bd642dbad07c62b2f39fae4c5640f93a *src/adssub.h +8a3dad68f1826270eef7ea08e098dfc5 *src/spatstatsub.f +5aa9f5862ef5b0e8bbcc327021e1489a *src/triangulate.c +e482b9d18794f53adaed3f2c98edd19a *src/triangulate.h +fb07aec2cf6396cab654966e2757ab5c *src/util.c diff --git a/NAMESPACE b/NAMESPACE new file mode 100755 index 0000000000000000000000000000000000000000..7f723b74c0a0bf9d738e160054c72c30a7bee2d2 --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,8 @@ +# Import external pkg names +# import(ade4, spatstat) +importFrom(ade4,"divc","is.euclid") +importFrom(spatstat,"border","bounding.box.xy","area.owin") +# Export all names (should be improved in the future) +exportPattern(".") +# load DLL +useDynLib(ads) diff --git a/R/fads.R b/R/fads.R new file mode 100755 index 0000000000000000000000000000000000000000..dd947c22d0d849edef16365faa74e72086916812 --- /dev/null +++ b/R/fads.R @@ -0,0 +1,1255 @@ +kfun<-function(p,upto,by,nsim=0,prec=0.01,alpha=0.01) { + # checking for input parameters + stopifnot(inherits(p,"spp")) + if(p$type!="univariate") + warning(paste(p$type,"point pattern has been considered to be univariate\n")) + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + stopifnot(is.numeric(nsim)) + stopifnot(nsim>=0) + nsim<-testInteger(nsim) + stopifnot(is.numeric(prec)) + stopifnot(prec>=0) + stopifnot(is.numeric(alpha)) + stopifnot(alpha>=0) + if(nsim>0) testIC(nsim,alpha) + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + intensity<-p$n/area.swin(p$window) + + if(cas==1) { #rectangle + if(nsim==0) { #without CI + res<-.C("ripley_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("ripley_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax),as.double(intensity), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(prec),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==2) { #circle + if(nsim==0) { #without CI + res<-.C("ripley_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("ripley_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0),as.double(intensity), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(prec),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==3) { #complex within rectangle + if(nsim==0) { #without CI + res<-.C("ripley_tr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("ripley_tr_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax),as.double(intensity), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(prec),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==4) { #complex within circle + if(nsim==0) { #without CI + res<-.C("ripley_tr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("ripley_tr_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0),as.double(intensity), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(prec),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + # formatting results + ds<-c(pi,diff(pi*r^2)) + g<-data.frame(obs=res$g/(intensity*ds),theo=rep(1,tmax)) + n<-data.frame(obs=res$k/(pi*r^2),theo=rep(intensity,tmax)) + k<-data.frame(obs=res$k/intensity,theo=pi*r^2) + l<-data.frame(obs=sqrt(res$k/(intensity*pi))-r,theo=rep(0,tmax)) + if(nsim>0) { + g<-cbind(g,sup=res$gic1/(intensity*ds),inf=res$gic2/(intensity*ds),pval=res$gval/(nsim+1)) + n<-cbind(n,sup=res$kic1/(pi*r^2),inf=res$kic2/(pi*r^2),pval=res$nval/(nsim+1)) + k<-cbind(k,sup=res$kic1/intensity,inf=res$kic2/intensity,pval=res$kval/(nsim+1)) + l<-cbind(l,sup=sqrt(res$kic1/(intensity*pi))-r,inf=sqrt(res$kic2/(intensity*pi))-r,pval=res$lval/(nsim+1)) + } + call<-match.call() + res<-list(call=call,r=r,g=g,n=n,k=k,l=l) + class(res)<-c("fads","kfun") + return(res) +} + +k12fun<-function(p,upto,by,nsim=0,H0=c("pitor","pimim","rl"),prec=0.01,nsimax=3000,conv=50,rep=10,alpha=0.01,marks) { + # checking for input parameters + options( CBoundsCheck = TRUE ) + # regle les problemes pour 32-bit + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="multivariate") + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + stopifnot(is.numeric(nsim)) + stopifnot(nsim>=0) + nsim<-testInteger(nsim) + H0<-H0[1] + stopifnot(H0=="pitor" || H0=="pimim" || H0=="rl") + if(H0=="rl") H0<-1 + else if(H0=="pitor") H0<-2 + else H0<-3 + stopifnot(is.numeric(prec)) + stopifnot(prec>=0) + stopifnot(is.numeric(alpha)) + stopifnot(alpha>=0) + if(nsim>0) testIC(nsim,alpha) + if(missing(marks)) + marks<-c(1,2) + stopifnot(length(marks)==2) + stopifnot(marks[1]!=marks[2]) + mark1<-marks[1] + mark2<-marks[2] + if(is.numeric(mark1)) + mark1<-levels(p$marks)[testInteger(mark1)] + else if(!mark1%in%p$marks) stop(paste("mark \'",mark1,"\' doesn\'t exist",sep="")) + if(is.numeric(mark2)) + mark2<-levels(p$marks)[testInteger(mark2)] + else if(!mark2%in%p$marks) stop(paste("mark \'",mark2,"\' doesn\'t exist",sep="")) + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + surface<-area.swin(p$window) + x1<-p$x[p$marks==mark1] + y1<-p$y[p$marks==mark1] + x2<-p$x[p$marks==mark2] + y2<-p$y[p$marks==mark2] + nbPts1<-length(x1) + nbPts2<-length(x2) + intensity2<-nbPts2/surface +# intensity<-(nbPts1+nbPts2)/surface + + # computing intertype functions + if(cas==1) { #rectangle + if(nsim==0) { #without CI + res<-.C("intertype_rect", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("intertype_rect_ic", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax),as.double(surface), + as.integer(tmax),as.double(by), + as.integer(nsim),as.integer(H0),as.double(prec),as.integer(nsimax),as.integer(conv),as.integer(rep),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==2) { #circle + if(nsim==0) { #without CI + res<-.C("intertype_disq", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("intertype_disq_ic", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0),as.double(surface), + as.integer(tmax),as.double(by), + as.integer(nsim),as.integer(H0),as.double(prec),as.integer(nsimax),as.integer(conv),as.integer(rep),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==3) { #complex within rectangle + if(nsim==0) { #without CI + res<-.C("intertype_tr_rect", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("intertype_tr_rect_ic", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax),as.double(surface), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nsim),as.integer(H0),as.double(prec),as.integer(nsimax),as.integer(conv),as.integer(rep),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==4) { #complex within circle + if(nsim==0) { #without CI + res<-.C("intertype_tr_disq", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("intertype_tr_disq_ic", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0),as.double(surface), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nsim),as.integer(H0),as.double(prec),as.integer(nsimax),as.integer(conv),as.integer(rep),as.double(alpha), + g=double(tmax),k=double(tmax), + gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),lval=double(tmax),nval=double(tmax), + PACKAGE="ads") + } + } + # formatting results + ds<-c(pi,diff(pi*r^2)) + g<-res$g/(intensity2*ds) + n<-res$k/(pi*r^2) + k<-res$k/intensity2 + l<-sqrt(res$k/(intensity2*pi))-r + if(H0==1) { + rip<-kfun(spp(c(x1,x2),c(y1,y2),p$window),upto,by) + theo<-list(g=rip$g$obs,n=intensity2*rip$k$obs/(pi*r^2),k=rip$k$obs,l=rip$l$obs) + } + else if (H0==2||H0==3) + theo<-list(g=rep(1,tmax),n=rep(intensity2,tmax),k=pi*r^2,l=rep(0,tmax)) + g<-data.frame(obs=g,theo=theo$g) + n<-data.frame(obs=n,theo=theo$n) + k<-data.frame(obs=k,theo=theo$k) + l<-data.frame(obs=l,theo=theo$l) + if(nsim>0) { + g<-cbind(g,sup=res$gic1/(intensity2*ds),inf=res$gic2/(intensity2*ds),pval=res$gval/(nsim+1)) + n<-cbind(n,sup=res$kic1/(pi*r^2),inf=res$kic2/(pi*r^2),pval=res$nval/(nsim+1)) + k<-cbind(k,sup=res$kic1/intensity2,inf=res$kic2/intensity2,pval=res$kval/(nsim+1)) + l<-cbind(l,sup=sqrt(res$kic1/(intensity2*pi))-r,inf=sqrt(res$kic2/(intensity2*pi))-r,pval=res$lval/(nsim+1)) + } + call<-match.call() + res<-list(call=call,r=r,g12=g,n12=n,k12=k,l12=l,marks=c(mark1,mark2)) + class(res)<-c("fads","k12fun") + return(res) +} + +kijfun<-kpqfun<-function(p,upto,by) { +# checking for input parameters + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="multivariate") + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + surface<-area.swin(p$window) + + tabMarks<-levels(p$marks) + nbMarks<-length(tabMarks) + mpt_nb<-summary(p$marks) +# computing RipleyClass + gij<-double(tmax*nbMarks^2) + kij<-double(tmax*nbMarks^2) + lij<-double(tmax*nbMarks^2) + nij<-double(tmax*nbMarks^2) + for(i in 1:nbMarks) { + x1<-p$x[p$marks==tabMarks[i]] + y1<-p$y[p$marks==tabMarks[i]] + if(cas==1) { #rectangle + res<-.C("ripley_rect", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==2) { #circle + res<-.C("ripley_disq", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==3) { #complex within rectangle + res<-.C("ripley_tr_rect", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==4) { #complex within circle + res<-.C("ripley_tr_disq", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + intensity1<-mpt_nb[i]/surface + matcol<-(i-1)*nbMarks+i-1 + j<-(matcol*tmax+1):(matcol*tmax+tmax) + ds<-c(pi,diff(pi*r^2)) + gij[j]<-res$g/(intensity1*ds) + nij[j]<-res$k/(pi*r^2) + kij[j]<-res$k/intensity1 + lij[j]<-sqrt(res$k/(intensity1*pi))-r + if(i<nbMarks) { + for(j in (i+1):nbMarks) { + x2<-p$x[p$marks==tabMarks[j]] + y2<-p$y[p$marks==tabMarks[j]] + if(cas==1) { #rectangle + res<-.C("intertype_rect", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==2) { #circle + res<-.C("intertype_disq", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==3) { #complex within rectangle + res<-.C("intertype_tr_rect", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==4) { #complex within circle + res<-.C("intertype_tr_disq", + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + intensity2<-mpt_nb[j]/surface + matcol<-(i-1)*nbMarks+j-1 + k<-(matcol*tmax+1):(matcol*tmax+tmax) + gij[k]<-res$g/(intensity2*ds) + nij[k]<-res$k/(pi*r^2) + kij[k]<-res$k/intensity2 + lij[k]<-sqrt(res$k/(intensity2*pi))-r + if(cas==1) { #rectangle + res<-.C("intertype_rect", + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==2) { #circle + res<-.C("intertype_disq", + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==3) { #complex within rectangle + res<-.C("intertype_tr_rect", + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==4) { #complex within circle + res<-.C("intertype_tr_disq", + as.integer(mpt_nb[j]),as.double(x2),as.double(y2), + as.integer(mpt_nb[i]),as.double(x1),as.double(y1), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + matcol<-(j-1)*nbMarks+i-1 + k<-(matcol*tmax+1):(matcol*tmax+tmax) + gij[k]<-res$g/(intensity1*ds) + nij[k]<-res$k/(pi*r^2) + kij[k]<-res$k/intensity1 + lij[k]<-sqrt(res$k/(intensity1*pi))-r + } + } + } + labij<-paste(rep(tabMarks,each=nbMarks),rep(tabMarks,nbMarks),sep="-") + gij<-matrix(gij,nrow=tmax,ncol=nbMarks^2) + kij<-matrix(kij,nrow=tmax,ncol=nbMarks^2) + nij<-matrix(nij,nrow=tmax,ncol=nbMarks^2) + lij<-matrix(lij,nrow=tmax,ncol=nbMarks^2) + call<-match.call() + res<-list(call=call,r=r,labpq=labij,gij=gij,kpq=kij,lpq=lij,npq=nij,intensity=summary(p)$intensity) + class(res)<-c("fads","kpqfun") + return(res) +} + +ki.fun<-kp.fun<-function(p,upto,by) { + # checking for input parameters + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="multivariate") + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + surface<-area.swin(p$window) + + tabMarks<-levels(p$marks) + nbMarks<-length(tabMarks) + mpt_nb<-summary(p$marks) + #computing RipleyAll + gis<-double(tmax*nbMarks) + kis<-double(tmax*nbMarks) + lis<-double(tmax*nbMarks) + nis<-double(tmax*nbMarks) + for(i in 1:nbMarks) { + x1<-p$x[p$marks==tabMarks[i]] + y1<-p$y[p$marks==tabMarks[i]] + x2<-p$x[p$marks!=tabMarks[i]] + y2<-p$y[p$marks!=tabMarks[i]] + nbPts1<-mpt_nb[i] + nbPts2<-sum(mpt_nb)-nbPts1 + if(cas==1) { #rectangle + res<-.C("intertype_rect", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==2) { #circle + res<-.C("intertype_disq", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==3) { #complex within rectangle + res<-.C("intertype_tr_rect", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + else if(cas==4) { #complex within circle + res<-.C("intertype_tr_disq", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + g=double(tmax),k=double(tmax), + PACKAGE="ads") + } + intensity2<-nbPts2/surface + j<-((i-1)*tmax+1):((i-1)*tmax+tmax) + ds<-c(pi,diff(pi*r^2)) + gis[j]<-res$g/(intensity2*ds) + nis[j]<-res$k/(pi*r^2) + kis[j]<-res$k/intensity2 + lis[j]<-sqrt(res$k/(intensity2*pi))-r + } + # formatting results + labi<-tabMarks + gis<-matrix(gis,nrow=tmax,ncol=nbMarks) + kis<-matrix(kis,nrow=tmax,ncol=nbMarks) + nis<-matrix(nis,nrow=tmax,ncol=nbMarks) + lis<-matrix(lis,nrow=tmax,ncol=nbMarks) + call<-match.call() + res<-list(call=call,r=r,labp=labi,gp.=gis,kp.=kis,lp.=lis,np.=nis,intensity=summary(p)$intensity) + class(res)<-c("fads","kp.fun") + return(res) +} + +kmfun<-function(p,upto,by,nsim=0,alpha=0.01) { + # checking for input parameters + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="marked") + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + stopifnot(is.numeric(nsim)) + stopifnot(nsim>=0) + nsim<-testInteger(nsim) + #cmoy<-mean(p$marks) + cvar<-var(p$marks) + stopifnot(is.numeric(alpha)) + stopifnot(alpha>=0) + if(nsim>0) testIC(nsim,alpha) + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + intensity<-p$n/area.swin(p$window) + + if(cas==1) { #rectangle + if(nsim==0) { #without CI + res<-.C("corr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + gm=double(tmax),km=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("corr_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(alpha), + gm=double(tmax),km=double(tmax), + gmic1=double(tmax),gmic2=double(tmax),kmic1=double(tmax),kmic2=double(tmax), + gmval=double(tmax),kmval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==2) { #circle + if(nsim==0) { #without CI + res<-.C("corr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + gm=double(tmax),km=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("corr_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(alpha), + gm=double(tmax),km=double(tmax), + gmic1=double(tmax),gmic2=double(tmax),kmic1=double(tmax),kmic2=double(tmax), + gmval=double(tmax),kmval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==3) { #complex within rectangle + if(nsim==0) { #without CI + res<-.C("corr_tr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + gm=double(tmax),km=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("corr_tr_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(alpha), + gm=double(tmax),km=double(tmax), + gmic1=double(tmax),gmic2=double(tmax),kmic1=double(tmax),kmic2=double(tmax), + gmval=double(tmax),kmval=double(tmax), + PACKAGE="ads") + } + } + else if(cas==4) { #complex within circle + if(nsim==0) { #without CI + res<-.C("corr_tr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + gm=double(tmax),km=double(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("ripley_tr_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(p$marks), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nsim),as.double(alpha), + gm=double(tmax),km=double(tmax), + gmic1=double(tmax),gmic2=double(tmax),kmic1=double(tmax),kmic2=double(tmax), + gmval=double(tmax),kmval=double(tmax), + PACKAGE="ads") + } + } + # formatting results + gm<-data.frame(obs=res$gm,theo=rep(0,tmax)) + km<-data.frame(obs=res$km,theo=rep(0,tmax)) + if(nsim>0) { + gm<-cbind(gm,sup=res$gmic1,inf=res$gmic2,pval=res$gmval/(nsim+1)) + km<-cbind(km,sup=res$kmic1,inf=res$kmic2,pval=res$kmval/(nsim+1)) + } + call<-match.call() + res<-list(call=call,r=r,gm=gm,km=km) + class(res)<-c("fads","kmfun") + return(res) +} + +ksfun<-function(p,upto,by,nsim=0,alpha=0.01) { +# checking for input parameters + #options( CBoundsCheck = TRUE ) + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="multivariate") + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + stopifnot(is.numeric(nsim)) + stopifnot(nsim>=0) + nsim<-testInteger(nsim) + stopifnot(is.numeric(alpha)) + stopifnot(alpha>=0) + if(nsim>0) testIC(nsim,alpha) + +###faire test sur les marks + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + surface<-area.swin(p$window) + intensity<-p$n/surface + tabMarks<-levels(p$marks) + nbMarks<-nlevels(p$marks) +#nbMarks<-length(tabMarks) + marks<-as.numeric(p$marks) + freq<-as.vector(table(p$marks)) + D<-1-sum(freq*(freq-1))/(p$n*(p$n-1)) + +# computing Shimatani + if(cas==1) { #rectangle + if(nsim==0) { #without CI + res<-.C("shimatani_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + as.integer(nbMarks),as.integer(marks),as.double(surface),gg=double(tmax),kk=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("shimatani_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), as.integer(nsim), as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(surface),as.double(D), + gg=double(tmax),kk=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + } + else if(cas==2) { #circle + if(nsim==0) { #without CI + res<-.C("shimatani_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + as.integer(nbMarks),as.integer(marks),as.double(surface),gg=double(tmax),kk=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("shimatani_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), as.integer(nsim), as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(surface),as.double(D), + gg=double(tmax),kk=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + } + else if(cas==3) { #complex within rectangle + if(nsim==0) { #without CI + res<-.C("shimatani_tr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nbMarks),as.integer(marks),as.double(surface),gg=double(tmax),kk=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("shimatani_tr_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), as.integer(nsim), as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(surface),as.double(D), + gg=double(tmax),kk=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + } + else if(cas==4) { #complex within circle + if(nsim==0) { #without CI + res<-.C("shimatani_tr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.integer(nbMarks),as.integer(marks),as.double(surface),gg=double(tmax),kk=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("shimatani_tr_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), as.integer(nsim), as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(surface),as.double(D), + gg=double(tmax),kk=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + } + if(sum(res$erreur>0)){ + message("Error in ", appendLF=F) + print(match.call()) + message("No neigbors within distance intervals:") + print(paste(by*(res$erreur[res$erreur>0]-1),"-",by*res$erreur[res$erreur>0])) + message("Increase argument 'by'") + return(res=NULL) + } + gs<-data.frame(obs=res$gg/D,theo=rep(1,tmax)) + ks<-data.frame(obs=res$kk/D,theo=rep(1,tmax)) + if(nsim>0) { + gs<-cbind(gs,sup=res$gic1/D,inf=res$gic2/D,pval=res$gval/(nsim+1)) + ks<-cbind(ks,sup=res$kic1/D,inf=res$kic2/D,pval=res$kval/(nsim+1)) + } + call<-match.call() + res<-list(call=call,r=r,gs=gs,ks=ks) + class(res)<-c("fads","ksfun") + return(res) +} + + +################# +#V2 that calls K12fun +############## +krfun<-function(p,upto,by,nsim=0,dis=NULL,H0=c("rl","se"),alpha=0.01) { +# checking for input parameters + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="multivariate") + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + H0<-H0[1] + stopifnot(H0=="se" || H0=="rl") + ifelse(H0=="se",H0<-2,H0<-1) + if(is.null(dis)) { + stopifnot(H0==1) + dis<-as.dist(matrix(1,nlevels(p$marks),nlevels(p$marks))) + attr(dis,"Labels")<-levels(p$marks) + } + stopifnot(inherits(dis,"dist")) + stopifnot(attr(dis,"Diag")==FALSE) + stopifnot(attr(dis,"Upper")==FALSE) + stopifnot(suppressWarnings(is.euclid(dis))) +###revoir tests sur dis + if(length(levels(p$marks))!=length(labels(dis))) { + stopifnot(all(levels(p$marks)%in%labels(dis))) +#dis<-subsetdist(dis,which(labels(dis)%in%levels(p$marks))) + dis<-subsetdist(dis,levels(p$marks)) + warning("matrix 'dis' have been subsetted to match with levels(p$marks)") + } +#else if(any(labels(dis)!=levels(p$marks))) { +# attr(dis,"Labels")<-levels(p$marks) +# warning("levels(p$marks) have been assigned to attr(dis, ''Labels'')") +# } + stopifnot(is.numeric(nsim)) + stopifnot(nsim>=0) + nsim<-testInteger(nsim) + stopifnot(is.numeric(alpha)) + stopifnot(alpha>=0) + if(nsim>0) testIC(nsim,alpha) + +###faire test sur les marks + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + surface<-area.swin(p$window) + intensity<-p$n/surface + nbMarks<-nlevels(p$marks) + marks<-as.numeric(p$marks) # => position du label dans levels(p$marks) + dis<-as.dist(sortmat(dis,levels(p$marks))) + HD<-suppressWarnings(divc(as.data.frame(unclass(table(p$marks))),sqrt(2*dis),scale=F)[1,1]) + HD<-HD*p$n/(p$n-1) + dis<-as.vector(dis) + +# computing Rao + if(cas==1) { #rectangle + if(nsim==0) { #without CI + res<-.C("rao_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by),as.integer(H0), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("rao_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), as.integer(nsim),as.integer(H0),as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + } + else if(cas==2) { #circle + if(nsim==0) { #without CI + res<-.C("rao_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by),as.integer(H0), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("rao_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), as.integer(nsim),as.integer(H0),as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + } + else if(cas==3) { #complex within rectangle + if(nsim==0) { #without CI + res<-.C("rao_tr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by),as.integer(H0), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("rao_tr_rect_ic", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by),as.integer(nsim), as.integer(H0),as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + } + else if(cas==4) { #complex within circle + if(nsim==0) { #without CI + res<-.C("rao_tr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by),as.integer(H0), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI (not based on K12) + res<-.C("rao_tr_disq_ic", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by),as.integer(nsim), as.integer(H0),as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gg=double(tmax),kk=double(tmax),gs=double(tmax),ks=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),serreur=integer(tmax), + PACKAGE="ads") + } + } + if(sum(res$erreur>0)){ + message("Error in ", appendLF=F) + print(match.call()) + message("No neigbors within distance intervals:") + print(paste(by*(res$erreur[res$erreur>0]-1),"-",by*res$erreur[res$erreur>0])) + message("Increase argument 'by'") + return(res=NULL) + } + if(H0==1) { + theog<-rep(1,tmax) + theok<-rep(1,tmax) + } + if(H0==2) { + theog<-res$gs + theok<-res$ks + } + gr<-data.frame(obs=res$gg,theo=theog) + kr<-data.frame(obs=res$kk,theo=theok) + if(nsim>0) { + gr<-cbind(gr,sup=res$gic1,inf=res$gic2,pval=res$gval/(nsim+1)) + kr<-cbind(kr,sup=res$kic1,inf=res$kic2,pval=res$kval/(nsim+1)) + } + call<-match.call() + res<-list(call=call,r=r,gr=gr,kr=kr) + class(res)<-c("fads","krfun") + return(res) +} + +kdfun<-function(p,upto,by,dis,nsim=0,alpha=0.01) { +# checking for input parameters + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="multivariate") + if(min(p$x)<0) + p$x<-p$x+abs(min(p$x)) + if(min(p$y)<0) + p$y<-p$y+abs(min(p$y)) + stopifnot(is.numeric(upto)) + stopifnot(upto>=1) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + stopifnot(inherits(dis,"dist")) + stopifnot(attr(dis,"Diag")==FALSE) + stopifnot(attr(dis,"Upper")==FALSE) + stopifnot(suppressWarnings(is.euclid(dis))) +###revoir tests sur dis + if(length(levels(p$marks))!=length(labels(dis))) { + stopifnot(all(levels(p$marks)%in%labels(dis))) +#dis<-subsetdist(dis,which(labels(dis)%in%levels(p$marks))) + dis<-subsetdist(dis,levels(p$marks)) + warning("matrix 'dis' have been subsetted to match with levels(p$marks)") + } +#else if(any(labels(dis)!=levels(p$marks))) { +# attr(dis,"Labels")<-levels(p$marks) +# warning("levels(p$marks) have been assigned to attr(dis, ''Labels'')") +# } + stopifnot(is.numeric(nsim)) + stopifnot(nsim>=0) + nsim<-testInteger(nsim) + stopifnot(is.numeric(alpha)) + stopifnot(alpha>=0) + if(nsim>0) testIC(nsim,alpha) + + surface<-area.swin(p$window) + intensity<-p$n/surface + nbMarks<-nlevels(p$marks) + marks<-as.numeric(p$marks) # => position du label dans levels(p$marks) + dis<-as.dist(sortmat(dis,levels(p$marks))) + HD<-suppressWarnings(divc(as.data.frame(unclass(table(p$marks))),sqrt(2*dis),scale=F)[1,1]) + HD<-HD*p$n/(p$n-1) + dis<-as.vector(dis) + +###faire test sur les marks + + if(nsim==0) { #without CI + res<-.C("shen", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.integer(tmax),as.double(by), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gd=double(tmax),kd=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + else { #with CI + res<-.C("shen_ic", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.integer(tmax),as.double(by), as.integer(nsim),as.double(alpha), + as.integer(nbMarks),as.integer(marks),as.double(dis),as.double(surface),as.double(HD), + gd=double(tmax),kd=double(tmax),gic1=double(tmax),gic2=double(tmax),kic1=double(tmax),kic2=double(tmax), + gval=double(tmax),kval=double(tmax),erreur=integer(tmax), + PACKAGE="ads") + } + + if(sum(res$erreur>0)){ + message("Error in ", appendLF=F) + print(match.call()) + message("No neigbors within distance intervals:") + print(paste(by*(res$erreur[res$erreur>0]-1),"-",by*res$erreur[res$erreur>0])) + message("Increase argument 'by'") + return(res=NULL) + } + gd<-data.frame(obs=res$gd,theo=rep(1,tmax)) + kd<-data.frame(obs=res$kd,theo=rep(1,tmax)) + if(nsim>0) { + gd<-cbind(gd,sup=res$gic1,inf=res$gic2,pval=res$gval/(nsim+1)) + kd<-cbind(kd,sup=res$kic1,inf=res$kic2,pval=res$kval/(nsim+1)) + } + call<-match.call() + res<-list(call=call,r=r,gd=gd,kd=kd) + class(res)<-c("fads","kdfun") + return(res) +} diff --git a/R/mimetic.R b/R/mimetic.R new file mode 100755 index 0000000000000000000000000000000000000000..c428df8dfcdc9fe47c9d30d06bd54e35d372587d --- /dev/null +++ b/R/mimetic.R @@ -0,0 +1,111 @@ +#mimetic point process as in Goreaud et al. 2004 +#RP 11/06/2013 +################################################### + +mimetic<-function(x,upto=NULL,by=NULL,prec=NULL,nsimax=3000,conv=50) { +# checking for input parameters + stopifnot(inherits(x,"fads")||inherits(x,"spp")) + if(inherits(x,"fads")) { + call<-x$call + p<-eval(call[[2]]) + upto<-call[[3]] + by<-call[[4]] + if(length(call)==6) + prec<-call[[6]] + else + prec<-0.01 + lobs<-x$l$obs + r<-x$r + linit<-x + } + else if(inherits(x,"spp")) { + p<-x + if(is.null(prec)) + prec<-0.01 + else + prec<-prec + linit<-kfun(p=p,upto=upto,by=by,nsim=0,prec=prec) + lobs<-linit$l$obs + r<-linit$r + } + surface<-area.swin(p$window) + tmax<-length(r) +#lobs<-lobs+r + if("rectangle"%in%p$window$type) { + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + tri<-p$window$triangles + nbTri<-nrow(tri) + res<-.C("mimetic_tr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(surface), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.double(prec),as.integer(tmax),as.double(by), + as.double(lobs),as.integer(nsimax),as.integer(conv),cost=double(nsimax), + g=double(tmax),k=double(tmax),xx=double(p$n),yy=double(p$n),mess=as.integer(1), + PACKAGE="ads") + } + else { + res<-.C("mimetic_rect", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(surface), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.double(prec),as.integer(tmax),as.double(by), + as.double(lobs),as.integer(nsimax),as.integer(conv),cost=double(nsimax), + g=double(tmax),k=double(tmax),xx=double(p$n),yy=double(p$n),mess=as.integer(1), + PACKAGE="ads") + } + } + else if("circle"%in%p$window$type) { + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + tri<-p$window$triangles + nbTri<-nrow(tri) + res<-.C("mimetic_tr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(surface), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.double(prec),as.integer(tmax),as.double(by), + as.double(lobs),as.integer(nsimax),as.integer(conv),cost=double(nsimax), + g=double(tmax),k=double(tmax),xx=double(p$n),yy=double(p$n),mess=as.integer(1), + PACKAGE="ads") + } + else { + res<-.C("mimetic_disq", + as.integer(p$n),as.double(p$x),as.double(p$y),as.double(surface), + as.double(x0),as.double(y0),as.double(r0),as.double(prec),as.integer(tmax),as.double(by), + as.double(lobs),as.integer(nsimax),as.integer(conv),cost=double(nsimax), + g=double(tmax),k=double(tmax),xx=double(p$n),yy=double(p$n),mess=as.integer(1), + PACKAGE="ads") + } + } + else + stop("invalid window type") + psim<-spp(res$x,res$y,window=p$window) + lsim<-kfun(psim,upto,by,nsim=0,prec) + cost<-res$cost + call<-match.call() + l<-data.frame(obs=linit$l$obs,sim=lsim$l$obs) + fads<-list(r=lsim$r,l=l) + class(fads)<-c("fads","mimetic") + res<-list(call=call,fads=fads,spp=psim,cost=cost[cost>0]) + class(res)<-c("mimetic") + return(res) +} + +plot.mimetic<-function (x,cols,lty,main,sub,legend=TRUE,csize=1,cex.main=1.5,pos="top",...) { + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + mylayout<-layout(matrix(c(1,1,2,3,2,3),ncol=2,byrow=TRUE)) + main<-deparse(x$call,width.cutoff=100) + plot.fads.mimetic(x$fads,main=main,cex.main=1.5*csize,pos=pos,...) + plot(x$spp,main="x$spp (simulated)",cex.main=csize,...) + barplot(x$cost,main=paste("x$cost (nsim=",length(x$cost),")",sep=""),cex.main=csize,...) + +} \ No newline at end of file diff --git a/R/plot.fads.R b/R/plot.fads.R new file mode 100755 index 0000000000000000000000000000000000000000..badaf431338d968c6f7fdc95fc4f75103b8b1556 --- /dev/null +++ b/R/plot.fads.R @@ -0,0 +1,645 @@ +plot.fads<-function (x,opt,cols,lty,main,sub,legend,csize,...) { + UseMethod("plot.fads") +} + +plot.fads.kfun<-function (x,opt=c("all","L","K","n","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + ifelse(!is.null(x$call$nsim)&&(x$call$nsim>0),ci<-TRUE,ci<-FALSE) + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + opt<-opt[1] + if(opt=="all") + mylayout<-layout(matrix(c(1,1,1,1,2,2,3,3,2,2,3,3,4,4,5,5,4,4,5,5),ncol=4,byrow=TRUE)) + else if(opt%in%c("L","K","n","g")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,16)),ncol=4,byrow=TRUE)) + else + stopifnot(opt%in%c("all","L","K","n","g")) + if(missing(cols)) + cols=c(1,2,3) + else if(length(cols)!=3) + cols=c(cols,cols,cols) + if(missing(lty)) + lty=c(1,3,2) + else if(length(lty)!=3) + lty=c(lty,lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-c("pair density function","second-order neighbour density function","Ripley's K-function","L-function : sqrt[K(r)/pi]-r") + if(ci) { + alpha<-x$call[["alpha"]] + p<-ifelse(!is.null(alpha),signif(100*(1-alpha),digits=6),99) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$g$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (CSR)",paste(p,"% CI of CSR")),cex=1.5,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.75*csize,csize)) + if(opt%in%c("all","g")) { # g-function + lim<-range(x$g[,1:4]) + plot(x$r,x$g$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="g(r)",cex.lab=1.25,...) + lines(x$r,x$g$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$g$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$g$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$g$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","n")) {# n-function + lim<-range(x$n[,1:4]) + plot(x$r,x$n$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="n(r)",cex.lab=1.25,...) + lines(x$r,x$n$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$n$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$n$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$n$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","K")) { # K-function + plot(x$r,x$k$obs,ylim=range(x$k[,1:4]),main=paste("\n\n",sub[3]),type="n",xlab="distance (r)",ylab="K(r)",cex.lab=1.25,...) + lines(x$r,x$k$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$k$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$k$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$k$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","L")) { # L-function + lim<-range(x$l[,1:4]) + plot(x$r,x$l$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[4]),type="n",xlab="distance (r)",ylab="L(r)",cex.lab=1.25,...) + lines(x$r,x$l$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$l$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$l$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$l$inf,lty=lty[3],col=cols[3],...) + } + } + else { + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$g$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (CSR)"),cex=1.5,lty=lty[1:2],bty="n",horiz=TRUE,title=main,col=cols[1:2],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.75*csize,csize)) + if(opt%in%c("all","g")) { # g-function + lim<-range(x$g) + plot(x$r,x$g$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="g(r)",cex.lab=1.25,...) + lines(x$r,x$g$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$g$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","n")) { # n-function + lim<-range(x$n) + plot(x$r,x$n$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="n(r)",cex.lab=1.25,...) + lines(x$r,x$n$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$n$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","K")) { # k-function + plot(x$r,x$k$obs,ylim=range(x$k),main=paste("\n\n",sub[3]),type="n",xlab="distance (r)",ylab="K(r)",cex.lab=1.25,...) + lines(x$r,x$k$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$k$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","L")) { # L-function + lim<-range(x$l) + plot(x$r,x$l$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[4]),type="n",xlab="distance (r)",ylab="L(r)",cex.lab=1.25,...) + lines(x$r,x$l$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$l$theo,lty=lty[2],col=cols[2],...) + } + } +} + +plot.fads.k12fun<-function(x,opt=c("all","L","K","n","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + #ifelse(!is.null(x$call[["nsim"]]),ci<-TRUE,ci<-FALSE) + ifelse(!is.null(x$call$nsim)&&(x$call$nsim>0),ci<-TRUE,ci<-FALSE) + if(is.null(x$call[["H0"]])||(x$call[["H0"]]=="pitor")) h0<-"PI-tor" + else if(x$call[["H0"]]=="pimim") h0<-"PI-mim" + else h0<-"RL" + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + opt<-opt[1] + if(opt=="all") + mylayout<-layout(matrix(c(1,1,1,1,2,2,3,3,2,2,3,3,4,4,5,5,4,4,5,5),ncol=4,byrow=TRUE)) + else if(opt%in%c("L","K","n","g")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,16)),ncol=4,byrow=TRUE)) + else + stopifnot(opt%in%c("all","L","K","n","g")) + if(missing(cols)) + cols=c(1,2,3) + else if(length(cols)!=3) + cols=c(cols,cols,cols) + if(missing(lty)) + lty=c(1,3,2) + else if(length(lty)!=3) + lty=c(lty,lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-c("pair density function","second-order neighbour density function","intertype function","modified intertype function : sqrt[K12(r)/pi]-r") + if(ci) { + alpha<-x$call[["alpha"]] + p<-ifelse(!is.null(alpha),signif(100*(1-alpha),digits=6),99) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$g12$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs",paste("theo (",h0,")",sep=""),paste(p,"% CI of",h0)),cex=1.5,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.75*csize,csize)) + if(opt%in%c("all","g")) { # g12-function + lim<-range(x$g12[,1:4]) + plot(x$r,x$g12$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="g12(r)",cex.lab=1.25) + lines(x$r,x$g12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$g12$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$g12$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$g12$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","n")) { # n12-function + lim<-range(x$n12[,1:4]) + plot(x$r,x$n12$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="n12(r)",cex.lab=1.25) + lines(x$r,x$n12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$n12$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$n12$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$n12$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","K")) { # K-function + plot(x$r,x$k12$obs,ylim=range(x$k12[,1:4]),main=paste("\n\n",sub[3]),type="n",xlab="distance (r)",ylab="K12(r)",cex.lab=1.25) + lines(x$r,x$k12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$k12$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$k12$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$k12$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","L")) { # L-function + lim<-range(x$l12[,1:4]) + plot(x$r,x$l12$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[4]),type="n",xlab="distance (r)",ylab="L12(r)",cex.lab=1.25) + lines(x$r,x$l12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$l12$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$l12$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$l12$inf,lty=lty[3],col=cols[3],...) + } + } + else { + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$g12$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs",paste("theo (",h0,")",sep="")),cex=1.5,lty=lty[1:2],bty="n",horiz=TRUE,title=main,col=cols[1:2],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.75*csize,csize)) + if(opt%in%c("all","g")) { # g-function + lim<-range(x$g12) + plot(x$r,x$g12$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance step (r)",ylab="g12(r)",cex.lab=1.25,...) + lines(x$r,x$g12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$g12$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","n")) { # n-function + lim<-range(x$n12) + plot(x$r,x$n12$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[2]),type="n",xlab="distance step (r)",ylab="n12(r)",cex.lab=1.25,...) + lines(x$r,x$n12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$n12$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","K")) { # k-function + plot(x$r,x$k12$obs,ylim=range(x$k),main=paste("\n\n",sub[3]),type="n",xlab="distance step (r)",ylab="K12(r)",cex.lab=1.25,...) + lines(x$r,x$k12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$k12$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","L")) { # L-function + lim<-range(x$l12) + plot(x$r,x$l12$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[4]),type="n",xlab="distance step (r)",ylab="L12(r)",cex.lab=1.25,...) + lines(x$r,x$l12$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$l12$theo,lty=lty[2],col=cols[2],...) + } + } +} + +plot.fads.kpqfun<-function (x,opt=c("L","K","n","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + na<-length(x$labpq) + nf<-ceiling(sqrt(na)) + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + opt<-opt[1] + if(opt=="g") { + val<-x$gpq + theo<-matrix(rep(rep(1,na),each=length(x$r)),ncol=na) + ylab=paste("gpq(r)",sep="") + } + if(opt=="n") { + val<-x$npq + theo<-matrix(rep(rep(x$intensity,nf),each=length(x$r)),ncol=na) + ylab=paste("npq(r)",sep="") + } + if(opt=="K") { + val<-x$kpq + theo<-matrix(rep(pi*x$r^2,na),ncol=na) + ylab=paste("Kpq(r)",sep="") + } + if(opt=="L") { + val<-x$lpq + theo<-matrix(rep(rep(0,na),each=length(x$r)),ncol=na) + ylab=paste("Lpq(r)",sep="") + } + if(missing(cols)) + cols=c(1,2) + else if(length(cols)!=2) + cols=c(cols,cols) + if(missing(lty)) + lty=c(1,3) + else if(length(lty)!=2) + lty=c(lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-x$labpq + lim<-range(val) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot.default(val[,1],val[,2]/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (CSR/PI)"),cex=1.5,lty=lty[1:2],bty="n",horiz=TRUE,title=main,col=cols[1:2],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=0.66*csize) + for(i in 1:na) { + plot(x$r,val[,i],ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[i]),type="n",xlab="distance (r)",ylab=ylab,cex.lab=1.25,...) + lines(x$r,val[,i],lty=lty[1],col=cols[1],...) + lines(x$r,theo[,i],lty=lty[2],col=cols[2],...) + } +} + +plot.fads.kp.fun<-function (x,opt=c("L","K","n","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + na<-length(x$labp) + nf<-ceiling(sqrt(na)) + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + opt<-opt[1] + if(opt=="g") { + val<-x$gp. + theo<-matrix(rep(rep(1,na),each=length(x$r)),ncol=na) + ylab=paste("gp.(r)",sep="") + } + if(opt=="n") { + val<-x$np. + intensity<-sum(x$intensity)-x$intensity + theo<-matrix(rep(intensity,each=length(x$r)),ncol=na) + ylab=paste("np.(r)",sep="") + } + if(opt=="K") { + val<-x$kp. + theo<-matrix(rep(pi*x$r^2,na),ncol=na) + ylab=paste("Kp.(r)",sep="") + } + if(opt=="L") { + val<-x$lp. + theo<-matrix(rep(rep(0,na),each=length(x$r)),ncol=na) + ylab=paste("Lp.(r)",sep="") + } + if(missing(cols)) + cols=c(1,2) + else if(length(cols)!=2) + cols=c(cols,cols) + if(missing(lty)) + lty=c(1,3) + else if(length(lty)!=2) + lty=c(lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-paste(x$labp,"-all others",sep="") + lim<-range(val) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot.default(val[,1],val[,2]/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (PI)"),cex=1.5,lty=lty[1:2],bty="n",horiz=TRUE,title=main,col=cols[1:2],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=0.66*csize) + for(i in 1:na) { + plot(x$r,val[,i],ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[i]),type="n",xlab="distance (r)",ylab=ylab,cex.lab=1.25,...) + lines(x$r,val[,i],lty=lty[1],col=cols[1],...) + lines(x$r,theo[,i],lty=lty[2],col=cols[2],...) + } +} + +plot.fads.kmfun<-function (x,opt=c("all","K","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + ifelse(!is.null(x$call$nsim)&&(x$call$nsim>0),ci<-TRUE,ci<-FALSE) + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + opt<-opt[1] + if(opt=="all") + mylayout<-layout(matrix(c(1,1,1,1,rep(2,8),rep(3,8)),ncol=4,byrow=TRUE)) + else if(opt%in%c("K","g")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,16)),ncol=4,byrow=TRUE)) + else + stopifnot(opt%in%c("all","K","g")) + if(missing(cols)) + cols=c(1,2,3) + else if(length(cols)!=3) + cols=c(cols,cols,cols) + if(missing(lty)) + lty=c(1,3,2) + else if(length(lty)!=3) + lty=c(lty,lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-c("pair correlation function","mark correlation function") + if(ci) { + alpha<-x$call[["alpha"]] + p<-ifelse(!is.null(alpha),signif(100*(1-alpha),digits=6),99) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gm$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (IM)",paste(p,"% CI of IM")),cex=1.5,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # gm-function + lim<-range(x$gm[,1:4]) + plot(x$r,x$gm$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gm(r)",cex.lab=1.25,...) + lines(x$r,x$gm$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gm$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$gm$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$gm$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","K")) { # K-function + plot(x$r,x$km$obs,ylim=range(x$km[,1:4]),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Km(r)",cex.lab=1.25,...) + lines(x$r,x$km$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$km$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$km$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$km$inf,lty=lty[3],col=cols[3],...) + } + } + else { + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gm$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (IM)"),cex=1.5,lty=lty[1:2],bty="n",horiz=TRUE,title=main,col=cols[1:2],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # g-function + lim<-range(x$gm) + plot(x$r,x$gm$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gm(r)",cex.lab=1.25,...) + lines(x$r,x$gm$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gm$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","K")) { # k-function + plot(x$r,x$km$obs,ylim=range(x$km),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Km(r)",cex.lab=1.25,...) + lines(x$r,x$km$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$km$theo,lty=lty[2],col=cols[2],...) + } + } +} + +plot.fads.ksfun<-function (x,opt=c("all","K","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + ifelse(!is.null(x$call$nsim)&&(x$call$nsim>0),ci<-TRUE,ci<-FALSE) + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) +#if(options()$device=="windows") +# csize<-0.75*csize + opt<-opt[1] + if(opt=="all") + mylayout<-layout(matrix(c(1,1,1,1,rep(2,8),rep(3,8)),ncol=4,byrow=TRUE)) + else if(opt%in%c("K","g")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,16)),ncol=4,byrow=TRUE)) + else + stopifnot(opt%in%c("all","K","g")) + +# opt<-opt[1] +# if(opt=="all") +# mylayout<-layout(matrix(c(1,1,1,1,2,2,3,3,2,2,3,3,4,4,4,4,4,4,4,4),ncol=4,byrow=TRUE)) +# else if(opt%in%c("K","P","g")) +# mylayout<-layout(matrix(c(1,1,1,1,rep(2,16)),ncol=4,byrow=TRUE)) +# else +# stopifnot(opt%in%c("all","K","P","g")) + if(missing(cols)) + cols=c(1,2,3) + else if(length(cols)!=3) + cols=c(cols,cols,cols) + if(missing(lty)) + lty=c(1,3,2) + else if(length(lty)!=3) + lty=c(lty,lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-c("Standardized Shimatani non-cumulative (beta) function","Standardized Shimatani cumulative (alpha) function") + if(ci) { + alpha<-x$call[["alpha"]] + p<-ifelse(!is.null(alpha),signif(100*(1-alpha),digits=6),99) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gs$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (RL)",paste(p,"% CI of RL",sep="")),cex=1.3,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # gs-function + lim<-range(x$gs[,1:4]) + plot(x$r,x$gs$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gs(r)",cex.lab=1.25,...) + lines(x$r,x$gs$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gs$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$gs$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$gs$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","K")) { # Ks-function + plot(x$r,x$ks$obs,ylim=range(x$ks[,1:4]),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Ks(r)",cex.lab=1.25,...) + lines(x$r,x$ks$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$ks$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$ks$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$ks$inf,lty=lty[3],col=cols[3],...) + } + } + else { + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gs$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (RL)"),cex=1.3,lty=lty[1:2],bty="n",horiz=TRUE,title=main,col=cols[1:2],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # gs-function + lim<-range(x$gs) + plot(x$r,x$gs$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gs(r)",cex.lab=1.25,...) + lines(x$r,x$gs$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gs$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","K")) { # ks-function + plot(x$r,x$ks$obs,ylim=range(x$ks),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Ks(r)",cex.lab=1.25,...) + lines(x$r,x$ks$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$ks$theo,lty=lty[2],col=cols[2],...) + } + } +} + +plot.fads.krfun<-function (x,opt=c("all","K","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + ifelse(!is.null(x$call$nsim)&&(x$call$nsim>0),ci<-TRUE,ci<-FALSE) + ifelse((is.null(x$call[["H0"]])||(x$call[["H0"]]=="rl")),h0<-"RL",h0<-"SE") + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) +#if(options()$device=="windows") +# csize<-0.75*csize + opt<-opt[1] + if(opt%in%c("all")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,8),rep(3,8)),ncol=4,byrow=TRUE)) + else if(opt%in%c("K","g")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,16)),ncol=4,byrow=TRUE)) + else + stopifnot(opt%in%c("all","K","g")) + if(missing(cols)) + cols=c(1,2,3) + else if(length(cols)!=3) + cols=c(cols,cols,cols) + if(missing(lty)) + lty=c(1,3,2) + else if(length(lty)!=3) + lty=c(lty,lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-c("Standardized Rao non-cumulative function","Standardized Rao cumulative function") + if(ci) { + alpha<-x$call[["alpha"]] + p<-ifelse(!is.null(alpha),signif(100*(1-alpha),digits=6),99) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gr$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs",paste("theo (",h0,")",sep=""),paste(p,"% CI of",h0)),cex=1.3,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # gr-function + lim<-range(x$gr[,1:4]) + plot(x$r,x$gr$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gr(r)",cex.lab=1.25,...) + lines(x$r,x$gr$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gr$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$gr$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$gr$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","K")) { # Kr-function + plot(x$r,x$kr$obs,ylim=range(x$kr[,1:4]),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Kr(r)",cex.lab=1.25,...) + lines(x$r,x$kr$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$kr$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$kr$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$kr$inf,lty=lty[3],col=cols[3],...) + } + } + else { + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gr$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs",paste("theo (",h0,")",sep="")),cex=1.3,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # gr-function + lim<-range(x$gr) + plot(x$r,x$gr$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gr(r)",cex.lab=1.25,...) + lines(x$r,x$gr$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gr$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","K")) { # kr-function + plot(x$r,x$kr$obs,ylim=range(x$kr),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Kr(r)",cex.lab=1.25,...) + lines(x$r,x$kr$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$kr$theo,lty=lty[2],col=cols[2],...) + } + } +} + +plot.fads.kdfun<-function (x,opt=c("all","K","g"),cols,lty,main,sub,legend=TRUE,csize=1,...) { + ifelse(!is.null(x$call$nsim)&&(x$call$nsim>0),ci<-TRUE,ci<-FALSE) + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) +#if(options()$device=="windows") +# csize<-0.75*csize + opt<-opt[1] + if(opt%in%c("all")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,8),rep(3,8)),ncol=4,byrow=TRUE)) + else if(opt%in%c("K","g")) + mylayout<-layout(matrix(c(1,1,1,1,rep(2,16)),ncol=4,byrow=TRUE)) + else + stopifnot(opt%in%c("all","K","g")) + if(missing(cols)) + cols=c(1,2,3) + else if(length(cols)!=3) + cols=c(cols,cols,cols) + if(missing(lty)) + lty=c(1,3,2) + else if(length(lty)!=3) + lty=c(lty,lty,lty) + if(missing(main)) + main<-deparse(x$call,width.cutoff=100) + if(missing(sub)) + sub<-c("Standardized Shen non-cumulative function","Standardized Shen cumulative function") + if(ci) { + alpha<-x$call[["alpha"]] + p<-ifelse(!is.null(alpha),signif(100*(1-alpha),digits=6),99) + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gd$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (SE)",paste(p,"% CI of SE")),cex=1.3,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # gd-function + lim<-range(x$gd[,1:4]) + plot(x$r,x$gd$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gd(r)",cex.lab=1.25,...) + lines(x$r,x$gd$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gd$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$gd$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$gd$inf,lty=lty[3],col=cols[3],...) + } + if(opt%in%c("all","K")) { # Kd-function + plot(x$r,x$kd$obs,ylim=range(x$kd[,1:4]),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Kd(r)",cex.lab=1.25,...) + lines(x$r,x$kd$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$kd$theo,lty=lty[2],col=cols[2],...) + lines(x$r,x$kd$sup,lty=lty[3],col=cols[3],...) + lines(x$r,x$kd$inf,lty=lty[3],col=cols[3],...) + } + } + else { + par(mar=c(0.1,0.1,0.1,0.1),cex=csize) + plot(x$r,x$gd$obs/2,type="n",axes=FALSE,xlab="",ylab="") + if(legend) + legend("center",c("obs","theo (SE)"),cex=1.3,lty=lty[1:3],bty="n",horiz=TRUE,title=main,col=cols[1:3],...) + else + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + par(mar=c(5,5,0.1,2),cex=ifelse(opt%in%c("all"),0.85*csize,csize)) + if(opt%in%c("all","g")) { # gd-function + lim<-range(x$gd) + plot(x$r,x$gd$obs,ylim=c(lim[1],lim[2]+0.1*diff(lim)),main=paste("\n\n",sub[1]),type="n",xlab="distance (r)",ylab="gd(r)",cex.lab=1.25,...) + lines(x$r,x$gd$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$gd$theo,lty=lty[2],col=cols[2],...) + } + if(opt%in%c("all","K")) { # Kd-function + plot(x$r,x$kd$obs,ylim=range(x$kd),main=paste("\n\n",sub[2]),type="n",xlab="distance (r)",ylab="Kd(r)",cex.lab=1.25,...) + lines(x$r,x$kd$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$kd$theo,lty=lty[2],col=cols[2],...) + } + } +} + +plot.fads.mimetic<-function (x,opt=NULL,cols,lty,main,sub,legend=TRUE,csize=1,cex.main=1.5,pos,...) { + if(missing(cols)) + cols=c(1,2) + else if(length(cols)!=2) + cols=c(cols,cols) + if(missing(lty)) + lty=c(1,1) + else if(length(lty)!=2) + lty=c(lty,lty) + if(missing(main)) { + call<-match.call() + main<-deparse(eval(eval(expression(call))[[2]][[2]])$call,width.cutoff=100) + } + plot(x$r,x$l$obs,ylim=range(rbind(x$l$obs,x$l$sim)),main=main,type="n",xlab="distance (r)",ylab="L(r)",cex.lab=1.25,cex.main=cex.main,...) + lines(x$r,x$l$obs,lty=lty[1],col=cols[1],...) + lines(x$r,x$l$sim,lty=lty[2],col=cols[2],...) + if(legend) + legend(pos,c("obs","sim"),cex=1.5,lty=lty[1:2],bty="n",horiz=TRUE,col=cols[1:2],...) +} + + diff --git a/R/plot.vads.R b/R/plot.vads.R new file mode 100755 index 0000000000000000000000000000000000000000..9f80ffbdaaebaa0beb626366fba2b9a8c8e97044 --- /dev/null +++ b/R/plot.vads.R @@ -0,0 +1,308 @@ +plot.vads<-function(x,main,opt,select,chars,cols,maxsize,char0,col0,legend,csize,...) { + UseMethod("plot.vads") +} + +plot.vads.dval<-function (x,main,opt=c("dval","cval"),select,chars=c("circles","squares"),cols,maxsize,char0,col0,legend=TRUE,csize=1,...) { + if(!missing(select)) { + d<-c() + for(i in 1:length(select)) { + select.in.r<-c() + for(j in 1:length(x$r)) { + select.in.r<-c(select.in.r,ti<-isTRUE(all.equal(select[i],x$r[j]))) + if(ti) + d<-c(d,j) + } + stopifnot(any(select.in.r==TRUE)) + } + } + else + d<-rank(x$r) + nd<-length(d) + nf<-ceiling(sqrt(nd)) + stopifnot(opt%in%c("dval","cval")) + opt<-opt[1] + stopifnot(chars%in%c("circles","squares")) + chars<-chars[1] + ifelse(opt=="dval",val<-x$dval[,d],val<-x$cval[,d]) + v<-val + val<-data.frame(adjust.marks.size(val,x$window,if(!missing(maxsize)) maxsize)) + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + if (missing(main)) + main <- deparse(substitute(x)) + mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + s<-summary(x$window) + par(mar=c(0.1,0.1,1,0.1),cex=csize) + plot(s$xrange,s$yrange,type="n",axes=FALSE,asp=1/nf) + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + if(legend) { + mid<-(s$xrange[2]-s$xrange[1])/2 + xl<-c(mid-0.5*mid,mid,mid+0.5*mid) + yl<-rep(s$xrange[2]*0.25,3) + lm<-range(v[v>0]) + lm<-c(lm[1],mean(lm),lm[2]) + lms<-range(val[val>0]) + lms<-c(lms[1],mean(lms),lms[2]) + if(missing(chars)||chars=="circles") { + symbols(xl,yl,circles=sqrt(lms),fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl,labels=signif(lm,2),pos=4,cex=1.5) + } + else if(chars=="squares") { + symbols(xl,yl,squares=1.5*sqrt(lms),fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl,labels=signif(lm,2),pos=4,cex=1.5) + } + } + #if(!is.null(main)) { + # mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + # plot.default(x$xy$x,x$xy$y,type="n",axes=FALSE) + # text(mean(range(x$xy$x)),mean(range(x$xy$y)),pos=3,cex=2,labels=main) + #ajouter une lŽgende ??? + #} + #else + # mylayout<-layout(matrix(seq(1,(nf*nf),1),nf,nf,byrow=TRUE)) + ifelse(missing(cols),cols<-1,cols<-cols[1]) + if(!missing(char0)||!missing(col0)) { + ifelse(missing(col0),col0<-cols,col0<-col0[1]) + if(missing(char0)) + char0<-3 + } + for(i in 1:nd) { + plot.swin(x$window,main=paste("r =",x$r[d[i]]),scale=FALSE,csize=0.66*csize,...) + nort<-(val[,i]==0) + if(!missing(char0)&&any(nort)) + points(x$xy$x[nort],x$xy$y[nort],pch=char0,col=col0,...) + if(any(!nort)) { + if(chars=="circles") + symbols(x$xy$x[!nort],x$xy$y[!nort],circles=nf*sqrt(val[!nort,i]), + fg=cols,bg=cols,inches=FALSE,add=TRUE,...) + else if(chars=="squares") + symbols(x$xy$x[!nort],x$xy$y[!nort],squares=1.5*nf*sqrt(val[!nort,i]), + fg=cols,bg=cols,inches=FALSE,add=TRUE,...) + } + } + ## mŽthode en courbes de niveaux ? +} + +plot.vads.kval<-function (x,main,opt=c("lval","kval","nval","gval"),select,chars=c("circles","squares"),cols,maxsize,char0,col0,legend=TRUE,csize=1,...) { + if(!missing(select)) { + d<-c() + for(i in 1:length(select)) { + select.in.r<-c() + for(j in 1:length(x$r)) { + select.in.r<-c(select.in.r,ti<-isTRUE(all.equal(select[i],x$r[j]))) + if(ti) + d<-c(d,j) + } + stopifnot(any(select.in.r==TRUE)) + } + } + else + d<-rank(x$r) + nd<-length(d) + nf<-ceiling(sqrt(nd)) + opt<-opt[1] + stopifnot(chars%in%c("circles","squares")) + chars<-chars[1] + + if(opt=="lval") + val<-x$lval[,d] + else if(opt=="kval") + val<-x$kval[,d] + else if(opt=="nval") + val<-x$nval[,d] + else if(opt=="gval") + val<-x$gval[,d] + else + stopifnot(opt%in%c("lval","kval","nval","gval")) + v<-val + #val<-data.frame(adjust.marks.size(val,x$window,if(!missing(maxsize)) maxsize)) + val<-data.frame(adjust.marks.size(val,x$window)) + if(!missing(maxsize)) + val<-val*maxsize + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + if (missing(main)) + main <- deparse(substitute(x)) + mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + s<-summary(x$window) + par(mar=c(0.1,0.1,1,0.1),cex=csize) + plot.default(s$xrange,s$yrange,type="n",axes=FALSE,asp=1/nf) + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + if(legend) { + mid<-(s$xrange[2]-s$xrange[1])/2 + xl<-c(mid-0.5*mid,mid,mid+0.5*mid) + yl<-rep(s$xrange[2]*0.25,3) + lm<-range(abs(v)[abs(v)>0]) + lm<-c(lm[1],mean(lm),lm[2]) + lms<-range(abs(val)[abs(val)>0]) + lms<-c(lms[1],mean(lms),lms[2]) + if(missing(chars)||chars=="circles") { + symbols(xl,yl,circles=sqrt(lms),fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1]+1,xl[2]+lms[2]+1,xl[3]+lms[3]+1),yl,labels=signif(lm,2),pos=4,cex=1) + symbols(xl,yl*0.5,circles=sqrt(lms),fg=ifelse(missing(cols),1,cols),bg="white",inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl*0.5,labels=signif(-lm,2),pos=4,cex=1) + + } + else if(chars=="squares") { + symbols(xl,yl,squares=1.5*sqrt(lms),fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1]+1,xl[2]+lms[2]+1,xl[3]+lms[3]+1),yl,labels=signif(lm,2),pos=4,cex=1) + symbols(xl,yl*0.5,squares=1.5*sqrt(lms),fg=ifelse(missing(cols),1,cols),bg="white",inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl*0.5,labels=signif(-lm,2),pos=4,cex=1) + + } + } + #if(!is.null(main)) { + # mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + # plot.default(x$xy$x,x$xy$y,type="n",axes=FALSE) + # text(mean(range(x$xy$x)),mean(range(x$xy$y)),pos=3,cex=2,labels=main) + #ajouter une lŽgende ??? + #} + #else + # mylayout<-layout(matrix(seq(1,(nf*nf),1),nf,nf,byrow=TRUE)) + ifelse(missing(cols),cols<-1,cols<-cols[1]) + if(!missing(char0)||!missing(col0)) { + ifelse(missing(col0),col0<-cols,col0<-col0[1]) + if(missing(char0)) + char0<-3 + } + for(i in 1:nd) { + plot.swin(x$window,main=paste("r =",x$r[d[i]]),scale=FALSE,csize=0.66*csize,...) + nort<-(val[,i]==0) + neg<-(val[,i]<0) + if(!missing(char0)&&any(nort)) + points(x$xy$x[nort],x$xy$y[nort],pch=char0,col=col0,...) + if(any(!nort)) { + if(chars=="circles") { + if(any(!neg)) + symbols(x$xy$x[(!neg&!nort)],x$xy$y[(!neg&!nort)],circles=nf*sqrt(abs(val[(!neg&!nort),i])), + fg=cols,bg=cols,inches=FALSE,add=TRUE,...) + if(any(neg)) + symbols(x$xy$x[(neg&!nort)],x$xy$y[(neg&!nort)],circles=nf*sqrt(abs(val[(neg&!nort),i])), + fg=cols,bg="white",inches=FALSE,add=TRUE,...) + } + else if(chars=="squares") { + if(any(!neg)) + symbols(x$xy$x[(!neg&!nort)],x$xy$y[(!neg&!nort)],squares=1.5*nf*sqrt(abs(val[(!neg&!nort),i])), + fg=cols,bg=cols,inches=FALSE,add=TRUE,...) + if(any(neg)) + symbols(x$xy$x[(neg&!nort)],x$xy$y[(neg&!nort)],squares=1.5*nf*sqrt(abs(val[(neg&!nort),i])), + fg=cols,bg="white",inches=FALSE,add=TRUE,...) + } + } + } + ## mŽthode en courbes de niveaux ? +} + +plot.vads.k12val<-function (x,main,opt=c("lval","kval","nval","gval"),select,chars=c("circles","squares"),cols,maxsize,char0,col0,legend=TRUE,csize=1,...) { + if(!missing(select)) { + d<-c() + for(i in 1:length(select)) { + select.in.r<-c() + for(j in 1:length(x$r)) { + select.in.r<-c(select.in.r,ti<-isTRUE(all.equal(select[i],x$r[j]))) + if(ti) + d<-c(d,j) + } + stopifnot(any(select.in.r==TRUE)) + } + } + else + d<-rank(x$r) + nd<-length(d) + nf<-ceiling(sqrt(nd)) + opt<-opt[1] + stopifnot(chars%in%c("circles","squares")) + chars<-chars[1] + + if(opt=="lval") + val<-x$l12val[,d] + else if(opt=="kval") + val<-x$k12val[,d] + else if(opt=="nval") + val<-x$n12val[,d] + else if(opt=="gval") + val<-x$g12val[,d] + else + stopifnot(opt%in%c("lval","kval","nval","gval")) + v<-val + #val<-data.frame(adjust.marks.size(val,x$window,if(!missing(maxsize)) maxsize)) + val<-data.frame(adjust.marks.size(val,x$window)) + if(!missing(maxsize)) + val<-val*maxsize + def.par <- par(no.readonly = TRUE) + on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + if (missing(main)) + main <- deparse(substitute(x)) + mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + s<-summary(x$window) + par(mar=c(0.1,0.1,1,0.1),cex=csize) + plot.default(s$xrange,s$yrange,type="n",axes=FALSE,asp=1/nf) + legend("center","",cex=1.5,bty="n",horiz=TRUE,title=main,...) + if(legend) { + mid<-(s$xrange[2]-s$xrange[1])/2 + xl<-c(mid-0.5*mid,mid,mid+0.5*mid) + yl<-rep(s$xrange[2]*0.25,3) + lm<-range(abs(v)[abs(v)>0]) + lm<-c(lm[1],mean(lm),lm[2]) + lms<-range(abs(val)[abs(val)>0]) + lms<-c(lms[1],mean(lms),lms[2]) + if(missing(chars)||chars=="circles") { + symbols(xl,yl,circles=sqrt(lms),fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1]+1,xl[2]+lms[2]+1,xl[3]+lms[3]+1),yl,labels=signif(lm,2),pos=4,cex=1) + symbols(xl,yl*0.5,circles=sqrt(lms),fg=ifelse(missing(cols),1,cols),bg="white",inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl*0.5,labels=signif(-lm,2),pos=4,cex=1) + } + else if(chars=="squares") { + symbols(xl,yl,squares=1.5*sqrt(lms),fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl,labels=signif(lm,2),pos=4,cex=1) + symbols(xl,yl*0.5,squares=1.5*sqrt(lms),fg=ifelse(missing(cols),1,cols),bg="white",inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl*0.5,labels=signif(-lm,2),pos=4,cex=1) + } + } + #if(!is.null(main)) { + # mylayout<-layout(matrix(c(rep(1,nf),seq(2,((nf*nf)+1),1)),(nf+1),nf,byrow=TRUE)) + # plot.default(x$xy$x,x$xy$y,type="n",axes=FALSE) + # text(mean(range(x$xy$x)),mean(range(x$xy$y)),pos=3,cex=2,labels=main) + #ajouter une lŽgende ??? + #} + #else + # mylayout<-layout(matrix(seq(1,(nf*nf),1),nf,nf,byrow=TRUE)) + ifelse(missing(cols),cols<-1,cols<-cols[1]) + if(!missing(char0)||!missing(col0)) { + ifelse(missing(col0),col0<-cols,col0<-col0[1]) + if(missing(char0)) + char0<-3 + } + for(i in 1:nd) { + plot.swin(x$window,main=paste("r =",x$r[d[i]]),scale=FALSE,csize=0.66*csize,...) + nort<-(val[,i]==0) + neg<-(val[,i]<0) + if(!missing(char0)&&any(nort)) + points(x$xy$x[nort],x$xy$y[nort],pch=char0,col=col0,...) + if(any(!nort)) { + if(chars=="circles") { + if(any(!neg)) + symbols(x$xy$x[(!neg&!nort)],x$xy$y[(!neg&!nort)],circles=nf*sqrt(abs(val[(!neg&!nort),i])), + fg=cols,bg=cols,inches=FALSE,add=TRUE,...) + if(any(neg)) + symbols(x$xy$x[(neg&!nort)],x$xy$y[(neg&!nort)],circles=nf*sqrt(abs(val[(neg&!nort),i])), + fg=cols,bg="white",inches=FALSE,add=TRUE,...) + } + else if(chars=="squares") { + if(any(!neg)) + symbols(x$xy$x[(!neg&!nort)],x$xy$y[(!neg&!nort)],squares=1.5*nf*sqrt(abs(val[(!neg&!nort),i])), + fg=cols,bg=cols,inches=FALSE,add=TRUE,...) + if(any(neg)) + symbols(x$xy$x[(neg&!nort)],x$xy$y[(neg&!nort)],squares=1.5*nf*sqrt(abs(val[(neg&!nort),i])), + fg=cols,bg="white",inches=FALSE,add=TRUE,...) + } + } + } + ## mŽthode en courbes de niveaux ? +} diff --git a/R/print.fads.R b/R/print.fads.R new file mode 100755 index 0000000000000000000000000000000000000000..59708fa107c97550e3e775d8d559ef9ae3c4703c --- /dev/null +++ b/R/print.fads.R @@ -0,0 +1,40 @@ +print.fads<-function(x,...) { + UseMethod("print.fads") +} + +print.fads.kfun<-function(x,...) { + cat("Univariate second-order neighbourhood functions:\n") + str(x) +} + +print.fads.k12fun<-function(x,...) { + cat("Bivariate second-order neighbourhood functions:\n") + str(x) +} + +print.fads.kpqfun<-function(x,...) { + cat("Multivariate second-order neighbourhood functions :\n") + cat("Interaction between each category p and each category q\n") + str(x) +} + +print.fads.kp.fun<-function(x,...) { + cat("Multivariate second-order neighbourhood functions:\n") + cat("Interaction between each category p and all the remaining categories.\n") + str(x) +} + +print.fads.kmfun<-function(x,...) { + cat("Mark correlation functions:\n") + str(x) +} + +print.fads.ksfun<-function(x,...) { + cat("Shimatani multivariate functions:\n") + str(x) +} + +print.fads.krfun<-function(x,...) { + cat("Rao multivariate functions:\n") + str(x) +} diff --git a/R/print.vads.R b/R/print.vads.R new file mode 100755 index 0000000000000000000000000000000000000000..b2587a3411ef140ca830a8c41bff579df1856b93 --- /dev/null +++ b/R/print.vads.R @@ -0,0 +1,72 @@ +print.vads<-function(x,...) { + UseMethod("print.vads") +} + +print.vads.dval<-function(x,...) { + cat("First-order local density values:\n") + str(x) + #cat("class: ",class(x),"\n") + #cat("call: ") + #print(x$call) + #cat("sampling window :",x$window$type,"\n") + #cat("\n") + #sumry <- array("", c(1, 4), list(1:1, c("vector", "length", "mode", "content"))) + #sumry[1, ] <- c("$r", length(x$r), mode(x$r), "distance (r)") + #class(sumry) <- "table" + #print(sumry) + #cat("\n") + #sumry <- array("", c(3, 4), list(1:3, c("matrix", "nrow", "ncol", "content"))) + #sumry[1, ] <- c("$grid", nrow(x$grid), ncol(x$grid), "(x,y) coordinates of the sampling points A") + #sumry[2, ] <- c("$count", nrow(x$count), ncol(x$count), "counting function NA(r)") + #sumry[3, ] <- c("$density", nrow(x$dens), ncol(x$dens), "local density function nA(r)") + #class(sumry) <- "table" + #print(sumry) +} + +print.vads.kval<-function(x,...) { + cat("Univariate second-order local neighbourhood values:\n") + str(x) + #cat("class: ",class(x),"\n") + #cat("call: ") + #print(x$call) + #cat("\n") + #sumry <- array("", c(1, 4), list(1:1, c("vector", "length", "mode", "content"))) + #sumry[1, ] <- c("$r", length(x$r), mode(x$r), "distance (r)") + #class(sumry) <- "table" + #print(sumry) + #cat("\n") + #sumry <- array("", c(5, 4), list(1:5, c("matrix", "nrow", "ncol", "content"))) + #sumry[1, ] <- c("$coord", nrow(x$coord), ncol(x$coord), "(x,y) coordinates of points i") + #sumry[2, ] <- c("$gi", nrow(x$gi), ncol(x$gi), "individual pair density values gi(r)") + #sumry[3, ] <- c("$ni", nrow(x$ni), ncol(x$ni), "individual local neighbour density values ni(r)") + #sumry[4, ] <- c("$ki", nrow(x$ki), ncol(x$ki), "individual Ripley's values Ki(r)") + #sumry[5, ] <- c("$li", nrow(x$li), ncol(x$li), "modified individual Ripley's values Li(r)") + #class(sumry) <- "table" + #print(sumry) +} + +print.vads.k12val<-function(x,...) { + #verifyclass(x,"k12ival") + cat("Bivariate second-order local neighbourhood values:\n") + str(x) + #cat("class: ",class(x),"\n") + #cat("call: ") + #print(x$call) + #cat("mark1: ",x$marks[1],"\n") + #cat("mark2: ",x$marks[2],"\n") + #cat("\n") + #sumry <- array("", c(1, 4), list(1:1, c("vector", "length", "mode", "content"))) + #sumry[1, ] <- c("$r", length(x$r), mode(x$r), "distance (r)") + #class(sumry) <- "table" + #print(sumry) + #cat("\n") + #sumry <- array("", c(5, 4), list(1:5, c("matrix", "nrow", "ncol", "content"))) + #sumry[1, ] <- c("$coord1", nrow(x$coord1), ncol(x$coord1), "(x,y) coordinates of points of mark 1") + #sumry[2, ] <- c("$g12i", nrow(x$g12i), ncol(x$g12i), "individual pair density values g12i(r)") + #sumry[3, ] <- c("$n12i", nrow(x$n12i), ncol(x$n12i), "individual local neighbour density values n12i(r)") + #sumry[4, ] <- c("$k12i", nrow(x$k12i), ncol(x$k12i), "individual intertype values K12i(r)") + #sumry[5, ] <- c("$l12i", nrow(x$l12i), ncol(x$l12i), "modified intrtype Ripley's values L12i(r)") + #class(sumry) <- "table" + #print(sumry) +} + diff --git a/R/spp.R b/R/spp.R new file mode 100755 index 0000000000000000000000000000000000000000..24f21483a031202326f7c43fd26caba365678704 --- /dev/null +++ b/R/spp.R @@ -0,0 +1,266 @@ +spp<-function (x,y=NULL,window,triangles,marks,int2fac=TRUE) { + if(is.list(x)) { + stopifnot(length(x)==2) + y<-x[[2]] + x<-x[[1]] + } + else + stopifnot(!is.null(y)) + stopifnot(is.numeric(x)) + stopifnot(is.numeric(y)) + stopifnot(length(x)==length(y)) + if(any(duplicated(cbind(x,y)))) + warning("duplicated (x,y) points") +#stopifnot(!duplicated(cbind(x,y))) + if(!inherits(window,"swin")) { + if(missing(triangles)) + w<-swin(window) + else + w<-swin(window,triangles) + } + else if("simple"%in%window$type&&!missing(triangles)) { + if("rectangle"%in%window$type) + w<-swin(c(window$xmin,window$ymin,window$xmax,window$ymax),triangles=triangles) + else if("circle"%in%window$type) + w<-swin(c(window$x0,window$y0,window$r0),triangles=triangles) + else + stop("invalid window type") + } + else + w<-window + stopifnot(any(ok<-inside.swin(x,y,w)!=FALSE)) + xout<-x[!ok] + yout<-y[!ok] + x<-x[ok] + y<-y[ok] + n<-length(x) + nout<-length(xout) + spp<-list(type="univariate",window=w,n=n,x=x,y=y) + if(nout>0) spp<-c(spp,list(nout=nout,xout=xout,yout=yout)) + if(!missing(marks)) { + stopifnot(length(marks)==(n+nout)) + if(!is.factor(marks)) { + stopifnot(is.vector(marks)) + if(is.integer(marks)&&int2fac==TRUE) { + marks<-as.factor(marks) + warning("integer marks have been coerced to factor",call.=FALSE) + } + else if(is.character(marks)) + marks<-as.factor(marks) + else { + spp$type<-"marked" + spp$marks <- marks[ok] + if(nout>0) + spp$marksout<-marks[!ok] + } + } + if(is.factor(marks)) { + spp$type<-"multivariate" + names(marks)<-NULL + spp$marks <- factor(marks[ok],exclude=NULL) + if(nout>0) + spp$marksout<-factor(marks[!ok],exclude=NULL) + } + } + class(spp)<-"spp" + return(spp) +} + +print.spp<-function (x,...) { + cat("Spatial point pattern:\n") + str(x) +} + +summary.spp<-function (object,...) { + res<-list(type=object$type,window=summary(object$window)) + area<-res$window$area + if(object$type=="multivariate") + res$intensity<-summary(object$marks)/area + else + res$intensity<-object$n/area + if(object$type=="marked") + res$marks<-summary(object$marks) + class(res)<-"summary.spp" + return(res) +} + +print.summary.spp<-function (x,...) { + cat(paste("Spatial point pattern type:",x$type[1],"\n")) + print(x$window) + if(x$type=="multivariate") { + cat("intensity:") + print(array(x$intensity,dim=c(length(x$intensity),1),dimnames=list(paste(" .",names(x$intensity)),""))) + } + else + cat(paste("intensity:",signif(x$intensity),"\n")) + if(x$type=="marked") { + cat("marks:\n") + print(x$marks) + } +} + +plot.spp<-function (x,main,out=FALSE,use.marks=TRUE,cols,chars,cols.out,chars.out,maxsize,scale=TRUE,add=FALSE,legend=TRUE,csize=1,...) { + stopifnot(x$n>0) + if (missing(main)) + main <- deparse(substitute(x)) + #def.par <- par(no.readonly = TRUE) + #on.exit(par(def.par)) + #if(options()$device=="windows") + # csize<-0.75*csize + par(cex=csize) + #print(par("cex")) + if (!add) { + if(out) { + s<-summary(x$window) + e<-max(c(diff(c(min(x$xout),s$xrange[1])),diff(c(s$xrange[2],max(x$xout))), + diff(c(min(x$yout),s$yrange[1])),diff(c(s$yrange[2],max(x$yout))))) + plot.swin(x$window,main,e,scale,csize=csize,...) + } + else if(x$type!="univariate"&&legend==TRUE) { + s<-summary(x$window) + e<-0.2*(s$yrange[2]-s$yrange[1]) + plot.swin(x$window,main,e,scale,csize=csize,...) + } + else + plot.swin(x$window,main,scale=scale,csize=csize,...) + } + if(x$type=="univariate"||!use.marks) { + if(!missing(cols)) + stopifnot(length(cols)==1) + if(!missing(chars)) + stopifnot(length(chars)==1) + points(x$x,x$y,pch=ifelse(missing(chars),1,chars),col=ifelse(missing(cols),"black",cols),cex=ifelse(missing(maxsize),1,maxsize),...) + if(out) { + if(!missing(cols.out)) + stopifnot(length(cols.out)==1) + if(!missing(chars.out)) + stopifnot(length(chars.out)==1) + points(x$xout,x$yout,pch=ifelse(missing(chars.out),2,chars.out),col=ifelse(missing(cols.out),"red",cols.out), + cex=ifelse(missing(maxsize),1,maxsize),...) + } + } + else if(x$type=="multivariate") { + if(!missing(cols)) + stopifnot(length(cols)==nlevels(x$marks)) + if(!missing(chars)) + stopifnot(length(chars)==nlevels(x$marks)) + for(i in 1:nlevels(x$marks)) { + rel<-(x$marks==levels(x$marks)[i]) + points(x$x[rel],x$y[rel],pch=ifelse(missing(chars),i,chars[i]),col=ifelse(missing(cols),i,cols[i]), + cex=ifelse(missing(maxsize),1,maxsize),...) + } + if(out) { + if(!missing(cols.out)) + stopifnot(length(cols.out)==nlevels(x$marksout)) + if(!missing(chars.out)) + stopifnot(length(chars.out)==nlevels(x$marksout)) + for(i in 1:nlevels(x$marksout)) { + rel<-(x$marksout==levels(x$marksout)[i]) + points(x$xout[rel],x$yout[rel],pch=ifelse(missing(chars.out),i,chars.out[i]), + col=ifelse(missing(cols.out),i,cols.out[i]),cex=ifelse(missing(maxsize),1,maxsize),...) + } + } + if(legend) { + xl<-c(s$xrange[1],s$xrange[2]) + yl<-c(s$yrange[2]*1.15,s$yrange[2]) + #xl<-c(p$window$xmin,p$window$xmax) + #yl<-c(p$window$ymax*1.1,p$window$ymax) + legend(x=xl,y=yl,levels(x$marks),cex=1,bty="n",pch=if(missing(chars)) c(1:nlevels(x$marks)) + else chars,col=if(missing(cols)) c(1:nlevels(x$marks)) else cols,horiz=TRUE,xjust=0.5,...) + } + } + else if(x$type=="marked") { + if(!missing(cols)) + stopifnot(length(cols)==1) + if(!missing(chars)) + stopifnot(length(chars)==1) + if(out) { + #ms<-adjust.marks.size(c(x$marks,x$marksout),x$window,if(!missing(maxsize)) maxsize) + ms<-adjust.marks.size(c(x$marks,x$marksout),x$window) + if(!missing(maxsize)) + ms<-ms*maxsize + msout<-ms[(x$n+1):(x$n+x$nout)] + ms<-ms[1:x$n] + } + else { + #ms<-adjust.marks.size(x$marks,x$window,if(!missing(maxsize)) maxsize) + ms<-adjust.marks.size(x$marks,x$window) + if(!missing(maxsize)) + ms<-ms*maxsize + } + neg<-(x$marks<0) + if(missing(chars)||chars=="circles") { + if(any(neg)) + symbols(x$x[neg],x$y[neg],circles=-ms[neg]/2,fg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + if(any(!neg)) + symbols(x$x[!neg],x$y[!neg],circles=ms[!neg]/2,fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + } + else if(chars=="squares") { + if(any(neg)) + symbols(x$x[neg],x$y[neg],squares=-ms[neg],fg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + if(any(!neg)) + symbols(x$x[!neg],x$y[!neg],squares=ms[!neg],fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + } + else + stopifnot(chars%in%c("circles","squares")) + if(out) { + neg<-(x$marksout<0) + if(missing(chars.out)||chars.out=="circles") { + if(any(neg)) + symbols(x$xout[neg],x$yout[neg],circles=-msout[neg]/2,fg=ifelse(missing(cols.out),2,cols.out),inches=FALSE,add=TRUE,...) + if(any(!neg)) + symbols(x$xout[!neg],x$yout[!neg],circles=msout[!neg]/2,fg=ifelse(missing(cols.out),2,cols.out), + bg=ifelse(missing(cols.out),2,cols.out),inches=FALSE,add=TRUE,...) + + } + else if(chars.out=="squares") { + if(any(neg)) + symbols(x$xout[neg],x$yout[neg],squares=-msout[neg],fg=ifelse(missing(cols.out),2,cols.out),inches=FALSE,add=TRUE,...) + if(any(!neg)) + symbols(x$xout[!neg],x$yout[!neg],squares=msout[!neg],fg=ifelse(missing(cols.out),2,cols.out), + bg=ifelse(missing(cols.out),2,cols.out),inches=FALSE,add=TRUE,...) + + } + else + stopifnot(chars.out%in%c("circles","squares")) + } + if(legend) { + mid<-(s$xrange[2]-s$xrange[1])/2 + xl<-c(mid-0.5*mid,mid,mid+0.5*mid) + yl<-rep((s$yrange[2]*1.15),3) + lm<-range(abs(x$marks)) + lm<-c(lm[1],mean(lm),lm[2]) + lms<-range(abs(ms)) + lms<-c(lms[1],mean(lms),lms[2]) + if(missing(chars)||chars=="circles") { + symbols(xl,yl,circles=lms/2,fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1]+1,xl[2]+lms[2]+1,xl[3]+lms[3]+1),yl,labels=signif(lm,2),pos=4,cex=1) + if(any(neg)) { + symbols(xl,yl*0.93,circles=lms/2,fg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl*0.93,labels=signif(-lm,2),pos=4,cex=1) + } + } + else if(chars=="squares") { + symbols(xl,yl,squares=lms,fg=ifelse(missing(cols),1,cols),bg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1]+1,xl[2]+lms[2]+1,xl[3]+lms[3]+1),yl,labels=signif(lm,2),pos=4,cex=1) + if(any(neg)) { + symbols(xl,yl*0.93,squares=lms,fg=ifelse(missing(cols),1,cols),inches=FALSE,add=TRUE,...) + text(c(xl[1]+lms[1],xl[2]+lms[2],xl[3]+lms[3]),yl*0.93,labels=signif(-lm,2),pos=4,cex=1) + } + } + } + + } + else + stop("invalid point pattern type") +} + +ppp2spp<-function(p) { + stopifnot(inherits(p,"ppp")) + sw<-owin2swin(p$window) + if(is.null(p$marks)) + sp<-spp(p$x,p$y,sw) + else + sp<-spp(p$x,p$y,window=sw,marks=p$marks) + return(sp) +} diff --git a/R/summary.vads.R b/R/summary.vads.R new file mode 100755 index 0000000000000000000000000000000000000000..e617af1513c21cb63497eb61ce157d70be825ca2 --- /dev/null +++ b/R/summary.vads.R @@ -0,0 +1,53 @@ +summary.vads<-function(object,...) { + UseMethod("summary.vads") +} + +summary.vads.dval<-function (object,...) { + res<-list(spp=summary(eval(object$call$p))) + res$gsize<-c(diff(res$spp$window$xrange)/object$call$nx,diff(res$spp$window$yrange)/object$call$ny) + res$ldens<-data.frame(apply(object$dval,2,summary)) + names(res$ldens)<-as.character(object$r) + class(res)<-"summary.dval" + return(res) +} + +print.summary.dval<-function(x,...) { + cat(paste("Multiscale first-order local density:\n")) + print(x$spp) + cat(paste("grid size:",x$gsize[1],"X",x$gsize[2],"\n")) + cat("local density:\n") + print(t(x$ldens)) +} + +summary.vads.kval<-function (object,...) { + res<-list(spp=summary(eval(object$call$p))) + res$lneig<-data.frame(apply(object$nval,2,summary)) + names(res$lneig)<-as.character(object$r) + class(res)<-"summary.kval" + return(res) +} + +print.summary.kval<-function(x,...) { + cat(paste("Multiscale second-order local neighbour density:\n")) + print(x$spp) + cat("local neighbour density:\n") + print(t(x$lneig)) +} + +summary.vads.k12val<-function (object,...) { + res<-list(spp=summary(eval(object$call$p))) + res$marks<-object$marks + res$lneig<-data.frame(apply(object$n12val,2,summary)) + names(res$lneig)<-as.character(object$r) + class(res)<-"summary.k12val" + return(res) +} + +print.summary.k12val<-function(x,...) { + cat(paste("Multiscale bivariate second-order local neighbour density:\n")) + print(x$spp) + cat("mark 1:",x$marks[1],"\n") + cat("mark 2:",x$marks[2],"\n") + cat("bivariate local neighbour density:\n") + print(t(x$lneig)) +} diff --git a/R/swin.R b/R/swin.R new file mode 100755 index 0000000000000000000000000000000000000000..fc17c57bdb66804349df42c93615546b71d78526 --- /dev/null +++ b/R/swin.R @@ -0,0 +1,231 @@ +# rectangle: c(xmin,ymin,xmax,ymax) +# circle: c(x0,y0,r0) +# triangles: mat(x1,y1,x2,y2,x3,y3) +swin<-function(window,triangles) { + if(inherits(window,"swin")) { + stopifnot("simple"%in%window$type) + if(missing(triangles)) + return(window) + else if("rectangle"%in%window$type) + window<-c(window$xmin,window$ymin,window$xmax,window$ymax) + else if("circle"%in%window$type) + window<-c(window$x0,window$y0,window$r0) + else + stop("invalid window type") + } + stopifnot(is.numeric(window)) + stopifnot(length(window)%in%c(3,4)) + if(!missing(triangles)) { + if(is.vector(triangles)) + triangles<-matrix(triangles,1,6) + else + triangles<-as.matrix(triangles) + stopifnot(is.numeric(triangles)) + stopifnot(dim(triangles)[2]==6) + dimnames(triangles)[[2]]<-c("ax","ay","bx","by","cx","cy") + if(dim(triangles)[1]>1) + stopifnot(!overlapping.polygons(convert(triangles))) + triangles<-data.frame(triangles) + } + if(length(window)==4) { + stopifnot((window[3]-window[1])>0) + stopifnot((window[4]-window[2])>0) + xmin<-window[1] + ymin<-window[2] + xmax<-window[3] + ymax<-window[4] + sw<-list(type=c("simple","rectangle"),xmin=xmin,ymin=ymin,xmax=xmax,ymax=ymax) + if(!missing(triangles)) { + sw$type=c("complex","rectangle") + stopifnot(unlist(lapply(convert(triangles),function(x) in.rectangle(x$x,x$y,xmin,ymin,xmax,ymax)))) + sw$triangles<-triangles + } + } + else if(length(window)==3) { + x0<-window[1] + y0<-window[2] + r0<-window[3] + sw<-list(type=c("simple","circle"),x0=x0,y0=y0,r0=r0) + if(!missing(triangles)) { + sw$type=c("complex","circle") + stopifnot(unlist(lapply(convert(triangles),function(x) in.circle(x$x,x$y,x0,y0,r0)))) + sw$triangles<-triangles + } + } + else + stop("invalid input parameters") + class(sw) <- "swin" + return(sw) +} + +print.swin<-function (x, ...) { + cat("Sampling window:\n") + str(x) +} + +area.swin<-function (w) { + stopifnot(inherits(w,"swin")) + if("rectangle"%in%w$type) + area<-(w$xmax-w$xmin)*(w$ymax-w$ymin) + else if("circle"%in%w$type) + area<-pi*w$r0^2 + else + stop("invalid window type") + if ("complex"%in%w$type) { + tri<-w$triangles + area.tri<-0 + for(i in 1:nrow(tri)) + area.tri<-area.tri+abs(area.poly(c(tri$ax[i],tri$bx[i],tri$cx[i]),c(tri$ay[i],tri$by[i],tri$cy[i]))) + area<-area-area.tri + } + return(area) +} + +summary.swin<-function (object, ...) { + res<-alist() + res$type<-object$type + if("rectangle"%in%object$type) { + res$xrange<-c(object$xmin,object$xmax) + res$yrange<-c(object$ymin,object$ymax) + } + else if("circle"%in%object$type) { + res$xrange<-c(object$x0-object$r0,object$x0+object$r0) + res$yrange<-c(object$y0-object$r0,object$y0+object$r0) + } + else + stop("invalid window type") + res$area<-area.swin(object) + if("complex"%in%object$type) { + res$nbtri<-nrow(object$triangles) + if("rectangle"%in%object$type) + res$area.init<-area.swin(swin(c(object$xmin,object$ymin,object$xmax,object$ymax))) + else if("circle"%in%object$type) + res$area.init<-area.swin(swin(c(object$x0,object$y0,object$r0))) + } + class(res) <- "summary.swin" + return(res) +} + +print.summary.swin<-function (x,...) { + cat(paste("Sampling window type:",x$type[1],x$type[2],"\n")) + cat(paste("xrange: [",signif(x$xrange[1]),",",signif(x$xrange[2]),"]\n")) + cat(paste("yrange: [",signif(x$yrange[1]),",",signif(x$yrange[2]),"]\n")) + if("simple"%in%x$type) + cat(paste("area:",signif(x$area),"\n")) + else if("complex"%in%x$type) { + cat(paste("initial",x$type[2],"area:",signif(x$area.init),"\n")) + cat(paste("number of triangles removed:",x$nbtri,"\n")) + cat(paste("actual complex window area:",signif(x$area),"\n")) + } + else + stop("invalid window type") +} + +plot.swin<-function (x,main,edge,scale=TRUE,add=FALSE,csize=1,...) { + if(missing(main)) + main<-deparse(substitute(x)) + if(missing(edge)) + edge<-0 + #if(options()$device=="windows"&&sys.nframe()<=2) + # csize<-0.75*csize + par(cex=csize) + if("rectangle"%in%x$type) { + rx<-c(x$xmin,x$xmax) + ry<-c(x$ymin,x$ymax) + if(edge>0) { + rx<-c(rx[1]-edge,rx[2]+edge) + ry<-c(ry[1]-edge,ry[2]+edge) + } + if(scale) + plot(rx,ry,asp=1,main=main,type="n",axes=TRUE,frame.plot=FALSE,xlab="",ylab="",...) + else + plot(rx,ry,asp=1,main=main,type="n",axes=FALSE,xlab="",ylab="",...) + polygon(c(x$xmin,x$xmin,x$xmax,x$xmax),c(x$ymin,x$ymax,x$ymax,x$ymin)) + } + else if("circle"%in%x$type) { + rx<-c(x$x0-x$r0,x$x0+x$r0) + ry<-c(x$y0-x$r0,x$y0+x$r0) + if(edge>0) { + rx<-c(rx[1]-edge,rx[2]+edge) + ry<-c(ry[1]-edge,ry[2]+edge) + } + if(scale) + plot(rx,ry,asp=1,main=main,type="n",axes=TRUE,frame.plot=FALSE,xlab="",ylab="",...) + else + plot(rx,ry,asp=1,main=main,type="n",axes=FALSE,xlab="",ylab="",...) + symbols(x$x0,x$y0,circles=x$r0,inches=FALSE,add=TRUE) + } + else + stop("invalid window type") + if("complex"%in%x$type) { + tri<-x$triangles + for(i in 1:length(tri$ax)) { + xi<-c(tri$ax[i],tri$bx[i],tri$cx[i]) + yi<-c(tri$ay[i],tri$by[i],tri$cy[i]) + polygon(xi,yi,col="grey",...) + text(mean(xi),mean(yi),labels=as.character(i),cex=1) + } + } +} + +inside.swin<-function(x,y,w,bdry=TRUE) { + stopifnot(inherits(w,"swin")) + stopifnot(length(x)==length(y)) + if("rectangle"%in%w$type) + inside<-in.rectangle(x,y,w$xmin,w$ymin,w$xmax,w$ymax,bdry) + else if("circle"%in%w$type) + inside<-in.circle(x,y,w$x0,w$y0,w$r0,bdry) + else + stop("invalid window type") + if("complex"%in%w$type) { + tri<-w$triangles + for(i in 1:nrow(tri)) + inside[in.triangle(x,y,tri$ax[i],tri$ay[i],tri$bx[i],tri$by[i],tri$cx[i],tri$cy[i])]<-FALSE + } + return(inside) +} + +owin2swin<-function(w) { + stopifnot(inherits(w,"owin")) + if(identical(w$type,c("rectangle"))) + sw<-swin(c(w$xrange[1],w$yrange[1],w$xrange[2],w$yrange[2])) + else if(identical(w$type,c("polygonal"))) { + if(length(w$bdry)==1) { #single polygon + stopifnot(w$bdry[[1]]$hole==FALSE) + wx<-border(w,0.1,outside=TRUE) + outer.poly<-data.frame(x=c(rep(wx$xrange[1],2),rep(wx$xrange[2],2)),y=c(wx$yrange,wx$yrange[2:1])) + tri<-triangulate(outer.poly,data.frame(w$bdry[[1]][1:2])) + sw<-swin(c(wx$xrange[1],wx$yrange[1],wx$xrange[2],wx$yrange[2]),triangles=tri) + } + else { #polygon with holes + stopifnot(w$bdry[[1]]$hole==FALSE) + bb<-bounding.box.xy(w$bdry[[1]][1:2]) + if((bb$xrange==w$xrange)&&(bb$yrange==w$yrange)&&(area.owin(bb)==w$bdry[[1]]$area)) { #first poly is rectangular window frame + outer.poly<-data.frame(x=c(rep(w$xrange[1],2),rep(w$xrange[2],2)),y=c(w$yrange,w$yrange[2:1])) + for(i in 2:length(w$bdry)) { + stopifnot(w$bdry[[i]]$hole==TRUE) + if(i==2) + tri<-triangulate(w$bdry[[i]][1:2]) + else + tri<-rbind(tri,triangulate(w$bdry[[i]][1:2])) + } + sw<-swin(c(w$xrange[1],w$yrange[1],w$xrange[2],w$yrange[2]),triangles=tri) + } + else { #first poly is a polygonal frame + wx<-border(w,0.1,outside=TRUE) + outer.poly<-data.frame(x=c(rep(wx$xrange[1],2),rep(wx$xrange[2],2)),y=c(wx$yrange,wx$yrange[2:1])) + tri<-triangulate(outer.poly,w$bdry[[1]][1:2]) + for(i in 2:length(w$bdry)) { + stopifnot(w$bdry[[i]]$hole==TRUE) + tri<-rbind(tri,triangulate(w$bdry[[i]][1:2])) + } + sw<-swin(c(wx$xrange[1],wx$yrange[1],wx$xrange[2],wx$yrange[2]),triangles=tri) + } + } + } + else + stop("non convertible 'owin' object") + return(sw) +} + + diff --git a/R/triangulate.R b/R/triangulate.R new file mode 100755 index 0000000000000000000000000000000000000000..fb425769ae223eebcd3eef285c420d78721a5459 --- /dev/null +++ b/R/triangulate.R @@ -0,0 +1,42 @@ +triangulate<-function(outer.poly,holes) { + if(is.vector(outer.poly)&&is.numeric(outer.poly)&&(length(outer.poly)==4)) { + stopifnot((outer.poly[3]-outer.poly[1])>0) + stopifnot((outer.poly[4]-outer.poly[2])>0) + outer.poly<-list(x=c(outer.poly[1],outer.poly[1],outer.poly[3],outer.poly[3]), + y=c(outer.poly[2],outer.poly[4],outer.poly[4],outer.poly[2])) + } + if(!missing(holes)) { + if(is.list(holes[[1]])) { + if(all(unlist(lapply(holes,is.poly)))) + stopifnot(!overlapping.polygons(holes)) + } + else if(is.poly(holes)) + holes<-list(holes) + for(i in 1:length(holes)) + stopifnot(in.poly(holes[[i]]$x,holes[[i]]$y,outer.poly)) + nbpoly<-length(holes)+1 + nbpts<-length(outer.poly$x) + vertX<-outer.poly$x + vertY<-outer.poly$y + for(i in 2:nbpoly) { + nbpts[i]<-length(holes[[i-1]]$x) + vertX<-c(vertX,holes[[i-1]]$x) + vertY<-c(vertY,holes[[i-1]]$y) + } + nbptot<-sum(nbpts) + nbtri<-(nbptot-2)+2*(nbpoly-1) + } + else { + nbpoly<-1 + nbpts<-nbptot<-length(outer.poly$x) + vertX<-outer.poly$x + vertY<-outer.poly$y + nbtri<-(nbpts-2) + } + tri<-.C("triangulate", + as.integer(nbpoly),as.integer(nbpts),as.integer(nbptot),as.double(vertX),as.double(vertY),as.integer(nbtri), + X1=double(nbtri),Y1=double(nbtri),X2=double(nbtri),Y2=double(nbtri),X3=double(nbtri),Y3=double(nbtri), + PACKAGE="ads") + return(data.frame(ax=tri$X1,ay=tri$Y1,bx=tri$X2,by=tri$Y2,cx=tri$X3,cy=tri$Y3)) +} + diff --git a/R/util.R b/R/util.R new file mode 100755 index 0000000000000000000000000000000000000000..62905788974ec6bbe084dcca611968827f709df2 --- /dev/null +++ b/R/util.R @@ -0,0 +1,337 @@ +overlapping.polygons<-function(listpoly) { + stopifnot(unlist(lapply(listpoly,is.poly))) + nbpoly<-length(listpoly) + res<-rep(FALSE,(nbpoly-1)) + for(i in 1:(nbpoly-1)) { + for(j in (i+1):nbpoly) { + if(abs(overlap.poly(listpoly[[i]],listpoly[[j]]))>.Machine$double.eps^0.5) + res[i]<-TRUE + } + } + return(res) +} + +#from area.xypolygon{spatstat} +#return area>0 when (xp,yp) vertices are ranked anticlockwise +#or area<0 when (xp,yp) vertices are ranked clockwise +area.poly<-function(xp,yp) { + nedges <- length(xp) + yp <- yp - min(yp) + nxt <- c(2:nedges, 1) + dx <- xp[nxt] - xp + ym <- (yp + yp[nxt])/2 + -sum(dx * ym) +} + +in.circle<-function(x,y,x0,y0,r0,bdry=TRUE) { + stopifnot(length(x)==length(y)) + l<-length(x) + inside<-vector(mode="logical",length=l) + for(i in 1:l) { + if(bdry) { + if(((x[i]-x0)^2+(y[i]-y0)^2)<=(r0^2)) + inside[i]<-TRUE + } + else { + if(((x[i]-x0)^2+(y[i]-y0)^2)<(r0^2)) + inside[i]<-TRUE + } + } + return(inside) +} + +in.rectangle<-function(x,y,xmin,ymin,xmax,ymax,bdry=TRUE) { + stopifnot(length(x)==length(y)) + stopifnot((xmax-xmin)>0) + stopifnot((ymax-ymin)>0) + rect<-list(x=c(xmin,xmax,xmax,xmin),y=c(ymin,ymin,ymax,ymax)) + return(in.poly(x,y,rect,bdry)) +} + +in.triangle<-function(x,y,ax,ay,bx,by,cx,cy,bdry=TRUE) { + stopifnot(length(x)==length(y)) + tri<-list(x=c(ax,bx,cx),y=c(ay,by,cy)) + return(in.poly(x,y,tri,bdry)) +} + +#modified from plot.ppp{spatstat} +adjust.marks.size<-function(marks,window,maxsize=NULL) { + if(is.null(maxsize)) { + if("rectangle"%in%window$type) + diam<-sqrt((window$xmin-window$xmax)^2+(window$ymin-window$ymax)^2) + else if("circle"%in%window$type) + diam<-2*window$r0 + maxsize<-min(1.4/sqrt(pi*length(marks)/area.swin(window)),diam*0.07) + } + mr<-range(c(0,marks)) + maxabs<-max(abs(mr)) + if(diff(mr)<4*.Machine$double.eps||maxabs<4*.Machine$double.eps) { + ms<-rep(0.5*maxsize,length(marks)) + mp.value<-mr[1] + mp.plotted<-0.5*maxsize + } + else { + scal<-maxsize/maxabs + ms<-marks*scal + mp.value<-pretty(mr) + mp.plotted<-mp.value*scal + } + return(ms) +} + +#modified from verify.xypolygon{spatstat} +is.poly<-function (p) { + stopifnot(is.list(p)) + stopifnot(length(p)==2,length(names(p))==2) + stopifnot(identical(sort(names(p)),c("x","y"))) + stopifnot(!is.null(p$x),!is.null(p$y)) + stopifnot(is.numeric(p$x),is.numeric(p$y)) + stopifnot(length(p$x)==length(p$y)) + return(TRUE) +} + +testInteger<-function(i) { + if(as.integer(i)!=i) { + warning(paste(substitute(i),"=",i," has been converted to integer : ",as.integer(i),sep=""),call.=FALSE) + i<-as.integer(i) + } + return(i) +} + +testIC<-function(nbSimu,lev) { + if(lev*(nbSimu+1)<5) { + warning(paste( + "Low validity test: a*(n+1) < 5\n Significance level: a = ",lev, + "\n Number of simulations: n = ",nbSimu,"\n",sep="")) + } +} + +#from spatstat +overlap.poly <- function(P, Q) { + # compute area of overlap of two simple closed polygons + # verify.xypolygon(P) + #verify.xypolygon(Q) + + xp <- P$x + yp <- P$y + np <- length(xp) + nextp <- c(2:np, 1) + + xq <- Q$x + yq <- Q$y + nq <- length(xq) + nextq <- c(2:nq, 1) + + # adjust y coordinates so all are nonnegative + ylow <- min(c(yp,yq)) + yp <- yp - ylow + yq <- yq - ylow + + area <- 0 + for(i in 1:np) { + ii <- c(i, nextp[i]) + xpii <- xp[ii] + ypii <- yp[ii] + for(j in 1:nq) { + jj <- c(j, nextq[j]) + area <- area + + overlap.trapez(xpii, ypii, xq[jj], yq[jj]) + } + } + return(area) +} + +#from spatstat +overlap.trapez <- function(xa, ya, xb, yb, verb=FALSE) { + # compute area of overlap of two trapezia + # which have same baseline y = 0 + # + # first trapezium has vertices + # (xa[1], 0), (xa[1], ya[1]), (xa[2], ya[2]), (xa[2], 0). + # Similarly for second trapezium + + # Test for vertical edges + dxa <- diff(xa) + dxb <- diff(xb) + if(dxa == 0 || dxb == 0) + return(0) + + # Order x coordinates, x0 < x1 + if(dxa > 0) { + signa <- 1 + lefta <- 1 + righta <- 2 + if(verb) cat("A is positive\n") + } else { + signa <- -1 + lefta <- 2 + righta <- 1 + if(verb) cat("A is negative\n") + } + if(dxb > 0) { + signb <- 1 + leftb <- 1 + rightb <- 2 + if(verb) cat("B is positive\n") + } else { + signb <- -1 + leftb <- 2 + rightb <- 1 + if(verb) cat("B is negative\n") + } + signfactor <- signa * signb # actually (-signa) * (-signb) + if(verb) cat(paste("sign factor =", signfactor, "\n")) + + # Intersect x ranges + x0 <- max(xa[lefta], xb[leftb]) + x1 <- min(xa[righta], xb[rightb]) + if(x0 >= x1) + return(0) + if(verb) { + cat(paste("Intersection of x ranges: [", x0, ",", x1, "]\n")) + abline(v=x0, lty=3) + abline(v=x1, lty=3) + } + + # Compute associated y coordinates + slopea <- diff(ya)/diff(xa) + y0a <- ya[lefta] + slopea * (x0-xa[lefta]) + y1a <- ya[lefta] + slopea * (x1-xa[lefta]) + slopeb <- diff(yb)/diff(xb) + y0b <- yb[leftb] + slopeb * (x0-xb[leftb]) + y1b <- yb[leftb] + slopeb * (x1-xb[leftb]) + + # Determine whether upper edges intersect + # if not, intersection is a single trapezium + # if so, intersection is a union of two trapezia + + yd0 <- y0b - y0a + yd1 <- y1b - y1a + if(yd0 * yd1 >= 0) { + # edges do not intersect + areaT <- (x1 - x0) * (min(y1a,y1b) + min(y0a,y0b))/2 + if(verb) cat(paste("Edges do not intersect\n")) + } else { + # edges do intersect + # find intersection + xint <- x0 + (x1-x0) * abs(yd0/(yd1 - yd0)) + yint <- y0a + slopea * (xint - x0) + if(verb) { + cat(paste("Edges intersect at (", xint, ",", yint, ")\n")) + points(xint, yint, cex=2, pch="O") + } + # evaluate left trapezium + left <- (xint - x0) * (min(y0a, y0b) + yint)/2 + # evaluate right trapezium + right <- (x1 - xint) * (min(y1a, y1b) + yint)/2 + areaT <- left + right + if(verb) + cat(paste("Left area = ", left, ", right=", right, "\n")) + } + + # return area of intersection multiplied by signs + return(signfactor * areaT) +} + +#TRUE: les points sur la bordure sont = inside +in.poly<-function(x,y,poly,bdry=TRUE) { + stopifnot(is.poly(poly)) + xp <- poly$x + yp <- poly$y + npts <- length(x) + nedges <- length(xp) # sic + + score <- rep(0, npts) + on.boundary <- rep(FALSE, npts) + temp <- .Fortran( + "inpoly", + x=as.double(x), + y=as.double(y), + xp=as.double(xp), + yp=as.double(yp), + npts=as.integer(npts), + nedges=as.integer(nedges), + score=as.double(score), + onbndry=as.logical(on.boundary), + PACKAGE="ads" + ) + score <- temp$score + on.boundary <- temp$onbndry + score[on.boundary] <- 1 + res<-rep(FALSE,npts) + res[score==(-1)]<-TRUE + if(bdry) + res[score==1]<-TRUE + return(res) +} + +#################### +convert<-function(x) { +r<-alist() +x<-as.matrix(x) +for(i in 1:dim(x)[1]) + r[[i]]<-data.frame(x=c(x[i,1],x[i,5],x[i,3]),y=c(x[i,2],x[i,6],x[i,4])) +return(r) +} + +convert2<-function(x){ # liste de liste vers df 6 var +x<-unlist(x) +mat<-matrix(x,ncol=6,byrow=TRUE,dimnames=list(NULL,c("ax","bx","cx","ay","by","cy"))) +#mat<-cbind(tmp$ax,tmp$ay,tmp$bx,tmp$by,tmp$cx,tmp$cy) +r<-data.frame(ax=mat[,1],ay=mat[,4],bx=mat[,2],by=mat[,5],cx=mat[,3],cy=mat[,6]) +return(r) +} + + +read.tri<-function(X) { + res<-NULL + tabtri<-read.table(X) + + n<-length(tabtri[,1]) + + for(i in 1:n) { + tri<-list(x=c(tabtri[,1][i],tabtri[,3][i],tabtri[,5][i]), + y=c(tabtri[,2][i],tabtri[,4][i],tabtri[,6][i])) + + #if(area.xypolygon(tri)>0){ + if(area.poly(tri$x,tri$y)>0){ + tri<-list(x=c(tabtri[,5][i],tabtri[,3][i],tabtri[,1][i]), + y=c(tabtri[,6][i],tabtri[,4][i],tabtri[,2][i])) + } + + res<-c(res,list(tri)) + } + if(length(res)==1) { + res<-unlist(res,recursive=FALSE) + } + return(res) +} + +transpose<-function(x,y) { + + nbTri<-length(x)/3 + + res<-.C("transpose",x=as.double(x),y=as.double(y),nbTri=as.integer(nbTri), + x1=double(nbTri),y1=double(nbTri),x2=double(nbTri),y2=double(nbTri), + x3=double(nbTri),y3=double(nbTri),PACKAGE="ads") + + list(x1=res$x1,y1=res$y1,x2=res$x2,y2=res$y2,x3=res$x3,y3=res$y3) +} +############## +#subsetting dist objects +#sub is a logical vector of True/False +subsetdist<-function(dis,sub) { + mat<-as.matrix(dis) + k<-dimnames(mat)[[1]]%in%sub + submat<-mat[k,k] + return(as.dist(submat)) +} + +#ordering dist objetcs on ind +sortmat<-function(dis,ind) { + mat<-as.matrix(dis)[,ind] + mat<-mat[ind,] + return(as.dist(mat)) +} + + diff --git a/R/vads.R b/R/vads.R new file mode 100755 index 0000000000000000000000000000000000000000..a26c740219b7fec733c240606ad1d3a2019d9eb6 --- /dev/null +++ b/R/vads.R @@ -0,0 +1,305 @@ +dval<-function(p,upto,by,nx,ny) { +#si multivariŽ, choix du type de points ??? + stopifnot(inherits(p,"spp")) + stopifnot(is.numeric(upto)) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + stopifnot(is.numeric(nx)) + stopifnot(nx>=1) + nx<-testInteger(nx) + stopifnot(is.numeric(ny)) + stopifnot(ny>=1) + ny<-testInteger(ny) + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + xsample<-rep(xmin+(seq(1,nx)-0.5)*(xmax-xmin)/nx,each=ny) + ysample<-rep(ymin+(seq(1,ny)-0.5)*(ymax-ymin)/ny,nx) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + xsample<-rep(x0-r0+(seq(1,nx)-0.5)*2*r0/nx,each=ny) + ysample<-rep(y0-r0+(seq(1,ny)-0.5)*2*r0/ny,nx) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + + ok <- inside.swin(xsample, ysample, p$window) + xsample<-xsample[ok] + ysample<-ysample[ok] + stopifnot(length(xsample)==length(ysample)) + nbSample<-length(xsample) + + if(cas==1) { #rectangle + count<-.C("density_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + as.double(xsample),as.double(ysample),as.integer(nbSample), + count=double(tmax*nbSample), + PACKAGE="ads")$count + } + else if(cas==2) { #circle + count<-.C("density_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + as.double(xsample),as.double(ysample),as.integer(nbSample), + count=double(tmax*nbSample), + PACKAGE="ads")$count + } + else if(cas==3) { #complex within rectangle + count<-.C("density_tr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.double(xsample),as.double(ysample),as.integer(nbSample), + count=double(tmax*nbSample), + PACKAGE="ads")$count + } + else if(cas==4) { #complex within circle + count<-.C("density_tr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + as.double(xsample),as.double(ysample),as.integer(nbSample), + count=double(tmax*nbSample), + PACKAGE="ads")$count + } + ## rajouter un indice lorsque les disques ne sont pas indŽpendants + # formatting results + dens<-count/(pi*r^2) + #grid<-matrix(c(xsample,ysample),nrow=nbSample,ncol=2) + count<-matrix(count,nrow=nbSample,ncol=tmax,byrow=TRUE) + dens<-matrix(dens,nrow=nbSample,ncol=tmax,byrow=TRUE) + call<-match.call() + res<-list(call=call,window=p$window,r=r,xy=data.frame(x=xsample,y=ysample),cval=count,dval=dens) + class(res)<-c("vads","dval") + return(res) +} + +kval<-function(p,upto,by) { + # checking for input parameters + stopifnot(inherits(p,"spp")) + if(p$type!="univariate") + warning(paste(p$type,"point pattern has been considered to be univariate\n")) + stopifnot(is.numeric(upto)) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + intensity<-p$n/area.swin(p$window) + + #computing ripley local functions + if(cas==1) { #rectangle + res<-.C("ripleylocal_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + gi=double(p$n*tmax),ki=double(p$n*tmax), + PACKAGE="ads") + } + else if(cas==2) { #circle + res<-.C("ripleylocal_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + gi=double(p$n*tmax),ki=double(p$n*tmax), + PACKAGE="ads") + } + else if(cas==3) { #complex within rectangle + res<-.C("ripleylocal_tr_rect", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + gi=double(p$n*tmax),ki=double(p$n*tmax), + PACKAGE="ads") + } + else if(cas==4) { #complex within circle + res<-.C("ripleylocal_tr_disq", + as.integer(p$n),as.double(p$x),as.double(p$y), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + gi=double(p$n*tmax),ki=double(p$n*tmax), + PACKAGE="ads") + } + # formatting results + #coord<-matrix(c(X$x,X$y),nrow=nbPts,ncol=2) + #coord<-data.frame(x=p$x,y=p$y) + #r<-seq(dr,dr*tmax,dr) + #ds<-pi*r^2-pi*seq(0,dr*tmax-dr,dr)^2 + ds<-c(pi,diff(pi*r^2)) + gi<-matrix(res$gi/(intensity*ds),nrow=p$n,ncol=tmax,byrow=TRUE) + ni<-matrix(res$ki/(pi*r^2),nrow=p$n,ncol=tmax,byrow=TRUE) + ki<-matrix(res$ki/intensity,nrow=p$n,ncol=tmax,byrow=TRUE) + li<-matrix(sqrt(res$ki/(intensity*pi))-r,nrow=p$n,ncol=tmax,byrow=TRUE) + call<-match.call() + res<-list(call=call,window=p$window,r=r,xy=data.frame(x=p$x,y=p$y),gval=gi,kval=ki,nval=ni,lval=li) + class(res)<-c("vads","kval") + return(res) +} + +k12val<-function(p,upto,by,marks) { + # checking for input parameters + stopifnot(inherits(p,"spp")) + stopifnot(p$type=="multivariate") + stopifnot(is.numeric(upto)) + stopifnot(is.numeric(by)) + stopifnot(by>0) + r<-seq(by,upto,by) + tmax<-length(r) + if(missing(marks)) + marks<-c(1,2) + stopifnot(length(marks)==2) + stopifnot(marks[1]!=marks[2]) + mark1<-marks[1] + mark2<-marks[2] + if(is.numeric(mark1)) + mark1<-levels(p$marks)[testInteger(mark1)] + else if(!mark1%in%p$marks) stop(paste("mark \'",mark1,"\' doesn\'t exist",sep="")) + if(is.numeric(mark2)) + mark2<-levels(p$marks)[testInteger(mark2)] + else if(!mark2%in%p$marks) stop(paste("mark \'",mark2,"\' doesn\'t exist",sep="")) + # initializing variables + if("rectangle"%in%p$window$type) { + cas<-1 + xmin<-p$window$xmin + xmax<-p$window$xmax + ymin<-p$window$ymin + ymax<-p$window$ymax + stopifnot(upto<=(0.5*max((xmax-xmin),(ymax-ymin)))) + if ("complex"%in%p$window$type) { + cas<-3 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else if("circle"%in%p$window$type) { + cas<-2 + x0<-p$window$x0 + y0<-p$window$y0 + r0<-p$window$r0 + stopifnot(upto<=r0) + if ("complex"%in%p$window$type) { + cas<-4 + tri<-p$window$triangles + nbTri<-nrow(tri) + } + } + else + stop("invalid window type") + surface<-area.swin(p$window) + x1<-p$x[p$marks==mark1] + y1<-p$y[p$marks==mark1] + x2<-p$x[p$marks==mark2] + y2<-p$y[p$marks==mark2] + nbPts1<-length(x1) + nbPts2<-length(x2) + intensity2<-nbPts2/surface + #computing intertype local functions + if(cas==1) { #rectangle + res<-.C("intertypelocal_rect", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(tmax),as.double(by), + gi=double(nbPts1*tmax),ki=double(nbPts1*tmax), + PACKAGE="ads") + } + else if(cas==2) { #circle + res<-.C("intertypelocal_disq", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(tmax),as.double(by), + gi=double(nbPts1*tmax),ki=double(nbPts1*tmax), + PACKAGE="ads") + } + else if(cas==3) { #complex within rectangle + res<-.C("intertypelocal_tr_rect", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(xmin),as.double(xmax),as.double(ymin),as.double(ymax), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + gi=double(nbPts1*tmax),ki=double(nbPts1*tmax), + PACKAGE="ads") + } + else if(cas==4) { #complex within circle + res<-.C("intertypelocal_tr_disq", + as.integer(nbPts1),as.double(x1),as.double(y1), + as.integer(nbPts2),as.double(x2),as.double(y2), + as.double(x0),as.double(y0),as.double(r0), + as.integer(nbTri),as.double(tri$ax),as.double(tri$ay),as.double(tri$bx),as.double(tri$by),as.double(tri$cx),as.double(tri$cy), + as.integer(tmax),as.double(by), + gi=double(nbPts1*tmax),ki=double(nbPts1*tmax), + PACKAGE="ads") + } + # formatting results + #coord<-matrix(c(x1,y1),nrow=nbPts1,ncol=2) + #coord<-data.frame(x1=x1,y1=y1) + #r<-seq(dr,dr*tmax,dr) + #ds<-pi*r^2-pi*seq(0,dr*tmax-dr,dr)^2 + ds<-c(pi,diff(pi*r^2)) + gi<-matrix(res$gi/(intensity2*ds),nrow=nbPts1,ncol=tmax,byrow=TRUE) + ni<-matrix(res$ki/(pi*r^2),nrow=nbPts1,ncol=tmax,byrow=TRUE) + ki<-matrix(res$ki/intensity2,nrow=nbPts1,ncol=tmax,byrow=TRUE) + li<-matrix(sqrt(res$ki/(intensity2*pi))-r,nrow=nbPts1,ncol=tmax,byrow=TRUE) + call<-match.call() + res<-list(call=call,window=p$window,r=r,xy=data.frame(x=x1,y=y1),g12val=gi,k12val=ki,n12val=ni,l12val=li,marks=c(mark1,mark2)) + class(res)<-c("vads","k12val") + return(res) +} + diff --git a/data/Allogny.rda b/data/Allogny.rda new file mode 100755 index 0000000000000000000000000000000000000000..5cf20e0e533bfc7606683c09c495ec3427bbfd2a Binary files /dev/null and b/data/Allogny.rda differ diff --git a/data/BPoirier.rda b/data/BPoirier.rda new file mode 100644 index 0000000000000000000000000000000000000000..9ca6a5037c2c36d3cdba66abad474d0c020717e2 Binary files /dev/null and b/data/BPoirier.rda differ diff --git a/data/Couepia.rda b/data/Couepia.rda new file mode 100755 index 0000000000000000000000000000000000000000..401e81f0c356a4dc313b5c74abacf65e68a04ea0 Binary files /dev/null and b/data/Couepia.rda differ diff --git a/data/Paracou15.rda b/data/Paracou15.rda new file mode 100755 index 0000000000000000000000000000000000000000..b0783a29fe6933739891790764d2eeedf223b8b1 Binary files /dev/null and b/data/Paracou15.rda differ diff --git a/data/demopat.rda b/data/demopat.rda new file mode 100644 index 0000000000000000000000000000000000000000..b2cbffb52d840a62b9b020f7be0db6c0c9ee9787 Binary files /dev/null and b/data/demopat.rda differ diff --git a/inst/CITATION b/inst/CITATION new file mode 100644 index 0000000000000000000000000000000000000000..f6441168cf519c632a9873676456a7e5a43b5e7a --- /dev/null +++ b/inst/CITATION @@ -0,0 +1,20 @@ +citHeader("To cite ads in publications use:") + +citEntry(entry = "Article", + title = "{ads} Package for {R}: A Fast Unbiased Implementation of the $K$-function Family for Studying Spatial Point Patterns in Irregular-Shaped Sampling Windows", + author = personList(as.person("Rapha{\\\"e}l P{\\'e}lissier"), + as.person("Fran\\c{c}ois Goreaud")), + journal = "Journal of Statistical Software", + year = "2015", + volume = "63", + number = "6", + pages = "1--18", + url = "http://www.jstatsoft.org/v63/i06/", + + textVersion = + paste("Raphael Pelissier, Francois Goreaud (2015).", + "ads Package for R: A Fast Unbiased Implementation of the K-function Family for Studying Spatial Point Patterns in Irregular-Shaped Sampling Windows.", + "Journal of Statistical Software, 63(6), 1-18.", + "URL http://www.jstatsoft.org/v63/i06/.") +) + diff --git a/man/Allogny.Rd b/man/Allogny.Rd new file mode 100755 index 0000000000000000000000000000000000000000..c6a82c9d8df29ec114c8c80f189f1011ece6b59a --- /dev/null +++ b/man/Allogny.Rd @@ -0,0 +1,27 @@ +\name{Allogny} +\encoding{latin1} +\alias{Allogny} +\docType{data} +\title{Spatial pattern of oaks suffering from frost shake in Allogny, France.} +\description{ +Spatial pattern of sound and splited oaks (\emph{Quercus petraea}) suffering from frost shake in a 2.35-ha plot in Allogny, France. +} +\usage{data(Allogny)} +\format{ +A list with 4 components:\cr +\code{$rect } is a vector of coordinates \eqn{(xmin,ymin,xmax,ymax)} of the origin and the opposite corner of a 125 by 188 m square plot.\cr +\code{$trees } is a list of tree coordinates \eqn{(x,y)}.\cr +\code{$status } is a factor with 2 levels \eqn{("splited","sound")}.\cr +} +\source{ + Grandjean, G., Jabiol, B., Bruchiamacchie, M. and Roustan, F. 1990. \emph{Recherche de corrélations entre les paramètres édaphiques, et plus spécialement texture, hydromorphie et drainage interne, et la réponse individuelle des chenes sessiles et pédonculés à la gélivure.} Rapport de recherche ENITEF, Nogent sur Vernisson, France. +} +\references{ +Goreaud, F. & Pélissier, R. 2003. Avoiding misinterpretation of biotic interactions with the intertype \emph{K12}-function: population independence vs. random labelling hypotheses. \emph{Journal of Vegetation Science}, 14: 681-692. +} +\examples{ +data(Allogny) +allo.spp <- spp(Allogny$trees, mark=Allogny$status, window=Allogny$rect) +plot(allo.spp) +} +\keyword{datasets} diff --git a/man/BPoirier.Rd b/man/BPoirier.Rd new file mode 100755 index 0000000000000000000000000000000000000000..d5a66222eeaf84ea21863e3771587e2cbb930dfc --- /dev/null +++ b/man/BPoirier.Rd @@ -0,0 +1,34 @@ +\encoding{latin1} +\name{BPoirier} +\alias{BPoirier} +\docType{data} +\title{Tree spatial pattern in Beau Poirier plot, Haye forest, France} +\description{ +Spatial pattern of 162 beeches, 72 oaks and 3 hornbeams in a 1-ha 140 yr-old temperate forest plot in Haye, France. +} +\usage{data(BPoirier)} +\format{ +A list with 8 components:\cr +\code{$rect } is a vector of coordinates \eqn{(xmin,ymin,xmax,ymax)} of the origin and the opposite corner of a 110 by 90 m rectangular plot.\cr +\code{$tri1 } is a list of vertice coordinates \eqn{(ax,ay,bx,by,cx,cy)} of contiguous triangles covering the denser part of the plot.\cr +\code{$tri2 } is a list of vertice coordinates \eqn{(ax,ay,bx,by,cx,cy)} of contiguous triangles covering the sparser part of the plot.\cr +\code{$poly1 } is a list of vertice coordinates \eqn{(x,y)} of the polygon enclosing \code{BPoirier$tri1}.\cr +\code{$poly2 } is a list of two polygons vertice coordinates \eqn{(x,y)} enclosing \code{BPoirier$tri2}.\cr +\code{$trees } is a list of tree coordinates \eqn{(x,y)}.\cr +\code{$species } is a factor with 3 levels \eqn{("beech","oak","hornbeam")} corresponding to species names of the trees.\cr +\code{$dbh } is a vector of tree size (diameter at breast height in cm). +} +\source{ +Pardé, J. 1981. De 1882 à 1976/80 : les places d'expèrience de sylviculture du hetre en foret domainiale de Haye. \emph{Revue Forestière Française}, 33: 41-64. +} + +\references{ +Goreaud, F. 2000. \emph{Apports de l'analyse de la structure spatiale en foret tempérée à l'étude et la modélisation des peuplements complexes}. Thèse de doctorat, ENGREF, Nancy, France.\cr\cr +Pélissier, R. & Goreaud, F. 2001. A practical approach to the study of spatial structure in simple cases of heterogeneous vegetation. \emph{Journal of Vegetation Science}, 12: 99-108. +} +\examples{ +data(BPoirier) +BP.spp <- spp(BPoirier$trees, mark=BPoirier$species, window=BPoirier$rect) +plot(BP.spp) +} +\keyword{datasets} diff --git a/man/Couepia.Rd b/man/Couepia.Rd new file mode 100755 index 0000000000000000000000000000000000000000..16576221de4fa357876702a9cd52dae143ec065a --- /dev/null +++ b/man/Couepia.Rd @@ -0,0 +1,28 @@ +\encoding{latin1} +\name{Couepia} +\alias{Couepia} +\docType{data} +\title{Spatial pattern of Couepia caryophylloides in Paracou, a canopy tree species of French Guiana.} +\description{ +Spatial pattern of 34 mature individuals and 173 young individuals of the tree species \emph{Couepia caryophylloides} (Chrysobalanaceae) in a 25-ha forest plot in Paracou, French Guiana. +} +\usage{data(Couepia)} +\format{ +A list with 4 components:\cr +\code{$rect } is a vector of coordinates \eqn{(xmin,ymin,xmax,ymax)} of the origin and the opposite corner of a 500 by 500 m rectangular plot.\cr +\code{$tri } is a list of vertice coordinates \eqn{(ax,ay,bx,by,cx,cy)} of contiguous triangles covering swampy parts of the plot.\cr +\code{$trees } is a list of tree coordinates \eqn{(x,y)}.\cr +\code{$stage } is a factor with 2 levels \eqn{("mature","young")}.\cr +} +\source{ + Collinet, F. 1997. \emph{Essai de regroupement des principales espèces structurantes d'une foret dense humide d'après l'analyse de leur répartition spatiale (foret de Paracou - Guyane).} Thèse de doctorat, Université Claude Bernard, Lyon, France. +} +\references{ +Goreaud, F. & Pélissier, R. 2003. Avoiding misinterpretation of biotic interactions with the intertype \emph{K12}-function: population independence vs. random labelling hypotheses. \emph{Journal of Vegetation Science}, 14: 681-692. +} +\examples{ +data(Couepia) +coca.spp <- spp(Couepia$trees, mark=Couepia$stage, window=Couepia$rect, triangles=Couepia$tri) +plot(coca.spp) +} +\keyword{datasets} diff --git a/man/Paracou15.Rd b/man/Paracou15.Rd new file mode 100755 index 0000000000000000000000000000000000000000..e3aee182faa318aa70cf9653f3b41d1fd1c75152 --- /dev/null +++ b/man/Paracou15.Rd @@ -0,0 +1,29 @@ +\encoding{latin1} +\name{Paracou15} +\alias{Paracou15} +\docType{data} +\title{Tree spatial pattern in control plot 15, Paracou experimental station, French Guiana} +\description{ +Spatial pattern of 4128 trees of 332 diffrent species in a 250 m X 250 m control plot in Paracou experimental station, French Guiana. +} +\usage{data(Paracou15)} +\format{ +A list with 5 components:\cr +\code{$rect } is a vector of coordinates \eqn{(xmin,ymin,xmax,ymax)} of the origin and the opposite corner of a 250 by 250 m rectangular plot.\cr +\code{$trees } is a list of tree coordinates \eqn{(x,y)}.\cr +\code{$species } is a factor with 332 levels corresponding to species names of the trees.\cr +\code{$spdist } is an object of class \code{"dist"} giving between-species distances based on functional traits (see Paine et al. 2011).\cr +} +\source{ +Gourlet-Fleury, S., Ferry, B., Molino, J.-F., Petronelli, P. & Schmitt, L. 2004. \emph{Exeprimental plots: key features.} Pp. 3-60 In Gourlet-Fleury, S., Guehl, J.-M. & Laroussinie, O. (Eds.), Ecology and Managament of a Neotropical rainforest - Lessons drawn from Paracou, a long-term experimental research site in French Guiana. Elsevier SAS, France. +} + +\references{ +Paine, C. E. T., Baraloto, C., Chave, J. & Hérault, B. 2011. Functional traits of individual trees reveal ecological constraints on community assembly in tropical rain forests. \emph{Oikos}, 120: 720-727.\cr\cr +} +\examples{ +data(Paracou15) +P15.spp <- spp(Paracou15$trees, mark = Paracou15$species, window = Paracou15$rect) +plot(P15.spp, chars = rep("o", 332), cols = rainbow(332), legend = FALSE, maxsize = 0.5) +} +\keyword{dataset} diff --git a/man/area.swin.Rd b/man/area.swin.Rd new file mode 100755 index 0000000000000000000000000000000000000000..d6042f29d1c120723baaa95ee72fe0581c0c7921 --- /dev/null +++ b/man/area.swin.Rd @@ -0,0 +1,45 @@ +\encoding{latin1} +\name{area.swin} +\alias{area.swin} +\title{Area of a sampling window} +\description{ + Function \code{area.swin} computes the area of a sampling window. +} +\usage{ +area.swin(w) +} +\arguments{ + \item{w}{an object of class \code{"swin"} defining the sampling window.} +} +\details{ +For \code{"simple"} sampling windows, returns simply the area of the rectangle or circle delineating the study region.\cr +For \code{"complex"} sampling windows, returns the area of the initial rectangle or circle, minus the total area of the +triangles to remove (see \code{\link{swin}}). +} +\value{ +The area of the sampling window. +} +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\seealso{ + \code{\link{swin}}. +} +\examples{ + #rectangle of size [0,110] x [0,90] + wr<-swin(c(0,0,110,90)) + area.swin(wr) + + #circle with radius 50 centred on (55,45) + wc<-swin(c(55,45,50)) + area.swin(wc) + + # polygon (diamond shape) + t1 <- c(0,0,55,0,0,45) + t2 <- c(55,0,110,0,110,45) + t3 <- c(0,45,0,90,55,90) + t4 <- c(55,90,110,90,110,45) + wp <- swin(wr, rbind(t1,t2,t3,t4)) + area.swin(wp) +} +\keyword{spatial} diff --git a/man/demopat.Rd b/man/demopat.Rd new file mode 100755 index 0000000000000000000000000000000000000000..f6cb08165afce8743dcddeb4fc99b212f043931d --- /dev/null +++ b/man/demopat.Rd @@ -0,0 +1,22 @@ +\name{demopat} +\encoding{latin1} +\alias{demopat} +\docType{data} +\title{Artificial Data Point Pattern from \code{spatstat} package.} +\description{ +This is an artificial dataset, for use in testing and demonstrating compatibility between \code{spatstat} and \code{ads} objects. It is a multitype point pattern in an irregular polygonal window. + There are two types of points. The window contains a polygonal hole. +} +\usage{data(demopat)} +\format{ +An object of class "ppp" representing a \code{spatstat} point pattern. +} +\source{ + data(demopat) in \code{spatstat} +} +\examples{ + data(demopat) + demo.spp<-ppp2spp(demopat) + plot(demo.spp) +} +\keyword{datasets} diff --git a/man/dval.Rd b/man/dval.Rd new file mode 100755 index 0000000000000000000000000000000000000000..89e6050dfa3243492fd0537890867c41f8cf7a33 --- /dev/null +++ b/man/dval.Rd @@ -0,0 +1,72 @@ +\encoding{latin1} +\name{dval} +\alias{dval} +\alias{print.dval} +\alias{summary.dval} +\alias{print.summary.dval} +\title{Multiscale local density of a spatial point pattern} +\description{ + Computes local density estimates of a spatial point pattern, i.e. the number of points per unit area, + within sample circles of regularly increasing radii \eqn{r}, centred at the nodes of + a grid covering a simple (rectangular or circular) or complex sampling window (see Details). +} +\usage{ +dval(p, upto, by, nx, ny) +} +\arguments{ + \item{p }{a \code{"spp"} object defining a spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} + \item{nx,ny }{number of sample circles regularly spaced out in \eqn{x} and \eqn{y} directions.} + } +\details{ + The local density is estimated for a regular sequence of sample circles radii given by \code{seq(by,upto,by)} (see \code{\link{seq}}). + The sample circles are centred at the nodes of a regular grid with size \eqn{nx} by \eqn{ny}. Ripley's edge effect correction is applied when + the sample circles overlap boundary of the sampling window (see Ripley (1977) or Goreaud & Pélissier (1999) for an extension to circular and complex + sampling windows). Due to edge effect correction, \code{upto}, the maximum radius of the sample circles, is half the longer side for a rectangle sampling + window (i.e. \eqn{0.5*max((xmax-xmin),(ymax-ymin))}) and the radius \eqn{r0} for a circular sampling window (see \code{\link{swin}}). +} +\value{ + A list of class \code{c("vads","dval")} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{xy }{a data frame of \eqn{(nx*ny)} observations giving \eqn{(x,y)} coordinates of the centers of the sample circles (the grid nodes).} + \item{cval }{a matrix of size \eqn{(nx*ny,length(r))} giving the estimated number of points of the pattern per sample circle with radius \eqn{r}.} + \item{dval }{a matrix of size \eqn{(nx*ny,length(r))} giving the estimated number of points of the pattern per unit area per sample circle with radius \eqn{r}.} + } +\references{ + Goreaud, F. and Pélissier, R. 1999. On explicit formula of edge effect correction for Ripley's \emph{K}-function. \emph{Journal of Vegetation Science}, 10:433-438.\cr\cr + Pélissier, R. and Goreaud, F. 2001. A practical approach to the study of spatial structure in simple cases of heterogeneous vegetation. \emph{Journal of Vegetation Science}, 12:99-108.\cr\cr + Ripley, B.D. 1977. Modelling spatial patterns. \emph{Journal of the Royal Statistical Society B}, 39:172-212. +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing, summary and plotting methods for \code{"vads"} objects. +} + \section{Warning }{ + In its current version, function \code{dval} ignores the marks of multivariate and marked point patterns (they are all considered to be univariate patterns). +} +\seealso{ + \code{\link{plot.vads}}, + \code{\link{spp}}.} +\examples{ + data(BPoirier) + BP <- BPoirier + # spatial point pattern in a rectangle sampling window of size [0,110] x [0,90] + swr <- spp(BP$trees, win=BP$rect) + dswr <- dval(swr,25,1,11,9) + summary(dswr) + plot(dswr) + + # spatial point pattern in a circle with radius 50 centred on (55,45) + swc <- spp(BP$trees, win=c(55,45,45)) + dswc <- dval(swc,25,1,9,9) + summary(dswc) + plot(dswc) + + # spatial point pattern in a complex sampling window + swrt <- spp(BP$trees, win=BP$rect, tri=BP$tri1) + dswrt <- dval(swrt,25,1,11,9) + summary(dswrt) + plot(dswrt) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/inside.swin.Rd b/man/inside.swin.Rd new file mode 100755 index 0000000000000000000000000000000000000000..d4fed90b4f8ce43d6a92ab54ff77a03c606b316d --- /dev/null +++ b/man/inside.swin.Rd @@ -0,0 +1,42 @@ +\encoding{latin1} +\name{inside.swin} +\alias{inside.swin} +\title{Test wether points are inside a sampling window} +\description{ + Function \code{inside.swin} tests whether points lie inside or outside a given sampling window. +} +\usage{ +inside.swin(x, y, w, bdry=TRUE) +} +\arguments{ + \item{x}{a vector of \code{x} coordinates of points.} + \item{y}{a vector of \code{y} coordinates of points.} + \item{w}{an object of class \code{"swin"} (see \code{\link{swin}}) defining the sampling window.} + \item{bdry}{by default \code{bdry = TRUE}. If \code{FALSE}, points located + on the boundary of the sampling window are considered to be outside.} +} +\value{ + A logical vector whose \code{ith} entry is \code{TRUE} if the corresponding point \eqn{(x[i],y[i])} is inside w, \code{FALSE} otherwise. +} +\note{ + For \code{"complex"} sampling windows, points inside the triangles to remove or on their boundary, are considered outside. +} +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\seealso{ + \code{\link{swin}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + wr <- swin(BP$rect) + sum(inside.swin(BP$trees$x, BP$trees$y, wr)) + + wc <- swin(c(55,45,45)) + sum(inside.swin(BP$trees$x, BP$trees$y, wc)) + + wrt <- swin(BP$rect, triangles=BP$tri1) + sum(inside.swin(BP$trees$x, BP$trees$y,wrt)) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/internal.Rd b/man/internal.Rd new file mode 100755 index 0000000000000000000000000000000000000000..6920a3f2723939c9facc2a51474a824fc7781319 --- /dev/null +++ b/man/internal.Rd @@ -0,0 +1,67 @@ +\encoding{latin1} +\name{ads-internal} +\alias{adjust.marks.size} +\alias{area.poly} +\alias{convert} +\alias{convert2} +\alias{in.circle} +\alias{in.poly} +\alias{in.rectangle} +\alias{in.triangle} +\alias{is.poly} +\alias{overlap.poly} +\alias{overlap.trapez} +\alias{overlapping.polygons} +\alias{print.fads} +\alias{print.fads.k12fun} +\alias{print.fads.kfun} +\alias{print.fads.kp.fun} +\alias{print.fads.kpqfun} +\alias{print.fads.kmfun} +\alias{print.fads.ksfun} +\alias{print.fads.krfun} +\alias{print.vads} +\alias{print.vads.dval} +\alias{print.vads.k12val} +\alias{print.vads.kval} +\alias{read.tri} +\alias{sortmat} +\alias{summary.vads} +\alias{summary.vads.dval} +\alias{summary.vads.k12val} +\alias{summary.vads.kval} +\alias{testIC} +\alias{testInteger} +\alias{transpose} +\alias{subsetdist} +\title{Internal ads functions} +\description{ + Internal \code{ads} functions. +} +\usage{ +adjust.marks.size(marks,window,maxsize=NULL) +area.poly(xp, yp) +convert(x) +convert2(x) +in.circle(x, y, x0, y0, r0, bdry=TRUE) +in.poly(x, y, poly, bdry=TRUE) +in.rectangle(x, y, xmin, ymin, xmax, ymax, bdry=TRUE) +in.triangle(x, y, ax, ay, bx, by, cx, cy, bdry=TRUE) +is.poly(p) +overlap.poly(P, Q) +overlap.trapez(xa, ya, xb, yb, verb=FALSE) +overlapping.polygons(listpoly) +\method{print}{fads}(x,\dots) +\method{print}{vads}(x,\dots) +read.tri(X) +\method{summary}{vads}(object,\dots) +sortmat(dis,ind) +subsetdist(dis,sub) +testIC(nbSimu, lev) +testInteger(i) +transpose(x, y) +} +\details{ + These are usually not to be called by the user. +} +\keyword{internal} \ No newline at end of file diff --git a/man/k12fun.Rd b/man/k12fun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..9b903949cde222916c07cf5074e0842ae3987396 --- /dev/null +++ b/man/k12fun.Rd @@ -0,0 +1,126 @@ +\encoding{latin1} +\name{k12fun} +\alias{k12fun} +\title{Multiscale second-order neigbourhood analysis of a bivariate spatial point pattern} +\description{ + Computes estimates of the intertype \emph{K12}-function and associated neigbourhood functions from a bivariate spatial point pattern + in a simple (rectangular or circular) or complex sampling window. Computes optionally local confidence limits of the functions + under the null hypotheses of population independence or random labelling (see Details). +} +\usage{ +k12fun(p, upto, by, nsim=0, H0=c("pitor","pimim","rl"), prec=0.01, nsimax=3000, conv=50, + rep=10, alpha=0.01, marks) +} +\arguments{ + \item{p}{a \code{"spp"} object defining a multivariate spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto}{maximum radius of the sample circles (see Details).} + \item{by}{interval length between successive sample circles radii (see Details).} + \item{nsim}{number of Monte Carlo simulations to estimate local confidence limits of the selected null hypothesis (see Details). + By default \code{nsim=0}, so that no confidence limits are computed.} + \item{H0}{one of \code{c("pitor","pimim","rl")} to select either the null hypothesis of population independence using toroidal shift (\code{H0="pitor"}) or mimetic point process (\code{H0="pimim"}), or of random labelling (\code{H0="rl"}) (see Details). + By default, the null hypothesis is population independence using toroidal shift.} + \item{prec}{if \code{nsim>0} and \code{H0="pitor"} or \code{H0="pimim"}, precision of the random vector or point coordinates generated during simulations. By default \code{prec=0.01}.} + \item{nsimax}{if \code{nsim>0} and \code{H0="pimim"}, maximum number of simulations allowed (see \code{\link{mimetic}}. By default \code{nsimax=3000}.} + \item{conv}{if \code{nsim>0} and \code{H0="pimim"}, convergence criterion (see \code{\link{mimetic}}. By default \code{conv=50}.} + \item{rep}{if \code{nsim>0} and \code{H0="pimim"}, controls for convergence failure of the mimetic point process (see details). By default \code{rep=10} so that the function aborts after 10 consecutive failures in mimetic point process convergence.} + \item{alpha}{if \code{nsim>0}, significant level of the confidence limits. By default \eqn{\alpha=0.01}.} + \item{marks}{by default c(1,2), otherwise a vector of two numbers or character strings identifying the types (the \code{p$marks} levels) + of points of type 1 and 2, respectively.} +} +\details{ + Function \code{k12fun} computes the intertype \eqn{K12(r)} function of second-order neigbourhood analysis and the associated functions \eqn{g12(r)}, + \eqn{n12(r)} and \eqn{L12(r)}.\cr\cr + For a homogeneous isotropic bivariate point process of intensities \eqn{\lambda1} and \eqn{\lambda2}, + the second-order property could be characterized by a function \eqn{K12(r)} (Lotwick & Silverman 1982), so that the expected + number of neighbours of type 2 within a distance \eqn{r} of an arbitrary point of type 1 is: + \eqn{N12(r) = \lambda2*K12(r)}.\cr\cr + \eqn{K12(r)} is an intensity standardization of \eqn{N12(r)}: \eqn{K12(r) = N12(r)/\lambda2}.\cr\cr + \eqn{n12(r)} is an area standardization of of \eqn{N12(r)}: \eqn{n12(r) = N12(r)/(\pi*r^2)}, where \eqn{\pi*r^2} is the area of the disc of radius \eqn{r}.\cr\cr + \eqn{L12(r)} is a linearized version of \eqn{K12(r)}, which has an expectation of 0 under population independence: \eqn{L12(r) = \sqrt(K12(r)/\pi)-r}. \eqn{L12(r)} becomes positive when the two population show attraction and negative when they show repulsion. + Under the null hypothesis of random labelling, the expectation of \eqn{L12(r)} is \eqn{L(r)}. It becomes greater than \eqn{L(r)} when the types tend to be positively correlated and lower when they tend to be negatively correlated.\cr\cr + \eqn{g12(r)} is the derivative of \eqn{K12(r)} or bivariate pair density function, so that the expected + number of points of type 2 at a distance \eqn{r} of an arbitrary point of type 1 (i.e. within an annuli between two successive circles with radii \eqn{r} and \eqn{r-by}) is: + \eqn{O12(r) = \lambda2*g12(r)} (Wiegand & Moloney 2004).\cr\cr + + The program introduces an edge effect correction term according to the method proposed by Ripley (1977) + and extended to circular and complex sampling windows by Goreaud & Pélissier (1999).\cr\cr + + Theoretical values under the null hypothesis of either population independence or random labelling as well as + local Monte Carlo confidence limits and p-values of departure from the null hypothesis (Besag & Diggle 1977) are estimated at each distance \eqn{r}.\cr + + The population independence hypothesis assumes that the location of points of a given population is independent from the location + of points of the other. It is therefore tested conditionally to the intrinsic spatial pattern of each population. Two different procedures are available: + \code{H0="pitor"} just shifts the pattern of type 1 points around a torus following Lotwick & Silverman (1982); \code{H0="pimim"} uses a mimetic point process (Goreaud et al. 2004) + to mimic the pattern of type 1 points (see \code{\link{mimetic}}.\cr + The random labelling hypothesis \code{"rl"} assumes that the probability to bear a given mark is the same for all points of the pattern and + doesn't depends on neighbours. It is therefore tested conditionally to the whole spatial pattern, by randomizing the marks over the points' + locations kept unchanged (see Goreaud & Pélissier 2003 for further details). +} +\value{ + A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{g12 }{a data frame containing values of the bivariate pair density function \eqn{g12(r)}.} + \item{n12 }{a data frame containing values of the bivariate local neighbour density function \eqn{n12(r)}.} + \item{k12 }{a data frame containing values of the intertype function \eqn{K12(r)}.} + \item{l12 }{a data frame containing values of the modified intertype function \eqn{L12(r)}.\cr\cr} + \item{ }{Each component except \code{r} is a data frame with the following variables:\cr\cr} + \item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected under the selected null hypothesis.} + \item{sup }{(optional) if \code{nsim>0} a vector of the upper local confidence limits of the selected null hypothesis at a significant level \eqn{\alpha}.} + \item{inf }{(optional) if \code{nsim>0} a vector of the lower local confidence limits of the selected null hypothesis at a significant level \eqn{\alpha}.} + \item{pval }{(optional) if \code{nsim>0} a vector of local p-values of departure from the selected null hypothesis.} +} +\references{ + Besag J.E. & Diggle P.J. 1977. Simple Monte Carlo tests spatial patterns. \emph{Applied Statistics}, 26:327-333.\cr\cr + Goreaud F. & Pélissier R. 1999. On explicit formulas of edge effect correction for Ripley's K-function. \emph{Journal of Vegetation Science}, 10:433-438.\cr\cr + Goreaud, F. & Pélissier, R. 2003. Avoiding misinterpretation of biotic interactions with the intertype \emph{K12}-function: population independence vs. random labelling hypotheses. \emph{Journal of Vegetation Science}, 14: 681-692.\cr\cr + Lotwick, H.W. & Silverman, B.W. 1982. Methods for analysing spatial processes of several types of points. \emph{Journal of the Royal Statistical Society B}, 44:403-413.\cr\cr + Ripley B.D. 1977. Modelling spatial patterns. \emph{Journal of the Royal Statistical Society B}, 39:172-192.\cr\cr + Wiegand, T. & Moloney, K.A. 2004. Rings, circles, and null-models for point pattern analysis in ecology. \emph{Oikos}, 104:209-229. + Goreaud F., Loussier, B., Ngo Bieng, M.-A. & Allain R. 2004. Simulating realistic spatial structure for forest stands: a mimetic point process. In \emph{Proceedings of Interdisciplinary Spatial Statistics Workshop}, 2-3 December, 2004. Paris, France. +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"fads"} objects. +} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{k12val}}, + \code{\link{kfun}}, + \code{\link{kijfun}}, + \code{\link{ki.fun}}, + \code{\link{mimetic}}, + \code{\link{kmfun}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + # spatial point pattern in a rectangle sampling window of size [0,110] x [0,90] + swrm <- spp(BP$trees, win=BP$rect, marks=BP$species) + #testing population independence hypothesis + k12swrm.pi <- k12fun(swrm, 25, 1, 500, marks=c("beech","oak")) + plot(k12swrm.pi) + #testing random labelling hypothesis + k12swrm.rl <- k12fun(swrm, 25, 1, 500, H0="rl", marks=c("beech","oak")) + plot(k12swrm.rl) + + # spatial point pattern in a circle with radius 50 centred on (55,45) + swc <- spp(BP$trees, win=c(55,45,45), marks=BP$species) + k12swc.pi <- k12fun(swc, 25, 1, 500, marks=c("beech","oak")) + plot(k12swc.pi) + + # spatial point pattern in a complex sampling window + swrt.rl <- spp(BP$trees, win=BP$rect, tri=BP$tri2, marks=BP$species) + k12swrt.rl <- k12fun(swrt.rl, 25, 1, 500, H0="rl",marks=c("beech","oak")) + plot(k12swrt.rl) + #testing population independence hypothesis + #requires minimizing the outer polygon + xr<-range(BP$tri3$ax,BP$tri3$bx,BP$tri3$cx) + yr<-range(BP$tri3$ay,BP$tri3$by,BP$tri3$cy) + rect.min<-swin(c(xr[1], yr[1], xr[2], yr[2])) + swrt.pi <- spp(BP$trees, window = rect.min, triangles = BP$tri3, marks=BP$species) + k12swrt.pi <- k12fun(swrt.pi, 25, 1, nsim = 500, marks = c("beech", "oak")) + plot(k12swrt.pi) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/k12val.Rd b/man/k12val.Rd new file mode 100755 index 0000000000000000000000000000000000000000..6c70d679f3f923ee702aabcf53d4d69b119b0350 --- /dev/null +++ b/man/k12val.Rd @@ -0,0 +1,73 @@ +\encoding{latin1} +\name{k12val} +\alias{k12val} +\alias{print.k12val} +\alias{summary.k12val} +\alias{print.summary.k12val} +\title{Multiscale local second-order neighbour density of a bivariate spatial point pattern} +\description{ + Computes local second-order neighbour density estimates for a bivariate spatial point pattern, i.e. the number of neighbours of type 2 per unit area + within sample circles of regularly increasing radii \eqn{r}, centred at each type 1 point of the pattern (see Details). +} +\usage{ + k12val(p, upto, by, marks) +} +\arguments{ + \item{p}{a \code{"spp"} object defining a multivariate spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} + \item{marks}{by default \code{c(1,2)}, otherwise a vector of two numbers or character strings identifying the types (the \code{p$marks} levels) + of points of type 1 and 2, respectively.} +} +\details{ + Function \code{K12val} returns individual values of \emph{K12(r)} and associated functions (see \code{\link{k12fun}}) + estimated at each type 1 point of the pattern. For a given distance \emph{r}, these values can be mapped within the sampling window, as in + Getis & Franklin 1987 or Pélissier & Goreaud 2001. +} +\value{ + A list of class \code{c("vads","k12val")} with essentially the following components: + \item{r }{a vector of regularly spaced distances (\code{seq(by,upto,by)}).} + \item{xy }{a data frame with 2 components giving \eqn{(x,y)} coordinates of type 1 points of the pattern.} + \item{g12val }{a matrix of size \eqn{(length(xy),length(r))} giving individual values of the bivariate pair density function \eqn{g12(r)}.} + \item{n12val }{a matrix of size \eqn{(length(xy),length(r))} giving individual values of the bivariate neighbour density function \eqn{n12(r)}.} + \item{k12val }{a matrix of size \eqn{(length(xy),length(r))} giving individual values of the intertype function \eqn{K12(r)}.} + \item{l12val }{a matrix of size \eqn{(length(xy),length(r))} giving individual values the modified intertype function \eqn{L12(r)}.} +} +\references{ + Getis, A. and Franklin, J. 1987. Second-order neighborhood analysis of mapped point patterns. \emph{Ecology}, 68:473-477.\cr\cr + Pélissier, R. and Goreaud, F. 2001. A practical approach to the study of spatial structure in simple cases of heterogeneous vegetation. \emph{Journal of Vegetation Science}, 12:99-108. +} +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\note{ + There are printing, summary and plotting methods for \code{"vads"} objects. +} +\seealso{ + \code{\link{plot.vads}}, + \code{\link{k12fun}}, + \code{\link{dval}}, + \code{\link{kval}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + # spatial point pattern in a rectangle sampling window of size [0,110] x [0,90] + swrm <- spp(BP$trees, win=BP$rect, marks=BP$species) + k12vswrm <- k12val(swrm, 25, 1, marks=c("beech","oak")) + summary(k12vswrm) + plot(k12vswrm) + + # spatial point pattern in a circle with radius 50 centred on (55,45) + swc <- spp(BP$trees, win=c(55,45,45), marks=BP$species) + k12vswc <- k12val(swc, 25, 1, marks=c("beech","oak")) + summary(k12vswc) + plot(k12vswc) + + # spatial point pattern in a complex sampling window + swrt <- spp(BP$trees, win=BP$rect, tri=BP$tri2, marks=BP$species) + k12vswrt <- k12val(swrt, 25, 1, marks=c("beech","oak")) + summary(k12vswrt) + plot(k12vswrt) +} +\keyword{spatial} diff --git a/man/kdfun.Rd b/man/kdfun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..735a4365c68a64501be5a839f3fc9dcf6ce9a5cc --- /dev/null +++ b/man/kdfun.Rd @@ -0,0 +1,92 @@ +\encoding{latin1} +\name{kdfun} +\alias{kdfun} +\title{Multiscale second-order neigbourhood analysis of a spatial phylogenetic or functional community pattern from fully mapped data} +\description{ + Computes distance-dependent estimates of Shen et al. (2014) phylogenetic or functional mark correlation functions from a multivariate spatial point pattern + in a simple (rectangular or circular) or complex sampling window. Computes optionally local confidence limits of the functions + under the null hypothesis of species equivalence (see Details). +} +\usage{ +kdfun(p, upto, by, dis, nsim=0, alpha = 0.01) +} +\arguments{ + \item{p }{a \code{"spp"} object defining a spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} + \item{dis }{a \code{"dist"} object defining Euclidean distances between species.} + \item{nsim }{number of Monte Carlo simulations to estimate local confidence limits of the null hypothesis of a random allocation of species distances (species equivalence; see Details). + By default \code{nsim = 0}, so that no confidence limits are computed.} + \item{alpha }{if \code{nsim>0}, significant level of the confidence limits. By default \eqn{\alpha = 0.01}.} +} +\details{ + Function \code{kdfun} computes Shen et al. (2014) \eqn{Kd} and \emph{gd}-functions. For a multivariate point pattern consisting of \eqn{S} species with intensity \eqn{\lambda}p, such functions can be estimated from the bivariate \eqn{Kpq}-functions between each pair of different species \eqn{p} and \eqn{q}. + Function \code{kdfun} is thus a simple wrapper of \code{\link{k12fun}} (Pélissier & Goreaud 2014): + + \eqn{Kd(r) = D * Kr(r) / HD * Ks(r) = D * sum(\lambda p * \lambda q * Kpq(r) * dpq) / HD * sum(\lambda p * \lambda q * Kpq(r))}.\cr + \eqn{gd(r) = D * g(r) / HD * gs(r) = D * sum(\lambda p * \lambda q * gpq(r) * dpq) / HD * sum(\lambda p * \lambda q * gpq(r))}.\cr\cr + + where \eqn{Ks(r)} and \eqn{gs(r)} are distance-dependent versions of Simpson's diversity index, \eqn{D} (see \code{\link{ksfun}}), \eqn{Kr(r)} and \eqn{gr(r)} are distance-dependent versions of Rao's diversity coefficient (see \code{\link{krfun}}); + \eqn{dpq} is the distance between species \eqn{p} and \eqn{q} defined by matrix \code{dis}, typically a taxonomic, phylogentic or functional distance. The advantage here is that as the edge effects vanish between \eqn{Kr(r)} and \eqn{Ks(r)}, + implementation is fast for a sampling window of any shape. \eqn{Kd(r)} provides the expected phylogenetic or functional distance of two heterospecific individuals a distance less than \emph{r} apart (Shen et al. 2014), while \eqn{gd(r)} + provides the same within an annuli between two consecutive distances of \emph{r} and \emph{r-by}. + + Theoretical values under the null hypothesis of species equivalence as well as local Monte Carlo confidence limits and p-values of departure from the null hypothesis (Besag & Diggle 1977) are estimated at each distance \eqn{r}, + by randomizing the between-species distances, keeping the point locations and distribution of species labels unchanged. The theoretical expectations of \eqn{gd(r)} and \eqn{Kd(r)} are thus \eqn{1}. + +} +\value{ + A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{gd }{a data frame containing values of the function \eqn{gd(r)}.} + \item{kd }{a data frame containing values of the function \eqn{Kd(r)}.\cr\cr} + \item{}{Each component except \code{r} is a data frame with the following variables:\cr\cr} +\item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected under the null hypothesis of species equivalence.} + \item{sup }{(optional) if \code{nsim>0} a vector of the upper local confidence limits of a random distribution of the null hypothesis at a significant level \eqn{\alpha}.} + \item{inf }{(optional) if \code{nsim>0} a vector of the lower local confidence limits of a random distribution of the null hypothesis at a significant level \eqn{\alpha}.} + \item{pval }{(optional) if \code{nsim>0} a vector of local p-values of departure from the null hypothesis.} +} +\references{ + Shen, G., Wiegand, T., Mi, X. & He, F. (2014). Quantifying spatial phylogenetic structures of fully stem-mapped plant communities. \emph{Methods in Ecology and Evolution}, 4, 1132-1141. + + Pélissier, R. & Goreaud, F. ads package for R: A fast unbiased implementation of the K-function family for studying spatial point patterns in irregular-shaped sampling windows. \emph{Journal of Statistical Software}, in press. + +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"fads"} objects. +} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{ksfun}}, + \code{\link{krfun}}, + \code{\link{divc}}. +} +\examples{ + data(Paracou15) + P15<-Paracou15 + # spatial point pattern in a rectangle sampling window of size 125 x 125 + swmr <- spp(P15$trees, win = c(175, 175, 250, 250), marks = P15$species) + # testing the species equivalence hypothesis + kdswmr <- kdfun(swmr, dis = P15$spdist, 50, 2, 100) + #running more simulations is slow + #kdswmr <- drfun(swmr, dis = P15$spdist, 50, 2, 500) + plot(kdswmr) + + # spatial point pattern in a circle with radius 50 centred on (125,125) + swmc <- spp(P15$trees, win = c(125,125,50), marks = P15$species) + kdswmc <- kdfun(swmc, dis = P15$spdist, 50, 2, 100) + #running more simulations is slow + #kdswmc <- kdfun(swmc, dis = P15$spdist, 50, 2, 500) + plot(kdswmc) + + # spatial point pattern in a complex sampling window + swrt <- spp(P15$trees, win = c(125,125,250,250), tri = P15$tri, marks = P15$species) + kdswrt <- kdfun(swrt, dis = P15$spdist, 50, 2, 100) + #running simulations is slow + #kdswrt <- kdfun(swrt, dis = P15$spdist, 50, 2, 500) + plot(kdswrt) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/kfun.Rd b/man/kfun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..43a130559ec8b6ff0861193bcc1fcfcb48687958 --- /dev/null +++ b/man/kfun.Rd @@ -0,0 +1,100 @@ +\encoding{latin1} +\name{kfun} +\alias{kfun} +\title{Multiscale second-order neigbourhood analysis of an univariate spatial point pattern} +\description{ + Computes estimates of Ripley's \emph{K}-function and associated neigbourhood functions from an univariate spatial point pattern + in a simple (rectangular or circular) or complex sampling window. Computes optionally local confidence limits of the functions + under the null hypothesis of Complete Spatial Randomness (see Details). +} +\usage{ +kfun(p, upto, by, nsim=0, prec=0.01, alpha=0.01) +} +\arguments{ + \item{p }{a \code{"spp"} object defining a spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} + \item{nsim }{number of Monte Carlo simulations to estimate local confidence limits of the null hypothesis of complete spatial randomness (CSR) (see Details). + By default \code{nsim=0}, so that no confidence limits are computed.} + \item{prec }{if \code{nsim>0}, precision of points' coordinates generated during simulations. By default \code{prec=0.01}.} + \item{alpha }{if \code{nsim>0}, significant level of the confidence limits. By default \eqn{\alpha=0.01}.} +} +\details{ + Function \code{kfun} computes Ripley's \eqn{K(r)} function of second-order neighbourhood analysis and the associated functions \eqn{g(r)}, \eqn{n(r)} and \eqn{L(r)}.\cr\cr + For a homogeneous isotropic point process of intensity \eqn{\lambda}, Ripley (1977) showed that + the second-order property could be characterized by a function \eqn{K(r)}, so that the expected + number of neighbours within a distance \eqn{r} of an arbitrary point of the pattern is: + \eqn{N(r) = \lambda*K(r)}.\cr\cr + \eqn{K(r)} is a intensity standardization of \eqn{N(r)}, which has an expectation of \eqn{\pi*r^2} under the null hypothesis of CSR: \eqn{K(r) = N(r)/\lambda}.\cr\cr + \eqn{n(r)} is an area standardization of \eqn{N(r)}, which has an expectation of \eqn{\lambda} under the null hypothesis of CSR: \eqn{n(r) = N(r)/(\pi*r^2)}, where \eqn{\pi*r^2} is the area of the disc of radius \eqn{r}.\cr\cr + \eqn{L(r)} is a linearized version of \eqn{K(r)} (Besag 1977), which has an expectation of 0 under the null hypothesis of CSR: \eqn{L(r) = \sqrt(K(r)/\pi)-r}. \emph{L(r)} becomes positive when the pattern tends to clustering and negative when it tends to regularity.\cr\cr + \eqn{g(r)} is the derivative of \eqn{K(r)} or pair density function (Stoyan et al. 1987), so that the expected + number of neighbours at a distance \eqn{r} of an arbitrary point of the pattern (i.e. within an annuli between two successive circles with radii \eqn{r} and \eqn{r-by}) is: + \eqn{O(r) = \lambda*g(r)}.\cr\cr + + The program introduces an edge effect correction term according to the method proposed by Ripley (1977) + and extended to circular and complex sampling windows by Goreaud & Pélissier (1999).\cr\cr + + Theoretical values under the null hypothesis of CSR as well as + local Monte Carlo confidence limits and p-values of departure from CSR (Besag & Diggle 1977) are estimated at each distance \eqn{r}. +} +\value{ + A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{g }{a data frame containing values of the pair density function \eqn{g(r)}.} + \item{n }{a data frame containing values of the local neighbour density function \eqn{n(r)}.} + \item{k }{a data frame containing values of Ripley's function \eqn{K(r)}.} + \item{l }{a data frame containing values of the modified Ripley's function \eqn{L(r)}.\cr\cr} + \item{}{Each component except \code{r} is a data frame with the following variables:\cr\cr} +\item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected for a Poisson pattern.} + \item{sup }{(optional) if \code{nsim>0} a vector of the upper local confidence limits of a Poisson pattern at a significant level \eqn{\alpha}.} + \item{inf }{(optional) if \code{nsim>0} a vector of the lower local confidence limits of a Poisson pattern at a significant level \eqn{\alpha}.} + \item{pval }{(optional) if \code{nsim>0} a vector of local p-values of departure from a Poisson pattern.} +} +\references{ + Besag J.E. 1977. Discussion on Dr Ripley's paper. \emph{Journal of the Royal Statistical Society B}, 39:193-195. + + Besag J.E. & Diggle P.J. 1977. Simple Monte Carlo tests spatial patterns. \emph{Applied Statistics}, 26:327-333. + + Goreaud F. & Pélissier R. 1999. On explicit formulas of edge effect correction for Ripley's K-function. \emph{Journal of Vegetation Science}, 10:433-438. + + Ripley B.D. 1977. Modelling spatial patterns. \emph{Journal of the Royal Statistical Society B}, 39:172-192. + + Stoyan D., Kendall W.S. & Mecke J. 1987. \emph{Stochastic geometry and its applications}. Wiley, New-York. +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"fads"} objects. +} + \section{Warning }{ + Function \code{kfun} ignores the marks of multivariate and marked point patterns, which are analysed as univariate patterns. +} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{kval}}, + \code{\link{k12fun}}, + \code{\link{kijfun}}, + \code{\link{ki.fun}}, + \code{\link{kmfun}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + # spatial point pattern in a rectangle sampling window of size [0,110] x [0,90] + swr <- spp(BP$trees, win=BP$rect) + kswr <- kfun(swr,25,1,500) + plot(kswr) + + # spatial point pattern in a circle with radius 50 centred on (55,45) + swc <- spp(BP$trees, win=c(55,45,45)) + kswc <- kfun(swc, 25, 1, 500) + plot(kswc) + + # spatial point pattern in a complex sampling window + swrt <- spp(BP$trees, win=BP$rect, tri=BP$tri1) + kswrt <- kfun(swrt, 25, 1, 500) + plot(kswrt) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/kmfun.Rd b/man/kmfun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..bc39f5a49f988c43b2ac5a86418d750a6508e0fa --- /dev/null +++ b/man/kmfun.Rd @@ -0,0 +1,89 @@ +\encoding{latin1} +\name{kmfun} +\alias{kmfun} +\title{Multiscale second-order neigbourhood analysis of a marked spatial point pattern} +\description{ + Computes estimates of the mark correlation \emph{Km}-function and associated neigbourhood functions from a marked spatial point pattern + in a simple (rectangular or circular) or complex sampling window. Computes optionally local confidence limits of the functions + under the null hypothesis of no correlation between marks (see Details). +} +\usage{ +kmfun(p, upto, by, nsim=0, alpha=0.01) +} +\arguments{ + \item{p}{a \code{"spp"} object defining a marked spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} + \item{nsim }{number of Monte Carlo simulations to estimate local confidence limits of the null hypothesis of no correlation between marks (see Details). + By default \code{nsim=0}, so that no confidence limits are computed.} + \item{alpha }{if \code{nsim>0}, significant level of the confidence limits. By default \eqn{\alpha=0.01}.} +} +\details{ + Function \code{kmfun} computes the mark correlation function \eqn{Km(r)} and the associated function \eqn{gm(r)}.\cr\cr + It is defined from a general definition of spatial autocorrelation (Goreaud 2000) as:\cr + + \eqn{Km(r) = (COV(Xi,Xj)|d(i,j)<r) / VAR(X)}\cr + + where \eqn{X} is a quantitative random variable attached to each point of the pattern. + + \emph{Km(r)} has a very similar interpretation than more classical correlation functions, such as Moran's \emph{I}: it takes values between -1 and 1, with an expectation of 0 under the null hypothesis of no spatial correlation between the values of \emph{X}, becomes positive when values of \eqn{X} at distance \emph{r} are positively correlated and negative when values of \eqn{X} at distance \emph{r} are negatively correlated. + + \eqn{gm(r)} is the derivative of \eqn{Km(r)} or pair mark correlation function, which gives the correlation of marks within an annuli between two successive circles with radii \eqn{r} and \eqn{r-by}).\cr\cr + + The program introduces an edge effect correction term according to the method proposed by Ripley (1977) and extended to circular and complex sampling windows by Goreaud & Pélissier (1999). + + Local Monte Carlo confidence limits and p-values of departure from the null hypothesis of no correlation are estimated at each distance \eqn{r}, after reallocating at random the values of \emph{X} over all points of the pattern, the location of trees being kept unchanged. +} +\value{ + A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{gm }{a data frame containing values of the pair mark correlation function \eqn{gm(r)}.} + \item{km }{a data frame containing values of the mark correlation function \eqn{Km(r)}.\cr\cr} + \item{ }{Each component except \code{r} is a data frame with the following variables:\cr\cr} + \item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected for the null hypothesis of no correlation between marks.} + \item{sup }{(optional) if \code{nsim>0} a vector of the upper local confidence limits of the null hypothesis at a significant level \eqn{\alpha}.} + \item{inf }{(optional) if \code{nsim>0} a vector of the lower local confidence limits of the null hypothesis at a significant level \eqn{\alpha}.} + \item{pval }{(optional) if \code{nsim>0} a vector of local p-values of departure from the null hypothesis.} +} +\note{ +Applications of this function can be found in Oddou-Muratorio \emph{et al.} (2004) and Madelaine \emph{et al.} (submitted). +} + + \references{Goreaud, F. 2000. \emph{Apports de l'analyse de la structure spatiale en foret tempérée à l'étude et la modélisation des peuplements complexes}. Thèse de doctorat, ENGREF, Nancy, France.\cr\cr +Goreaud F. & Pélissier R. 1999. On explicit formulas of edge effect correction for Ripley's K-function. \emph{Journal of Vegetation Science}, 10:433-438.\cr\cr +Madelaine, C., Pélissier, R., Vincent, G., Molino, J.-F., Sabatier, D., Prévost, M.-F. & de Namur, C. 2007. Mortality and recruitment in a lowland tropical rainforest of French Guiana: effects of soil type and species guild. \emph{Journal of Tropical Ecology}, 23:277-287. + +Oddou-Muratorio, S., Demesure-Musch, B., Pélissier, R. & Gouyon, P.-H. 2004. Impacts of gene flow and logging history on the local genetic structure of a scattered tree species, Sorbus torminalis L. \emph{Molecular Ecology}, 13:3689-3702. + +Ripley B.D. 1977. Modelling spatial patterns. \emph{Journal of the Royal Statistical Society B}, 39:172-192. +} +\author{\email{Raphael.Pelissier@ird.fr}} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{kfun}}, + \code{\link{k12fun}}, + \code{\link{kijfun}}, + \code{\link{ki.fun}}. + } +\examples{ + data(BPoirier) + BP <- BPoirier + # spatial point pattern in a rectangle sampling window of size [0,110] x [0,90] + swrm <- spp(BP$trees, win=BP$rect, marks=BP$dbh) + kmswrm <- kmfun(swrm, 25, 2, 500) + plot(kmswrm) + + # spatial point pattern in a circle with radius 50 centred on (55,45) + swc <- spp(BP$trees, win=c(55,45,45), marks=BP$dbh) + kmswc <- kmfun(swc, 25, 2, 500) + plot(kmswc) + + # spatial point pattern in a complex sampling window + swrt <- spp(BP$trees, win=BP$rect, tri=BP$tri2, marks=BP$dbh) + kmswrt <- kmfun(swrt, 25, 2, 500) + plot(kmswrt) + +} +\keyword{spatial} diff --git a/man/kp.fun.Rd b/man/kp.fun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..c42e544dcb208b975cdfbf35a89c1cec66f80103 --- /dev/null +++ b/man/kp.fun.Rd @@ -0,0 +1,64 @@ +\encoding{latin1} +\name{kp.fun} +\alias{kp.fun} +\alias{ki.fun} +\title{ Multiscale second-order neigbourhood analysis of a multivariate spatial point pattern} +\description{ +(Formerly \code{ki.fun}) Computes a set of \emph{K12}-functions between all possible marks \eqn{p} and the other marks in + a multivariate spatial point pattern defined in a simple (rectangular or circular) + or complex sampling window (see Details). +} +\usage{ +kp.fun(p, upto, by) +} +\arguments{ + \item{p }{a \code{"spp"} object defining a multivariate spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} +} +\details{ + Function \code{kp.fun} is simply a wrapper to \code{\link{k12fun}}, which computes \emph{K12(r)} between each mark \eqn{p} of the pattern + and all other marks grouped together (the \eqn{j} points). +} +\value{ + A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced distances (\code{seq(by,upto,by)}).} + \item{labp }{a vector containing the levels \eqn{i} of \code{p$marks}.} + \item{gp. }{a data frame containing values of the pair density function \eqn{g12(r)}.} + \item{np. }{a data frame containing values of the local neighbour density function \eqn{n12(r)}.} + \item{kp. }{a data frame containing values of the \eqn{K12(r)} function.} + \item{lp. }{a data frame containing values of the modified \eqn{L12(r)} function.\cr\cr} + \item{ }{Each component except \code{r} is a data frame with the following variables:\cr\cr} + \item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected under the null hypothesis of population independence (see \code{\link{k12fun}}).} +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"fads"} objects. +} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{kfun}}, + \code{\link{k12fun}}, + \code{\link{kpqfun}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + # multivariate spatial point pattern in a rectangle sampling window + swrm <- spp(BP$trees, win=BP$rect, marks=BP$species) + kp.swrm <- kp.fun(swrm, 25, 1) + plot(kp.swrm) + + # multivariate spatial point pattern in a circle with radius 50 centred on (55,45) + swcm <- spp(BP$trees, win=c(55,45,45), marks=BP$species) + kp.swcm <- kp.fun(swcm, 25, 1) + plot(kp.swcm) + + # multivariate spatial point pattern in a complex sampling window + swrtm <- spp(BP$trees, win=BP$rect, tri=BP$tri2, marks=BP$species) + kp.swrtm <- kp.fun(swrtm, 25, 1) + plot(kp.swrtm) +} +\keyword{spatial} diff --git a/man/kpqfun.Rd b/man/kpqfun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..3fa67d10513b18c5391d2d8341fcd570cc0666fb --- /dev/null +++ b/man/kpqfun.Rd @@ -0,0 +1,66 @@ +\encoding{latin1} +\name{kpqfun} +\alias{kpqfun} +\alias{kijfun} +\title{Multiscale second-order neigbourhood analysis of a multivariate spatial point pattern} +\description{ + (Formerly \code{kijfun}) Computes a set of \emph{K}- and \emph{K12}-functions for all possible pairs of marks \eqn{(p,q)} in a multivariate spatial + point pattern defined in a simple (rectangular or circular) + or complex sampling window (see Details). +} +\usage{ + kpqfun(p, upto, by) +} +\arguments{ + \item{p }{a \code{"spp"} object defining a multivariate spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} +} +\details{ + Function \code{kpqfun} is simply a wrapper to \code{\link{kfun}} and \code{\link{k12fun}}, which computes either \emph{K(r)} + for points of mark \eqn{p} when \eqn{p=q} or \emph{K12(r)} between the marks \eqn{p} and \eqn{q} otherwise. +} +\value{ +A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced distances (\code{seq(by,upto,by)}).} + \item{labpq }{a vector containing the \eqn{(p,q)} paired levels of \code{p$marks}.} + \item{gpq }{a data frame containing values of the pair density functions \eqn{g(r)} and \eqn{g12(r)}.} + \item{npq }{a data frame containing values of the local neighbour density functions \eqn{n(r)} and \eqn{n12(r)}.} + \item{kpq }{a data frame containing values of the \eqn{K(r)} and \eqn{K12(r)} functions.} +\item{lpq }{a data frame containing values of the modified \eqn{L(r)} and \eqn{L12(r)} functions.\cr\cr} + \item{ }{Each component except \code{r} is a data frame with the following variables:\cr} + \item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected under the null hypotheses of spatial randomness (see \code{\link{kfun}}) and + population independence (see \code{\link{k12fun}}).} +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"fads"} objects. +} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{kfun}}, + \code{\link{k12fun}}, + \code{\link{kp.fun}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + # multivariate spatial point pattern in a rectangle sampling window + swrm <- spp(BP$trees, win=BP$rect, marks=BP$species) + kpqswrm <- kpqfun(swrm, 25, 1) + plot(kpqswrm) + + # multivariate spatial point pattern in a circle with radius 50 centred on (55,45) + swcm <- spp(BP$trees, win=c(55,45,45), marks=BP$species) + kpqswcm <- kpqfun(swcm, 25, 1) + plot(kpqswcm) + + # multivariate spatial point pattern in a complex sampling window + swrtm <- spp(BP$trees, win=BP$rect, tri=BP$tri2, marks=BP$species) + kpqswrtm <- kpqfun(swrtm, 25, 1) + plot(kpqswrtm) + +} +\keyword{spatial} diff --git a/man/krfun.Rd b/man/krfun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..4232582d526e9ad8f632a0ae8b226761598f0a6c --- /dev/null +++ b/man/krfun.Rd @@ -0,0 +1,107 @@ +\encoding{latin1} +\name{krfun} +\alias{krfun} +\title{Multiscale second-order neigbourhood analysis of a multivariate spatial point pattern using Rao quandratic entropy} +\description{ + Computes distance-dependent estimates of Rao's quadratic entropy from a multivariate spatial point pattern + in a simple (rectangular or circular) or complex sampling window. Computes optionally local confidence limits of the functions + under the null hypothesis of either a random labelling or a species equivalence (see Details). +} +\usage{ +krfun(p, upto, by, nsim=0, dis = NULL, H0 = c("rl", "se"), alpha = 0.01) +} +\arguments{ + \item{p }{a \code{"spp"} object defining a spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} + \item{nsim }{number of Monte Carlo simulations to estimate local confidence limits of the null hypothesis of a random allocation of species labels (see Details). + By default \code{nsim = 0}, so that no confidence limits are computed.} + \item{dis }{(optional) a \code{"dist"} object defining Euclidean distances between species. By default \eqn{dis = NULL} so that species are considered equidistant.} +\item{H0}{one of c("rl","se") to select either the null hypothesis of random labelling (H0 = "rl") or species equivalence (H0 = "se") (see Details). By default, the null hypothesis is random labelling.} + \item{alpha }{if \code{nsim>0}, significant level of the confidence limits. By default \eqn{\alpha = 0.01}.} +} +\details{ + Function \code{krfun} computes distance-dependent functions of Rao (1982) quadratic entropy (see \code{\link{divc}} in package \code{ade4}).\cr\cr + For a multivariate point pattern consisting of \eqn{S} species with intensity \eqn{\lambda}p, such functions can be estimated from the bivariate \eqn{Kpq}-functions between each pair of different species \eqn{p} and \eqn{q}. + Function \code{krfun} is thus a simple wrapper function of \code{\link{k12fun}} and \code{\link{kfun}}, standardized by Rao diversity coefficient (Pélissier & Goreaud 2014): + + \eqn{Kr(r) = sum(\lambda p * \lambda q * Kpq(r)*dpq) / (\lambda * \lambda * K(r) * HD)}.\cr + \eqn{gr(r) = sum(\lambda p * \lambda q * gpq(r)*dpq) / (\lambda * \lambda * g(r) * HD)}.\cr\cr + + where \eqn{dpq} is the distance between species \eqn{p} and \eqn{q} defined by matrix \code{dis}, typically a taxonomic, phylogentic or functional distance, and \eqn{HD=sum(Np*Nq*dpq/(N(N - 1)))} is the unbiased version of Rao diversity coefficient (see Shimatani 2001). When \code{dis = NULL}, species are considered each other equidistant and \code{krfun} returns the same results than \code{\link{ksfun}}. + +The program introduces an edge effect correction term according to the method proposed by Ripley (1977) + and extended to circular and complex sampling windows by Goreaud & Pélissier (1999).\cr\cr + +Theoretical values under the null hypothesis of either random labelling or species equivalence as well as local Monte Carlo confidence limits and p-values of departure from the null hypothesis (Besag & Diggle 1977) are estimated at each distance \eqn{r}. + +The random labelling hypothesis (H0 = "rl") is tested by reallocating species labels at random among all points of the pattern, keeping the point locations unchanged, so that expectations of \eqn{gr(r)} and \eqn{Kr(r)} are 1 for all \eqn{r}. +The species equivalence hypothesis (H0 = "se") is tested by randomizing the between-species distances, keeping the point locations and distribution of species labels unchanged. The theoretical expectations of \eqn{gr(r)} and \eqn{Kr(r)} are thus \eqn{gs(r)} and \eqn{Ks(r)}, respectively (see \code{\link{ksfun}}). + +} +\value{ + A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{gr }{a data frame containing values of the function \eqn{gr(r)}.} + \item{kr }{a data frame containing values of the function \eqn{Kr(r)}.\cr\cr} + \item{}{Each component except \code{r} is a data frame with the following variables:\cr\cr} +\item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected under the selected null hypothesis.} + \item{sup }{(optional) if \code{nsim>0} a vector of the upper local confidence limits of a random distribution of the selected null hypothesis at a significant level \eqn{\alpha}.} + \item{inf }{(optional) if \code{nsim>0} a vector of the lower local confidence limits of a random distribution of the selected null hypothesis at a significant level \eqn{\alpha}.} + \item{pval }{(optional) if \code{nsim>0} a vector of local p-values of departure from the selected null hypothesis.} +} +\references{ + Rao, C.R. 1982. Diversity and dissimilarity coefficient: a unified approach. \emph{Theoretical Population Biology}, 21:24-43. + + Shimatani, K. 2001. On the measurement of species diversity incorporating species differences. \emph{Oïkos}, 93, 135-147. + + Goreaud F. & Pélissier R. 1999. On explicit formulas of edge effect correction for Ripley's K-function. \emph{Journal of Vegetation Science}, 10:433-438. + + Ripley B.D. 1977. Modelling spatial patterns. \emph{Journal of the Royal Statistical Society B}, 39:172-192. + + Pélissier, R. & Goreaud, F. 2014. ads package for R: A fast unbiased implementation of the k-function family for studying spatial point patterns in irregular-shaped sampling windows. \emph{Journal of Statistical Software}, in press. + +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"fads"} objects. +} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{ksfun}}, + \code{\link{kdfun}}, + \code{\link{divc}}. +} +\examples{ + data(Paracou15) + P15<-Paracou15 + # spatial point pattern in a rectangle sampling window of size 125 x 125 + swmr <- spp(P15$trees, win = c(175, 175, 250, 250), marks = P15$species) + # testing the random labeling hypothesis + krwmr.rl <- krfun(swmr, dis = P15$spdist, H0 = "rl", 25, 2, 50) + #running more simulations is slow + #krwmr.rl <- krfun(swmr, dis = P15$spdist, H0 = "rl", 25, 2, 500) + plot(krwmr.rl) + # testing the species equivalence hypothesis + krwmr.se <- krfun(swmr, dis = P15$spdist, H0 = "se", 25, 2, 50) + #running more simulations is slow + #krwmr.se <- krfun(swmr, dis = P15$spdist, H0 = "se", 25, 2, 500) + plot(krwmr.se) + + # spatial point pattern in a circle with radius 50 centred on (125,125) + swmc <- spp(P15$trees, win = c(125,125,50), marks = P15$species) + krwmc <- krfun(swmc, dis = P15$spdist, H0 = "rl", 25, 2, 100) + #running more simulations is slow + #krwmc <- krfun(swmc, dis = P15$spdist, H0 = "rl, 25, 2, 500) + plot(krwmc) + + # spatial point pattern in a complex sampling window + swrt <- spp(P15$trees, win = c(125,125,250,250), tri = P15$tri, marks = P15$species) + krwrt <- krfun(swrt, dis = P15$spdist, H0 = "rl", 25, 2) + #running simulations is slow + #krwrt <- krfun(swrt, dis = P15$spdist, H0 = "rl", 25, 2, 500) + plot(krwrt) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/ksfun.Rd b/man/ksfun.Rd new file mode 100755 index 0000000000000000000000000000000000000000..55259a2d0543bdef412b314b42fddec9f72035fa --- /dev/null +++ b/man/ksfun.Rd @@ -0,0 +1,93 @@ +\encoding{latin1} +\name{ksfun} +\alias{ksfun} +\title{Multiscale second-order neigbourhood analysis of a multivariate spatial point pattern using Simpson diversity} +\description{ + Computes estimates of Shimatani \emph{alpha} and \emph{beta} functions of Simpson diversity from a multivariate spatial point pattern + in a simple (rectangular or circular) or complex sampling window. Computes optionally local confidence limits of the functions + under the null hypothesis of a random allocation of species labels (see Details). +} +\usage{ +ksfun(p, upto, by, nsim=0, alpha=0.01) +} +\arguments{ + \item{p }{a \code{"spp"} object defining a spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} + \item{nsim }{number of Monte Carlo simulations to estimate local confidence limits of the null hypothesis of a random allocation of species labels (see Details). + By default \code{nsim=0}, so that no confidence limits are computed.} + \item{alpha }{if \code{nsim>0}, significant level of the confidence limits. By default \eqn{\alpha=0.01}.} +} +\details{ + Function \code{ksfun} computes Shimatani \eqn{\alpha(r)} and \eqn{\beta(r)} functions of Simpson diversity, called here \eqn{Ks(r)} and \eqn{gs(r)}, respectively.\cr\cr + For a multivariate point pattern consisting of \eqn{S} species with intensity \eqn{\lambda}p, Shimatani (2001) showed that + a distance-dependent measure of Simpson (1949) diversity can be estimated from Ripley (1977) \eqn{K}-function computed for each species separately and for all the points grouped toghether (see also Eckel et al. 2008). + Function \code{ksfun} is thus a simple wrapper function of \code{\link{kfun}}, standardized by Simpson diversity coefficient: + + + \eqn{Ks(r) = 1 - sum(\lambda p * \lambda p * Kp(r)) / (\lambda * \lambda * K(r) * D)} which is a standardized estimator of \eqn{\alpha(r)} in Shimatani (2001).\cr\cr + \eqn{gs(r) = 1 - sum(\lambda p * \lambda p * gp(r)) / (\lambda * \lambda * g(r) * D)} corresponding to a standardized version of \eqn{\beta(r)} in Shimatani (2001).\cr\cr + + \eqn{Kp(r)} and \eqn{K(r)} (resp. \eqn{gp(r)} and \eqn{g(r)}) are univariate K-functions computed for species \eqn{p} and for all species toghether; \eqn{D = 1 - sum(Np * (Np - 1) / (N*(N - 1)))} is the unbiased version of Simpson diversity, + with \eqn{Np} the number of individuals of species \eqn{p} in the sample and \eqn{N = sum(Np)}. + + The program introduces an edge effect correction term according to the method proposed by Ripley (1977) + and extended to circular and complex sampling windows by Goreaud & Pélissier (1999).\cr\cr + + The theoretical values of \eqn{gr(r)} and \eqn{Kr(r)} under the null hypothesis of random labelling is 1 for all \eqn{r}. + Local Monte Carlo confidence limits and p-values of departure from this hypothesis are estimated at each distance \eqn{r} by reallocating at random the species labels among points of the pattern, keeping the point locations unchanged. +} +\value{ + A list of class \code{"fads"} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{gs }{a data frame containing values of the function \eqn{gs(r)}.} + \item{ks }{a data frame containing values of the function \eqn{Ks(r)}.\cr\cr} + \item{}{Each component except \code{r} is a data frame with the following variables:\cr\cr} +\item{obs }{a vector of estimated values for the observed point pattern.} + \item{theo }{a vector of theoretical values expected under the null hypothesis of random labelling, i.e. 1 for all \eqn{r}.} + \item{sup }{(optional) if \code{nsim>0} a vector of the upper local confidence limits of a random distribution of species labels at a significant level \eqn{\alpha}.} + \item{inf }{(optional) if \code{nsim>0} a vector of the lower local confidence limits of a Prandom distribution of species labels at a significant level \eqn{\alpha}.} + \item{pval }{(optional) if \code{nsim>0} a vector of local p-values of departure from a random distribution of species labels.} +} +\references{ + Shimatani K. 2001. Multivariate point processes and spatial variation in species diversity. \emph{Forest Ecology and Managaement}, 142:215-229. + + Eckel, S., Fleisher, F., Grabarnik, P. and Schmidt V. 2008. An investigation of the spatial correlations for relative purchasing power in Baden-Württemberg. \emph{AstA - Advances in Statistical Analysis}, 92:135-152. + + Simpson, E.H. 1949. Measurement of diversity. \emph{Nature}, 688:163. + + Goreaud F. & Pélissier R. 1999. On explicit formulas of edge effect correction for Ripley's K-function. \emph{Journal of Vegetation Science}, 10:433-438. + + Ripley B.D. 1977. Modelling spatial patterns. \emph{Journal of the Royal Statistical Society B}, 39:172-192. +} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"fads"} objects. +} +\seealso{ +\code{\link{plot.fads}}, + \code{\link{spp}}, + \code{\link{kfun}}, + \code{\link{kpqfun}}, + \code{\link{kp.fun}}, + \code{\link{krfun}}. +} +\examples{ + data(Paracou15) + P15<-Paracou15 + # spatial point pattern in a rectangle sampling window of size 125 x 125 + swmr <- spp(P15$trees, win = c(125, 125, 250, 250), marks = P15$species) + kswmr <- ksfun(swmr, 50, 5, 500) + plot(kswmr) + + # spatial point pattern in a circle with radius 50 centred on (125,125) + swmc <- spp(P15$trees, win = c(125, 125, 50), marks = P15$species) + kswmc <- ksfun(swmc, 50, 5, 500) + plot(kswmc) + + # spatial point pattern in a complex sampling window + swrt <- spp(P15$trees, win = c(125, 125, 250, 250), tri=P15$tri, marks=P15$species) + kswrt <- ksfun(swrt, 50, 5, 500) + plot(kswrt) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/kval.Rd b/man/kval.Rd new file mode 100755 index 0000000000000000000000000000000000000000..ac9f740c4f4fa4f6e0e06b15294b3c9ef4347648 --- /dev/null +++ b/man/kval.Rd @@ -0,0 +1,74 @@ +\encoding{latin1} +\name{kval} +\alias{kval} +\alias{print.kval} +\alias{summary.kval} +\alias{print.summary.kval} +\title{Multiscale local second-order neighbour density of a spatial point pattern} +\description{ + Computes local second-order neighbour density estimates for an univariate spatial point pattern, i.e. the number of neighbours per unit area + within sample circles of regularly increasing radii \eqn{r}, centred at each point of the pattern (see Details). +} +\usage{ + kval(p, upto, by) +} +\arguments{ + \item{p}{a \code{"spp"} object defining a spatial point pattern in a given sampling window (see \code{\link{spp}}).} + \item{upto }{maximum radius of the sample circles (see Details).} + \item{by }{interval length between successive sample circles radii (see Details).} +} +\details{ + Function \code{kval} returns indivdiual values of \emph{K(r)} and associated functions (see \code{\link{kfun}}) + estimated for each point of the pattern. For a given distance \emph{r}, these values can be mapped within the sampling window + (Getis & Franklin 1987, Pélissier & Goreaud 2001). +} +\value{ +A list of class \code{c("vads","kval")} with essentially the following components: + \item{r }{a vector of regularly spaced out distances (\code{seq(by,upto,by)}).} + \item{xy }{a data frame with 2 components giving \eqn{(x,y)} coordinates of points of the pattern.} + \item{gval }{a matrix of size \eqn{(length(xy),length(r))} giving individual values of the pair density function \eqn{g(r)}.} + \item{nval }{a matrix of size \eqn{(length(xy),length(r))} giving individual values of the neighbour density function \eqn{n(r)}.} + \item{kval }{a matrix of size \eqn{(length(xy),length(r))} giving individual values of Ripley's function \eqn{K(r)}.} + \item{lval }{a matrix of size \eqn{(length(xy),length(r))} giving individual values the modified Ripley's function \eqn{L(r)}.} + } +\references{ + Getis, A. and Franklin, J. 1987. Second-order neighborhood analysis of mapped point patterns. \emph{Ecology}, 68:473-477.\cr\cr + Pélissier, R. and Goreaud, F. 2001. A practical approach to the study of spatial structure in simple cases of heterogeneous vegetation. \emph{Journal of Vegetation Science}, 12:99-108. +} +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\note{ + There are printing, summary and plotting methods for \code{"vads"} objects. +} +\section{Warning }{ + Function \code{kval} ignores the marks of multivariate and marked point patterns (they are all considered to be univariate patterns). +} +\seealso{ + \code{\link{plot.vads}}, + \code{\link{kfun}}, + \code{\link{dval}}, + \code{\link{k12val}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + # spatial point pattern in a rectangle sampling window of size [0,110] x [0,90] + swr <- spp(BP$trees, win=BP$rect) + kvswr <- kval(swr, 25, 1) + summary(kvswr) + plot(kvswr) + + # spatial point pattern in a circle with radius 50 centred on (55,45) + swc <- spp(BP$trees, win=c(55,45,45)) + kvswc <- kval(swc, 25, 1) + summary(kvswc) + plot(kvswc) + + # spatial point pattern in a complex sampling window + swrt <- spp(BP$trees, win=BP$rect, tri=BP$tri1) + kvswrt <- kval(swrt, 25, 1) + summary(kvswrt) + plot(kvswrt) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/mimetic.Rd b/man/mimetic.Rd new file mode 100755 index 0000000000000000000000000000000000000000..a7ea80973f4677883b7324a377a55356ccd88518 --- /dev/null +++ b/man/mimetic.Rd @@ -0,0 +1,64 @@ +\encoding{latin1} +\name{mimetic} +\alias{mimetic} +\alias{plot.mimetic} +\title{Univariate point pattern simulation by mimetic point process} +\description{ + Simulates replicates of an observed univariate point pattern by stochastic optimization of its L-function properties. +} +\usage{ +mimetic(x,upto=NULL,by=NULL,prec=NULL,nsimax=3000,conv=50) +} +\arguments{ + \item{x }{either a \code{("fads", "kfun")} object or a \code{"spp"} object of type "univariate" defining a spatial point pattern in a given sampling window (see \code{\link{kfun}} or \code{\link{spp}}).} + \item{upto }{(optional) maximum radius of the sample circles when \code{x} is a \code{"spp"} object.} + \item{by }{(optional) interval length between successive sample circles radii when \code{x} is a \code{"spp"} object.} + \item{prec }{precision of point coordinates generated during simulations when \code{x} is a \code{"spp"} object. By default prec=0.01 or the value used in fonction \code{kfun} when \code{x} is a \code{("fads", "kfun")} object.} + \item{nsimax }{maximum number of simulations allowed. By default the process stops after \code{nsimax=3000} if convergence is not reached.} + \item{conv }{maximum number of simulations without optimization gain (convergence criterion).} +} +\details{ + Function \code{mimetic} uses a stepwise depletion-replacement algorithm to generate a point pattern whose L-function is optimized with regards to an observed one, following the mimetic point process principle (Goreaud et al. 2004). + Four points are randomly deleted at each step of the process and replaced by new points that minimize the following cost function:||\eqn{Lobs(r) - Lsim (r)}||)^2. The simulation stops as soon as the cost fonction doesn't decrease + after \code{conv} simulations or after a maximum of \code{nsimax} simulations. The process apply to rectangular, circular or comlex sampling windows (see \code{\link{spp}}). There exist a \code{plot} method that displays diagnostic + plots, i.e. the observed and simulated L-function, the simulated point pattern and the successive values of the cost function. +} +\value{ + A list of class \code{"mimetic"} with essentially the following components: + \item{call }{the function call.} + \item{fads }{an object of class \code{("fads", "mimetic")} with 2 components:\cr\cr} + \item{..r }{a vector of regularly spaced out distances corresponding to seq(by,upto,by).} + \item{..l }{a dataframe with 2 components:\cr\cr} + \item{.. ..obs}{a vector of values of the L-function estimated for the initial observed pattern} + \item{.. ..sim}{a vector of values of the L-function estimated for the simulated pattern} +\item{spp }{a object of class \code{"spp"} corresponding to the simulated point pattern (see \code{\link{spp}}).} + \item{theo }{a vector of theoretical values, i.e. Simpson \eqn{D} for all the points.} + \item{cost }{a vector of the successive values of the cost function.} +} +\references{ + Goreaud F., Loussier, B., Ngo Bieng, M.-A. & Allain R. 2004. Simulating realistic spatial structure for forest stands: a mimetic point process. In Proceedings of Interdisciplinary Spatial Statistics Workshop, 2-3 December, 2004. Paris, France.} +\author{\email{Raphael.Pelissier@ird.fr}} +\note{ + There are printing and plotting methods for \code{"mimetic"} objects. +} +\seealso{ + \code{\link{spp}}, + \code{\link{kfun}}, +} +\examples{ + data(BPoirier) + BP<-BPoirier + # performing point pattern analysis in a rectangle sampling window + swr <- spp(BP$trees, win=BP$rect) + plot(swr) + + # performing the mimetic point process from "spp" object + mimswr <- mimetic(swr, 20, 2) + plot(mimswr) + + # performing the mimetic point process from "fads" object + mimkswr <- mimetic(kfun(swr, 20, 2)) + plot(mimkswr) + + } +\keyword{spatial} \ No newline at end of file diff --git a/man/plot.fads.Rd b/man/plot.fads.Rd new file mode 100755 index 0000000000000000000000000000000000000000..409277b1057e5886e399f866d942bc2aaf70cb25 --- /dev/null +++ b/man/plot.fads.Rd @@ -0,0 +1,66 @@ +\encoding{latin1} +\name{plot.fads} +\alias{plot.fads} +\alias{plot.fads.kfun} +\alias{plot.fads.k12fun} +\alias{plot.fads.kpqfun} +\alias{plot.fads.kp.fun} +\alias{plot.fads.kmfun} +\alias{plot.fads.ksfun} +\alias{plot.fads.krfun} +\alias{plot.fads.kdfun} +\alias{plot.fads.mimetic} +\title{Plot second-order neigbourhood functions} +\description{ + Plot second-order neigbourhood function estimates returned by functions \code{\link{kfun}, \link{k12fun}, \link{kmfun}}, \cr + \code{ \link{kijfun} or \link{ki.fun}}. +} +\usage{ +\method{plot}{fads}(x, opt, cols, lty, main, sub, legend, csize, \dots) +} +\arguments{ + \item{x}{an object of class \code{"fads"} (see Details).} + \item{opt}{one of \code{c("all","L","K","n","g")} to dislay either all or one of the functions in a single window. By default \code{opt = "all"} for \code{fads} + objects of subclass \code{"kfun"}, \code{"k12fun"}, or \code{"kmfun"}; by default \code{opt = "L"} for \code{fads} objects of subclass \code{"kij"}, or \code{"ki."}.} + \item{cols}{(optional) coulours used for plotting functions.} + \item{lty}{(optional) line types used for plotting functions.} + \item{main}{by default, the value of argument x, otherwise a text to be displayed as a title of the plot. \code{main=NULL} displays no title.} + \item{sub}{by default, the name of the function displayed, otherwise a text to be displayed as function subtitle. \code{sub=NULL} displays no subtitle.} + \item{legend}{If \code{legend = TRUE} (the default) a legend for the plotting functions is displayed.} + \item{csize}{scaling factor for font size so that actual font size is \code{par("cex")*csize}. By default \code{csize = 1}.} + \item{\dots}{extra arguments that will be passed to the plotting functions \code{\link{plot.swin}}, \cr + \code{\link{plot.default}}, \code{\link{symbols}} and/or \code{\link{points}}.} +} +\details{ + Function \code{plot.fads} displays second-order neighbourhood function estimates as a function of interpoint distance, with expected values + as well as confidence interval limits when computed. Argument \code{x} can be any \code{fads} object returned by functions \code{\link{kfun}, + \link{k12fun}, \link{kmfun}, \link{kijfun} or \link{ki.fun}}. +} +\value{none.} +\author{\email{Raphael.Pelissier@ird.fr}} +\seealso{ + \code{\link{kfun}}, + \code{\link{k12fun}}, + \code{\link{kmfun}}, + \code{\link{kijfun}}, + \code{\link{ki.fun}}.} +\examples{ + data(BPoirier) + BP <- BPoirier + # Ripley's function + swr <- spp(BP$trees, win=BP$rect) + k.swr <- kfun(swr, 25, 1, 500) + plot(k.swr) + + # Intertype function + swrm <- spp(BP$trees, win=BP$rect, marks=BP$species) + k12.swrm <- k12fun(swrm, 25, 1, 500, marks=c("beech","oak")) + plot(k12.swrm, opt="L", cols=1) + + # Mark correlation function + swrm <- spp(BP$trees, win=BP$rect, marks=BP$dbh) + km.swrm <- kmfun(swrm, 25, 1, 500) + plot(km.swrm, main="Example 1", sub=NULL, legend=FALSE) + +} +\keyword{spatial} diff --git a/man/plot.spp.Rd b/man/plot.spp.Rd new file mode 100755 index 0000000000000000000000000000000000000000..9f0503a15500420ab9cc6f418e08985b080c1170 --- /dev/null +++ b/man/plot.spp.Rd @@ -0,0 +1,99 @@ +\encoding{latin1} +\name{plot.spp} +\alias{plot.spp} +\title{Plot a Spatial Point Pattern object} +\description{ + Plot a Spatial Point Pattern object returned by function \code{\link{spp}}. +} +\usage{ +\method{plot}{spp}(x, main, out=FALSE, use.marks=TRUE, cols, chars, cols.out, chars.out, +maxsize, scale=TRUE, add=FALSE, legend=TRUE, csize=1, ...) +} +\arguments{ + \item{x}{an object of class \code{"spp"} (see \code{\link{spp}}).} + \item{main}{by default, the value of argument \code{x}, otherwise a text to be displayed as a title of the plot.\code{main=NULL} displays no title.} + \item{out}{by default \code{out = FALSE}. If \code{TRUE} points of the pattern located outside the sampling window are plotted.} + \item{use.marks}{by default \code{use.marks = TRUE}. If \code{FALSE} different symbols are not used for each mark of multivariate + or marked point patterns, so that they are plotted as univariate (see \code{\link{spp}}).} + \item{cols}{(optional) the coulour(s) used to plot points located inside the sampling window (see Details).} + \item{chars}{(optional) plotting character(s) used to plot points located inside the sampling window (see Details).} + \item{cols.out}{(optional) if \code{out = TRUE}, the coulour(s) used to plot points located outside the sampling window (see Details).} + \item{chars.out}{(optional) if \code{out = TRUE}, plotting character(s) used to plot points located outside the sampling window (see Details).} + \item{maxsize}{(optional) maximum size of plotting symbols. By default \code{maxsize} is automatically adjusted to plot size.} + \item{csize}{scaling factor for font size so that actual font size is \code{par("cex")*csize}. By default \code{csize = 1}.} + \item{scale}{If \code{scale = TRUE} (the default) graduations giving plot size are displayed.} + \item{legend}{If \code{legend = TRUE} (the default) a legend for plot symbols is displayed (multivariate and marked types only).} + \item{add}{by default \code{add = FALSE}. If \code{TRUE} a new window is not created and just the points are plotted over the existing plot.} + \item{\dots}{extra arguments that will be passed to the plotting functions \code{\link{plot.default}}, \code{\link{points}} and/or \code{\link{symbols}}.} +} +\details{ +The sampling window \code{x$window} is plotted first, through a call to function \code{\link{plot.swin}}. +Then the points themselves are plotted, in a fashion that depends on the type of spatial point pattern (see \code{\link{spp}}). +\itemize{ + \item + \bold{univariate pattern:} + if \code{x$type = c("univariate")}, i.e. the point pattern does not have marks, or if \code{use.marks = FALSE}, then the locations of all + points is plotted using a single plot character. + \item + \bold{multivariate pattern:} + if \code{x$type = c("multivariate")}, i.e. the marks are levels of a factor, then each level is represented by a different plot character. + \item + \bold{marked pattern:} + if \code{x$type = c("marked")}, i.e. the marks are real numbers, then points are represented by circles (argument \code{chars = "circles"}, the default) or squares + (argument \code{chars = "squares"}) proportional to their marks' value (positive values are filled, while negative values are unfilled). + } + + Arguments \code{cols} and \code{cols.out} (if \code{out = TRUE}) determine the colour(s) used to display the points located inside and outside the sampling window, respectively. + Colours may be specified as codes or colour names (see \code{\link[graphics]{par}("col")}). For univariate and marked point patterns, \code{cols} and \code{cols.out} are single character strings, while + for multivariate point patterns they are charcater vectors of same length as \code{levels(x$marks)} and \code{levels(x$marksout)}, respectively. + + Arguments \code{chars} and \code{chars.out} (if \code{out = TRUE}) determine the symbol(s) used to display the points located inside and outside the sampling window, respectively. + Symbols may be specified as codes or character strings (see \code{\link[graphics]{par}("pch")}). For univariate point patterns, \code{chars} and \code{chars.out} are single character strings, while + for multivariate point patterns they are charcater vectors of same length as \code{levels(x$marks)} and \code{levels(x$marksout)}, respectively. For marked point patterns, + \code{chars} and \code{chars.out} can only take the value \code{"circles"} or \code{"squares"}. +} +\value{ + none. +} +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\seealso{ + \code{\link{spp}}, + \code{\link{swin}}, + \code{\link{plot.swin}}. +} +\examples{ + data(BPoirier) + BP<-BPoirier + + # a univariate point pattern in a rectangle sampling window + plot(spp(BP$trees, win=BP$rect)) + + # a univariate point pattern in a circular sampling window + #with all points and graduations displayed + plot(spp(BP$trees, win=c(55,45,45)), out=TRUE, scale=TRUE) + + # a univariate point pattern in a complex sampling window + #with points outside the sampling window displayed (in red colour) + plot(spp(BP$trees, win=BP$rect, tri=BP$tri1), out=TRUE) + + # a multivariate point pattern in a rectangle sampling window + plot(spp(BP$trees, win=BP$rect, marks=BP$species)) + + # a multivariate point pattern in a circular sampling window + #with all points inside the sampling window displayed in blue colour + #and all points outside displayed with the symbol "+" in red colour + plot(spp(BP$trees, win=c(55,45,45), marks=BP$species), out=TRUE, cols=c("blue","blue","blue"), + chars.out=c("+","+","+"), cols.out=c("red","red","red")) + + # a marked point pattern in a rectangle sampling window + #with circles in green colour + plot(spp(BP$trees, win=BP$rect, marks=BP$dbh), cols="green") + + # a marked point pattern in a circular sampling window + #with squares in red colour inside and circles in blue colour outside + plot(spp(BP$trees, win=c(55,45,45), marks=BP$dbh), out=TRUE, chars="squares", + cols="red", cols.out="blue") +} +\keyword{spatial} diff --git a/man/plot.vads.Rd b/man/plot.vads.Rd new file mode 100755 index 0000000000000000000000000000000000000000..6deced86b6eed3680ebbd1ba8e74a50f8eab9f72 --- /dev/null +++ b/man/plot.vads.Rd @@ -0,0 +1,73 @@ +\encoding{latin1} +\name{plot.vads} +\alias{plot.vads} +\alias{plot.vads.dval} +\alias{plot.vads.k12val} +\alias{plot.vads.kval} +\title{Plot local density values} +\description{ + Plot local density estimates returned by functions \code{\link{dval}, + \link{kval} or \link{k12val}}. +} +\usage{ +\method{plot}{vads}(x, main, opt, select, chars, cols, maxsize, char0, col0, legend, csize, \dots) +} +\arguments{ + \item{x}{an object of class \code{'vads'} (see Details).} + \item{main}{by default, the value of argument x, otherwise a text to be displayed as a title of the plot. \code{main=NULL} displays no title.} + \item{opt}{(optional) a character string to change the type of values to be plotted (see Details).} + \item{select}{(optional) a vector of selected distances in \code{x$r}. By default, a multiple window displays all distances.} + \item{chars}{one of \code{c("circles","squares")} plotting symbols with areas proportional to local density values. By default, circles are plotted.} + \item{cols}{(optional) the coulour used for the plotting symbols. Black colour is the default.} + \item{maxsize}{(optional) maximum size of the circles/squares plotted. By default, maxsize is automatically adjusted to plot size.} + \item{char0}{(optional) the plotting symbol used to represent null values. By default, null values are not plotted.} + \item{col0}{(optional) the coulour used for the null values plotting symbol. By default, the same as argument \code{cols}.} + \item{legend}{If \code{legend = TRUE} (the default) a legend for the plotting values is displayed.} + \item{csize}{scaling factor for font size so that actual font size is \code{par("cex")*csize}. By default \code{csize = 1}.} + \item{\dots}{extra arguments that will be passed to the plotting functions \code{\link{plot.swin}}, \cr + \code{\link{plot.default}}, \code{\link{symbols}} and/or \code{\link{points}}.} +} +\details{ +Function \code{plot.vads} displays a map of first-order local density or second-order local neighbour density values as symbols with areas proportional +to the values estimated at the plotted points. +Positive values are represented by coloured symbols, while negative values are represented by open symbols. The plotted function values depend upon the +type of \code{'vads'} object: + \itemize{ + \item + if \code{class(x)=c("vads","dval")}, the plotted values are first-order local densities and argument \code{opt="dval"} by default, but + is potentially one of \code{c("dval","cval")} returned by \code{\link{dval}}.\cr + \item + if \code{class(x)=c("vads","kval")} or \code{class(x)=c("vads","k12val")}, the plotted values are univariate or bivariate second-order + local neighbour densities. Argument \code{opt="lval"} by default, but is potentially one of \code{c("lval","kval","nval","gval")} + returned by \code{\link{kval}} and \code{\link{k12val}}. + } +} +\value{ + none. +} +\author{\email{Raphael.Pelissier@ird.fr}} +\seealso{ + \code{\link{dval}}, + \code{\link{kval}}, + \code{\link{k12val}}. +} +\examples{ + data(BPoirier) + BP <- BPoirier + # local density in a rectangle sampling window + dswr <- dval(spp(BP$trees, win=BP$rect), 25, 1, 11, 9) + plot(dswr) + # display only distance r from 5 to 10 with null symbols as red crosses + plot(dswr, select=c(5:10), char0=3, col0="red") + + # local L(r) values in a circular sampling window + lvswc <- kval(spp(BP$trees, win=c(55,45,45)), 25, 0.5) + plot(lvswc) + # display square symbols in blue for selected values of r and remove title + plot(lvswc, chars="squares", cols="blue", select=c(5,7.5,10,12.5,15), main=NULL) + + # local K12(r) values (1="beech", 2="oak") in a complex sampling window + k12swrt <- k12val(spp(BP$trees, win=BP$rect, tri=BP$tri1, marks=BP$species), 25, 1) + plot(k12swrt, opt="kval") +} +\keyword{spatial} diff --git a/man/spp.Rd b/man/spp.Rd new file mode 100755 index 0000000000000000000000000000000000000000..93c86d9f3b95a578a7e18637ceea48cea89ecff4 --- /dev/null +++ b/man/spp.Rd @@ -0,0 +1,113 @@ +\encoding{latin1} +\name{spp} +\alias{spp} +\alias{print.spp} +\alias{summary.spp} +\alias{print.summary.spp} +\alias{ppp2spp} +\title{Creating a spatial point pattern} +\description{ + Function \code{spp} creates an object of class \code{"spp"}, which represents a + spatial point pattern observed in a finite sampling window (or study region). + The \code{ads} library supports univariate, multivariate and marked point patterns + observed in simple (rectangular or circular) or complex sampling windows. +} +\usage{ +spp(x, y=NULL, window, triangles, marks, int2fac=TRUE) +ppp2spp(p) +} +\arguments{ + \item{x,y}{if \code{y=NULL}, \eqn{x} is a list of two vectors of point coordinates, else both \eqn{x} and \eqn{y} are atomic vectors of point coordinates.} + \item{window}{a \code{"swin"} object or a vector defining the limits of a simple sampling + window: \code{c(xmin,ymin,xmax,ymax)} for a rectangle ; \code{c(x0,y0,r0)} for a circle.} + \item{triangles}{(optional) a list of triangles removed from a simple initial window to define a + complex sampling window (see \code{\link{swin}}).} + \item{marks}{(optional) a vector of mark values, which may be factor levels or numerical values (see Details).} + \item{int2fac}{if TRUE, integer marks are automatically coerced into factor levels.} + \item{p}{a \code{"ppp"} object from package \code{spatstat}.} +} +\details{ +A spatial point pattern is assumed to have been observed within a specific + sampling window (a finite study region) defined by the \code{window} argument. If \code{window} is a simple \code{"swin"} object, + it may be coerced into a complex type by adding a \code{triangles} argument (see \code{\link{swin}}). A spatial point pattern may be of 3 different types. + \itemize{ + \item + \bold{univariate pattern:} + by default when argument \code{marks} is not given. + \item + \bold{multivariate pattern:} + \code{marks} is a factor, which levels are interpreted as categorical marks (e.g. colours, species, etc.) attached to points of the pattern. + Integer marks may be automatically coerced into factor levels when argument \code{int2fac = TRUE}. + \item + \bold{marked pattern:} + \code{marks} is a vector of real numbers attached to points of the pattern. Integer values may also be considered as numerical values + if argument \code{int2fac = FALSE}. + } +} +\value{ + An object of class \code{"spp"} describing a spatial point pattern observed in a given sampling window. + \item{\code{$type}}{a character string indicating if the spatial point pattern is \code{"univariate"}, \code{"multivariate"} or \code{"marked"}.} + \item{\code{$window}}{an \code{swin} object describing the sampling window (see \code{\link{swin}}).} + \item{\code{$n}}{an integer value giving the number of points of the pattern located inside the sampling window (points on the boundary are considered to be inside).} + \item{\code{$x}}{a vector of \eqn{x} coordinates of points located inside the sampling window.} + \item{\code{$y}}{a vector of \eqn{y} coordinates of points located inside the sampling window.} + \item{\code{$nout}}{(optional) an integer value giving the number of points of the pattern located outside the sampling window.} + \item{\code{$xout}}{(optional) a vector of \eqn{x} coordinates of points located outside the sampling window.} + \item{\code{$yout}}{(optional) a vector of \eqn{y} coordinates of points located outside the sampling window.} + \item{\code{$marks}}{(optional) a vector of the marks attached to points located inside the sampling window.} + \item{\code{$marksout}}{(optional) a vector of the marks attached to points located outside the sampling window.} +} +\references{ + Goreaud, F. and Pélissier, R. 1999. On explicit formula of edge effect correction for Ripley's \emph{K}-function. \emph{Journal of Vegetation Science}, 10:433-438. +} +\note{ +There are printing, summary and plotting methods for \code{"spp"} objects.\cr +Function \code{ppp2spp} converts an \code{\link[spatstat]{ppp.object}} from package \code{spatstat} into an \code{"spp"} object. +} +\seealso{ + \code{\link{plot.spp}}, + \code{\link{swin}} + } +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\examples{ + data(BPoirier) + BP <- BPoirier + # univariate pattern in a rectangle of size [0,110] x [0,90] + swr <- spp(BP$trees, win=BP$rect) + # an alternative using atomic vectors of point coordinates + #swr <- spp(BP$trees, win=BP$rect) + summary(swr) + plot(swr) + + # univariate pattern in a circle with radius 50 centred on (55,45) + swc <- spp(BP$trees, win=c(55,45,50)) + summary(swc) + plot(swc) + plot(swc, out=TRUE) # plot points outside the circle + + # multivariate pattern in a rectangle of size [0,110] x [0,90] + swrm <- spp(BP$trees, win=BP$rect, marks=BP$species) + summary(swrm) + plot(swrm) + plot(swrm, chars=c("b","h","o")) # replace symbols by letters + + # marked pattern in a rectangle of size [0,110] x [0,90] + swrn <- spp(BP$trees, win=BP$rect, marks=BP$dbh) + summary(swrn) + plot(swrn) + + # multivariate pattern in a complex sampling window + swrt <- spp(BP$trees, win=BP$rect, tri=BP$tri1, marks=BP$species) + summary(swrt) + plot(swrt) + plot(swrt, out=TRUE) # plot points outside the sampling window + + + #converting a ppp object from spatstat + data(demopat) + demo.spp<-ppp2spp(demopat) + plot(demo.spp) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/swin.Rd b/man/swin.Rd new file mode 100755 index 0000000000000000000000000000000000000000..8fcf150425aa62b076fb00a5d3134fa62a294437 --- /dev/null +++ b/man/swin.Rd @@ -0,0 +1,109 @@ +\encoding{latin1} +\name{swin} +\alias{swin} +\alias{print.swin} +\alias{summary.swin} +\alias{print.summary.swin} +\alias{plot.swin} +\alias{owin2swin} +\title{Creating a sampling window} +\description{ + Function \code{swin} creates an object of class \code{"swin"}, which represents + the sampling window (or study region) in which a spatial point pattern was + observed. The \code{ads} library supports simple (rectangular or circular) and complex + sampling windows. +} +\usage{ + swin(window, triangles) + owin2swin(w) +} +\arguments{ + \item{window}{a vector defining the limits of a simple sampling window: \code{c(xmin,ymin,xmax,ymax)} + for a rectangle ; \code{c(x0,y0,r0)} for a circle.} + \item{triangles}{(optional) a list of triangles removed from a simple initial window to define a complex + sampling window (see Details).}` + \item{w}{a \code{"owin"} object from package \code{spatstat}.} +} +\details{ +A sampling window may be of simple or complex type. A simple sampling window may be a rectangle or a circle. + A complex sampling window is defined by removing triangular surfaces from a simple (rectangular or circular) + initial sampling window. + \itemize{ + \item + \bold{rectangular window:} + \code{window=c(ximn,ymin,xmax,ymax)} a vector of length 4 giving the coordinates \eqn{(ximn,ymin)} and \eqn{(xmax,ymax)} + of the origin and the opposite corner of a rectangle. + \item + \bold{circular window:} + \code{window=c(x0,y0,r0)} a vector of length 3 giving the coordinates \eqn{(x0,y0)} + of the centre and the radius \eqn{r0} of a circle. + \item + \bold{complex window:} + \code{triangles} is a list of 6 variables giving the vertices coordinates \cr + \eqn{(ax,ay,bx,by,cx,cy)} of the triangles to remove from a simple (rectangular or circular) initial window. The triangles may be removed + near the boundary of a rectangular window in order to design a polygonal sampling window, or within a rectangle + or a circle, to delineating holes in the initial sampling window (see Examples). The triangles do not overlap each other, nor overlap boundary + of the initial sampling window. Any polygon (possibly with holes) can be decomposed into contiguous triangles using \code{\link{triangulate}}. + } +} +\value{ + An object of class \code{"swin"} describing the sampling window. It may be of four different types + with different arguments: + \item{\code{$type}}{a vector of two character strings defining the type of sampling window among \code{c("simple","rectangle")}, \code{c("simple","circle")}, \code{c("complex","rectangle")} or \code{c("complex","circle")}.} + \item{\code{$xmin,$ymin,$xmax,$ymax}}{(optional) coordinates of the origin and the opposite corner for a rectangular sampling window (see details).} + \item{\code{$x0,$y0,$r0}}{(optional) coordinates of the center and radius for a circular sampling window (see details).} + \item{\code{$triangles}}{(optional) vertices coordinates of triangles for a complex sampling window (see details).} +} +\references{ + Goreaud, F. and Pélissier, R. 1999. On explicit formula of edge effect correction for Ripley's \emph{K}-function. \emph{Journal of Vegetation Science}, 10:433-438. +} +\note{ +There are printing, summary and plotting methods for \code{"swin"} objects.\cr +Function \code{owin2swin} converts an \code{\link[spatstat]{owin.object}} from package \code{spatstat} into an \code{"swin"} object. +} +\seealso{ + \code{\link{area.swin}}, + \code{\link{inside.swin}}, + \code{\link{spp}} + } +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\examples{ + #rectangle of size [0,110] x [0,90] + wr <- swin(c(0,0,110,90)) + summary(wr) + plot(wr) + + #circle with radius 50 centred on (55,45) + wc <- swin(c(55,45,50)) + summary(wc) + plot(wc) + + # polygon (diamond shape) + t1 <- c(0,0,55,0,0,45) + t2 <- c(55,0,110,0,110,45) + t3 <- c(0,45,0,90,55,90) + t4 <- c(55,90,110,90,110,45) + wp <- swin(wr, rbind(t1,t2,t3,t4)) + summary(wp) + plot(wp) + + #rectangle with a hole + h1 <- c(25,45,55,75,85,45) + h2 <- c(25,45,55,15,85,45) + wrh <- swin(wr, rbind(h1,h2)) + summary(wrh) + plot(wrh) + + #circle with a hole + wch <- swin(wc, rbind(h1,h2)) + summary(wch) + plot(wch) + + #converting an owin object from spatstat + data(demopat) + demo.swin<-owin2swin(demopat$window) + plot(demo.swin) +} +\keyword{spatial} \ No newline at end of file diff --git a/man/triangulate.Rd b/man/triangulate.Rd new file mode 100755 index 0000000000000000000000000000000000000000..e2a4579553797a443f3b0f55fddf26dc3b14f800 --- /dev/null +++ b/man/triangulate.Rd @@ -0,0 +1,61 @@ +\encoding{latin1} +\name{triangulate} +\alias{triangulate} +\title{Triangulate polygon} +\description{ + Function \code{triangulate} decomposes a simple polygon (optionally having holes) into contiguous triangles. +} +\usage{ +triangulate(outer.poly, holes) +} +\arguments{ + \item{outer.poly}{a list with two component vectors \code{x} and \code{y} giving vertice coordinates of the polygon + or a vector \code{(xmin,ymin,xmax,ymax)} giving coordinates \eqn{(ximn,ymin)} and \eqn{(xmax,ymax)} of the origin and the + opposite corner of a rectangle sampling window (see \code{\link{swin}}). } + \item{holes}{(optional) a list (or a list of list) with two component vectors \code{x} and \code{y} giving vertices + coordinates of inner polygon(s) delineating hole(s) within the \code{outer.poly}.} +} +\details{ + In argument \code{outer.poly}, the vertices must be listed following boundary of the polygon without any repetition (i.e. do not repeat the first vertex). + Argument \code{holes} may be a list of vertices coordinates of a single hole (i.e. with \eqn{x} and \eqn{y} component vectors) or a list of list for multiple holes, + where each \code{holes[[i]]} is a list with \eqn{x} and \eqn{y} component vectors. Holes' vertices must all be inside the \code{outer.poly} boundary (vertices on the boundary + are considered outside). Multiple holes do not overlap each others. + } +\value{ + A list of 6 variables, suitable for using in \code{\link{swin}} and \code{\link{spp}}, and giving the vertices coordinates \eqn{(ax,ay,bx,by,cx,cy)} of the triangles that + pave the polygon. For a polygon with \emph{t} holes totalling \eqn{n} vertices (outer contour + holes), the number of triangles produced +is \eqn{(n-2)+2t}, with \eqn{n<200} in this version of the program. +} +\references{ + Goreaud, F. and Pélissier, R. 1999. On explicit formula of edge effect correction for Ripley's \emph{K}-function. \emph{Journal of Vegetation Science}, 10:433-438.\cr\cr + Narkhede, A. & Manocha, D. 1995. Fast polygon triangulation based on Seidel's algoritm. Pp 394-397 In A.W. Paeth (Ed.) + \emph{Graphics Gems V}. Academic Press. \url{http://www.cs.unc.edu/~dm/CODE/GEM/chapter.html}. +} +\author{ + \email{Raphael.Pelissier@ird.fr} +} +\seealso{ + \code{\link{spp}}, + \code{\link{swin}} +} +\examples{ + data(BPoirier) + BP <- BPoirier + plot(BP$poly1$x, BP$poly1$y) + + # a single polygon triangulation + tri1 <- triangulate(BP$poly1) + plot(swin(BP$rect, tri1)) + + # a single polygon with a hole + #tri2 <- triangulate(c(-10,-10,120,100), BP$poly1) + #plot(swin(c(-10,-10,120,100), tri2)) + + # the same with narrower outer polygon + #tri3 <- lapply(BP$poly2,triangulate) + #tri3<-do.call(rbind,tri3) + #xr<-range(tri3$ax,tri3$bx,tri3$cx) + #yr<-range(tri3$ay,tri3$by,tri3$cy) + #plot(swin(c(xr[1],yr[1],xr[2],yr[2]), tri3)) + } +\keyword{spatial} diff --git a/src/Zlibs.c b/src/Zlibs.c new file mode 100755 index 0000000000000000000000000000000000000000..bbc86e31e4b09192170be619b8ac6fd176e7fd3d --- /dev/null +++ b/src/Zlibs.c @@ -0,0 +1,7619 @@ +#include "adssub.h" +#include "Zlibs.h" +#include <math.h> +#include <R.h> + +/************************************************************************/ +/*Fonctions de calcul geometriques pour la correction des effets de bord*/ +/************************************************************************/ +/* a exterieur ; b et c interieur*/ +double un_point( double ax, double ay, double bx, double by, double cx, double cy, double x, double y, double d) +{ double alpha, beta, gamma, delta, ttt, ang; + double ex,ey,fx,fy; + + /*premier point d'intersection*/ + alpha=(bx-ax)*(bx-ax)+(by-ay)*(by-ay); + beta=(2*(ax-x)*(bx-ax)+2*(ay-y)*(by-ay)); + gamma=((ax-x)*(ax-x)+(ay-y)*(ay-y)-d*d); + delta=beta*beta-4*alpha*gamma; + if (delta<=0) + Rprintf("erreur1\n"); + ttt=(-beta-sqrt(delta))/(2*alpha); + if ((ttt<=0)||(ttt>=1)) + Rprintf("erreur2\n"); + ex=ax+ttt*(bx-ax); + ey=ay+ttt*(by-ay); + + /* deuxieme point d'intersection*/ + alpha=(cx-ax)*(cx-ax)+(cy-ay)*(cy-ay); + beta=(2*(ax-x)*(cx-ax)+2*(ay-y)*(cy-ay)); + delta=beta*beta-4*alpha*gamma; + if (delta<=0) + Rprintf("erreur3\n"); + ttt=(-beta-sqrt(delta))/(2*alpha); + if ((ttt<=0)||(ttt>=1)) + Rprintf("erreur4\n"); + fx=ax+ttt*(cx-ax); + fy=ay+ttt*(cy-ay); + + /*calcul de l'angle*/ + ang=bacos(((ex-x)*(fx-x)+(ey-y)*(fy-y))/(d*d)); + return ang; +} + +/* a interieur , b et c exterieur*/ +double deux_point(double ax, double ay, double bx, double by, double cx, double cy,double x, double y, double d) +{ double alpha, beta, gamma, delta, ttt, ang; + double ex,ey,fx,fy,gx,gy,hx,hy; + int cas; + + /* premier point d'intersection*/ + alpha=((bx-ax)*(bx-ax)+(by-ay)*(by-ay)); + beta=(2*(ax-x)*(bx-ax)+2*(ay-y)*(by-ay)); + gamma=((ax-x)*(ax-x)+(ay-y)*(ay-y)-d*d); + delta=beta*beta-4*alpha*gamma; + if (delta<=0) + Rprintf("erreur6\n"); + ttt=(-beta+sqrt(delta))/(2*alpha); + if ((ttt<=0)||(ttt>=1)) + Rprintf("erreur7\n"); + ex=ax+ttt*(bx-ax); + ey=ay+ttt*(by-ay); + + /* deuxieme point d'intersection*/ + alpha=((cx-ax)*(cx-ax)+(cy-ay)*(cy-ay)); + beta=(2*(ax-x)*(cx-ax)+2*(ay-y)*(cy-ay)); + delta=beta*beta-4*alpha*gamma; + if (delta<=0) + Rprintf("erreur8\n"); + ttt=(-beta+sqrt(delta))/(2*alpha); + if ((ttt<=0)||(ttt>=1)) + Rprintf("erreur9\n"); + fx=ax+ttt*(cx-ax); + fy=ay+ttt*(cy-ay); + + /* y a t il deux autres intersections?*/ + cas=0; + alpha=((cx-bx)*(cx-bx)+(cy-by)*(cy-by)); + beta=(2*(bx-x)*(cx-bx)+2*(by-y)*(cy-by)); + gamma=((bx-x)*(bx-x)+(by-y)*(by-y)-d*d); + delta=beta*beta-4*alpha*gamma; + if (delta>0) + { ttt=(-beta-sqrt(delta))/(2*alpha); + if ((ttt>=0)&&(ttt<=1)) + { gx=bx+ttt*(cx-bx); + gy=by+ttt*(cy-by); + ttt=(-beta+sqrt(delta))/(2*alpha); + if ((ttt>=0)&&(ttt<=1)) + { cas=1; + hx=bx+ttt*(cx-bx); + hy=by+ttt*(cy-by); + } + else + Rprintf("erreur9bis\n"); + } + } + + /* calcul de l'angle*/ + if (cas==0) + ang=bacos(((ex-x)*(fx-x)+(ey-y)*(fy-y))/(d*d)); + else + { ang=bacos(((ex-x)*(gx-x)+(ey-y)*(gy-y))/(d*d)); + ang+=bacos(((fx-x)*(hx-x)+(fy-y)*(hy-y))/(d*d)); + } + + return ang; +} + +/* a exterieur, b interieur, c sur le bord*/ +double ununun_point(double ax, double ay, double bx, double by, double cx, double cy, double x, double y, double d) +{ double alpha, beta, gamma, delta, ttt, ang; + double ex,ey,fx,fy; + + /* premier point d'intersection sur ab*/ + alpha=(bx-ax)*(bx-ax)+(by-ay)*(by-ay); + beta=(2*(ax-x)*(bx-ax)+2*(ay-y)*(by-ay)); + gamma=((ax-x)*(ax-x)+(ay-y)*(ay-y)-d*d); + delta=beta*beta-4*alpha*gamma; + if (delta<=0) + Rprintf("erreur1b\n"); + ttt=(-beta-sqrt(delta))/(2*alpha); + if ((ttt<=0)||(ttt>=1)) + Rprintf("erreur2b\n"); + ex=ax+ttt*(bx-ax); + ey=ay+ttt*(by-ay); + + /* deuxieme point d'intersection ac*/ + alpha=(cx-ax)*(cx-ax)+(cy-ay)*(cy-ay); + beta=(2*(ax-x)*(cx-ax)+2*(ay-y)*(cy-ay)); + delta=beta*beta-4*alpha*gamma; + ttt=1; + if (delta>0) + { ttt=(-beta-sqrt(delta))/(2*alpha); + if ((ttt<=0)||(ttt>1)) + ttt=1; + if (ttt<=0) + Rprintf("e3b\n"); + } + fx=ax+ttt*(cx-ax); + fy=ay+ttt*(cy-ay); + + /* calcul de l'angle*/ + ang=bacos(((ex-x)*(fx-x)+(ey-y)*(fy-y))/(d*d)); + return ang; +} + +/* a,b et c exterieurs*/ +double trois_point(double ax, double ay, double bx, double by, double cx, double cy, double x, double y, double d) +{ double alpha, beta, gamma, delta, te,tf,tg,th,ti,tj, ang; + double ex=0,ey=0,fx=0,fy=0,gx=0,gy=0,hx=0,hy=0,ix=0,iy=0,jx=0,jy=0; + + /* premier segment ab*/ + alpha=(bx-ax)*(bx-ax)+(by-ay)*(by-ay); + beta=2*(ax-x)*(bx-ax)+2*(ay-y)*(by-ay); + gamma=(ax-x)*(ax-x)+(ay-y)*(ay-y)-d*d; + delta=beta*beta-4*alpha*gamma; + if (delta<0) + { te=-1; + tf=-1; + } + else + { te=(-beta-sqrt(delta))/(2*alpha); + tf=(-beta+sqrt(delta))/(2*alpha); + if ((te<0)||(te>=1)||(tf==0)) + { te=-1; + tf=-1; + } + else + { ex=ax+te*(bx-ax); + ey=ay+te*(by-ay); + fx=ax+tf*(bx-ax); + fy=ay+tf*(by-ay); + if ((tf<=0)||(tf>1)) + Rprintf("pb te %f tf %f\n",te,tf); + } + } + + /* deuxieme segment bc*/ + alpha=(cx-bx)*(cx-bx)+(cy-by)*(cy-by); + beta=2*(bx-x)*(cx-bx)+2*(by-y)*(cy-by); + gamma=(bx-x)*(bx-x)+(by-y)*(by-y)-d*d; + delta=beta*beta-4*alpha*gamma; + if (delta<0) + { tg=-1; + th=-1; + } + else + { tg=(-beta-sqrt(delta))/(2*alpha); + th=(-beta+sqrt(delta))/(2*alpha); + if ((tg<0)||(tg>=1)||(th==0)) + { tg=-1; + th=-1; + } + else + { gx=bx+tg*(cx-bx); + gy=by+tg*(cy-by); + hx=bx+th*(cx-bx); + hy=by+th*(cy-by); + if ((th<=0)||(th>1)) + Rprintf("pb tg %f th %f\n",tg,th); + } + } + + /* troisieme segment ca*/ + alpha=(ax-cx)*(ax-cx)+(ay-cy)*(ay-cy); + beta=2*(cx-x)*(ax-cx)+2*(cy-y)*(ay-cy); + gamma=(cx-x)*(cx-x)+(cy-y)*(cy-y)-d*d; + delta=beta*beta-4*alpha*gamma; + if (delta<0) + { ti=-1; + tj=-1; + } + else + { ti=(-beta-sqrt(delta))/(2*alpha); + tj=(-beta+sqrt(delta))/(2*alpha); + if ((ti<0)||(ti>=1)||(tj==0)) + { ti=-1; + tj=-1; + } + else + { ix=cx+ti*(ax-cx); + iy=cy+ti*(ay-cy); + jx=cx+tj*(ax-cx); + jy=cy+tj*(ay-cy); + if ((tj<=0)||(tj>1)) + Rprintf("pb ti %f tj %f\n",ti,tj); + } + } + + /* quelle configuration ?*/ + if (te<0) + { if (tg<0) + { if (ti<0) + /* pas d'intersection... ouf!*/ + ang=0; + else + /* un seul cote (ca) coupe le cercle en i,j*/ + ang=bacos(((ix-x)*(jx-x)+(iy-y)*(jy-y))/(d*d)); + } + else + { if (ti<0) + /* un seul cote (bc) coupe le cercle en g,h*/ + ang=bacos(((gx-x)*(hx-x)+(gy-y)*(hy-y))/(d*d)); + else + { /* deux cotes (bc et ca) coupent le cercle en g,h,i,j*/ + ang=bacos(((gx-x)*(jx-x)+(gy-y)*(jy-y))/(d*d)); + ang+=bacos(((hx-x)*(ix-x)+(hy-y)*(iy-y))/(d*d)); + } + } + } + else + { if (tg<0) + { if (ti<0) + /* un seul cote (ab) coupe le cercle en e,f*/ + ang=bacos(((ex-x)*(fx-x)+(ey-y)*(fy-y))/(d*d)); + else + { /* deux cotes (ab et ca) coupent le cercle en e,f,i,j*/ + ang=bacos(((ex-x)*(jx-x)+(ey-y)*(jy-y))/(d*d)); + ang+=bacos(((fx-x)*(ix-x)+(fy-y)*(iy-y))/(d*d)); + } + } + else + { if (ti<0) + { /* deux cotes (ab et bc) coupent le cercle en e,f,g,h*/ + ang=bacos(((ex-x)*(hx-x)+(ey-y)*(hy-y))/(d*d)); + ang+=bacos(((fx-x)*(gx-x)+(fy-y)*(gy-y))/(d*d)); + } + else + { /* les trois cotes coupent le cercle*/ + ang=bacos(((ex-x)*(jx-x)+(ey-y)*(jy-y))/(d*d)); + ang+=bacos(((hx-x)*(ix-x)+(hy-y)*(iy-y))/(d*d)); + ang+=bacos(((fx-x)*(gx-x)+(fy-y)*(gy-y))/(d*d)); + } + } + } + + /*if ((ang<0)||(ang>Pi()))*/ + if ((ang<0)||(ang>3.141593)) + Rprintf("erreur12 : ang=%11.10f, %d %d %d %d %d %d\n",ang,te,tf,tg,th,ti,tj); + + return ang; +} + +/* a est le point sur le bord , b et c exterieur*/ +double deuxun_point(double ax, double ay, double bx, double by, double cx, double cy,double x, double y, double d) +{ double alpha, beta, gamma, delta, te,tf,tg,th, ang; + double ex,ey,fx,fy,gx,gy,hx,hy; + int cas; + + /* premier point d'intersection*/ + alpha=((bx-ax)*(bx-ax)+(by-ay)*(by-ay)); + beta=(2*(ax-x)*(bx-ax)+2*(ay-y)*(by-ay)); + gamma=((ax-x)*(ax-x)+(ay-y)*(ay-y)-d*d); + delta=beta*beta-4*alpha*gamma; + te=0; + if (delta>0) + { te=(-beta+sqrt(delta))/(2*alpha); + if ((te<0)||(te>=1)) + te=0; + if (te>=1) + Rprintf("e15\n"); + } + ex=ax+te*(bx-ax); + ey=ay+te*(by-ay); + + /* deuxieme point d'intersection*/ + alpha=((cx-ax)*(cx-ax)+(cy-ay)*(cy-ay)); + beta=(2*(ax-x)*(cx-ax)+2*(ay-y)*(cy-ay)); + delta=beta*beta-4*alpha*gamma; + tf=0; + if (delta>0) + { tf=(-beta+sqrt(delta))/(2*alpha); + if ((tf<0)||(tf>=1)) + tf=0; + if (tf>=1) + Rprintf("e15\n"); + } + fx=ax+tf*(cx-ax); + fy=ay+tf*(cy-ay); + + /* y a t il deux autres intersections?*/ + cas=0; + alpha=((cx-bx)*(cx-bx)+(cy-by)*(cy-by)); + beta=(2*(bx-x)*(cx-bx)+2*(by-y)*(cy-by)); + gamma=((bx-x)*(bx-x)+(by-y)*(by-y)-d*d); + delta=beta*beta-4*alpha*gamma; + if (delta>0) + { tg=(-beta-sqrt(delta))/(2*alpha); + if ((tg>=0)&&(tg<=1)) + { gx=bx+tg*(cx-bx); + gy=by+tg*(cy-by); + th=(-beta+sqrt(delta))/(2*alpha); + if ((th>=0)&&(th<=1)) + { cas=1; + hx=bx+th*(cx-bx); + hy=by+th*(cy-by); + } + else + Rprintf("erreur9ter\n"); + } + } + + /* calcul de l'angle*/ + if (cas==0) + { if ((te==0)&&(tf==0)) + ang=0; + else + ang=bacos(((ex-x)*(fx-x)+(ey-y)*(fy-y))/(d*d)); + } + else + { ang=bacos(((ex-x)*(gx-x)+(ey-y)*(gy-y))/(d*d)); + ang+=bacos(((fx-x)*(hx-x)+(fy-y)*(hy-y))/(d*d)); + } + return ang; +} + +/* a exterieur, b et c sur le bord*/ +double deuxbord_point(double ax, double ay, double bx, double by, double cx, double cy, double x, double y, double d) +{ double alpha, beta, gamma, delta, te,tf, ang; + double ex,ey,fx,fy; + + /* premier point d'intersection sur ab*/ + alpha=(bx-ax)*(bx-ax)+(by-ay)*(by-ay); + beta=(2*(ax-x)*(bx-ax)+2*(ay-y)*(by-ay)); + gamma=((ax-x)*(ax-x)+(ay-y)*(ay-y)-d*d); + delta=beta*beta-4*alpha*gamma; + te=1; + if (delta>0) + { te=(-beta-sqrt(delta))/(2*alpha); + if ((te<=0)||(te>=1)) + te=1; + if (te<=0) + Rprintf("e1t\n"); + } + ex=ax+te*(bx-ax); + ey=ay+te*(by-ay); + + /* deuxieme point d'intersection ac*/ + alpha=(cx-ax)*(cx-ax)+(cy-ay)*(cy-ay); + beta=(2*(ax-x)*(cx-ax)+2*(ay-y)*(cy-ay)); + delta=beta*beta-4*alpha*gamma; + tf=1; + if (delta>0) + { tf=(-beta-sqrt(delta))/(2*alpha); + if ((tf<=0)||(tf>=1)) + tf=1; + if (tf<=0) + Rprintf("e4t\n"); + } + fx=ax+tf*(cx-ax); + fy=ay+tf*(cy-ay); + + /* calcul de l'angle*/ + ang=bacos(((ex-x)*(fx-x)+(ey-y)*(fy-y))/(d*d)); + return ang; +} + +/*retourne 1 si le point x,y est du meme cote de la droite (ab) que c (seg=0) ou sur la droite (seg=1)*/ +int in_droite(double x,double y,double ax,double ay,double bx,double by,double cx,double cy,int seg) +{ double vabx,vaby,vacx,vacy,vamx,vamy,pv1,pv2; + + vabx=bx-ax; + vaby=by-ay; + vacx=cx-ax; + vacy=cy-ay; + vamx=x-ax; + vamy=y-ay; + pv1=vabx*vacy-vaby*vacx; + pv2=vabx*vamy-vaby*vamx; + + if(seg==0) + { if (((pv1>0)&&(pv2>0))||((pv1<0)&&(pv2<0))) /*pour overlap*/ + return 1; + else + return 0; + } + if(seg==1) + { if (((pv1>0)&&(pv2>=0))||((pv1<0)&&(pv2<=0))) /*pour points*/ + return 1; + else + return 0; + } + return -1; +} + +/*retourne 1 si (x,y) est dans le triangle abc (seg=0) ou sur ses bords (seg=1)*/ +int in_triangle(double x,double y,double ax,double ay,double bx,double by,double cx,double cy,int seg) +{ int res; + + res=0; + if (in_droite(x,y,ax,ay,bx,by,cx,cy,seg)==1) + if (in_droite(x,y,bx,by,cx,cy,ax,ay,seg)==1) + if (in_droite(x,y,cx,cy,ax,ay,bx,by,seg)==1) + res=1; + return res; +} + +/*Range les resultats pour l'ic*/ +void ic(int i,int i0,double **gic,double **kic,double *gic1,double *kic1,int nbInt) { + int j,cro; + double mer; + + /*On stocke les 2i0+1 premieres valeurs en les triant au fur et a mesure*/ + if (i<=2*i0+1) { + + for(j=1;j<=nbInt;j++) { + gic[j][i]=gic1[j-1]; + kic[j][i]=kic1[j-1]; + } + + /*De la deuxieme a la 2i0+1 eme valeur : on trie la nouvelle valeur en direct*/ + if (i>1) { + + /*Tri bulle de g vers le bas*/ + for(j=1;j<=nbInt;j++) { + if (gic[j][i-1]>gic[j][i]) { + mer=gic[j][i]; + cro=i-1; + while ((cro>0)&&(gic[j][cro]>mer)){ + gic[j][cro+1]=gic[j][cro]; + cro=cro-1; + } + gic[j][cro+1]=mer; + } + } + + /*Tri bulle de k vers le bas*/ + for(j=1;j<=nbInt;j++) { + if (kic[j][i-1]>kic[j][i]) { + mer=kic[j][i]; + cro=i-1; + while ((cro>0)&&(kic[j][cro]>mer)){ + kic[j][cro+1]=kic[j][cro]; + cro=cro-1; + } + kic[j][cro+1]=mer; + } + } + } + } + else { + /*On a deja rempli et trie le tableau des 2i0+1 valeurs, on met la nouvelle valeur en i0*/ + for(j=1;j<=nbInt;j++) { + gic[j][i0+1]=gic1[j-1]; + kic[j][i0+1]=kic1[j-1]; + } + + /*On trie les nouvelles valeurs de k et g*/ + for(j=1;j<=nbInt;j++) { + + /* si g doit descendre*/ + if (gic[j][i0+1]<gic[j][i0]) { + mer=gic[j][i0+1]; + cro=i0; + while ((cro>0)&&(gic[j][cro]>mer)) + { gic[j][cro+1]=gic[j][cro]; + cro=cro-1; + } + gic[j][cro+1]=mer; + } + /* si g doit monter*/ + else { + if (gic[j][i0+1]>gic[j][i0+2]) { + mer=gic[j][i0+1]; + cro=i0+2; + while ((cro<2*i0+2)&&(gic[j][cro]<mer)) + { gic[j][cro-1]=gic[j][cro]; + cro=cro+1; + } + gic[j][cro-1]=mer; + } + } + + /* si k doit descendre*/ + if (kic[j][i0+1]<kic[j][i0]) { + mer=kic[j][i0+1]; + cro=i0; + while ((cro>0)&&(kic[j][cro]>mer)) + { kic[j][cro+1]=kic[j][cro]; + cro=cro-1; + } + kic[j][cro+1]=mer; + } + /* si k doit monter*/ + else { + if (kic[j][i0+1]>kic[j][i0+2]) { + mer=kic[j][i0+1]; + cro=i0+2; + while ((cro<2*i0+2)&&(kic[j][cro]<mer)) + { kic[j][cro-1]=kic[j][cro]; + cro=cro+1; + } + kic[j][cro-1]=mer; + } + } + } + } +} + +/******************************************************************************/ +/* Cette routine donne le perimetre/ddd du cercle centre en (xxx,yyy) et */ +/* de rayon ddd, qui est a l'interieur de la zone rectangulaire xmi xma ymiyma*/ +/* Elle traite les cas 1 bord, 2 bords d'angle (2), 2 bords opposes, 3 bords */ +/* Ce resultat correspond a la correction des effets de bord pour Ripley */ +/******************************************************************************/ +double perim_in_rect(double xxx, double yyy, double ddd, double xmi, double xma, double ymi, double yma) +{ double d1,d2,d3,d4; + + if ((xxx>=xmi+ddd)&&(yyy>=ymi+ddd)&&(xxx<=xma-ddd)&&(yyy<=yma-ddd)) + { /*Rprintf("*");*/ + return 2*Pi(); + } + else + { d1=(xxx-xmi)/ddd; + d2=(yyy-ymi)/ddd; + d3=(xma-xxx)/ddd; + d4=(yma-yyy)/ddd; + if (d1>=1) + { if (d2>=1) + { if (d3>=1) + { if (d4>=1) /* cercle dans le rectangle */ + { return 2*Pi(); + } + else /* bord seul en d4 */ + { + return (2*(Pi()-acos(d4))); + } + } + else + { if (d4>=1) /* bord seul en d3 */ + { + return (2*(Pi()-acos(d3))); + } + else /* 2 bords d3 et d4 */ + { + if (d3*d3+d4*d4<1) + { + return (1.5*Pi()-acos(d3)-acos(d4)); + } + else + { + return (2*(Pi()-acos(d3)-acos(d4))); + } + } + } + } + else + { if (d3>=1) + { if (d4>=1) /* bord seul en d2 */ + { + return (2*(Pi()-acos(d2))); + } + else /* 2 bords d2 et d4 */ + { + return (2*(Pi()-acos(d2)-acos(d4))); + } + } + else + { if (d4>=1) /* 2 bords d2 et d3 */ + { if (d2*d2+d3*d3<1) + { + return ((1.5*Pi()-acos(d2)-acos(d3))); + } + else + { + return (2*(Pi()-acos(d2)-acos(d3))); + } + } + else /* 3 bords d2,d3,d4 */ + { if (d2*d2+d3*d3<1) + { if (d3*d3+d4*d4<1) + { + return((Pi()-acos(d2)-acos(d4))); + } + else + { + return((1.5*Pi()-acos(d2)-acos(d3)-2*acos(d4))); + } + } + else + { if (d3*d3+d4*d4<1) + { + return((1.5*Pi()-2*acos(d2)-acos(d3)-acos(d4))); + } + else + { + return(2*(Pi()-acos(d2)-acos(d3)-acos(d4))); + } + } + } + } + } + } + else + { + if (d2>=1) + { + if (d3>=1) + { + if (d4>=1) /* bord seul en d1 */ + { + return (2*(Pi()-acos(d1))); + } + else /* 2 bords d1 et d4 */ + { + if (d1*d1+d4*d4<1) + { + return ((1.5*Pi()-acos(d1)-acos(d4))); + } + else + { + return (2*(Pi()-acos(d1)-acos(d4))); + } + } + } + else + { if (d4>=1) /* 2 bords d1 et d3 */ + { + return (2*(Pi()-acos(d1)-acos(d3))); + } + else /* 3 bords d1,d3,d4 */ + { + if (d3*d3+d4*d4<1) + { if (d4*d4+d1*d1<1) + { + return ((Pi()-acos(d3)-acos(d1))); + } + else + { + return ((1.5*Pi()-acos(d3)-acos(d4)-2*acos(d1))); + } + } + else + { + if (d4*d4+d1*d1<1) + { + return ((1.5*Pi()-2*acos(d3)-acos(d4)-acos(d1))); + } + else + { + return (2*(Pi()-acos(d3)-acos(d4)-acos(d1))); + } + } + } + } + } + else + { + if (d3>=1) + { + if (d4>=1) /* 2 bords d1 et d2 */ + { + if (d1*d1+d2*d2<1) + { + return ((1.5*Pi()-acos(d1)-acos(d2))); + } + else + { + return (2*(Pi()-acos(d1)-acos(d2))); + } + } + else /* 3 bords d1,d2,d4 */ + { + if (d4*d4+d1*d1<1) + { + if (d1*d1+d2*d2<1) + { + return ((Pi()-acos(d4)-acos(d2))); + } + else + { + return ((1.5*Pi()-acos(d4)-acos(d1)-2*acos(d2))); + } + } + else + { + if (d1*d1+d2*d2<1) + { + return ((1.5*Pi()-2*acos(d4)-acos(d1)-acos(d2))); + } + else + { + return (2*(Pi()-acos(d4)-acos(d1)-acos(d2))); + } + } + } + } + else + { if (d4>=1) /* 3 bords d1,d2,d3 */ + { if (d1*d1+d2*d2<1) + { if (d2*d2+d3*d3<1) + { return ((Pi()-acos(d1)-acos(d3))); + } + else + { return ((1.5*Pi()-acos(d1)-acos(d2)-2*acos(d3))); + } + } + else + { if (d2*d2+d3*d3<1) + { return ((1.5*Pi()-2*acos(d1)-acos(d2)-acos(d3))); + } + else + { return (2*(Pi()-acos(d1)-acos(d2)-acos(d3))); + } + } + } + else /* 4 bords : je ne peux pas faire */ + { Rprintf("erreur : le nombre d'intervalles est trop grand\n"); + return -1; + } + } + } + } + } +} + +/*pour une zone circulaire definie par x0, y0, r0*/ +double perim_in_disq(double xxx, double yyy, double ddd, + double x0, double y0,double r0) +{ double d1; + + d1=sqrt((xxx-x0)*(xxx-x0)+(yyy-y0)*(yyy-y0)); + if (d1+ddd<=r0) + return 2*Pi(); + else + return 2*(Pi()-acos((r0*r0-d1*d1-ddd*ddd)/(2*d1*ddd))); +} + +/* renvoie la somme des angles du perim a l'interieur des triangles*/ +double perim_triangle(double x,double y, double d, int triangle_nb, double *ax,double *ay, double *bx, double *by, double *cx, double *cy) +{ double angle, epsilon; + double doa,dob,doc; + int h; + //int i; + + epsilon=0.0001; + angle=0; + + + for(h=0;h<triangle_nb;h++) + { doa=sqrt((x-ax[h])*(x-ax[h])+(y-ay[h])*(y-ay[h])); + dob=sqrt((x-bx[h])*(x-bx[h])+(y-by[h])*(y-by[h])); + doc=sqrt((x-cx[h])*(x-cx[h])+(y-cy[h])*(y-cy[h])); + + if (doa-d<-epsilon) + { if (dob-d<-epsilon) + { if (doc-d<-epsilon) + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + else if (doc-d>epsilon) + angle+=un_point(cx[h],cy[h],ax[h],ay[h],bx[h],by[h],x,y,d); + else + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + } + else if (dob-d>epsilon) + { if (doc-d<-epsilon) + angle+=un_point(bx[h],by[h],ax[h],ay[h],cx[h],cy[h],x,y,d); + else if (doc-d>epsilon) + angle+=deux_point(ax[h],ay[h],bx[h],by[h],cx[h],cy[h],x,y,d); + else + angle+=ununun_point(bx[h],by[h],ax[h],ay[h],cx[h],cy[h],x,y,d); + } + else /* b sur le bord*/ + { if (doc-d<-epsilon) + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + else if (doc-d>epsilon) + angle+=ununun_point(cx[h],cy[h],ax[h],ay[h],bx[h],by[h],x,y,d); + else + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + } + } + else if (doa-d>epsilon) + { if (dob-d<-epsilon) + { if (doc-d<-epsilon) + angle+=un_point(ax[h],ay[h],bx[h],by[h],cx[h],cy[h],x,y,d); + else if (doc-d>epsilon) + angle+=deux_point(bx[h],by[h],ax[h],ay[h],cx[h],cy[h],x,y,d); + else + angle+=ununun_point(ax[h],ay[h],bx[h],by[h],cx[h],cy[h],x,y,d); + } + else if (dob-d>epsilon) + { if (doc-d<-epsilon) + angle+=deux_point(cx[h],cy[h],ax[h],ay[h],bx[h],by[h],x,y,d); + else if (doc-d>epsilon) + angle+=trois_point(ax[h],ay[h],bx[h],by[h],cx[h],cy[h],x,y,d); + else + angle+=deuxun_point(cx[h],cy[h],ax[h],ay[h],bx[h],by[h],x,y,d); + } + else /* b sur le bord*/ + { if (doc-d<-epsilon) + angle+=ununun_point(ax[h],ay[h],cx[h],cy[h],bx[h],by[h],x,y,d); + else if (doc-d>epsilon) + angle+=deuxun_point(bx[h],by[h],ax[h],ay[h],cx[h],cy[h],x,y,d); + else + angle+=deuxbord_point(ax[h],ay[h],bx[h],by[h],cx[h],cy[h],x,y,d); + } + } + else /* a sur le bord*/ + { if (dob-d<-epsilon) + { if (doc-d<-epsilon) + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + else if (doc-d>epsilon) + angle+=ununun_point(cx[h],cy[h],bx[h],by[h],ax[h],ay[h],x,y,d); + else + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + } + else if (dob-d>epsilon) + { if (doc-d<-epsilon) + angle+=ununun_point(bx[h],by[h],cx[h],cy[h],ax[h],ay[h],x,y,d); + else if (doc-d>epsilon) + angle+=deuxun_point(ax[h],ay[h],bx[h],by[h],cx[h],cy[h],x,y,d); + else + angle+=deuxbord_point(bx[h],by[h],ax[h],ay[h],cx[h],cy[h],x,y,d); + } + else /* b sur le bord*/ + { if (doc-d<-epsilon) + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + else if (doc-d>epsilon) + angle+=deuxbord_point(cx[h],cy[h],ax[h],ay[h],bx[h],by[h],x,y,d); + else + //i=1 + ; /* le triangle est dans le cercle, TVB*/ + } + } + } + + return angle; +} + + + + + + +/******************************************************************************/ +/* Calcule la fonction de Ripley K(r) pour un semis (x,y) en parametres */ +/* dans une zone de forme rectangulaire de bornes xmi xma ymi yma */ +/* Les corrections des effets de bords sont fait par la methode de Ripley, */ +/* i.e. l'inverse de la proportion d'arc de cercle inclu dans la fenetre. */ +/* Les calculs sont faits pour les t2 premiers intervalles de largeur dt. */ +/* La routine calcule g, densite des couples de points; et la fonction K */ +/* Les resultats sont stockes dans des tableaux g et k donnes en parametres */ +/******************************************************************************/ + +int ripley_rect(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi,double *yma, +int *t2,double *dt,double *g,double *k) +{ int i,j,tt; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRect(*point_nb,x,y,xmi,xma,ymi,yma); + + /* On rangera dans g le nombre de couples de points par distance tt*/ + for(tt=0;tt<*t2;tt++) + { g[tt]=0; + } + + /*On regarde les couples (i,j) et (j,i) : donc pour i>j seulement*/ + for(i=1;i<*point_nb;i++) + { for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)){ + /* dans quelle classe de distance est ce couple ?*/ + tt=d/(*dt); + + /*pour [i,j] : correction des effets de bord*/ + cin=perim_in_rect(x[i],y[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) + { Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + + /* pour [j,i] : correction des effets de bord*/ + cin=perim_in_rect(x[j],y[j],d,*xmi,*xma,*ymi,*yma); + if (cin<0) + { Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) { + g[tt]=g[tt]/(*point_nb); + } + + /* on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++) + { k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*fonction de Ripley pour une zone circulaire*/ +int ripley_disq(int *point_nb, double *x, double *y, double *x0, double *y0, double *r0, +int *t2, double *dt, double *g, double *k) +{ int tt,i,j; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCirc(*point_nb,x,y,x0,y0,*r0); + + for(tt=0;tt<*t2;tt++) { + g[tt]=0; + } + for(i=1;i<*point_nb;i++) { /*On calcule le nombre de couples de points par distance g*/ + for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + + /*pour [i,j] : correction des effets de bord*/ + cin=perim_in_disq(x[i],y[i],d,*x0,*y0,*r0); + if (cin<0) + { Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_disq(x[j],y[j],d,*x0,*y0,*r0); + if (cin<0) + { Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) + { g[tt]=g[tt]/(*point_nb); + } + + /* on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++) + { k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*Ripley triangles dans rectangle*/ +int ripley_tr_rect(int *point_nb, double *x, double *y, double *xmi, double *xma, double *ymi, double *yma, +int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2, double *dt, double *g, double *k) +{ int i,j,tt; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRectTri(*point_nb,x,y,xmi,xma,ymi,yma,*triangle_nb,ax,ay,bx,by,cx,cy); + + /* On calcule le nombre de couples de points par distance g*/ + for(tt=0;tt<*t2;tt++) + { g[tt]=0; + } + for(i=1;i<*point_nb;i++) + for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + + /*pour [i,j] : correction des effets de bord*/ + cin=perim_in_rect(x[i],y[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) + { Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[i],y[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) + { Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_rect(x[j],y[j],d,*xmi,*xma,*ymi,*yma); + if (cin<0) + { Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[j],y[j],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) + { Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) { + g[tt]=g[tt]/(*point_nb); + } + + /* on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++) { + k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*Ripley triangle dans disque*/ +int ripley_tr_disq(int *point_nb,double *x,double *y,double *x0,double *y0,double *r0,int *triangle_nb, +double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,double *g,double *k) +{ int i,j,tt; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCircTri(*point_nb,x,y,x0,y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy); + + /* On calcule le nombre de couples de points par distance g*/ + for(tt=0;tt<*t2;tt++) + { g[tt]=0; + } + for(i=1;i<*point_nb;i++) + for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + + /* pour [i,j] : correction des effets de bord*/ + cin=perim_in_disq(x[i],y[i],d,*x0,*y0,*r0); + if (cin<0) + { Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[i],y[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) + { Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + + /* pour [j,i] : correction des effets de bord*/ + cin=perim_in_disq(x[j],y[j],d,*x0,*y0,*r0); + if (cin<0) + { Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[j],y[j],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) + { Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) + { g[tt]=g[tt]/(*point_nb); + } + + /* on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++) + { k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*fonction de Ripley avec intervalle de confiance pour une zone rectangulaire*/ +int ripley_rect_ic(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi,double *yma,double *densite, +int *t2,double *dt,int *nbSimu, double *prec, double *lev,double *g,double *k, +double *gic1,double *gic2, double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) { + int i,j,i0,i1,i2; + double **gic,**kic; + double *gg,*kk,*ll,*nn; + int erreur=0; + + erreur=ripley_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + { return -1; + } + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) + { gg[i]=g[i]/(*densite*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/(*densite); + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + int lp=0; + + /*boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) + { s_alea_rect(*point_nb,x,y,*xmi,*xma,*ymi,*yma,*prec); + erreur=ripley_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,gic1,kic1); + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) + { i=i-1; + Rprintf("ERREUR Ripley\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) + { gictmp=gic1[j]/(*densite*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/(*densite); + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-*densite)<=(float)fabs(nictmp-*densite)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)fabs(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + + /*Traitement des resultats*/ + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux resultats*/ + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + + return 0; +} + +/*fonction de Ripley avec intervalle de confiance pour une zone circulaire*/ +int ripley_disq_ic(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0,double *densite, +int *t2,double *dt,int *nbSimu, double *prec, double *lev,double *g,double *k, +double *gic1,double *gic2, double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) +{ + int i,j,i0,i1,i2; + double **gic,**kic; + double *gg,*kk,*ll,*nn; + int erreur=0; + + erreur=ripley_disq(point_nb,x,y,x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + { return -1; + } + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) { + gg[i]=g[i]/(*densite*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/(*densite); + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + int lp=0; + + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + s_alea_disq(*point_nb,x,y,*x0,*y0,*r0,*prec); + erreur=ripley_disq(point_nb,x,y,x0,y0,r0,t2,dt,gic1,kic1); + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) + { i--; + Rprintf("ERREUR Ripley\n"); + } + else + { /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) + { gictmp=gic1[j]/(*densite*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/(*densite); + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-*densite)<=(float)fabs(nictmp-*densite)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)fabs(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + + /*Traitement des resultats*/ + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux resultats*/ + for(i=0;i<*t2;i++) { + gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + + return 0; +} + +/*fonction de Ripley avec intervalle de confiance pour une zone rectangulaire + triangles*/ +int ripley_tr_rect_ic(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi,double *yma,double *densite, +int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2,double *dt,int *nbSimu, double *prec, double *lev,double *g,double *k, +double *gic1,double *gic2, double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) { + int i,j,i0,i1,i2; + double **gic,**kic; + double *gg,*kk,*ll,*nn; + int erreur=0; + + erreur=ripley_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) { + return -1; + } + + /* definition de i0 : indice ou sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) + { gg[i]=g[i]/(*densite*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/(*densite); + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + int lp=0; + + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) + { s_alea_tr_rect(*point_nb,x,y,*xmi,*xma,*ymi,*yma,*triangle_nb,ax,ay,bx,by,cx,cy,*prec); + erreur=ripley_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) + { i=i-1; + Rprintf("ERREUR Ripley\n"); + } + else + { /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) + { gictmp=gic1[j]/(*densite*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/(*densite); + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-*densite)<=(float)fabs(nictmp-*densite)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)fabs(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + + /*Traitement des resultats*/ + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux resultats*/ + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + + return 0; +} + +/*fonction de Ripley avec intervalle de confiance pour une zone circulaire + triangles*/ +int ripley_tr_disq_ic(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0,double *densite, +int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2,double *dt,int *nbSimu, double *prec, double *lev,double *g,double *k, +double *gic1,double *gic2, double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) +{ int i,j,i0,i1,i2; + double **gic,**kic; + double *gg,*kk,*ll,*nn; + int erreur=0; + + erreur=ripley_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { return -1; + } + + /* definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) + { gg[i]=g[i]/(*densite*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/(*densite); + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + int lp=0; + + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + + s_alea_tr_disq(*point_nb,x,y,*x0,*y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy,*prec); + erreur=ripley_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR Ripley\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) + { gictmp=gic1[j]/(*densite*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/(*densite); + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-*densite)<=(float)fabs(nictmp-*densite)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)fabs(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + + /*Traitement des résultats*/ + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + + return 0; +} + +/*fonction de Ripley locale pour une zone rectangulaire*/ +int ripleylocal_rect(int *point_nb,double *x,double *y,double *xmi,double *xma,double *ymi,double *yma, +int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRect(*point_nb,x,y,xmi,xma,ymi,yma); + + + taballoc(&g,*point_nb,*t2); + taballoc(&k,*point_nb,*t2); + + for(i=0;i<*point_nb;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + + for(i=1;i<*point_nb;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)) { + tt=d/(*dt); + + /* pour [i,j] : correction des effets de bord*/ + cin=perim_in_rect(x[i],y[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_rect(x[j],y[j],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + g[j][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/*fonction de Ripley locale pour une zone circulaire*/ +int ripleylocal_disq(int *point_nb,double *x,double *y,double *x0,double *y0,double *r0, +int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCirc(*point_nb,x,y,x0,y0,*r0); + + taballoc(&g,*point_nb,*t2); + taballoc(&k,*point_nb,*t2); + + for(i=0;i<*point_nb;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + for(i=1;i<*point_nb;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + + /*pour [i,j] : correction des effets de bord*/ + cin=perim_in_disq(x[i],y[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_disq(x[j],y[j],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + g[j][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]+=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/*fonction de Ripley locale triangles dans rectangle*/ +int ripleylocal_tr_rect(int *point_nb,double *x,double *y,double *xmi,double *xma,double *ymi,double *yma, +int *triangle_nb,double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRectTri(*point_nb,x,y,xmi,xma,ymi,yma,*triangle_nb,ax,ay,bx,by,cx,cy); + + taballoc(&g,*point_nb,*t2); + taballoc(&k,*point_nb,*t2); + + for(i=0;i<*point_nb;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + + for(i=1;i<*point_nb;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + + /*pour [i,j] : correction des effets de bord*/ + cin=perim_in_rect(x[i],y[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[i],y[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_rect(x[j],y[j],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[j],y[j],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[j][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/*fonction de Ripley locale triangles dans cercle*/ +int ripleylocal_tr_disq(int *point_nb,double *x,double *y,double *x0,double *y0,double *r0, +int *triangle_nb,double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCircTri(*point_nb,x,y,x0,y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy); + taballoc(&g,*point_nb,*t2); + taballoc(&k,*point_nb,*t2); + + for(i=0;i<*point_nb;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + for(i=1;i<*point_nb;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + + /* pour [i,j] : correction des effets de bord*/ + cin=perim_in_disq(x[i],y[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[i],y[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_disq(x[j],y[j],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[j],y[j],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[j][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]+=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/*Densite locale pour une zone rectangulaire*/ +int density_rect(int *point_nb,double *x,double *y,double *xmi,double *xma,double *ymi, +double *yma, int *t2, double *dt, double *xx,double *yy,int *sample_nb,double *count) +{ int tt,i,j; + double ddd,cin; + double **s; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalSample(*sample_nb,xx,yy,*xmi,*ymi); + decalRect(*point_nb,x,y,xmi,xma,ymi,yma); + taballoc(&s,*sample_nb,*t2); + + for(j=0;j<*sample_nb;j++) + { for(tt=0;tt<*t2;tt++) + s[j][tt]=0; + for(i=0;i<*point_nb;i++) /* On calcule le nombre de voisins dans chaque disque de rayon r*/ + { ddd=sqrt((xx[j]-x[i])*(xx[j]-x[i])+(yy[j]-y[i])*(yy[j]-y[i])); + if (ddd<*t2*(*dt)) { + tt=ddd/(*dt); + + /* correction des effets de bord*/ + cin=perim_in_rect(xx[j],yy[j],ddd,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + s[j][tt]+=2*Pi()/cin; + } + } + } + for(i=0;i<*sample_nb;i++) + for(tt=1;tt<*t2;tt++) + s[i][tt]+=s[i][tt-1]; /* on integre*/ + + /*Copies des valeurs dans le tableau resultat*/ + for(i=0;i<*sample_nb;i++) + for(tt=0;tt<*t2;tt++) + count[i*(*t2)+tt]=s[i][tt]; + + freetab(s); + + return 0; +} + +/*Densite locale pour une zone circulaire*/ +int density_disq(int *point_nb,double *x,double *y,double *x0,double *y0,double *r0, + int *t2,double *dt,double *xx,double *yy,int *sample_nb,double *count) +{ int tt,i,j; + double ddd,cin; + double **s; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalSample(*sample_nb,xx,yy,*x0-*r0,*y0-*r0); + decalCirc(*point_nb,x,y,x0,y0,*r0); + + + taballoc(&s,*sample_nb,*t2); + + for(j=0;j<*sample_nb;j++) + { for(tt=0;tt<*t2;tt++) + s[j][tt]=0; + for(i=0;i<*point_nb;i++) /* On calcule le nombre de voisins dans chaque disque de rayon r*/ + { ddd=sqrt((xx[j]-x[i])*(xx[j]-x[i])+(yy[j]-y[i])*(yy[j]-y[i])); + if (ddd<*t2*(*dt)) + { tt=ddd/(*dt); + + /* correction des effets de bord*/ + cin=perim_in_disq(xx[j],yy[j],ddd,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + s[j][tt]+=2*Pi()/cin; + } + } + } + for(i=0;i<*sample_nb;i++) + for(tt=1;tt<*t2;tt++) + s[i][tt]+=s[i][tt-1]; /* on integre*/ + + /*Copies des valeurs dans le tableau resultat*/ + for(i=0;i<*sample_nb;i++) + for(tt=0;tt<*t2;tt++) + count[i*(*t2)+tt]=s[i][tt]; + + + freetab(s); + + return 0; +} + +/*Densite locale pour triangles dans rectangle*/ +int density_tr_rect(int *point_nb,double *x,double *y,double *xmi,double *xma, + double *ymi,double *yma,int *triangle_nb,double *ax,double *ay,double *bx, + double *by,double *cx,double *cy,int *t2,double *dt,double *xx, + double *yy,int *sample_nb,double *count) +{ int tt,i,j; + double ddd,cin; + double **s; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalSample(*sample_nb,xx,yy,*xmi,*ymi); + decalRectTri(*point_nb,x,y,xmi,xma,ymi,yma,*triangle_nb,ax,ay,bx,by,cx,cy); + taballoc(&s,*sample_nb,*t2); + + for(j=0;j<*sample_nb;j++) + { for(tt=0;tt<*t2;tt++) + s[j][tt]=0; + for(i=0;i<*point_nb;i++) /* On calcule le nombre de voisins dans chaque disque de rayon r*/ + { ddd=sqrt((xx[j]-x[i])*(xx[j]-x[i])+(yy[j]-y[i])*(yy[j]-y[i])); + if (ddd<*t2*(*dt)) + { tt=ddd/(*dt); + + /*correction des effets de bord*/ + cin=perim_in_rect(xx[j],yy[j],ddd,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(xx[j],yy[j],ddd,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + s[j][tt]+=2*Pi()/cin; + } + } + } + for(i=0;i<*sample_nb;i++) + for(tt=1;tt<*t2;tt++) + s[i][tt]+=s[i][tt-1]; /* on integre */ + +/* Copies des valeurs dans le tableau resultat*/ + for(i=0;i<*sample_nb;i++) + for(tt=0;tt<*t2;tt++) + count[i*(*t2)+tt]=s[i][tt]; + + freetab(s); + + return 0; +} + +/*Densite locale pour triangles dans cercle*/ +int density_tr_disq(int *point_nb,double *x,double *y,double *x0,double *y0,double *r0, + int *triangle_nb,double *ax,double *ay,double *bx,double *by, + double *cx,double *cy,int *t2,double *dt,double *xx,double *yy, + int *sample_nb,double *count) +{ int tt,i,j; + double ddd,cin; + double **s; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalSample(*sample_nb,xx,yy,*x0-*r0,*y0-*r0); + decalCircTri(*point_nb,x,y,x0,y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy); + taballoc(&s,*sample_nb,*t2); + + for(j=0;j<*sample_nb;j++) + { for(tt=0;tt<*t2;tt++) + s[j][tt]=0; + for(i=0;i<*point_nb;i++) /* On calcule le nombre de voisins dans chaque disque de rayon r*/ + { ddd=sqrt((xx[j]-x[i])*(xx[j]-x[i])+(yy[j]-y[i])*(yy[j]-y[i])); + if (ddd<*t2*(*dt)) + { tt=ddd/(*dt); + + /*correction des effets de bord*/ + cin=perim_in_disq(xx[j],yy[j],ddd,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(xx[j],yy[j],ddd,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + s[j][tt]+=2*Pi()/cin; + } + } + } + for(i=0;i<*sample_nb;i++) + for(tt=1;tt<*t2;tt++) + s[i][tt]+=s[i][tt-1]; /* on integre*/ + + /*Copies des valeurs dans le tableau resultat*/ + for(i=0;i<*sample_nb;i++) + for(tt=0;tt<*t2;tt++) + count[i*(*t2)+tt]=s[i][tt]; + + freetab(s); + + return 0; +} + +/******************************************************************************/ +/* Calcule la fonction intertype pour les semis (x,y) et (x2,y2) en parametres*/ +/* dans une zone de forme rectangulaire de bornes xmi xma ymi yma */ +/* Les corrections des effets de bords sont fait par la methode de Ripley, */ +/* i.e. l'inverse de la proportion d'arc de cercle inclu dans la fenetre. */ +/* Les calculs sont faits pour les t2 premiers intervalles de largeur dt. */ +/* La routine calcule g12, densite des couples de points; et la fonction K12 */ +/* Les resultats sont stockes dans des tableaux g et k donnes en parametres */ +/******************************************************************************/ + +int intertype_rect(int *point_nb1,double *x1,double *y1,int *point_nb2, double *x2, double *y2, +double *xmi,double *xma,double *ymi,double *yma,int *t2,double *dt,double *g,double *k) +{ int i,j,tt; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRect2(*point_nb1,x1,y1,*point_nb2,x2,y2,xmi,xma,ymi,yma); + + /*On rangera dans g le nombre de couples de points par distance tt*/ + for(tt=0;tt<*t2;tt++) + { g[tt]=0; + } + + /* On regarde tous les couples (i,j)*/ + for(i=0;i<*point_nb1;i++) + { for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) + { /* dans quelle classe de distance est ce couple ?*/ + tt=d/(*dt); + /* correction des effets de bord*/ + cin=perim_in_rect(x1[i],y1[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("\ncin<0 sur i AVANT"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) + { g[tt]=g[tt]/(*point_nb1); + } + + /*on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++) + { k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*fonction intertype pour une zone circulaire*/ +int intertype_disq(int *point_nb1, double *x1, double *y1, int *point_nb2, double *x2, + double *y2, double *x0, double *y0, double *r0,int *t2, double *dt, double *g, double *k) +{ int tt,i,j; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCirc2(*point_nb1,x1,y1,*point_nb2,x2,y2,x0,y0,*r0); + + for(tt=0;tt<*t2;tt++) { + g[tt]=0; + } + for(i=0;i<*point_nb1;i++) /* On calcule le nombre de couples de points par distance g*/ + for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + + /* correction des effets de bord*/ + cin=perim_in_disq(x1[i],y1[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("\ncin<0 sur i AVANT"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) { + g[tt]=g[tt]/(*point_nb1); + } + + /* on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++) { + k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*Intertype triangles dans rectangle*/ +int intertype_tr_rect(int *point_nb1,double *x1,double *y1,int *point_nb2,double *x2,double *y2, +double *xmi,double *xma,double *ymi,double *yma,int *triangle_nb,double *ax,double *ay,double *bx,double *by, +double *cx,double *cy,int *t2,double *dt,double *g,double *k) +{ int i,j,tt; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRectTri2(*point_nb1,x1,y1,*point_nb2,x2,y2,xmi,xma,ymi,yma,*triangle_nb,ax,ay,bx,by,cx,cy); + + /* On calcule le nombre de couples de points par distance g*/ + for(tt=0;tt<*t2;tt++){ + g[tt]=0; + } + for(i=0;i<*point_nb1;i++) + for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + cin=perim_in_rect(x1[i],y1[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("\ncin<0 sur i AVANT"); + return -1; + } + cin=cin-perim_triangle(x1[i],y1[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) { + g[tt]=g[tt]/(*point_nb1); + } + + /* on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++){ + k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*Intertype triangles dans cercle*/ +int intertype_tr_disq(int *point_nb1,double *x1,double *y1,int *point_nb2,double *x2,double *y2, +double *x0,double *y0,double *r0,int *triangle_nb,double *ax,double *ay,double *bx,double *by, +double *cx,double *cy,int *t2,double *dt,double *g,double *k) +{ int i,j,tt; + double d,cin; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCircTri2(*point_nb1,x1,y1,*point_nb2,x2,y2,x0,y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy); + + /* On calcule le nombre de couples de points par distance g*/ + for(tt=0;tt<*t2;tt++){ + g[tt]=0; + } + for(i=0;i<*point_nb1;i++) + for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) + { tt=d/(*dt); + cin=perim_in_disq(x1[i],y1[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("\ncin<0 sur i AVANT"); + return -1; + } + cin=cin-perim_triangle(x1[i],y1[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) { + g[tt]=g[tt]/(*point_nb1); + } + + /* on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++){ + k[tt]=k[tt-1]+g[tt]; + } + + return 0; +} + +/*fonction intertype avec intervalle de confiance pour une zone rectangulaire*/ +int intertype_rect_ic(int *point_nb1,double *x1,double *y1,int *point_nb2, double *x2, double *y2, +double *xmi,double *xma,double *ymi,double *yma,double *surface, + int *t2,double *dt,int *nbSimu,int *h0, double *prec, int *nsimax, int *conv, int *rep, double *lev,double *g,double *k, +double *gic1,double *gic2, double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) { + int i,j,i0,i1,i2,ptot,r; + double **gic,**kic; + double *gg,*kk,*ll,*nn; + double *gt,*kt,*lt,*nt; + int erreur=0,mess; + int *type; + //double *x,*y,*cost,surface,*xx,*yy; + double *x,*y,*cost,densite_1,densite_2,densite_tot; + int point_nb=0,point_nbtot; + + densite_1=(*point_nb1)/(*surface); + densite_2=(*point_nb2)/(*surface); + point_nbtot=(*point_nb1)+(*point_nb2); + densite_tot=point_nbtot/(*surface); + + erreur=intertype_rect(point_nb1,x1,y1,point_nb2,x2,y2,xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) return -1; + + //Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + //Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + //Normalisation de g et k et calcul de l et n pour le calcul des p-values + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) { + gg[i]=g[i]/(densite_2*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/densite_2; + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + //Initialisations avant la boucle principale + if (*h0==1) { //Option 1 : substitutions : on stocke tous les points + vecalloc(&x,point_nbtot); + vecalloc(&y,point_nbtot); + vecintalloc(&type,point_nbtot); + for(i=0;i<*point_nb1;i++) { + x[i]=x1[i]; + y[i]=y1[i]; + } + for(i=0;i<*point_nb2;i++) { + x[*point_nb1+i]=x2[i]; + y[*point_nb1+i]=y2[i]; + } + //on lance Ripley sur tous les points + normalization pour le calcul des p-values + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&nt,*t2); + /*ptot=*point_nb1+*point_nb2;*/ + erreur=ripley_rect(&point_nbtot,x,y,xmi,xma,ymi,yma,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) { + gt[j]=gt[j]/(densite_tot*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nt[j]=kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kt[j]=kt[j]/(densite_tot); + lt[j]=sqrt(kt[j]/Pi())-(j+1)*(*dt); + } + } + if (*h0==2) { //Option 2 : initialisation coordonnŽes points dŽcalŽs + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + } + + if (*h0==3) { //Option 3 : on lance Ripley sur les points de type 1 + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&cost,*nsimax); + /*densite1=(*densite-*densite2); + surface=(*point_nb1)/densite1;*/ + erreur=ripley_rect(point_nb1,x1,y1,xmi,xma,ymi,yma,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) + lt[j]=sqrt(kt[j]/(densite_1*Pi()))-(j+1)*(*dt); + } + int lp=0; + + //boucle principale de MC + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + + //On simule les hypotheses nulles + if(*h0==1) + erreur=randlabelling(x,y,*point_nb1,x1,y1,*point_nb2,x2,y2,type); + if(*h0==2) + erreur=randshifting_rect(&point_nb,x,y,*point_nb1,x1,y1,*xmi,*xma,*ymi,*yma,*prec); + if(*h0==3) { + erreur=1; + r=0; + while(erreur!=0) { + erreur=mimetic_rect(point_nb1,x1,y1,surface,xmi,xma,ymi,yma,prec,t2,dt,lt,nsimax,conv,cost,gt,kt,x,y,0); + r=r+erreur; + if(r==*rep) { + Rprintf("\nStop: mimetic_rect failed to converge more than %d times\n", r); + Rprintf("Adjust arguments nsimax and/or conv\n", r); + return -1; + } + } + } + + if (erreur==0) { + if (*h0==1)//etiquetage aleatoire + erreur=intertype_rect(point_nb1,x1,y1,point_nb2,x2,y2,xmi,xma,ymi,yma,t2,dt,gic1,kic1); + if (*h0==2) // décallage avec rectangle + erreur=intertype_rect(&point_nb,x,y,point_nb2,x2,y2,xmi,xma,ymi,yma,t2,dt,gic1,kic1); + if (*h0==3) // mimŽtique + erreur=intertype_rect(point_nb1,x,y,point_nb2,x2,y2,xmi,xma,ymi,yma,t2,dt,gic1,kic1); + } + // si il y a une erreur on recommence une simulation + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR Intertype\n"); + } + else { + //comptage du nombre de |¶obs|<=|¶simu| pour test local + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) { + gictmp=gic1[j]/(densite_2*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/densite_2; + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if(*h0==1) { + if ((float)fabs(gg[j]-gt[j])<=(float)fabs(gictmp-gt[j])) {gval[j]+=1;} + if ((float)fabs(nn[j]-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))<=(float)fabs(nictmp-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))) {nval[j]+=1;} + if ((float)fabs(kk[j]-kt[j])<=(float)(kictmp-kt[j])) {kval[j]+=1;} + if ((float)fabs(ll[j]-lt[j])<=(float)fabs(lictmp-lt[j])) {lval[j]+=1;} + } + else { //h0=2 ou 3 + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-densite_2)<=(float)fabs(nictmp-densite_2)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + } + + //Traitement des résultats + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux résultats + for(i=0;i<*t2;i++) { + gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + + + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + if(*h0==1) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(nt); + freeintvec(type); + } + if(*h0==3) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(cost); + } + freevec(x); + freevec(y); + return 0; +} + +/*fonction intertype avec intervalle de confiance pour une zone circulaire*/ +int intertype_disq_ic(int *point_nb1,double *x1,double *y1,int *point_nb2, double *x2, double *y2, +double *x0,double *y0,double *r0,double *surface, int *t2,double *dt,int *nbSimu,int *h0, double *prec, +int *nsimax, int *conv, int *rep, double *lev,double *g,double *k,double *gic1,double *gic2, + double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) { + int i,j,i0,i1,i2,ptot,r; + double **gic,**kic; + double *gt,*kt,*lt,*nt; + double *gg,*kk,*ll,*nn; + int erreur=0,mess; + int *type; + double *x,*y,*cost,densite_1,densite_2,densite_tot; + int point_nb=0,point_nbtot; + + densite_1=(*point_nb1)/(*surface); + densite_2=(*point_nb2)/(*surface); + point_nbtot=(*point_nb1)+(*point_nb2); + densite_tot=point_nbtot/(*surface); + + erreur=intertype_disq(point_nb1,x1,y1,point_nb2,x2,y2,x0,y0,r0,t2,dt,g,k); + if (erreur!=0) return -1; + + /*Définition de i0 : indice où sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) { + gg[i]=g[i]/(densite_2*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/(densite_2); + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + /*Initialisations avant la boucle principale*/ + + if (*h0==1) { /*Option 1 : substitutions : on stocke tous les points*/ + vecalloc(&x,point_nbtot); + vecalloc(&y,point_nbtot); + vecintalloc(&type,point_nbtot); + for(i=0;i<*point_nb1;i++) { + x[i]=x1[i]; + y[i]=y1[i]; + } + for(i=0;i<*point_nb2;i++) { + x[*point_nb1+i]=x2[i]; + y[*point_nb1+i]=y2[i]; + } + /*on lance Ripley sur tous les points + normalization pour le calcul des p-values*/ + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&nt,*t2); + erreur=ripley_disq(&point_nbtot,x,y,x0,y0,r0,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) { + gt[j]=gt[j]/(densite_tot*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nt[j]=kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kt[j]=kt[j]/(densite_tot); + lt[j]=sqrt(kt[j]/Pi())-(j+1)*(*dt); + } + } + //Sinon option 2 : rien a initialiser* + if (*h0==2) { + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + } + if (*h0==3) { //Option 3 : on lance Ripley sur les points de type 1 + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&cost,*nsimax); + erreur=ripley_disq(point_nb1,x1,y1,x0,y0,r0,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) + lt[j]=sqrt(kt[j]/(densite_1*Pi()))-(j+1)*(*dt); + } + int lp=0; + + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + + /*On simule les hypothèses nulles*/ + if(*h0==1) + erreur=randlabelling(x,y,*point_nb1,x1,y1,*point_nb2,x2,y2,type); + if(*h0==2) + erreur=randshifting_disq(&point_nb,x,y,*point_nb1,x1,y1,*x0,*y0,*r0,*prec); + if(*h0==3) { + erreur=1; + r=0; + while(erreur!=0) { + erreur=mimetic_disq(point_nb1,x1,y1,surface,x0,y0,r0,prec,t2,dt,lt,nsimax,conv,cost,gt,kt,x,y,0); + r=r+erreur; + if(r==*rep) { + Rprintf("\nStop: mimetic_disq failed to converge more than %d times\n", r); + Rprintf("Adjust arguments nsimax and/or conv\n", r); + return -1; + } + } + } + if (erreur==0) { + if (*h0==1) { + erreur=intertype_disq(point_nb1,x1,y1,point_nb2,x2,y2,x0,y0,r0,t2,dt,gic1,kic1); + } + if (*h0==2) { + erreur=intertype_disq(&point_nb,x,y,point_nb2,x2,y2,x0,y0,r0,t2,dt,gic1,kic1); + } + if (*h0==3) { + // mimŽtique + erreur=intertype_disq(point_nb1,x,y,point_nb2,x2,y2,x0,y0,r0,t2,dt,gic1,kic1); + } + } + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR Intertype\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) { + gictmp=gic1[j]/(densite_2*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/densite_2; + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if(*h0==1) { + if ((float)fabs(gg[j]-gt[j])<=(float)fabs(gictmp-gt[j])) {gval[j]+=1;} + if ((float)fabs(nn[j]-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))<=(float)fabs(nictmp-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))) {nval[j]+=1;} + if ((float)fabs(kk[j]-kt[j])<=(float)(kictmp-kt[j])) {kval[j]+=1;} + if ((float)fabs(ll[j]-lt[j])<=(float)fabs(lictmp-lt[j])) {lval[j]+=1;} + } + else {//h0=2 ou 3 + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-densite_2)<=(float)fabs(nictmp-densite_2)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + } + /*Traitement des résultats*/ + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + i1=i0+2; + i2=i0; + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + if(*h0==1) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(nt); + freeintvec(type); + } + if(*h0==3) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(cost); + } + freevec(x); + freevec(y); + return 0; +} + +/*fonction intertype avec intervalle de confiance pour une zone rectangulaire + triangles*/ +int intertype_tr_rect_ic(int *point_nb1,double *x1,double *y1,int *point_nb2, double *x2, double *y2, +double *xmi,double *xma,double *ymi,double *yma,double *surface, +int *triangle_nb,double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,int *nbSimu,int *h0, double *prec, int *nsimax, int *conv, int *rep, double *lev,double *g,double *k, +double *gic1,double *gic2, double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) { + int i,j,i0,i1,i2,ptot,r; + double **gic,**kic; + double *gg,*kk,*ll,*nn; + double *gt,*kt,*lt,*nt; + int erreur=0,mess; + int *type; + double *x,*y,*cost,densite_1,densite_2,densite_tot; + int point_nb=0,point_nbtot; + double **tab; + + densite_1=(*point_nb1)/(*surface); + densite_2=(*point_nb2)/(*surface); + point_nbtot=(*point_nb1)+(*point_nb2); + densite_tot=point_nbtot/(*surface); + + erreur=intertype_tr_rect(point_nb1,x1,y1,point_nb2,x2,y2,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) return -1; + + /*Définition de i0 : indice où sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + taballoc(&tab,2,point_nbtot); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) { + gg[i]=g[i]/(densite_2*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/densite_2; + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + /*Initialisations avant la boucle principale*/ + + if (*h0==1) { /*Option 1 : substitutions : on stocke tous les points*/ + vecalloc(&x,point_nbtot); + vecalloc(&y,point_nbtot); + vecintalloc(&type,point_nbtot); + for(i=0;i<*point_nb1;i++) { + x[i]=x1[i]; + y[i]=y1[i]; + } + for(i=0;i<*point_nb2;i++) { + x[*point_nb1+i]=x2[i]; + y[*point_nb1+i]=y2[i]; + } + /*on lance Ripley sur tous les points + normalization pour le calcul des p-values*/ + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&nt,*t2); + erreur=ripley_tr_rect(&point_nbtot,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) { + gt[j]=gt[j]/(densite_tot*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nt[j]=kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kt[j]=kt[j]/densite_tot; + lt[j]=sqrt(kt[j]/Pi())-(j+1)*(*dt); + } + } + /*Sinon option 2 : rien a initialiser*/ + if (*h0==2) { + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + } + + if (*h0==3) { //Option 3 : on lance Ripley sur les points de type 1 + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&cost,*nsimax); + erreur=ripley_tr_rect(point_nb1,x1,y1,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) /*normalisation pour mimetic*/ + lt[j]=sqrt(kt[j]/(densite_1*Pi())); + } + + int lp=0; + + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + + /*On simule les hypothèses nulles*/ + if(*h0==1) + erreur=randlabelling(x,y,*point_nb1,x1,y1,*point_nb2,x2,y2,type); + if(*h0==2) + erreur=randshifting_tr_rect(&point_nb,x,y,*point_nb1,x1,y1,*xmi,*xma,*ymi,*yma,*triangle_nb,ax,ay,bx,by,cx,cy,*prec); + if(*h0==3) { + erreur=1; + r=0; + while(erreur!=0) { + erreur=mimetic_tr_rect(point_nb1,x1,y1,surface,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,prec,t2,dt,lt,nsimax,conv,cost,gt,kt,x,y,0); + r=r+erreur; + if(r==*rep) { + Rprintf("\nStop: mimetic_tr_rect failed to converge more than %d times\n", r); + Rprintf("Adjust arguments nsimax and/or conv\n", r); + return -1; + } + } + } + + if (erreur==0) { + if (*h0==1) //étiquetage aléatoire + erreur=intertype_tr_rect(point_nb1,x1,y1,point_nb2,x2,y2,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (*h0==2) //décallage avec rectangle + erreur=intertype_tr_rect(&point_nb,x,y,point_nb2,x2,y2,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (*h0==3) // mimŽtique + erreur=intertype_tr_rect(point_nb1,x,y,point_nb2,x2,y2,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + } + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR Intertype\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) { + gictmp=gic1[j]/(densite_2*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/(densite_2); + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if(*h0==1) { + if ((float)fabs(gg[j]-gt[j])<=(float)fabs(gictmp-gt[j])) {gval[j]+=1;} + if ((float)fabs(nn[j]-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))<=(float)fabs(nictmp-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))) {nval[j]+=1;} + if ((float)fabs(kk[j]-kt[j])<=(float)(kictmp-kt[j])) {kval[j]+=1;} + if ((float)fabs(ll[j]-lt[j])<=(float)fabs(lictmp-lt[j])) {lval[j]+=1;} + } + else { //h0=2 ou 3 + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-densite_2)<=(float)fabs(nictmp-densite_2)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + } + + /*Traitement des résultats*/ + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + if(*h0==1) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(nt); + freeintvec(type); + } + if(*h0==3) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(cost); + } + freevec(x); + freevec(y); + return 0; +} + + +/*fonction intertype avec intervalle de confiance pour une zone circulaire + triangles*/ +int intertype_tr_disq_ic(int *point_nb1,double *x1,double *y1,int *point_nb2, double *x2, double *y2, +double *x0,double *y0,double *r0,double *surface, +int *triangle_nb,double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,int *nbSimu,int *h0, double *prec, int *nsimax, int *conv, int *rep, double *lev,double *g,double *k, +double *gic1,double *gic2, double *kic1,double *kic2, double *gval, double *kval, double *lval, double *nval) { + int i,j,i0,i1,i2,ptot,r; + double **gic,**kic; + double *gg,*kk,*ll,*nn; + double *gt,*kt,*lt,*nt; + int erreur=0,mess; + int *type; + double *x,*y,*cost,densite_1,densite_2,densite_tot; + int point_nb=0,point_nbtot; + + densite_1=(*point_nb1)/(*surface); + densite_2=(*point_nb2)/(*surface); + point_nbtot=(*point_nb1)+(*point_nb2); + densite_tot=point_nbtot/(*surface); + + erreur=intertype_tr_disq(point_nb1,x1,y1,point_nb2,x2,y2,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) return -1; + + /*Définition de i0 : indice où sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&gg,*t2); + vecalloc(&kk,*t2); + vecalloc(&ll,*t2); + vecalloc(&nn,*t2); + for(i=0;i<*t2;i++) { + gg[i]=g[i]/(densite_2*(Pi()*(i+1)*(i+1)*(*dt)*(*dt)-Pi()*i*i*(*dt)*(*dt))); + nn[i]=k[i]/(Pi()*(i+1)*(i+1)*(*dt)*(*dt)); + kk[i]=k[i]/densite_2; + ll[i]=sqrt(kk[i]/Pi())-(i+1)*(*dt); + gval[i]=1; + kval[i]=1; + nval[i]=1; + lval[i]=1; + } + + /*Initialisations avant la boucle principale*/ + + if (*h0==1) { /*Option 1 : substitutions : on stocke tous les points*/ + vecalloc(&x,point_nbtot); + vecalloc(&y,point_nbtot); + vecintalloc(&type,point_nbtot); + for(i=0;i<*point_nb1;i++) { + x[i]=x1[i]; + y[i]=y1[i]; + } + for(i=0;i<*point_nb2;i++) { + x[*point_nb1+i]=x2[i]; + y[*point_nb1+i]=y2[i]; + } + /*on lance Ripley sur tous les points + normalization pour le calcul des p-values*/ + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&nt,*t2); + erreur=ripley_tr_disq(&point_nbtot,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) { + gt[j]=gt[j]/(densite_tot*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nt[j]=kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kt[j]=kt[j]/densite_tot; + lt[j]=sqrt(kt[j]/Pi())-(j+1)*(*dt); + } + } + /*Sinon option 2 : rien a initialiser*/ + if (*h0==2) { + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + } + if (*h0==3) { //Option 3 : on lance Ripley sur les points de type 1 + vecalloc(&x,*point_nb1); + vecalloc(&y,*point_nb1); + vecalloc(>,*t2); + vecalloc(&kt,*t2); + vecalloc(<,*t2); + vecalloc(&cost,*nsimax); + erreur=ripley_tr_disq(point_nb1,x1,y1,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gt,kt); + if (erreur!=0) return -1; + for(j=0;j<*t2;j++) + lt[j]=sqrt(kt[j]/(densite_1*Pi()))-(j+1)*(*dt); + } + int lp=0; + + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + + /*On simule les hypothèses nulles*/ + if(*h0==1) + erreur=randlabelling(x,y,*point_nb1,x1,y1,*point_nb2,x2,y2,type); + if(*h0==2) + erreur=randshifting_tr_disq(&point_nb,x,y,*point_nb1,x1,y1,*x0,*y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy,*prec); + if(*h0==3) { + erreur=1; + r=0; + while(erreur!=0) { + erreur=mimetic_tr_disq(point_nb1,x1,y1,surface,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,prec,t2,dt,lt,nsimax,conv,cost,gt,kt,x,y,0); + r=r+erreur; + if(r==*rep) { + Rprintf("\nStop: mimetic_tr_disq failed to converge more than %d times\n", r); + Rprintf("Adjust arguments nsimax and/or conv\n", r); + return -1; + } + } + } + + if (erreur==0) { + if (*h0==1) //étiquetage aléatoire + erreur=intertype_tr_disq(point_nb1,x1,y1,point_nb2,x2,y2,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (*h0==2) //décallage avec rectangle + erreur=intertype_tr_disq(&point_nb,x,y,point_nb2,x2,y2,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (*h0==3) // mimŽtique + erreur=intertype_tr_disq(point_nb1,x,y,point_nb2,x2,y2,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + } + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR Intertype\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gictmp,kictmp,lictmp,nictmp; + for(j=0;j<*t2;j++) { + gictmp=gic1[j]/(densite_2*(Pi()*(j+1)*(j+1)*(*dt)*(*dt)-Pi()*j*j*(*dt)*(*dt))); + nictmp=kic1[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt)); + kictmp=kic1[j]/densite_2; + lictmp=sqrt(kictmp/Pi())-(j+1)*(*dt); + if(*h0==1) { + if ((float)fabs(gg[j]-gt[j])<=(float)fabs(gictmp-gt[j])) {gval[j]+=1;} + if ((float)fabs(nn[j]-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))<=(float)fabs(nictmp-(densite_2*kt[j]/(Pi()*(j+1)*(j+1)*(*dt)*(*dt))))) {nval[j]+=1;} + if ((float)fabs(kk[j]-kt[j])<=(float)(kictmp-kt[j])) {kval[j]+=1;} + if ((float)fabs(ll[j]-lt[j])<=(float)fabs(lictmp-lt[j])) {lval[j]+=1;} + } + else {//h0=2 ou 3 + if ((float)fabs(gg[j]-1)<=(float)fabs(gictmp-1)) {gval[j]+=1;} + if ((float)fabs(nn[j]-densite_2)<=(float)fabs(nictmp-densite_2)) {nval[j]+=1;} + if ((float)fabs(kk[j]-Pi()*(j+1)*(j+1)*(*dt)*(*dt))<=(float)(kictmp-Pi()*(j+1)*(j+1)*(*dt)*(*dt))) {kval[j]+=1;} + if ((float)fabs(ll[j])<=(float)fabs(lictmp)) {lval[j]+=1;} + } + } + + /*Traitement des résultats*/ + ic(i,i0,gic,kic,gic1,kic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + freetab(gic); + freetab(kic); + freevec(gg); + freevec(kk); + freevec(ll); + freevec(nn); + if(*h0==1) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(nt); + freeintvec(type); + } + if(*h0==3) { + freevec(gt); + freevec(kt); + freevec(lt); + freevec(cost); + } + freevec(x); + freevec(y); + return 0; +} + +/*fonction intertype locale pour une zone rectangulaire*/ +int intertypelocal_rect(int *point_nb1,double *x1,double *y1,int *point_nb2,double *x2,double *y2,double *xmi,double *xma, + double *ymi,double *yma,int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRect2(*point_nb1,x1,y1,*point_nb2,x2,y2,xmi,xma,ymi,yma); + taballoc(&g,*point_nb1,*t2); + taballoc(&k,*point_nb1,*t2); + + for(i=0;i<*point_nb1;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + + for(i=0;i<*point_nb1;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) { + tt=d/(*dt); + + /* correction des effets de bord*/ + cin=perim_in_rect(x1[i],y1[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb1;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb1;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/*fonction intertype locale pour une zone circulaire*/ +int intertypelocal_disq(int *point_nb1,double *x1,double *y1,int *point_nb2,double *x2,double *y2,double *x0,double *y0, + double *r0,int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCirc2(*point_nb1,x1,y1,*point_nb2,x2,y2,x0,y0,*r0); + + + taballoc(&g,*point_nb1,*t2); + taballoc(&k,*point_nb1,*t2); + + for(i=0;i<*point_nb1;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + + for(i=0;i<*point_nb1;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) { + tt=d/(*dt); + + /* correction des effets de bord*/ + cin=perim_in_disq(x1[i],y1[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb1;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb1;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/*fonction intertype locale pour une zone rectangulaire + triangles*/ +int intertypelocal_tr_rect(int *point_nb1,double *x1,double *y1,int *point_nb2,double *x2,double *y2,double *xmi,double *xma, +double *ymi,double *yma,int *triangle_nb,double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRectTri2(*point_nb1,x1,y1,*point_nb2,x2,y2,xmi,xma,ymi,yma,*triangle_nb,ax,ay,bx,by,cx,cy); + taballoc(&g,*point_nb1,*t2); + taballoc(&k,*point_nb1,*t2); + + for(i=0;i<*point_nb1;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + + for(i=0;i<*point_nb1;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) { + tt=d/(*dt); + + /* correction des effets de bord*/ + cin=perim_in_rect(x1[i],y1[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x1[i],y1[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb1;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb1;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/*fonction intertype locale pour une zone circulaire + triangles*/ +int intertypelocal_tr_disq(int *point_nb1,double *x1,double *y1,int *point_nb2,double *x2,double *y2,double *x0,double *y0, +double *r0,int *triangle_nb,double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,double *gi,double *ki) +{ int tt,i,j; + double d,cin; + double **g, **k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCircTri2(*point_nb1,x1,y1,*point_nb2,x2,y2,x0,y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy); + taballoc(&g,*point_nb1,*t2); + taballoc(&k,*point_nb1,*t2); + + for(i=0;i<*point_nb1;i++) + for(tt=0;tt<*t2;tt++) + g[i][tt]=0; + + for(i=0;i<*point_nb1;i++) /* On calcule le nombre de couples de points par distance g */ + for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) { + tt=d/(*dt); + + /* correction des effets de bord*/ + cin=perim_in_disq(x1[i],y1[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x1[i],y1[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[i][tt]+=2*Pi()/cin; + } + } + + for(i=0;i<*point_nb1;i++) + { k[i][0]=g[i][0]; + for(tt=1;tt<*t2;tt++) + k[i][tt]=k[i][tt-1]+g[i][tt]; /* on integre */ + } + + /*Copies des valeurs dans les tableaux resultat*/ + for(i=0;i<*point_nb1;i++) { + for(tt=0;tt<*t2;tt++) { + gi[i*(*t2)+tt]=g[i][tt]; + ki[i*(*t2)+tt]=k[i][tt]; + } + } + + freetab(g); + freetab(k); + + return 0; +} + +/******************************************************************************/ +/* Cette routine cree un semis poissonnien a la precision p pour x et y, */ +/* dans une forme rectangulaire xmi xma ymi yma, a la precision p, */ +/* et le range dans les tableaux dont les pointeurs sont fournis en parametre */ +/******************************************************************************/ +void s_alea_rect(int point_nb,double x[], double y[], + double xmi,double xma, double ymi,double yma,double p) +{ int i; + double xr,yr; + xr=xma-xmi; + yr=yma-ymi; + GetRNGstate(); + for(i=0;i<point_nb;i++) + { x[i]=xmi+(unif_rand()*(xr/p))*p; + y[i]=ymi+(unif_rand()*(yr/p))*p; + } + PutRNGstate(); +} + +/*pour un zone circulaire*/ +void s_alea_disq(int point_nb, double *x, double *y, double x0, double y0, double r0, double p) +{ int i; + double xx, yy, rr; + rr=2*r0; + GetRNGstate(); + i=0; + while (i<point_nb) + { xx=x0-r0+(unif_rand()*(rr/p))*p; + yy=y0-r0+(unif_rand()*(rr/p))*p; + if ((xx-x0)*(xx-x0)+(yy-y0)*(yy-y0)<r0*r0) + { x[i]=xx; + y[i]=yy; + i++; + } + } + PutRNGstate(); +} + +/*pour une zone rectangulaire avec exclusion de triangles*/ +void s_alea_tr_rect(int point_nb,double *x, double *y,double xmi,double xma, double ymi,double yma,int triangle_nb, +double *ax,double *ay,double *bx,double *by,double *cx,double *cy,double p) +{ int i,j,erreur; + double xr,yr; + xr=xma-xmi; + yr=yma-ymi; + GetRNGstate(); + + i=0; + while (i<point_nb) + { /* on simule le ieme point dans le rectangle*/ + x[i]=xmi+(unif_rand()*(xr/p))*p; + y[i]=ymi+(unif_rand()*(yr/p))*p; + + /* si il n'est dans aucun triangle, on passe au suivant, sinon on recommence*/ + erreur=0; + j=0; + while ((j<triangle_nb)&&(erreur==0)) + { if (in_triangle(x[i],y[i],ax[j],ay[j],bx[j],by[j],cx[j],cy[j],1)) + { + erreur=1; + } + j++; + } + if (erreur==0) + { i++; + } + } + PutRNGstate(); +} + +/*pour une zone circulaire avec exclusion de triangles*/ +void s_alea_tr_disq(int point_nb,double *x, double *y,double x0,double y0, double r0,int triangle_nb, +double *ax,double *ay,double *bx,double *by,double *cx,double *cy,double p) +{ int i,j,erreur; + double rr; + rr=2*r0; + GetRNGstate(); + + i=0; + while (i<point_nb) { + erreur=0; + /* on simule le ieme point dans le cercle*/ + x[i]=x0-r0+(unif_rand()*(rr/p))*p; + y[i]=y0-r0+(unif_rand()*(rr/p))*p; + if ((x[i]-x0)*(x[i]-x0)+(y[i]-y0)*(y[i]-y0)>r0*r0) erreur=1; + + /* si il n'est dans aucun triangle, on passe au suivant, sinon on recommence*/ + j=0; + while ((j<triangle_nb)&&(erreur==0)) + { if (in_triangle(x[i],y[i],ax[j],ay[j],bx[j],by[j],cx[j],cy[j],1)) + { + erreur=1; + } + j++; + } + if (erreur==0) + { i++; + } + } + PutRNGstate(); +} + +/************************************/ +/*hypotheses nulles pour intertype :*/ +/************************************/ + +/*1 : etiquetage aleatoire*/ +int randlabelling(double *x, double *y, int point_nb1, double *x1, double *y1,int point_nb2, double *x2, double *y2,int *type) { + int j,jj; + int erreur=0; + + GetRNGstate(); + + for(j=0;j<point_nb1+point_nb2;j++) { + type[j]=2; + } + /* on tire point_nb type 1*/ + j=0; + while (j<point_nb1) { + jj=unif_rand()*(point_nb1+point_nb2); + while (type[jj]!=2) { + jj=unif_rand()*(point_nb1+point_nb2); + } + type[jj]=1; + x1[j]=x[jj]; + y1[j]=y[jj]; + j++; + } + PutRNGstate(); + /*Il reste point_nb2 type 2*/ + jj=0; + for(j=0;j<point_nb1+point_nb2;j++) { + if (type[j]==2) { + x2[jj]=x[j]; + y2[jj]=y[j]; + jj=jj+1; + } + } + if (jj!=point_nb2) { + Rprintf("erreur substitution\n"); + erreur=1; + } + else { + erreur=0; + } + + return erreur; +} + +/*2 : decallage*/ +int randshifting_rect(int *point_nb,double *x, double *y, int point_nb1, double *x1, double *y1, +double xmi, double xma, double ymi, double yma, double prec) { + int j; + int dx,dy; + + GetRNGstate(); + + /*On decalle type 1*/ + *point_nb=point_nb1; + + /*en x d'abord*/ + dx=unif_rand()*((xma-xmi)/prec)*prec; + for(j=0;j<*point_nb;j++) { + x[j]=x1[j]+dx; + if (x[j]>xma) { + x[j]=x[j]-(xma-xmi); + } + } + /*en y ensuite*/ + dy=unif_rand()*((yma-ymi)/prec)*prec; + for(j=0;j<*point_nb;j++) { + y[j]=y1[j]+dy; + if (y[j]>yma) { + y[j]=y[j]-(yma-ymi); + } + } + + PutRNGstate(); + + return 0; +} + +int randshifting_disq(int *point_nb,double *x, double *y, int point_nb1, double *x1, double *y1, +double x0, double y0, double r0, double prec) { + int i; + + randshifting_rect(point_nb,x,y,point_nb1,x1,y1,x0-r0,x0+r0,y0-r0,y0+r0,prec); + + /*suppression des points hors cercle*/ + i=0; + while (i<*point_nb) + { if((x[i]-x0)*(x[i]-x0)+(y[i]-y0)*(y[i]-y0)>r0*r0) + { x[i]=x[*point_nb]; + y[i]=y[*point_nb]; + i--; + *point_nb=*point_nb-1; + } + i++; + } + + return 0; +} + +int randshifting_tr_rect(int *point_nb,double *x, double *y, int point_nb1, double *x1, double *y1, +double xmi, double xma, double ymi, double yma,int triangle_nb, double *ax, double *ay, double *bx, double *by, +double *cx, double *cy,double prec) { + int i,j; + int erreur; + + randshifting_rect(point_nb,x,y,point_nb1,x1,y1,xmi,xma,ymi,yma,prec); + + /*suppression des points dans triangles*/ + i=0; + erreur=0; + while (i<*point_nb) + { j=0; + while ((j<triangle_nb)&&(erreur==0)) + { if (in_triangle(x[i],y[i],ax[j],ay[j],bx[j],by[j],cx[j],cy[j],1)) erreur=1; + j++; + } + if (erreur == 1) + { x[i]=x[*point_nb]; + y[i]=y[*point_nb]; + i--; + *point_nb=*point_nb-1; + } + i++; + erreur=0; + } + + return 0; +} + +int randshifting_tr_disq(int *point_nb,double *x, double *y, int point_nb1, double *x1, double *y1, +double x0, double y0, double r0,int triangle_nb, double *ax, double *ay, double *bx, double *by, +double *cx, double *cy,double prec) { + int i,j; + int erreur; + + randshifting_disq(point_nb,x,y,point_nb1,x1,y1,x0,y0,r0,prec); + + /*suppression des points dans triangles*/ + i=0; + erreur=0; + while (i<*point_nb) + { j=0; + while ((j<triangle_nb)&&(erreur==0)) + { if (in_triangle(x[i],y[i],ax[j],ay[j],bx[j],by[j],cx[j],cy[j],1)) erreur=1; + j++; + } + if (erreur == 1) + { x[i]=x[*point_nb]; + y[i]=y[*point_nb]; + i--; + *point_nb=*point_nb-1; + } + i++; + erreur=0; + } + + return 0; +} + +/******************************************************************************/ +/* Calcule la fonction de corrŽlation des marques Km(r) pour un semis (x,y) */ +/* affectŽ d'une marque quantitative c(x,y) en parametres */ +/* dans une zone de forme rectangulaire de bornes xmi xma ymi yma */ +/* Les corrections des effets de bords sont fait par la methode de Ripley, */ +/* i.e. l'inverse de la proportion d'arc de cercle inclu dans la fenetre. */ +/* Les calculs sont faits pour les t2 premiers intervalles de largeur dt. */ +/* La routine calcule g, densite des couples de points; et la fonction K */ +/* Les resultats sont stockes dans des tableaux g et k donnes en parametres */ +/******************************************************************************/ +int corr_rect(int *point_nb,double *x,double *y,double *c, double *xmi,double *xma,double *ymi,double *yma, +int *t2,double *dt,double *gm,double *km) +{ int i,j,tt; + double d,cin,cmoy,cvar; + double *g,*k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRect(*point_nb,x,y,xmi,xma,ymi,yma); + + /*On calcule la moyenne des marques*/ + cmoy=0; + for(i=0;i<*point_nb;i++) + cmoy+=c[i]; + cmoy=cmoy/(*point_nb); + + /*On calcule la variance des marques*/ + cvar=0; + for(i=0;i<*point_nb;i++) + cvar+=(c[i]-cmoy)*(c[i]-cmoy); + cvar=cvar/(*point_nb); + + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + /* On rangera dans g le nombre de couples de points par distance tt + et dans gm la somme des covariances des marques */ + for(tt=0;tt<*t2;tt++) { + g[tt]=0; + gm[tt]=0; + } + + /*On regarde les couples (i,j) et (j,i) : donc pour i>j seulement*/ + for(i=1;i<*point_nb;i++) + { for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)){ + /* dans quelle classe de distance est ce couple ?*/ + tt=d/(*dt); + + /*pour [i,j] : correction des effets de bord*/ + cin=perim_in_rect(x[i],y[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_rect(x[j],y[j],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + } + } + } + + /* on integre*/ + k[0]=g[0]; + km[0]=gm[0]; + for(tt=1;tt<*t2;tt++) { + k[tt]=k[tt-1]+g[tt]; + km[tt]=km[tt-1]+gm[tt]; + } + + /* on normalise*/ + for(tt=0;tt<*t2;tt++) { + gm[tt]=gm[tt]/(g[tt]*cvar); + km[tt]=km[tt]/(k[tt]*cvar); + } + + freevec(g); + freevec(k); + return 0; +} + +/*function de corrŽlation dans forme circulaire*/ +int corr_disq(int *point_nb,double *x,double *y,double *c, double *x0,double *y0,double *r0, +int *t2,double *dt,double *gm,double *km) +{ int i,j,tt; + double d,cin,cmoy,cvar; + double *g,*k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCirc(*point_nb,x,y,x0,y0,*r0); + + /*On calcule la moyenne des marques*/ + cmoy=0; + for(i=0;i<*point_nb;i++) + cmoy+=c[i]; + cmoy=cmoy/(*point_nb); + + /*On calcule la variance des marques*/ + cvar=0; + for(i=0;i<*point_nb;i++) + cvar+=(c[i]-cmoy)*(c[i]-cmoy); + cvar=cvar/(*point_nb); + + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + /*On rangera dans g le nombre de couples de points par distance tt + et dans gm la somme des covariances des marques */ + for(tt=0;tt<*t2;tt++) { + g[tt]=0; + gm[tt]=0; + } + + /*On regarde les couples (i,j) et (j,i) : donc pour i>j seulement*/ + for(i=1;i<*point_nb;i++) + { for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)){ + /* dans quelle classe de distance est ce couple ?*/ + tt=d/(*dt); + + /* pour [i,j] : correction des effets de bord*/ + cin=perim_in_disq(x[i],y[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_disq(x[j],y[j],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + } + } + } + + /* on integre*/ + k[0]=g[0]; + km[0]=gm[0]; + for(tt=1;tt<*t2;tt++) { + k[tt]=k[tt-1]+g[tt]; + km[tt]=km[tt-1]+gm[tt]; + } + + /* on normalise*/ + for(tt=0;tt<*t2;tt++) { + gm[tt]=gm[tt]/(g[tt]*cvar); + km[tt]=km[tt]/(k[tt]*cvar); + } + + freevec(g); + freevec(k); + return 0; +} + +/*Kcor triangles dans rectangle*/ +int corr_tr_rect(int *point_nb,double *x,double *y,double *c, double *xmi,double *xma,double *ymi,double *yma, +int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2,double *dt,double *gm,double *km) +{ int i,j,tt; + double d,cin,cmoy,cvar; + double *g,*k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalRectTri(*point_nb,x,y,xmi,xma,ymi,yma,*triangle_nb,ax,ay,bx,by,cx,cy); + + /*On calcule la moyenne des marques*/ + cmoy=0; + for(i=0;i<*point_nb;i++) + cmoy+=c[i]; + cmoy=cmoy/(*point_nb); + + /*On calcule la variance des marques*/ + cvar=0; + for(i=0;i<*point_nb;i++) + cvar+=(c[i]-cmoy)*(c[i]-cmoy); + cvar=cvar/(*point_nb); + + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + /*On rangera dans g le nombre de couples de points par distance tt + et dans gm la somme des covariances des marques */ + for(tt=0;tt<*t2;tt++) { + g[tt]=0; + gm[tt]=0; + } + + /*On regarde les couples (i,j) et (j,i) : donc pour i>j seulement*/ + for(i=1;i<*point_nb;i++) + { for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)){ + /*dans quelle classe de distance est ce couple ?*/ + tt=d/(*dt); + + /*pour [i,j] : correction des effets de bord*/ + cin=perim_in_rect(x[i],y[i],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[i],y[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_rect(x[j],y[j],d,*xmi,*xma,*ymi,*yma); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[j],y[j],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + } + } + } + + + /*on integre*/ + k[0]=g[0]; + km[0]=gm[0]; + for(tt=1;tt<*t2;tt++) { + k[tt]=k[tt-1]+g[tt]; + km[tt]=km[tt-1]+gm[tt]; + } + + /* on normalise*/ + for(tt=0;tt<*t2;tt++) { + gm[tt]=gm[tt]/(g[tt]*cvar); + km[tt]=km[tt]/(k[tt]*cvar); + } + + freevec(g); + freevec(k); + return 0; +} + +/*kcor triangles dans disque*/ +int corr_tr_disq(int *point_nb,double *x,double *y,double *c, double *x0,double *y0,double *r0, +int *triangle_nb,double *ax,double *ay,double *bx,double *by,double *cx,double *cy, +int *t2,double *dt,double *gm,double *km) +{ int i,j,tt; + double d,cin,cmoy,cvar; + double *g,*k; + + /*Decalage pour n'avoir que des valeurs positives*/ + decalCircTri(*point_nb,x,y,x0,y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy); + + /*On calcule la moyenne des marques*/ + cmoy=0; + for(i=0;i<*point_nb;i++) + cmoy+=c[i]; + cmoy=cmoy/(*point_nb); + + /*On calcule la variance des marques*/ + cvar=0; + for(i=0;i<*point_nb;i++) + cvar+=(c[i]-cmoy)*(c[i]-cmoy); + cvar=cvar/(*point_nb); + + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + /* On rangera dans g le nombre de couples de points par distance tt + et dans gm la somme des covariances des marques */ + for(tt=0;tt<*t2;tt++) { + g[tt]=0; + gm[tt]=0; + } + + /*On regarde les couples (i,j) et (j,i) : donc pour i>j seulement*/ + for(i=1;i<*point_nb;i++) + { for(j=0;j<i;j++) + { d=sqrt((x[i]-x[j])*(x[i]-x[j])+(y[i]-y[j])*(y[i]-y[j])); + if (d<*t2*(*dt)){ + /* dans quelle classe de distance est ce couple ?*/ + tt=d/(*dt); + + /* pour [i,j] : correction des effets de bord*/ + cin=perim_in_disq(x[i],y[i],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur i AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[i],y[i],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + + /*pour [j,i] : correction des effets de bord*/ + cin=perim_in_disq(x[j],y[j],d,*x0,*y0,*r0); + if (cin<0) { + Rprintf("cin<0 sur j AVANT\n"); + return -1; + } + cin=cin-perim_triangle(x[j],y[j],d,*triangle_nb,ax,ay,bx,by,cx,cy); + if (cin<0) { + Rprintf("Overlapping triangles\n"); + return -1; + } + g[tt]+=2*Pi()/cin; + gm[tt]+=(c[i]-cmoy)*(c[j]-cmoy)*2*Pi()/cin; + } + } + } + + /* on integre*/ + k[0]=g[0]; + km[0]=gm[0]; + for(tt=1;tt<*t2;tt++) { + k[tt]=k[tt-1]+g[tt]; + km[tt]=km[tt-1]+gm[tt]; + } + + /* on normalise*/ + for(tt=0;tt<*t2;tt++) { + gm[tt]=gm[tt]/(g[tt]*cvar); + km[tt]=km[tt]/(k[tt]*cvar); + } + + freevec(g); + freevec(k); + return 0; +} + +/*Kcor dans rectangle + ic*/ +int corr_rect_ic(int *point_nb,double *x,double *y,double *c, double *xmi,double *xma,double *ymi,double *yma, +int *t2,double *dt,int *nbSimu, double *lev,double *gm,double *km, +double *gmic1,double *gmic2, double *kmic1,double *kmic2, double *gmval, double *kmval) { + int i,j,i0,i1,i2; + double *c2; + double **gmic,**kmic; + double *ggm,*kkm; + + int erreur=0; + + erreur=corr_rect(point_nb,x,y,c,xmi,xma,ymi,yma,t2,dt,gm,km); + if (erreur!=0) { + return -1; + } + + /*Définition de i0 : indice où sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gmic,*t2+1,2*i0+10+1); + taballoc(&kmic,*t2+1,2*i0+10+1); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&ggm,*t2); + vecalloc(&kkm,*t2); + for(i=0;i<*t2;i++) { + ggm[i]=gm[i]; + kkm[i]=km[i]; + + gmval[i]=1; + kmval[i]=1; + } + + int lp=0; + vecalloc(&c2,*point_nb); + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + randmark(*point_nb,c,c2); + erreur=corr_rect(point_nb,x,y,c2,xmi,xma,ymi,yma,t2,dt,gmic1,kmic1); + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR mark correlation\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gmictmp,kmictmp; + for(j=0;j<*t2;j++) { + gmictmp=gmic1[j]; + kmictmp=kmic1[j]; + if ((float)fabs(ggm[j]-1)<=(float)fabs(gmictmp-1)) {gmval[j]+=1;} + if ((float)fabs(kkm[j])<=(float)fabs(kmictmp)) {kmval[j]+=1;} + } + + /*Traitement des résultats*/ + ic(i,i0,gmic,kmic,gmic1,kmic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gmic1[i]=gmic[i+1][i1]; + gmic2[i]=gmic[i+1][i2]; + kmic1[i]=kmic[i+1][i1]; + kmic2[i]=kmic[i+1][i2]; + } + + + freetab(gmic); + freetab(kmic); + freevec(ggm); + freevec(kkm); + freevec(c2); + return 0; +} + +/*Kcor dans disque + ic*/ +int corr_disq_ic(int *point_nb,double *x,double *y,double *c, double *x0,double *y0,double *r0, +int *t2,double *dt,int *nbSimu, double *lev,double *gm,double *km, +double *gmic1,double *gmic2, double *kmic1,double *kmic2, double *gmval, double *kmval) { + int i,j,i0,i1,i2; + double *c2; + double **gmic,**kmic; + double *ggm,*kkm; + + int erreur=0; + + erreur=corr_disq(point_nb,x,y,c,x0,y0,r0,t2,dt,gm,km); + if (erreur!=0) { + return -1; + } + + /*Définition de i0 : indice où sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gmic,*t2+1,2*i0+10+1); + taballoc(&kmic,*t2+1,2*i0+10+1); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&ggm,*t2); + vecalloc(&kkm,*t2); + for(i=0;i<*t2;i++) { + ggm[i]=gm[i]; + kkm[i]=km[i]; + + gmval[i]=1; + kmval[i]=1; + } + + int lp=0; + vecalloc(&c2,*point_nb); + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + randmark(*point_nb,c,c2); + erreur=corr_disq(point_nb,x,y,c2,x0,y0,r0,t2,dt,gmic1,kmic1); + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR mark correlation\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gmictmp,kmictmp; + for(j=0;j<*t2;j++) { + gmictmp=gmic1[j]; + kmictmp=kmic1[j]; + if ((float)fabs(ggm[j]-1)<=(float)fabs(gmictmp-1)) {gmval[j]+=1;} + if ((float)fabs(kkm[j])<=(float)fabs(kmictmp)) {kmval[j]+=1;} + } + + /*Traitement des résultats*/ + ic(i,i0,gmic,kmic,gmic1,kmic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gmic1[i]=gmic[i+1][i1]; + gmic2[i]=gmic[i+1][i2]; + kmic1[i]=kmic[i+1][i1]; + kmic2[i]=kmic[i+1][i2]; + } + + + freetab(gmic); + freetab(kmic); + freevec(ggm); + freevec(kkm); + freevec(c2); + return 0; +} + + +/*Kcor triangles dans rectangle + ic*/ +int corr_tr_rect_ic(int *point_nb,double *x,double *y,double *c, double *xmi,double *xma,double *ymi,double *yma, +int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2,double *dt,int *nbSimu, double *lev,double *gm,double *km, +double *gmic1,double *gmic2, double *kmic1,double *kmic2, double *gmval, double *kmval) { + int i,j,i0,i1,i2; + double *c2; + double **gmic,**kmic; + double *ggm,*kkm; + + int erreur=0; + + erreur=corr_tr_rect(point_nb,x,y,c,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gm,km); + if (erreur!=0) { + return -1; + } + + /*Définition de i0 : indice où sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gmic,*t2+1,2*i0+10+1); + taballoc(&kmic,*t2+1,2*i0+10+1); + + /*Normalisation de g et k et calcul de l et n pour le calcul des p-values*/ + vecalloc(&ggm,*t2); + vecalloc(&kkm,*t2); + for(i=0;i<*t2;i++) { + ggm[i]=gm[i]; + kkm[i]=km[i]; + + gmval[i]=1; + kmval[i]=1; + } + + int lp=0; + vecalloc(&c2,*point_nb); + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + randmark(*point_nb,c,c2); + erreur=corr_tr_rect(point_nb,x,y,c2,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gmic1,kmic1); + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR Intertype\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gmictmp,kmictmp; + for(j=0;j<*t2;j++) { + gmictmp=gmic1[j]; + kmictmp=kmic1[j]; + if ((float)fabs(ggm[j]-1)<=(float)fabs(gmictmp-1)) {gmval[j]+=1;} + if ((float)fabs(kkm[j])<=(float)fabs(kmictmp)) {kmval[j]+=1;} + } + + /*Traitement des résultats*/ + ic(i,i0,gmic,kmic,gmic1,kmic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gmic1[i]=gmic[i+1][i1]; + gmic2[i]=gmic[i+1][i2]; + kmic1[i]=kmic[i+1][i1]; + kmic2[i]=kmic[i+1][i2]; + } + + + freetab(gmic); + freetab(kmic); + freevec(ggm); + freevec(kkm); + freevec(c2); + return 0; +} + +/*Kcor triangles dans disque + ic*/ +int corr_tr_disq_ic(int *point_nb,double *x,double *y,double *c, double *x0,double *y0,double *r0, +int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2,double *dt,int *nbSimu, double *lev,double *gm,double *km, +double *gmic1,double *gmic2, double *kmic1,double *kmic2, double *gmval, double *kmval) { + int i,j,i0,i1,i2; + double *c2; + double **gmic,**kmic; + double *ggm,*kkm; + + int erreur=0; + + erreur=corr_tr_disq(point_nb,x,y,c,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gm,km); + if (erreur!=0) { + return -1; + } + + /*Définition de i0 : indice où sera stocké l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gmic,*t2+1,2*i0+10+1); + taballoc(&kmic,*t2+1,2*i0+10+1); + + /*Calcul de gm et km pour le calcul des p-values*/ + vecalloc(&ggm,*t2); + vecalloc(&kkm,*t2); + for(i=0;i<*t2;i++) { + ggm[i]=gm[i]; + kkm[i]=km[i]; + + gmval[i]=1; + kmval[i]=1; + } + + int lp=0; + vecalloc(&c2,*point_nb); + /* boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(i=1;i<=*nbSimu;i++) { + randmark(*point_nb,c,c2); + erreur=corr_tr_disq(point_nb,x,y,c2,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gmic1,kmic1); + /* si il y a une erreur on recommence une simulation*/ + if (erreur!=0) { + i=i-1; + Rprintf("ERREUR Intertype\n"); + } + else { + /*comptage du nombre de |¶obs|<=|¶simu| pour test local*/ + double gmictmp,kmictmp; + for(j=0;j<*t2;j++) { + gmictmp=gmic1[j]; + kmictmp=kmic1[j]; + if ((float)fabs(ggm[j]-1)<=(float)fabs(gmictmp-1)) {gmval[j]+=1;} + if ((float)fabs(kkm[j])<=(float)fabs(kmictmp)) {kmval[j]+=1;} + } + + /*Traitement des résultats*/ + ic(i,i0,gmic,kmic,gmic1,kmic1,*t2); + } + R_FlushConsole(); + progress(i,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + /*Copies des valeurs dans les tableaux résultats*/ + for(i=0;i<*t2;i++) { + gmic1[i]=gmic[i+1][i1]; + gmic2[i]=gmic[i+1][i2]; + kmic1[i]=kmic[i+1][i1]; + kmic2[i]=kmic[i+1][i2]; + } + + + freetab(gmic); + freetab(kmic); + freevec(ggm); + freevec(kkm); + freevec(c2); + return 0; +} + +/*mark permutations*/ +//old version +/*void randmark2(int point_nb,double *c,double *c2) +{ int j,jj; + + for(j=0;j<point_nb;j++) + c2[j]=-1; + j=0; + GetRNGstate(); + while (j<point_nb) { + jj=unif_rand()*(point_nb); + while (c2[jj]>-1) { + jj=unif_rand()*(point_nb); + } + c2[jj]=c[j]; + j++; + } + PutRNGstate(); +}*/ + +//new version D. Redondo 2013 +void randmark(int point_nb,double *c,double *c2) +{ + int j,jj,i; + double temp; + for(i=0;i<point_nb;i++) + { + c2[i]=c[i]; + } + GetRNGstate(); + + for(j=0;j<point_nb;j++) + { + jj=unif_rand()*point_nb; + temp=c2[j]; + c2[j]=c2[jj]; + c2[jj]=temp; + } + PutRNGstate(); +} + + +/*********************************************************************************************/ +/* Fonctions de Shimatani pour les semis de points multivariŽs + fonctions utilitaires */ +/********************************************************************************************/ +/// fonction de shimatani pour une zone rectangulaire +int shimatani_rect(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi, +double *yma,int *t2,double *dt,int *nbtype,int *type,double *surface,double *gs, double *ks,int *error) +{ + int i,j,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + + double *g; + double *k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + { l[i]++; + } + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii; + double *kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg; + double *tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + erreur =ripley_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 0 Ripley\n"); + } + + for(j=0;j<*t2;j++) + { g[j]=((intensity*intensity)*(g[j])/intensity*ds[j]); + // g[j]=intensity*g[j]/ds[j]; + k[j]=(intensity*(k[j])); + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + if(z==0) + { for(i=0;i<*nbtype;i++) + { erreur=ripley_rect(&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 1 Ripley\n"); + } + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(g[j])/intensity1*ds[j]); + // gii[j]+=intensity1*g[j]/ds[j]; + + kii[j]=kii[j]+(intensity1*(k[j])); + } + + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + } + + for( i = 0; i < *nbtype; i++) + free(xx[i]); + free(xx); + for( i = 0; i < *nbtype; i++) + free(yy[i]); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int shimatani_disq(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0, +int *t2,double *dt,int *nbtype,int *type,double *surface,double *gs, double *ks,int *error) +{ + int i,j,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + erreur =ripley_disq(point_nb,x,y,x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + for(j=0;j<*t2;j++) + { g[j]=intensity*intensity*g[j]/intensity*ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + if(z==0) + { for(i=0;i<*nbtype;i++) + { erreur=ripley_disq(&l[i+1],xx[i],yy[i],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Ripley\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+intensity1*intensity1*g[j]/intensity1*ds[j]; + kii[j]=kii[j]+intensity1*k[j]; + } + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + } + + for( i = 0; i < *nbtype; i++) + free(xx[i]); + free(xx); + for( i = 0; i < *nbtype; i++) + free(yy[i]); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int shimatani_tr_rect(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi, +double *yma,int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2,double *dt,int *nbtype,int *type,double *surface,double *gs, double *ks,int *error) +{ + int i,j,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + + double *g; + double *k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + { l[i]++; + } + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii; + double *kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg; + double *tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + erreur =ripley_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 0 Ripley\n"); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*intensity*g[j]/intensity*ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + if(z==0) + { for(i=0;i<*nbtype;i++) + { erreur=ripley_tr_rect(&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 1 Ripley\n"); + } + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+intensity1*intensity1*g[j]/intensity1*ds[j]; + kii[j]=kii[j]+intensity1*k[j]; + } + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + } + + for( i = 0; i < *nbtype; i++) + free(xx[i]); + free(xx); + for( i = 0; i < *nbtype; i++) + free(yy[i]); + free(yy); + free(g); + free(k); + free(l); + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int shimatani_tr_disq(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0, +int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, +int *t2,double *dt,int *nbtype,int *type,double *surface,double *gs, double *ks,int *error) +{ + int i,j,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + erreur =ripley_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + for(j=0;j<*t2;j++) + { g[j]=intensity*intensity*g[j]/intensity*ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + if(z==0) + { for(i=0;i<*nbtype;i++) + { erreur=ripley_tr_disq(&l[i+1],xx[i],yy[i],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 1 Ripley\n"); + } + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+intensity1*intensity1*g[j]/intensity1*ds[j]; + kii[j]=kii[j]+intensity1*k[j]; + } + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + } + + for( i = 0; i < *nbtype; i++) + free(xx[i]); + free(xx); + for( i = 0; i < *nbtype; i++) + free(yy[i]); + free(yy); + free(g); + free(k); + free(l); + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int shimatani_rect_ic(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi,double *yma, + int *t2,double *dt,int *nbSimu,double *lev, + int *nbtype,int *type,double *surface,double *D, + double *gs, double *ks,double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,b,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + //pour tous les points + erreur =ripley_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 0 Ripley\n"); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*intensity*g[j]/intensity*ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + if(z==0) + { //boucle initiale + //pour chaque espce + for(i=0;i<*nbtype;i++) + { erreur=ripley_rect(&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 1 Ripley\n"); + } + intensity1=l[i+1]/ *(surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(g[j])/intensity1*ds[j]); + kii[j]=kii[j]+(intensity1*(k[j])); + } + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + + //simulations sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + //Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + //Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + double *gsic,*ksic; + vecalloc(&gsic,*t2); + vecalloc(&ksic,*t2); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + + int lp=0; + + //boucle principale de MC + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=0;i<*nbtype;i++) + { erreur=ripley_rect(&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 2 Ripley\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(gic1[j])/intensity1*ds[j]); + kii[j]=kii[j]+(intensity1*(kic1[j])); + } + + } + + for(j=0;j<*t2;j++) + { gii[j]=1-gii[j]/tabg[j]; + kii[j]=1-kii[j]/tabk[j]; + if ((float)fabs(gs[j]-*D)<=(float)fabs(gii[j]-*D)) {gval[j]+=1;} + if ((float)fabs(ks[j]-*D)<=(float)fabs(kii[j]-*D)) {kval[j]+=1;} + } + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + free(gsic); + free(ksic); + free(gic); + free(kic); + } + + for( i = 0; i < *nbtype; i++) { + free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + free(gii); + free(kii); + free(ds); + + return 0; +} + +int shimatani_disq_ic(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0, + int *t2,double *dt,int *nbSimu,double *lev, + int *nbtype,int *type,double *surface,double *D, + double *gs, double *ks, + double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,b,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + //pour tous les points + erreur =ripley_disq(point_nb,x,y,x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + for(j=0;j<*t2;j++) + { g[j]=intensity*intensity*g[j]/intensity*ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + + if(z==0) + { //boucle initiale + //pour chaque espce + for(i=0;i<*nbtype;i++) + { erreur=ripley_disq(&l[i+1],xx[i],yy[i],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + { i=i-1; + Rprintf("ERREUR 1 Ripley\n"); + } + intensity1=l[i+1]/ *(surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+intensity1*intensity1*g[j]/intensity1*ds[j]; + kii[j]=kii[j]+intensity1*k[j]; + } + + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + + //simulaitons sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + + int lp=0; + + /*boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=0;i<*nbtype;i++) + { erreur=ripley_disq(&l[i+1],xx[i],yy[i],x0,y0,r0,t2,dt,gic1,kic1); + if (erreur!=0) + { Rprintf("ERREUR 2 Ripley\n"); + } + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(gic1[j])/intensity1*ds[j]); + kii[j]=kii[j]+(intensity1*(kic1[j])); + } + } + + for(j=0;j<*t2;j++) + { gii[j]=1-gii[j]/tabg[j]; + kii[j]=1-kii[j]/tabk[j]; + if ((float)fabs(gs[j]-*D)<=(float)fabs(gii[j]-*D)) gval[j]+=1; + if ((float)fabs(ks[j]-*D)<=(float)fabs(kii[j]-*D)) kval[j]+=1; + } + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + free(gic); + free(kic); + } + + for( i = 0; i < *nbtype; i++) { + free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + free(tabg); + free(tabk); + free(gii); + free(kii); + free(ds); + + return 0; +} + +int shimatani_tr_rect_ic(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi, + double *yma,int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + int *t2,double *dt,int *nbSimu,double *lev, + int *nbtype,int *type,double *surface,double *D, + double *gs, double *ks,double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,b,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + + double *g; + double *k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + { l[i]++; + } + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii; + double *kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg; + double *tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + //pour tous les points + erreur =ripley_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 0 Ripley\n"); + } + + for(j=0;j<*t2;j++) + { g[j]=((intensity*intensity)*(g[j])/intensity*ds[j]); + k[j]=(intensity*(k[j])); + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + if(z==0) + { //boucle initiale + //pour chaque espce + for(i=0;i<*nbtype;i++) + { erreur=ripley_tr_rect(&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 1 Ripley\n"); + } + intensity1=l[i+1]/ *(surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(g[j])/intensity1*ds[j]); + kii[j]=kii[j]+(intensity1*(k[j])); + } + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + + //simulaitons sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + double *gsic,*ksic; + vecalloc(&gsic,*t2); + vecalloc(&ksic,*t2); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + + int lp=0; + + /*boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=0;i<*nbtype;i++) + { erreur=ripley_tr_rect(&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (erreur!=0) + { Rprintf("ERREUR 2 Ripley\n"); + } + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(gic1[j])/intensity1*ds[j]); + kii[j]=kii[j]+(intensity1*(kic1[j])); + } + + } + + for(j=0;j<*t2;j++) + { gii[j]=1-gii[j]/tabg[j]; + kii[j]=1-kii[j]/tabk[j]; + if ((float)fabs(gs[j]-*D)<=(float)fabs(gii[j]-*D)) {gval[j]+=1;} + if ((float)fabs(ks[j]-*D)<=(float)fabs(kii[j]-*D)) {kval[j]+=1;} + } + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + + free(gsic); + free(ksic); + free(gic); + free(kic); + } + + for( i = 0; i < *nbtype; i++) { + free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + free(tabg); + free(tabk); + free(gii); + free(kii); + free(ds); + + return 0; +} + +int shimatani_tr_disq_ic(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0, + int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + int *t2,double *dt,int *nbSimu,double *lev, + int *nbtype,int *type,double *surface,double *D, + double *gs, double *ks, + double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,b,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds; + + double *g; + double *k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + { l[i]++; + } + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1; + double intensity=*point_nb/(*surface); + double *gii; + double *kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg; + double *tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + //pour tous les points + erreur =ripley_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 0 Ripley\n"); + } + + for(j=0;j<*t2;j++) + { g[j]=((intensity*intensity)*(g[j])/intensity*ds[j]); + k[j]=(intensity*(k[j])); + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + } + if(z==0) + { //boucle initiale + //pour chaque espce + for(i=0;i<*nbtype;i++) + { erreur=ripley_tr_disq(&l[i+1],xx[i],yy[i],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { Rprintf("ERREUR 1 Ripley\n"); + } + intensity1=l[i+1]/ *(surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(g[j])/intensity1*ds[j]); + kii[j]=kii[j]+(intensity1*(k[j])); + } + } + + for(j=0;j<*t2;j++) + { gs[j]=1-gii[j]/tabg[j]; + ks[j]=1-kii[j]/tabk[j]; + } + + //simulaitons sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + double *gsic,*ksic; + vecalloc(&gsic,*t2); + vecalloc(&ksic,*t2); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + + int lp=0; + + /*boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=0;i<*nbtype;i++) + { erreur=ripley_tr_disq(&l[i+1],xx[i],yy[i],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (erreur!=0) + { Rprintf("ERREUR 2 Ripley\n"); + } + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+((intensity1*intensity1)*(gic1[j])/intensity1*ds[j]); + kii[j]=kii[j]+(intensity1*(kic1[j])); + } + + } + + for(j=0;j<*t2;j++) + { gii[j]=1-gii[j]/tabg[j]; + kii[j]=1-kii[j]/tabk[j]; + if ((float)fabs(gs[j]-*D)<=(float)fabs(gii[j]-*D)) {gval[j]+=1;} + if ((float)fabs(ks[j]-*D)<=(float)fabs(kii[j]-*D)) {kval[j]+=1;} + } + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + + free(gsic); + free(ksic); + free(gic); + free(kic); + } + + for( i = 0; i < *nbtype; i++) { + free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + free(tabg); + free(tabk); + free(gii); + free(kii); + free(ds); + + return 0; +} + +/*permutation of multivariate marks*/ +int randomlab(double *x,double *y,int total_nb,int *type,int nb_type, double **xx,int *taille_xy, double **yy) { + int j,jj; + int erreur=0; + + GetRNGstate(); + + for(j=0;j<total_nb;j++) { + type[j]=nb_type; + } + j=0; + int i=0; + + while(i<nb_type-1) { + //Rprintf("taille :%d\n",taille_xy[i+1]); + while (j<taille_xy[i+1]) { + jj=unif_rand()*(total_nb); + while (type[jj]!=nb_type) { + jj=unif_rand()*(total_nb); + } + type[jj]=i+1; + xx[i][j]=x[jj]; + yy[i][j]=y[jj]; + j++; + } + j=0; + i++; + } + + PutRNGstate(); + + jj=0; + for(j=0;j<total_nb;j++) { + if (type[j]==nb_type) { + xx[nb_type-1][jj]=x[j]; + yy[nb_type-1][jj]=y[j]; + jj=jj+1; + } + } + if (jj!=taille_xy[nb_type]) { + //Rprintf("jj : %d ::: taille : %d\n",jj,taille_xy[nb_type]); + erreur=1; + } + else { + erreur=0; + } + return erreur; +} + +/**********************************************************/ +/* Fonctions de Rao pour les semis de points multivariŽs */ +/**********************************************************/ +//V2 as wrapper of K12fun - 08/2013 +int rao_rect(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi,double *yma, + int *t2,double *dt,int *h0,int *nbtype,int *type,double *mat,double *surface,double *HD,double *gr, double *kr,double *gs,double *ks,int *error) +{ + int i,j,p,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds,dis; + + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + //Ripley all points + erreur =ripley_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + //Intertype for each pair of types + if(z==0) + { for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_rect(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_rect(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + } + + for(i=0;i<*nbtype;i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int rao_rect_ic(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi,double *yma, + int *t2,double *dt,int *nbSimu, int *h0, double *lev, + int *nbtype,int *type,double *mat,double *surface,double *HD, + double *gr, double *kr,double *gs,double *ks, double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,p,b,z=0; + int *l; + int compt[*nbtype+1]; + vecintalloc(&l,*nbtype+1); + double *ds,dis; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + // l contient le nombre d'arbres par espce + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + // crŽation des tableaux xx et yy par espce + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + //Ripley for all points + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + erreur =ripley_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + //standardization de Ripley (et Shimatani si H0=2) + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + + //Intertype for each pairs of types + if(z==0) + { for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_rect(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_rect(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + + //simulations sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + //Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + //Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + //prŽparation des tableaux pour randomisation de dis (H0=2) + int lp=0; + double HDsim; + int *vec, mat_size; + vecintalloc(&vec,*nbtype); + double *matp; + mat_size=*nbtype*(*nbtype-1)/2; + vecalloc(&matp,mat_size); + if(*h0==2) { + for(i=0;i<*nbtype;i++) + vec[i]=i; + for(i=0;i<mat_size;i++) + matp[i]=0; + } + + //boucle principale de MC + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { if(*h0==1) //random labelling + randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + if(*h0==2) //distance randomisation + randomdist(vec,*nbtype,mat,matp); + HDsim=0; + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { if(*h0==1) + dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + if(*h0==2) { + dis=matp[p*(*nbtype-2)-(p-1)*p/2+i-1]; + HDsim+=(float)l[i+1]/(float)(*point_nb)*(float)l[p+1]/(float)(*point_nb)*dis; + } + erreur=intertype_rect(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],xmi,xma,ymi,yma,t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*gic1[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*kic1[j]; + } + erreur=intertype_rect(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*gic1[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*kic1[j]; + } + } + } + + for(j=0;j<*t2;j++) + { if(*h0==1) {// standardisation by HD when species labels are randomized + gii[j]=gii[j]/(tabg[j]*(*HD)); + kii[j]=kii[j]/(tabk[j]*(*HD)); + //deviation from theo=1 + if ((float)fabs(gr[j]-1)<=(float)fabs(gii[j]-1)) gval[j]+=1; + if ((float)fabs(kr[j]-1)<=(float)fabs(kii[j]-1)) kval[j]+=1; + } + if(*h0==2) {// standardisation by Hsim when distance matrix is randomized + gii[j]=gii[j]/(tabg[j]*2*HDsim); + kii[j]=kii[j]/(tabk[j]*2*HDsim); + //deviation from theo=shimatani + if ((float)fabs(gr[j]-gs[j])<=(float)fabs(gii[j]-gs[j])) gval[j]+=1; + if ((float)fabs(kr[j]-ks[j])<=(float)fabs(kii[j]-ks[j])) kval[j]+=1; + } + } + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + free(gic); + free(kic); + freeintvec(vec); + freevec(matp); + } + + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + return 0; +} + +int rao_disq(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0, + int *t2,double *dt,int *h0,int *nbtype,int *type,double *mat,double *surface,double *HD,double *gr, double *kr,double *gs,double *ks,int *error) +{ + int i,j,p,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds,dis; + + double *g; + double *k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1,point_nb1,point_nb2,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + //Ripley all points + erreur =ripley_disq(point_nb,x,y,x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_disq(point_nb,x,y,x0,y0,r0,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + //Intertype for each pair of types + if(z==0) + { for(i=0;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_disq(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_disq(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + } + + for(i=0;i<*nbtype;i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int rao_disq_ic(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0, + int *t2,double *dt,int *nbSimu,int *h0,double *lev, + int *nbtype,int *type,double *mat,double *surface,double *HD, + double *gr, double *kr,double *gs,double *ks,double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,p,b,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds,dis; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx; + double **yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + //Ripley for all points + int erreur,ind; + double intensity1,point_nb1,point_nb2,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + erreur =ripley_disq(point_nb,x,y,x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_disq(point_nb,x,y,x0,y0,r0,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + //standardization de Ripley (et Shimatani si H0=2) + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + //Intertype for each pair of types + if(z==0) + { for(i=0;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_disq(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_disq(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + + //simulaitons sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + + int lp=0; + double HDsim; + int *vec, mat_size; + vecintalloc(&vec,*nbtype); + double *matp; + mat_size=*nbtype*(*nbtype-1)/2; + vecalloc(&matp,mat_size); + if(*h0==2) { + for(i=0;i<*nbtype;i++) + vec[i]=i; + for(i=0;i<mat_size;i++) + matp[i]=0; + } + + /*boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { if(*h0==1) //random labelling + randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + if(*h0==2) //distance randomisation + randomdist(vec,*nbtype,mat,matp); + HDsim=0; + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=0;i<*nbtype;i++) + { for(p=0;p<i;p++) + { if(*h0==1) + dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + if(*h0==2) { + dis=matp[p*(*nbtype-2)-(p-1)*p/2+i-1]; + HDsim+=(float)l[i+1]/(float)(*point_nb)*(float)l[p+1]/(float)(*point_nb)*dis; + } + erreur=intertype_disq(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_disq(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + for(j=0;j<*t2;j++) + { if(*h0==1) {// standardisation by HD when species labels are randomized + gii[j]=gii[j]/(tabg[j]*(*HD)); + kii[j]=kii[j]/(tabk[j]*(*HD)); + //deviation from theo=1 + if ((float)fabs(gr[j]-1)<=(float)fabs(gii[j]-1)) gval[j]+=1; + if ((float)fabs(kr[j]-1)<=(float)fabs(kii[j]-1)) kval[j]+=1; + } + if(*h0==2) {// standardisation by Hsim when distance matrix is randomized + gii[j]=gii[j]/(tabg[j]*2*HDsim); + kii[j]=kii[j]/(tabk[j]*2*HDsim); + //deviation from theo=shimatani + if ((float)fabs(gr[j]-gs[j])<=(float)fabs(gii[j]-gs[j])) gval[j]+=1; + if ((float)fabs(kr[j]-ks[j])<=(float)fabs(kii[j]-ks[j])) kval[j]+=1; + } + + } + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + free(gic); + free(kic); + freeintvec(vec); + freevec(matp); + } + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int rao_tr_rect(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi, + double *yma,int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + int *t2,double *dt,int *h0,int *nbtype,int *type,double *mat,double *surface,double *HD,double *gr, double *kr,double *gs,double *ks,int *error) +{ + int i,j,p,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds,dis; + + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + //Ripley all points + erreur =ripley_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + //Intertype for each pair of types + if(z==0) + { for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_tr_rect(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_tr_rect(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + } + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + + + +/***************/ +int rao_tr_disq(int *point_nb,double *x,double *y, double *x0,double *y0, + double *r0,int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + int *t2,double *dt,int *h0,int *nbtype,int *type,double *mat,double *surface,double *HD,double *gr, double *kr,double *gs,double *ks,int *error) +{ + int i,j,p,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds,dis; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + //Ripley all points + erreur =ripley_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + //Intertype for each pair of types + if(z==0) + { for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_tr_disq(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_tr_disq(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + } + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int rao_tr_rect_ic(int *point_nb,double *x,double *y, double *xmi,double *xma,double *ymi,double *yma, + int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + int *t2,double *dt,int *nbSimu,int *h0, double *lev,int *nbtype,int *type,double *mat,double *surface,double *HD, + double *gr, double *kr,double *gs,double *ks,double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,p,b,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds,dis; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + //Ripley for all points + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + //Ripley all points + erreur =ripley_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + //Intertype for each pairs of types + if(z==0) + { for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_tr_rect(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_tr_rect(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + + //simulaitons sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + + int lp=0; + double HDsim; + int *vec, mat_size; + vecintalloc(&vec,*nbtype); + double *matp; + mat_size=*nbtype*(*nbtype-1)/2; + vecalloc(&matp,mat_size); + if(*h0==2) { + for(i=0;i<*nbtype;i++) + vec[i]=i; + for(i=0;i<mat_size;i++) + matp[i]=0; + } + + /*boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { if(*h0==1) //random labelling + randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + if(*h0==2) //distance randomisation + randomdist(vec,*nbtype,mat,matp); + HDsim=0; + + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { if(*h0==1) + dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + if(*h0==2) { + dis=matp[p*(*nbtype-2)-(p-1)*p/2+i-1]; + HDsim+=(float)l[i+1]/(float)(*point_nb)*(float)l[p+1]/(float)(*point_nb)*dis; + } + erreur=intertype_tr_rect(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*gic1[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*kic1[j]; + } + erreur=intertype_tr_rect(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*gic1[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*kic1[j]; + } + } + } + + for(j=0;j<*t2;j++) + { if(*h0==1) {// standardisation by HD when species labels are randomized + gii[j]=gii[j]/(tabg[j]*(*HD)); + kii[j]=kii[j]/(tabk[j]*(*HD)); + //deviation from theo=1 + if ((float)fabs(gr[j]-1)<=(float)fabs(gii[j]-1)) gval[j]+=1; + if ((float)fabs(kr[j]-1)<=(float)fabs(kii[j]-1)) kval[j]+=1; + } + if(*h0==2) {// standardisation by Hsim when distance matrix is randomized + gii[j]=gii[j]/(tabg[j]*2*HDsim); + kii[j]=kii[j]/(tabk[j]*2*HDsim); + //deviation from theo=shimatani + if ((float)fabs(gr[j]-gs[j])<=(float)fabs(gii[j]-gs[j])) gval[j]+=1; + if ((float)fabs(kr[j]-ks[j])<=(float)fabs(kii[j]-ks[j])) kval[j]+=1; + } + } + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + free(gic); + free(kic); + freeintvec(vec); + freevec(matp); + } + + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +int rao_tr_disq_ic(int *point_nb,double *x,double *y, double *x0,double *y0,double *r0, + int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + int *t2,double *dt,int *nbSimu,int *h0, double *lev,int *nbtype,int *type,double *mat,double *surface,double *HD, + double *gr, double *kr,double *gs,double *ks,double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,p,b,z=0; + int *l;// contient le nombre d'arbres par espèce + int compt[*nbtype+1];// tableau de compteurs pour xx et yy + vecintalloc(&l,*nbtype+1); + double *ds,dis; + double *g,*k; + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + //Ripley for all points + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gii,*kii; + vecalloc(&gii,*t2); + vecalloc(&kii,*t2); + double *tabg,*tabk; + vecalloc(&tabg,*t2); + vecalloc(&tabk,*t2); + + for(j=0;j<*t2;j++) + { gii[j]=0; + kii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + //Ripley all points + erreur =ripley_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 0 Ripley\n"); + + // Shimatani function for normalisation under H0=2 + double D=0; + if(*h0==2) + { erreur=shimatani_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,nbtype,type,surface,gs,ks,error); + for(i=1;i<(*nbtype+1);i++) + D+=(float)l[i]*((float)l[i]-1); + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + } + + for(j=0;j<*t2;j++) + { g[j]=intensity*g[j]/ds[j]; + k[j]=intensity*k[j]; + tabg[j]=g[j]; + tabk[j]=k[j]; + if(g[j]==0) + { error[j]=j; + z+=1; + } + if(*h0==2) { + gs[j]=gs[j]/D; + ks[j]=ks[j]/D; + } + } + //Intertype for each pairs of types + if(z==0) + { for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + erreur=intertype_tr_disq(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*k[j]; + } + erreur=intertype_tr_disq(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*g[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*k[j]; + } + } + } + + for(j=0;j<*t2;j++) + { gr[j]=gii[j]/(tabg[j]*(*HD)); + kr[j]=kii[j]/(tabk[j]*(*HD)); + } + + //simulaitons sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + /*Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC*/ + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + /*Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC*/ + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + + int lp=0; + double HDsim; + int *vec, mat_size; + vecintalloc(&vec,*nbtype); + double *matp; + mat_size=*nbtype*(*nbtype-1)/2; + vecalloc(&matp,mat_size); + if(*h0==2) { + for(i=0;i<*nbtype;i++) + vec[i]=i; + for(i=0;i<mat_size;i++) + matp[i]=0; + } + + /*boucle principale de MC*/ + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { if(*h0==1) //random labelling + randomlab(x,y,*point_nb,type,*nbtype,xx,l,yy); + if(*h0==2) //distance randomisation + randomdist(vec,*nbtype,mat,matp); + HDsim=0; + for(i=0;i<*t2;i++) + { gii[i]=0; + kii[i]=0; + } + for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { if(*h0==1) + dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + if(*h0==2) { + dis=matp[p*(*nbtype-2)-(p-1)*p/2+i-1]; + HDsim+=(float)l[i+1]/(float)(*point_nb)*(float)l[p+1]/(float)(*point_nb)*dis; + } + erreur=intertype_tr_disq(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity1*gic1[j]/ds[j]; + kii[j]=kii[j]+dis*intensity1*kic1[j]; + } + erreur=intertype_tr_disq(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gii[j]=gii[j]+dis*intensity2*gic1[j]/ds[j]; + kii[j]=kii[j]+dis*intensity2*kic1[j]; + } + } + } + for(j=0;j<*t2;j++) + { if(*h0==1) {// standardisation by HD when species labels are randomized + gii[j]=gii[j]/(tabg[j]*(*HD)); + kii[j]=kii[j]/(tabk[j]*(*HD)); + //deviation from theo=1 + if ((float)fabs(gr[j]-1)<=(float)fabs(gii[j]-1)) gval[j]+=1; + if ((float)fabs(kr[j]-1)<=(float)fabs(kii[j]-1)) kval[j]+=1; + } + if(*h0==2) {// standardisation by Hsim when distance matrix is randomized + gii[j]=gii[j]/(tabg[j]*2*HDsim); + kii[j]=kii[j]/(tabk[j]*2*HDsim); + //deviation from theo=shimatani + if ((float)fabs(gr[j]-gs[j])<=(float)fabs(gii[j]-gs[j])) gval[j]+=1; + if ((float)fabs(kr[j]-ks[j])<=(float)fabs(kii[j]-ks[j])) kval[j]+=1; + } + } + + + //Traitement des resultats + ic(b,i0,gic,kic,gii,kii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + free(gic); + free(kic); + freeintvec(vec); + freevec(matp); + } + + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + + free(tabg); + free(tabk); + + freevec(gii); + freevec(kii); + freevec(ds); + + return 0; +} + +//permutation of species distance matrix +int randomdist(int *vec,int nb_type,double *mat,double *matp) { + int i,j,a,jj; + int mat_size,rowvec,colvec,ind; + int erreur=0; + + GetRNGstate(); + i=nb_type-1; + while(i>0) + { jj=unif_rand()*(i); + a=vec[i]; + vec[i]=vec[jj]; + vec[jj]=a; + i=i-1; + } + PutRNGstate(); + a=0; + for(i=1;i<nb_type;i++) + for(j=0;j<(nb_type-i);j++) + { rowvec=i+j; + colvec=i-1; + if(vec[rowvec]>vec[colvec]) + ind=vec[colvec]*(nb_type-2)-(vec[colvec]-1)*vec[colvec]/2+vec[rowvec]-1; + else { + ind=vec[rowvec]*(nb_type-2)-(vec[rowvec]-1)*vec[rowvec]/2+vec[colvec]-1; + } + matp[a]=mat[ind]; + a++; + } + return erreur; +} + +/******************************************************/ +/*Mimetic point process as in Goreaud et al. 2004 */ +/******************************************************/ +int mimetic_rect(int *point_nb,double *x,double *y, double *surface,double *xmi,double *xma,double *ymi,double *yma, + double *prec, int *t2, double *dt, double *lobs, int *nsimax, int *conv, double *cost, + double *g, double *k,double *xx,double *yy,int *mess) +{ + int i,compteur_c=0,r=0,erreur=0; + int compteur=0; + double *l; + double cout,cout_c; + double intensity=(*point_nb)/(*surface); + vecalloc(&l,*t2); + + //creation of a initial point pattern and cost + s_alea_rect(*point_nb,x,y,*xmi,*xma,*ymi,*yma,*prec); + erreur=ripley_rect(point_nb,x,y,xmi,xma,ymi,yma,t2,dt,g,k); + if (erreur!=0) return -1; + cout=0; + for(i=0;i<*t2;i++) + { //l[i]=sqrt(k[i]/(intensity*Pi())); + l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + cout+=(lobs[i]-l[i])*(lobs[i]-l[i]); + } + cost[0]=cout; + int lp=0; + if(mess!=0) + Rprintf("Simulated annealing\n"); + cout_c=0; + while(compteur<*nsimax) + { cout_c=echange_point_rect(*point_nb,x,y,*xmi,*xma,*ymi,*yma,intensity,*prec,cout,lobs,t2,dt,g,k); + if(cout==cout_c) + compteur_c++; + else + compteur_c=0; + cout=cout_c; + //Rprintf(" coût calculé : %f\n", cout); + compteur++; + cost[compteur]=cout; + if(compteur_c==*conv) + break; + if(mess!=0) { + R_FlushConsole(); + progress(compteur,&lp,*nsimax); + } + } + if(compteur==*nsimax) { + if(mess!=0) + Rprintf("Warning: failed to converge after nsimax=%d simulations",*nsimax); + r=1; + } + for(i=0;i<(*point_nb);i++) + { xx[i]=x[i]; + yy[i]=y[i]; + } + free(l); + return r; +} + +double echange_point_rect(int point_nb,double *x,double *y,double xmi,double xma,double ymi,double yma,double intensity,double p,double cout,double * lobs,int *t2,double *dt,double *g,double *k) +{ + double xr, yr, xcent[4], ycent[4], n_cout[4],*l,xprec,yprec; + int erreur,max,i,j,num; + vecalloc(&l,*t2); + GetRNGstate(); + num=unif_rand()* (point_nb);// numero de l'arbre que l'on retire + xprec=x[num]; + yprec=y[num]; + xr=xma-xmi; + yr=yma-ymi; + + for(i=0;i<*t2;i++) + { g[i]=0; + k[i]=0; + } + + + for(j=0;j<4;j++) + { + xcent[j]=xmi+(unif_rand()*(xr/p))*p;// coordonnées (x,y) du point tiré + ycent[j]=ymi+(unif_rand()*(yr/p))*p; + x[num]=xcent[j]; + y[num]=ycent[j]; + erreur=ripley_rect(&point_nb,x,y,&xmi,&xma,&ymi,&yma,t2,dt,g,k); + if (erreur!=0) return -1; + for(i=0;i<*t2;i++) + { l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + //l[i]=sqrt(k[i]/(intensity*Pi())); + } + n_cout[j]=0; + for(i=0;i<*t2;i++) + { n_cout[j]+=(lobs[i]-l[i])*(lobs[i]-l[i]); + //n_cout[j]+=(lobs[i]-l[i])*(lobs[i]-l[i])/(lobs[i]*lobs[i]); + } + } + PutRNGstate(); + max=0; + for(i=1;i<4;i++) + { + if(n_cout[i]<n_cout[max]) + max=i; + } + if(n_cout[max]<cout) // on prend le nouveau point qui minimise le coût + { + x[num]=xcent[max]; + y[num]=ycent[max]; + cout=n_cout[max]; + } + else // on reprend l'ancien point + { + x[num]=xprec; + y[num]=yprec; + } + + free(l); + + return cout; + + +} + +int mimetic_disq(int *point_nb,double *x,double *y, double *surface,double *x0,double *y0,double *r0, + double *prec, int *t2, double *dt, double *lobs, int *nsimax, int *conv, double *cost, + double *g, double *k,double *xx,double *yy,int *mess) +{ + int i,compteur_c=0,r=0,erreur=0; + int compteur=0; + double *l; + double cout,cout_c; + double intensity=(*point_nb)/(*surface); + vecalloc(&l,*t2); + + //creation of a initial point pattern and cost + //r=s_RegularProcess_disq(*point_nb,3,x,y,*x0,*y0,*r0,*prec); + //r=s_NeymanScott_disq(5,*point_nb,3,x,y,*x0,*y0,*r0,*prec); + s_alea_disq(*point_nb,x,y,*x0,*y0,*r0,*prec); + erreur=ripley_disq(point_nb,x,y,x0,y0,r0,t2,dt,g,k); + if (erreur!=0) + { + return -1; + } + cout=0; + for(i=0;i<*t2;i++) + { l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + cout+=(lobs[i]-l[i])*(lobs[i]-l[i]); + } + cost[0]=cout; + + int lp=0; + if(mess!=0) + Rprintf("Simulated annealing\n"); + while(compteur<*nsimax) + { cout_c=echange_point_disq(*point_nb,x,y,*x0,*y0,*r0,intensity,*prec,cout,lobs,t2,dt,g,k); + if(cout==cout_c) + { + compteur_c++; + } + else compteur_c=0; + cout=cout_c; + //Rprintf(" coût calculé : %f\n", cout); + compteur++; + cost[compteur]=cout; + if(compteur_c==*conv) + break; + if(mess!=0) { + R_FlushConsole(); + progress(compteur,&lp,*nsimax); + } + } + if(compteur==(*nsimax)) { + if(mess!=0) + Rprintf("Warning: failed to converge after nsimax=%d simulations",*nsimax); + r=1; + } + for(i=0;i<(*point_nb);i++) + { xx[i]=x[i]; + yy[i]=y[i]; + } + free(l); + return r; +} + +double echange_point_disq(int point_nb,double *x,double *y,double x0,double y0,double r0,double intensity,double p,double cout,double * lobs,int *t2,double *dt,double *g,double *k) +{ + double rr, xcent[4], ycent[4], n_cout[4],*l,xprec,yprec; + int erreur,max,i,j,num; + vecalloc(&l,*t2); + GetRNGstate(); + num=unif_rand()* (point_nb);// numero de l'arbre que l'on retire + xprec=x[num]; + yprec=y[num]; + rr=2*r0; + for(j=0;j<4;j++) + { + xcent[j]=x0-r0+(unif_rand()*(rr/p))*p;// coordonnées (x,y) du point tiré + ycent[j]=y0-r0+(unif_rand()*(rr/p))*p; + while ((xcent[j]-x0)*(xcent[j]-x0)+(ycent[j]-y0)*(ycent[j]-y0)>=r0*r0) + { + xcent[j]=x0-r0+(unif_rand()*(rr/p))*p;// coordonnées (x,y) du point tiré + ycent[j]=y0-r0+(unif_rand()*(rr/p))*p; + } + x[num]=xcent[j]; + y[num]=ycent[j]; + erreur=ripley_disq(&point_nb,x,y,&x0,&y0,&r0,t2,dt,g,k); + if (erreur!=0) + { + return -1; + } + for(i=0;i<*t2;i++) + { + l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + } + + n_cout[j]=0; + for(i=0;i<*t2;i++) + { + n_cout[j]+=(lobs[i]-l[i])*(lobs[i]-l[i]); + } + + + } + PutRNGstate(); + max=0; + for(i=1;i<4;i++) + { + if(n_cout[i]<n_cout[max]) + max=i; + } + if(n_cout[max]<cout) // on prend le nouveau point qui minimise le coût + { + x[num]=xcent[max]; + y[num]=ycent[max]; + cout=n_cout[max]; + } + else // on reprend l'ancien point + { + x[num]=xprec; + y[num]=yprec; + } + + free(l); + + return cout; + + +} + +int mimetic_tr_rect(int *point_nb,double *x,double *y, double *surface,double *xmi,double *xma,double *ymi,double *yma, + int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + double *prec, int *t2, double *dt, double *lobs, int *nsimax, int *conv, double *cost, + double *g, double *k,double *xx,double *yy,int *mess) +{ + int i,compteur_c=0,r=0,erreur=0; + int compteur=0; + double *l; + double cout,cout_c; + double intensity=(*point_nb)/(*surface); + vecalloc(&l,*t2); + + //creation of a initial point pattern and cost + s_alea_tr_rect(*point_nb,x,y,*xmi,*xma,*ymi,*yma,*triangle_nb,ax,ay,bx,by,cx,cy,*prec); + erreur=ripley_tr_rect(point_nb,x,y,xmi,xma,ymi,yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { + return -1; + } + cout=0; + for(i=0;i<*t2;i++) + { l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + cout+=(lobs[i]-l[i])*(lobs[i]-l[i]); + } + cost[0]=cout; + + int lp=0; + if(mess!=0) + Rprintf("Simulated annealing\n"); + while(compteur<*nsimax) + { cout_c=echange_point_tr_rect(*point_nb,x,y,*xmi,*xma,*ymi,*yma,triangle_nb,ax,ay,bx,by,cx,cy,intensity,*prec,cout,lobs,t2,dt,g,k); + if(cout==cout_c) + compteur_c++; + else compteur_c=0; + cout=cout_c; + //Rprintf(" coût calculé : %f\n", cout); + compteur++; + cost[compteur]=cout; + if(compteur_c==*conv) + break; + if(mess!=0) { + R_FlushConsole(); + progress(compteur,&lp,*nsimax); + } + } + if(compteur==(*nsimax)) { + if(mess!=0) + Rprintf("Warning: failed to converge after nsimax=%d simulations",*nsimax); + r=1; + } + for(i=0;i<(*point_nb);i++) + { xx[i]=x[i]; + yy[i]=y[i]; + } + free(l); + return r; +} + +double echange_point_tr_rect(int point_nb,double *x,double *y,double xmi,double xma,double ymi,double yma, + int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + double intensity,double p,double cout,double * lobs,int *t2,double *dt,double *g,double *k) +{ + double xr, yr, xcent[4], ycent[4], n_cout[4],*l,xprec,yprec; + int erreur,max,i,j,num,erreur_tr,s; + vecalloc(&l,*t2); + GetRNGstate(); + num=unif_rand()* (point_nb);// numero de l'arbre que l'on retire + xprec=x[num]; + yprec=y[num]; + xr=xma-xmi; + yr=yma-ymi; + for(j=0;j<4;j++) + { + do + { erreur_tr=0; + xcent[j]=xmi+(unif_rand()*(xr/p))*p;// coordonnées (x,y) du point tiré + ycent[j]=ymi+(unif_rand()*(yr/p))*p; + x[num]=xcent[j]; + y[num]=ycent[j]; + for(s=0;s<*triangle_nb;s++) + if (in_triangle(x[num],y[num],ax[s],ay[s],bx[s],by[s],cx[s],cy[s],1)) + erreur_tr=1; + } + while(erreur_tr==1); + //Rprintf("point pris\n"); + + erreur=ripley_tr_rect(&point_nb,x,y,&xmi,&xma,&ymi,&yma,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) return -1; + for(i=0;i<*t2;i++) + l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + n_cout[j]=0; + for(i=0;i<*t2;i++) + n_cout[j]+=(lobs[i]-l[i])*(lobs[i]-l[i]); + } + PutRNGstate(); + max=0; + for(i=1;i<4;i++) + { + if(n_cout[i]<n_cout[max]) + max=i; + } + if(n_cout[max]<cout) // on prend le nouveau point qui minimise le coût + { + x[num]=xcent[max]; + y[num]=ycent[max]; + cout=n_cout[max]; + } + else // on reprend l'ancien point + { + x[num]=xprec; + y[num]=yprec; + } + + free(l); + + return cout; + + +} + +int mimetic_tr_disq(int *point_nb,double *x,double *y, double *surface,double *x0,double *y0,double *r0, + int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + double *prec, int *t2, double *dt, double *lobs, int *nsimax, int *conv, double *cost, + double *g, double *k,double *xx,double *yy,int *mess) +{ + int i,compteur_c=0,r=0,erreur=0; + int compteur=0; + double *l; + double cout,cout_c; + double intensity=(*point_nb)/(*surface); + vecalloc(&l,*t2); + + //creation of a initial point pattern and cost + //r=s_RegularProcess_tr_disq(*point_nb,3,x,y,*x0,*y0,*r0,triangle_nb,ax,ay,bx,by,cx,cy,*prec); + //r=s_NeymanScott_tr_disq(4,*point_nb,2,x,y,*x0,*y0,*r0,triangle_nb,ax,ay,bx,by,cx,cy,*prec); + s_alea_tr_disq(*point_nb,x,y,*x0,*y0,*r0,*triangle_nb,ax,ay,bx,by,cx,cy,*prec); + erreur=ripley_tr_disq(point_nb,x,y,x0,y0,r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { + return -1; + } + cout=0; + for(i=0;i<*t2;i++) + { l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + cout+=(lobs[i]-l[i])*(lobs[i]-l[i]); + } + cost[0]=cout; + + int lp=0; + if(mess!=0) + Rprintf("Simulated annealing\n"); + while(compteur<*nsimax) + { cout_c=echange_point_tr_disq(*point_nb,x,y,*x0,*y0,*r0,triangle_nb,ax,ay,bx,by,cx,cy,intensity,*prec,cout,lobs,t2,dt,g,k); + if(cout==cout_c) + { + compteur_c++; + } + else compteur_c=0; + cout=cout_c; + //Rprintf(" coût calculé : %f\n", cout); + compteur++; + cost[compteur]=cout; + if(compteur_c==*conv) + break; + if(mess!=0) { + R_FlushConsole(); + progress(compteur,&lp,*nsimax); + } + } + if(compteur==(*nsimax)) { + if(mess!=0) + Rprintf("Warning: failed to converge after nsimax=%d simulations",*nsimax); + r=1; + } + for(i=0;i<(*point_nb);i++) + { xx[i]=x[i]; + yy[i]=y[i]; + } + free(l); + return r; +} + +double echange_point_tr_disq(int point_nb,double *x,double *y,double x0,double y0,double r0, + int *triangle_nb, double *ax, double *ay, double *bx, double *by, double *cx, double *cy, + double intensity,double p,double cout,double * lobs,int *t2,double *dt,double *g,double *k) +{ + double rr, xcent[4], ycent[4], n_cout[4],*l,xprec,yprec; + int erreur,max,i,j,num,erreur_tr,s; + vecalloc(&l,*t2); + GetRNGstate(); + num=unif_rand()* (point_nb);// numero de l'arbre que l'on retire + xprec=x[num]; + yprec=y[num]; + rr=2*r0; + for(j=0;j<4;j++) + { + do + { + erreur_tr=0; + xcent[j]=x0-r0+(unif_rand()*(rr/p))*p;// coordonnées (x,y) du point tiré + ycent[j]=y0-r0+(unif_rand()*(rr/p))*p; + while ((xcent[j]-x0)*(xcent[j]-x0)+(ycent[j]-y0)*(ycent[j]-y0)>=r0*r0) + { + xcent[j]=x0-r0+(unif_rand()*(rr/p))*p;// coordonnées (x,y) du point tiré + ycent[j]=y0-r0+(unif_rand()*(rr/p))*p; + } + x[num]=xcent[j]; + y[num]=ycent[j]; + for(s=0;s<*triangle_nb;s++) + { + if (in_triangle(x[num],y[num],ax[s],ay[s],bx[s],by[s],cx[s],cy[s],1)) + { + erreur_tr=1; + //Rprintf("erreur_tr\n"); + } + } + + } + while(erreur_tr==1); + //Rprintf("point pris\n"); + + erreur=ripley_tr_disq(&point_nb,x,y,&x0,&y0,&r0,triangle_nb,ax,ay,bx,by,cx,cy,t2,dt,g,k); + if (erreur!=0) + { + return -1; + } + for(i=0;i<*t2;i++) + { + l[i]=sqrt(k[i]/(intensity*Pi()))-(i+1)*(*dt); + } + + n_cout[j]=0; + for(i=0;i<*t2;i++) + { + n_cout[j]+=(lobs[i]-l[i])*(lobs[i]-l[i]); + } + + + } + PutRNGstate(); + max=0; + for(i=1;i<4;i++) + { + if(n_cout[i]<n_cout[max]) + max=i; + } + if(n_cout[max]<cout) // on prend le nouveau point qui minimise le coût + { + x[num]=xcent[max]; + y[num]=ycent[max]; + cout=n_cout[max]; + } + else // on reprend l'ancien point + { + x[num]=xprec; + y[num]=yprec; + } + + free(l); + + return cout; + +} + + +int shen(int *point_nb,double *x,double *y, + int *t2,double *dt, + int *nbtype,int *type,double *mat,double *surface,double *HD, + double *gd, double *kd, int *error) +{ + int i,j,p; + int *l; + int compt[*nbtype+1]; + double *g,*k; + double *ds,dis; + + vecintalloc(&l,*nbtype+1); + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + // l contient le nombre d'arbres par espce + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + // crŽation des tableaux xx et yy par espce + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gsii,*ksii,*grii,*krii; + vecalloc(&gsii,*t2); + vecalloc(&ksii,*t2); + vecalloc(&grii,*t2); + vecalloc(&krii,*t2); + + for(j=0;j<*t2;j++) + { gsii[j]=0; + ksii[j]=0; + grii[j]=0; + krii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + double D=(float)l[1]*((float)l[1]-1); + + //Intertype for each pairs of types + for(i=1;i<*nbtype;i++) + { D+=(float)l[i+1]*((float)l[i+1]-1); + for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + //D+=(float)l[i+1]*((float)l[p+1]); + //H+=dis*(float)l[i]*((float)l[p]); + erreur=intertype(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gsii[j]+=intensity1*g[j]/ds[j]; + ksii[j]+=intensity1*k[j]; + grii[j]+=dis*intensity1*g[j]/ds[j]; + krii[j]+=dis*intensity1*k[j]; + } + erreur=intertype(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gsii[j]+=intensity2*g[j]/ds[j]; + ksii[j]+=intensity2*k[j]; + grii[j]+=dis*intensity2*g[j]/ds[j]; + krii[j]+=dis*intensity2*k[j]; + } + } + } + + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + + for(j=0;j<*t2;j++) + { gd[j]=(D*grii[j])/((*HD)*gsii[j]); + kd[j]=(D*krii[j])/((*HD)*ksii[j]); + } + /*D=D/((float)(*point_nb)*((float)(*point_nb)-1)); + H=H/((float)(*point_nb)*((float)(*point_nb)-1)); + + for(j=0;j<*t2;j++) + { gd[j]=(grii[j]/H)/(gsii[j]/D); + kd[j]=(krii[j]/H)/(ksii[j]/D); + }*/ + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + freevec(gsii); + freevec(ksii); + freevec(grii); + freevec(krii); + freevec(ds); + return 0; +} + +int shen_ic(int *point_nb,double *x,double *y, + int *t2,double *dt,int *nbSimu,double *lev, + int *nbtype,int *type,double *mat,double *surface,double *HD, + double *gd, double *kd, double *gic1,double *gic2,double *kic1,double *kic2, + double *gval,double *kval,int *error) +{ + int i,j,p; + int *l; + int compt[*nbtype+1]; + double *g,*k; + double *ds,dis; + + vecintalloc(&l,*nbtype+1); + vecalloc(&g,*t2); + vecalloc(&k,*t2); + + // l contient le nombre d'arbres par espce + for(i=1;i<*nbtype+1;i++){ + l[i]=0; + compt[i]=0; + for(j=0;j<*point_nb;j++){ + if(type[j]==i) + l[i]++; + } + } + + // crŽation des tableaux xx et yy par espce + double **xx,**yy; + xx=taballoca(*nbtype,l); + yy=taballoca(*nbtype,l); + vecalloc(&ds,*t2); + complete_tab(*point_nb,xx,yy,type,compt,l,x,y); + + int erreur; + double intensity1,point_nb2,point_nb1,intensity2; + double intensity=*point_nb/(*surface); + double *gsii,*ksii,*grii,*krii; + vecalloc(&gsii,*t2); + vecalloc(&ksii,*t2); + vecalloc(&grii,*t2); + vecalloc(&krii,*t2); + + for(j=0;j<*t2;j++) + { gsii[j]=0; + ksii[j]=0; + grii[j]=0; + krii[j]=0; + ds[j]=(Pi()*(j+1)*(*dt)*(j+1)*(*dt))-(Pi()*j*j*(*dt)*(*dt)); + } + + double D=(float)l[1]*((float)l[1]-1); + + //Intertype for each pairs of types + for(i=1;i<*nbtype;i++) + { D+=(float)l[i+1]*((float)l[i+1]-1); + for(p=0;p<i;p++) + { dis=mat[p*(*nbtype-2)-(p-1)*p/2+i-1]; + //D+=(float)l[i+1]*((float)l[p+1]); + //H+=dis*(float)l[i]*((float)l[p]); + erreur=intertype(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { gsii[j]+=intensity1*g[j]/ds[j]; + ksii[j]+=intensity1*k[j]; + grii[j]+=dis*intensity1*g[j]/ds[j]; + krii[j]+=dis*intensity1*k[j]; + } + erreur=intertype(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],t2,dt,g,k); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { gsii[j]+=intensity2*g[j]/ds[j]; + ksii[j]+=intensity2*k[j]; + grii[j]+=dis*intensity2*g[j]/ds[j]; + krii[j]+=dis*intensity2*k[j]; + } + } + } + + D=1-D/((float)(*point_nb)*((float)(*point_nb)-1)); + + for(j=0;j<*t2;j++) + { gd[j]=(D*grii[j])/((*HD)*gsii[j]); + kd[j]=(D*krii[j])/((*HD)*ksii[j]); + } + + ////////////// + //simulations sur gii, kii + double **gic,**kic; + int i0,i1,i2; + + //Definition de i0 : indice ou sera stocke l'estimation des bornes de l'IC + i0=*lev/2*(*nbSimu+1); + if (i0<1) i0=1; + + //Initialisation des tableaux dans lesquels on va stocker les valeurs extremes lors de MC + taballoc(&gic,*t2+1,2*i0+10+1); + taballoc(&kic,*t2+1,2*i0+10+1); + + for(i=0;i<*t2;i++) + { gval[i]=1; + kval[i]=1; + } + //prŽparation des tableaux pour randomisation de dis (H0=2) + int b,lp=0; + double HDsim; + int *vec, mat_size; + vecintalloc(&vec,*nbtype); + double *matp; + mat_size=*nbtype*(*nbtype-1)/2; + vecalloc(&matp,mat_size); + for(i=0;i<*nbtype;i++) + vec[i]=i; + for(i=0;i<mat_size;i++) + matp[i]=0; + + //boucle principale de MC + Rprintf("Monte Carlo simulation\n"); + for(b=1;b<=*nbSimu;b++) + { randomdist(vec,*nbtype,mat,matp); + HDsim=0; + for(i=0;i<*t2;i++) + { grii[i]=0; + krii[i]=0; + } + for(i=1;i<*nbtype;i++) + { for(p=0;p<i;p++) + { dis=matp[p*(*nbtype-2)-(p-1)*p/2+i-1]; + HDsim+=(float)l[i+1]/(float)(*point_nb)*(float)l[p+1]/(float)(*point_nb)*dis; + erreur=intertype(&l[i+1],xx[i],yy[i],&l[p+1],xx[p],yy[p],t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 1 Intertype\n"); + intensity1=l[i+1]/(*surface); + for(j=0;j<*t2;j++) + { grii[j]+=dis*intensity1*gic1[j]/ds[j]; + krii[j]+=dis*intensity1*kic1[j]; + } + erreur=intertype(&l[p+1],xx[p],yy[p],&l[i+1],xx[i],yy[i],t2,dt,gic1,kic1); + if (erreur!=0) + Rprintf("ERREUR 2 Intertype\n"); + intensity2=l[p+1]/(*surface); + for(j=0;j<*t2;j++) + { grii[j]+=dis*intensity2*gic1[j]/ds[j]; + krii[j]+=dis*intensity2*kic1[j]; + } + } + } + + for(j=0;j<*t2;j++) + { grii[j]=(D*grii[j])/((2*HDsim)*gsii[j]); + krii[j]=(D*krii[j])/((2*HDsim)*ksii[j]); + //deviation from theo=1 + if ((float)fabs(gd[j]-1)<=(float)fabs(grii[j]-1)) gval[j]+=1; + if ((float)fabs(kd[j]-1)<=(float)fabs(krii[j]-1)) kval[j]+=1; + } + + //Traitement des resultats + ic(b,i0,gic,kic,grii,krii,*t2); + R_FlushConsole(); + progress(b,&lp,*nbSimu); + } + + i1=i0+2; + i2=i0; + + //Copies des valeurs dans les tableaux resultats + for(i=0;i<*t2;i++) + { gic1[i]=gic[i+1][i1]; + gic2[i]=gic[i+1][i2]; + kic1[i]=kic[i+1][i1]; + kic2[i]=kic[i+1][i2]; + } + free(gic); + free(kic); + freeintvec(vec); + freevec(matp); + + for( i = 0; i < *nbtype; i++) + { free(xx[i]); + free(yy[i]); + } + free(xx); + free(yy); + free(g); + free(k); + free(l); + freevec(gsii); + freevec(ksii); + freevec(grii); + freevec(krii); + freevec(ds); + return 0; +} + +int intertype(int *point_nb1,double *x1,double *y1,int *point_nb2, double *x2, double *y2,int *t2,double *dt,double *g,double *k) +{ int i,j,tt; + double d; + + /*On rangera dans g le nombre de couples de points par distance tt*/ + for(tt=0;tt<*t2;tt++) + g[tt]=0; + + /* On regarde tous les couples (i,j)*/ + for(i=0;i<*point_nb1;i++) + { for(j=0;j<*point_nb2;j++) + { d=sqrt((x1[i]-x2[j])*(x1[i]-x2[j])+(y1[i]-y2[j])*(y1[i]-y2[j])); + if (d<*t2*(*dt)) + { /* dans quelle classe de distance est ce couple ?*/ + tt=d/(*dt); + /* pas de correction des effets de bord*/ + g[tt]+=1; + } + } + } + + /* on moyenne -> densite*/ + for(tt=0;tt<*t2;tt++) + g[tt]=g[tt]/(*point_nb1); + + /*on integre*/ + k[0]=g[0]; + for(tt=1;tt<*t2;tt++) + k[tt]=k[tt-1]+g[tt]; + + return 0; +} diff --git a/src/Zlibs.h b/src/Zlibs.h new file mode 100755 index 0000000000000000000000000000000000000000..9130b52accd90d87d9d6aa0063d047ed99d007f1 --- /dev/null +++ b/src/Zlibs.h @@ -0,0 +1,175 @@ +double un_point(double,double,double,double,double,double,double,double,double); +double deux_point(double,double,double,double,double,double,double,double,double); +double ununun_point(double,double,double,double,double,double,double,double,double); +double trois_point(double,double,double,double,double,double,double,double,double); +double deuxun_point(double,double,double,double,double,double,double,double,double); +double deuxbord_point(double,double,double,double,double,double,double,double,double); + +int in_droite(double,double,double,double,double,double,double,double,int); +int in_triangle(double,double,double,double,double,double,double,double,int); + +void ic(int,int,double **,double **,double *,double *,int); + +double perim_in_rect(double, double, double, double, double, double, double); +double perim_in_disq(double,double,double,double,double,double); +double perim_triangle(double,double,double,int,double *,double *,double *,double *,double *,double *); + +int ripley_rect(int*,double*,double*,double*,double*,double*,double*,int*,double*,double*,double*); +int ripley_disq(int *,double *,double *,double *,double *,double *,int *,double *,double *,double *); +int ripley_tr_rect(int *,double *,double *,double *,double *,double *,double *,int *,double *,double *, + double *,double *,double *,double *,int *,double *,double *,double *); +int ripley_tr_disq(int *,double *,double *,double *,double *,double *,int *,double *,double *,double *,double *, + double *,double *,int *,double *,double *,double *); + +int ripley_rect_ic(int *,double *,double *,double *,double *,double *,double *,double *,int *,double *,int *, + double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *); +int ripley_disq_ic(int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,double *, + double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *); +int ripley_tr_rect_ic(int *,double *,double *,double *,double *,double *,double *,double *,int *, double *, + double *,double *,double *,double *,double *,int *,double *,int *,double *,double *,double *,double *, + double *,double *,double *,double *,double *,double *,double *,double *); +int ripley_tr_disq_ic(int *,double *,double *,double *,double *,double *,double *,int *, double *, double *, + double *,double *,double *,double *,int *,double *,int *,double *,double *,double *,double *,double *, + double *,double *,double *,double *,double *,double *,double *); + +int ripleylocal_rect(int*,double *,double *,double*,double*,double*,double*,int*,double*,double *,double *); +int ripleylocal_disq(int *,double *,double *,double *,double *,double *,int *,double *,double *,double *); +int ripleylocal_tr_rect(int *,double *,double *,double *,double *,double *,double *,int *, + double *,double *,double *,double *,double *,double *,int *,double *,double *,double *); +int ripleylocal_tr_disq(int *,double *,double *,double *,double *,double *,int *, + double *,double *,double *,double *,double *,double *,int *,double *,double *,double *); + +int density_rect(int*,double*,double*,double*,double*,double*,double*,int*,double*,double*,double*,int*,double*); +int density_disq(int*,double *,double *,double*,double*,double*,int*,double*,double *,double *,int*,double *); +int density_tr_rect(int*,double *,double *,double*,double*,double*,double*,int*,double *,double *,double *, + double *,double *,double *,int*,double*,double *,double *,int*,double *); +int density_tr_disq(int*,double *,double *,double*,double*,double*,int*,double *,double *,double *,double *, + double *,double *,int*,double*,double *,double *,int*,double *); + +int intertype_rect(int *,double *,double *,int *,double *,double *,double *,double *,double *,double *, + int *,double *,double *,double *); +int intertype_disq(int *,double *,double *,int *,double *,double *,double *,double *,double *,int *, + double *,double *,double *); +int intertype_tr_rect(int *,double *,double *,int *,double *,double *,double *,double *,double *,double *,int *, + double *,double *,double *,double *,double *,double *,int *,double *,double *,double *); +int intertype_tr_disq(int *,double *,double *,int *,double *,double *,double *,double *,double *,int *, + double *,double *,double *,double *,double *,double *,int *,double *,double *,double *); + +int intertype_rect_ic(int *,double *,double *,int *,double *,double *,double *,double *,double *,double *, + double *,int *,double *,int *,int *,double *,int *, int *, int *, double *,double *,double *,double *,double *,double *,double *, + double *,double *,double *,double *); +int intertype_disq_ic(int *,double *,double *,int *,double *,double *,double *,double *,double *,double *,int *, + double *,int *,int *,double *,int *,int *,int *,double *,double *,double *,double *,double *,double *,double *,double *, + double *,double *,double *); +int intertype_tr_rect_ic(int *,double *,double *,int *,double *,double *,double *,double *,double *,double *, + double *,int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,int *,double *,int *,int *,int *,double *, + double *,double *,double *,double *,double *,double *,double *,double *,double *,double *); +int intertype_tr_disq_ic(int *,double *,double *,int *, double *, double *,double *,double *,double *,double *, + int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,int *,double *,int *,int *,int*,double *,double *, + double *,double *,double *,double *,double *,double *,double *,double *,double *); + +int intertypelocal_rect(int*,double *,double *,int*,double *,double *,double*,double*,double*,double*, + int*,double*,double *,double *); +int intertypelocal_disq(int *,double *,double *,int *,double *,double *,double *,double *, double *,int *, + double *,double *,double *); +int intertypelocal_tr_rect(int *,double *,double *,int *,double *,double *,double *,double *,double *,double *, + int *,double *,double *,double *,double *,double *,double *,int *,double *,double *,double *); +int intertypelocal_tr_disq(int *,double *,double *,int *,double *,double *,double *,double *,double *,int *, + double *,double *,double *,double *,double *,double *,int *,double *,double *,double *); + +void s_alea_rect(int,double[],double[],double,double,double,double,double); +void s_alea_disq(int,double *,double *,double,double,double,double); +void s_alea_tr_rect(int,double *,double *,double,double,double,double,int,double *,double *,double *,double *, + double *,double *,double); +void s_alea_tr_disq(int ,double *,double *,double,double,double,int,double *,double *,double *,double *, + double *,double *,double); + +int randlabelling(double *, double *, int, double *, double *,int, double *, double *,int *); +int randshifting_rect(int *,double *,double *,int,double *,double *,double,double,double,double,double); +int randshifting_disq(int *,double *,double *,int,double *,double *,double,double,double,double); +int randshifting_tr_rect(int *,double *,double *,int,double *,double *,double,double,double,double,int, + double *,double *,double *,double *,double *,double *,double); +int randshifting_tr_disq(int *,double *,double *,int,double *,double *,double,double,double,int, + double *,double *,double *,double *,double *,double *,double); +int randomlab(double *,double *,int,int *,int,double **,int *,double **); +void randmark(int ,double *,double *); +int randomdist(int *,int,double *,double *); + +int corr_rect(int *,double *,double *,double *, double *,double *,double *,double *, +int *,double *,double *,double *); +int corr_disq(int *,double *,double *,double *, double *,double *,double *, +int *,double *,double *,double *); +int corr_tr_rect(int *,double *,double *,double *, double *,double *,double *,double *, +int *, double *, double *, double *, double *, double *, double *, +int *,double *,double *,double *); +int corr_tr_disq(int *,double *,double *,double *, double *,double *,double *, +int *,double *,double *,double *,double *,double *,double *, +int *,double *,double *,double *); + +int corr_rect_ic(int *,double *,double *,double *, double *,double *,double *,double *, +int *,double *,int *, double *,double *,double *, +double *,double *, double *,double *, double *, double *); +int corr_disq_ic(int *,double *,double *,double *, double *,double *,double *, +int *,double *,int *, double *,double *,double *, +double *,double *, double *,double *, double *, double *); +int corr_tr_rect_ic(int *,double *,double *,double *, double *,double *,double *,double *, +int *, double *, double *, double *, double *, double *, double *, +int *,double *,int *, double *,double *,double *, +double *,double *, double *,double *, double *, double *); +int corr_tr_disq_ic(int *,double *x,double *,double *, double *,double *,double *, +int *, double *, double *, double *, double *, double *, double *, +int *,double *,int *, double *,double *,double *, +double *,double *, double *,double *, double *, double *); + +int shimatani_rect(int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,int *,double *,double *, double *,int *); +int shimatani_disq(int *,double *,double *, double *,double *,double *,int *,double *,int *,int *,double *,double *, double *,int *); +int shimatani_tr_rect(int *,double *,double *, double *,double *,double *,double *,int *, double *, double *, double *, double *, double *, double *, + int *,double *,int *,int *,double *,double *, double *,int *); +int shimatani_tr_disq(int *,double *,double *, double *,double *,double *,int *, double *, double *, double *, double *, double *, double *, + int *,double *,int *,int *,double *,double *, double *,int *); +int shimatani_rect_ic(int *,double *,double *, double *,double *,double *,double *,int *,double *,int *,double *,int *,int *,double *,double *, + double *, double *,double *,double *,double *,double *,double *,double *,int *); +int shimatani_disq_ic(int *,double *,double *, double *,double *,double *,int *,double *,int *,double *,int *,int *,double *,double *, + double *, double *,double *,double *,double *,double *,double *,double *,int *); +int shimatani_tr_rect_ic(int *,double *,double *, double *,double *,double *,double *,int *, double *, double *, double *, double *, double *, double *, + int *,double *,int *,double *,int *,int *,double *,double *,double *, double *,double *,double *,double *,double *,double *,double *,int *); +int shimatani_tr_disq_ic(int *,double *,double *, double *,double *,double *,int *, double *, double *, double *, double *, double *, double *, + int *,double *,int *,double *,int *,int *,double *,double *,double *, double *,double *,double *,double *,double *,double *,double *,int *); + +int rao_rect(int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,int *,int *,double *,double *,double *,double *, + double *,double *,double *,int *); +int rao_rect_ic(int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,int *,double *,int *,int *,double *,double *, + double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,int *); +int rao_disq(int *,double *,double *,double *,double *,double *,int *,double *,int *,int *,int *,double *,double *,double *,double *, + double *,double *,double *,int *); +int rao_disq_ic(int *,double *,double *,double *,double *,double *,int *,double *,int *,int *,double *,int *,int *,double *,double *, + double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,int *); +int rao_tr_rect(int *,double *,double *,double *,double *,double *,double *,int *,double *,double *,double *,double *,double *,double *, + int *,double *,int *,int *,int *,double *,double *,double *,double *,double *,double *,double *,int *); + +int rao_tr_rect_ic(int *,double *,double *,double *,double *,double *,double *,int *,double *,double *,double *,double *,double *,double *, + int *,double *,int *,int *,double *,int *,int *,double *,double *,double *,double *,double *,double *,double *,double *, + double *,double *,double *,double *,double *,int *); +int rao_tr_disq(int *,double *,double *,double *,double *,double *,int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,int *,int *, + double *,double *,double *,double *,double *,double *,double *,int *); +int rao_tr_disq_ic(int *,double *,double *,double *,double *,double *,int *,double *,double *,double *,double *,double *,double *,int *,double *,int *,int *,double *, + int *,int *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,double *,int *); + +int mimetic_rect(int *,double *,double *, double *,double *,double *,double *,double *,double *, int *,double *,double *,int *,int *,double *,double *,double *,double *,double *,int *); +int mimetic_disq(int *,double *,double *,double *,double *,double *,double *,double *, int *, double *, double *, int *, int *, double *,double *,double *,double *,double *,int *); +int mimetic_tr_rect(int *,double *,double *, double *,double *,double *,double *,double *,int *, double *, double *, double *, double *, double *, double *, + double *, int *, double *, double *, int *, int *, double *,double *, double *,double *,double *,int *); +int mimetic_tr_disq(int *,double *,double *, double *,double *,double *,double *,int *, double *,double *,double *,double *,double *,double *cy, + double *, int *, double *, double *, int *, int *, double *,double *,double *,double *,double *,int *); +double echange_point_rect(int,double *,double *,double,double,double,double,double,double,double,double *,int *,double *,double *,double *); +double echange_point_disq(int,double *,double *,double,double,double,double,double,double,double *,int *,double *,double *,double *); +double echange_point_tr_rect(int,double *,double *,double,double,double,double,int *,double *,double *,double *,double *,double *,double *, + double,double,double,double *,int *,double *,double *,double *); +double echange_point_tr_disq(int,double *,double *,double,double,double,int *,double *,double *,double *,double *,double *,double *, + double,double,double,double *,int *,double *,double *,double *); + +int shen(int *,double *,double *,int *,double *,int *,int *,double *,double *,double *,double *, double *, int *); + +int shen_ic(int *,double *,double *,int *,double *,int *,double *,int *,int *,double *,double *,double *, + double *, double *, double *,double *,double *,double *,double *,double *,int *); +int intertype(int *,double *,double *,int *, double *, double *,int *,double *,double *,double *); diff --git a/src/adssub.c b/src/adssub.c new file mode 100755 index 0000000000000000000000000000000000000000..2ed04ba06c7bad388118c4ab1983e7d67091a5e3 --- /dev/null +++ b/src/adssub.c @@ -0,0 +1,349 @@ +#include "adssub.h" +#include <math.h> + +double Pi() { + return 2*acos(0); +} + +void progress(int i,int *l, int max) { + int nb=20; + int p=i*(nb+1)/max; + int j; + + if(p>*l){ + for(j=*l;j<p;j++) { + if(j==nb) { + Rprintf("ok\n"); + } + else { + Rprintf("."); + } + } + *l=p; + } +} + +/*double alea () { + double w; + w = ((double) rand())/ (double)RAND_MAX; + return (w); +}*/ + +/***********************************************************************/ +/*-------------------------------------------------- +* liberation de memoire pour un vecteur +--------------------------------------------------*/ +void freeintvec (int *vec) { + free((char *) vec); + +} + +/*-------------------------------------------------- +* Allocation de memoire dynamique pour un tableau (l1, c1) +--------------------------------------------------*/ +void freetab (double **tab) { + int i, n; + n = *(*(tab)); + for (i=0;i<=n;i++) { + free((char *) *(tab+i) ); + } + free((char *) tab); +} + +/*-------------------------------------------------- +* liberation de memoire pour un vecteur +--------------------------------------------------*/ +void freevec (double *vec) { + free((char *) vec); +} + +/*-------------------------------------------------- +* Allocation de memoire dynamique pour un tableau (l1, c1) +--------------------------------------------------*/ +void taballoc (double ***tab, int l1, int c1) { + int i, j; + if ( (*tab = (double **) calloc(l1+1, sizeof(double *))) != 0) { + for (i=0;i<=l1;i++) { + if ( (*(*tab+i)=(double *) calloc(c1+1, sizeof(double))) == 0 ) { + return; + for (j=0;j<i;j++) { + free(*(*tab+j)); + } + } + } + } + **(*tab) = l1; + **(*tab+1) = c1; +} + +/*-------------------------------------------------- +* Allocation de memoire dynamique pour un tableau +* d'entiers (l1, c1) +--------------------------------------------------*/ +void tabintalloc (int ***tab, int l1, int c1) { + int i, j; + *tab = (int **) calloc(l1+1, sizeof(int *)); + if ( *tab != NULL) { + for (i=0;i<=l1;i++) { + *(*tab+i)=(int *) calloc(c1+1, sizeof(int)); + if ( *(*tab+i) == NULL ) { + for (j=0;j<i;j++) { + free(*(*tab+j)); + } + return; + } + } + } else return; + **(*tab) = l1; + **(*tab+1) = c1; + for (i=1;i<=l1;i++) { + for (j=1;j<=c1;j++) { + (*tab)[i][j] = 0; + } + } +} + +/*-------------------------------------------------- +* Allocation de memoire dynamique pour un tableau +--------------------------------------------------*/ +void freeinttab (int **tab) { + int i, n; + n = *(*(tab)); + for (i=0;i<=n;i++) { + free((char *) *(tab+i) ); + } + free((char *) tab); +} + +/*-------------------------------------------------- +* Allocation de memoire pour un vecteur de longueur n +--------------------------------------------------*/ +void vecalloc (double **vec, int n) { + if ( (*vec = (double *) calloc(n+1, sizeof(double))) != 0) { + **vec = n; + return; + } else { + return; + } +} + +/*-------------------------------------------------- +* Allocation de memoire pour un vecteur d'entiers de longueur n +--------------------------------------------------*/ +void vecintalloc (int **vec, int n) { + if ( (*vec = (int *) calloc(n+1, sizeof(int))) != NULL) { + **vec = n; + return; + } else { + return; + } +} + +/*pour les triangles a exclure*/ +double bacos(double a) { + double b; + if (a>=1) + b=0; + else if (a<=-1) + b=Pi(); + else + b=acos(a); + return b; +} + +/*Decale les valeurs de v de la valeur val*/ +void decalVal(double *v, int n, double val) { + int i; + for(i=0;i<n;i++) { + v[i]=v[i]+val; + } +} + +/*Decale les points et la fenetre rectangulaire*/ +void decalRect(int point_nb,double *x, double *y,double *xmin, double *xmax, double *ymin, double *ymax) { + if(*xmin<0) { + decalVal(x,point_nb,-*xmin); + *xmax=*xmax-*xmin; + *xmin=0; + } + if(*ymin<0) { + decalVal(y,point_nb,-*ymin); + *ymax=*ymax-*ymin; + *ymin=0; + } +} + +/*Decale les points et la fenetre circulaire*/ +void decalCirc(int point_nb,double *x, double *y,double *x0, double *y0, double r0) { + int xmin=*x0-r0; + int ymin=*y0-r0; + if(xmin<0) { + decalVal(x,point_nb,-xmin); + *x0=*x0-xmin; + } + if(ymin<0) { + decalVal(y,point_nb,-ymin); + *y0=*y0-ymin; + } +} + +/*Decale les points et la fenetre rectangulaire + triangles*/ +void decalRectTri(int point_nb,double *x, double *y,double *xmin, double *xmax, double *ymin, double *ymax, +int tri_nb,double *ax, double *ay, double *bx, double *by, double *cx, double *cy) { + if(*xmin<0) { + decalVal(x,point_nb,-*xmin); + decalVal(ax,tri_nb,-*xmin); + decalVal(bx,tri_nb,-*xmin); + decalVal(cx,tri_nb,-*xmin); + *xmax=*xmax-*xmin; + *xmin=0; + } + if(*ymin<0) { + decalVal(y,point_nb,-*ymin); + decalVal(ay,tri_nb,-*ymin); + decalVal(by,tri_nb,-*ymin); + decalVal(cy,tri_nb,-*ymin); + *ymax=*ymax-*ymin; + *ymin=0; + } +} + +/*Decale les points et la fenetre circulaire + triangles*/ +void decalCircTri(int point_nb,double *x, double *y,double *x0, double *y0, double r0, +int tri_nb,double *ax, double *ay, double *bx, double *by, double *cx, double *cy) { + int xmin=*x0-r0; + int ymin=*y0-r0; + if(xmin<0) { + decalVal(x,point_nb,-xmin); + decalVal(ax,tri_nb,-xmin); + decalVal(bx,tri_nb,-xmin); + decalVal(cx,tri_nb,-xmin); + *x0=*x0-xmin; + } + if(ymin<0) { + decalVal(y,point_nb,-ymin); + decalVal(ay,tri_nb,-ymin); + decalVal(by,tri_nb,-ymin); + decalVal(cy,tri_nb,-ymin); + *y0=*y0-ymin; + } +} + +/*Decale les points et la fenetre rectangulaire (semis bivarie)*/ +void decalRect2(int point_nb1,double *x1, double *y1,int point_nb2,double *x2, double *y2, +double *xmin, double *xmax, double *ymin, double *ymax) { + if(*xmin<0) { + decalVal(x1,point_nb1,-*xmin); + decalVal(x2,point_nb2,-*xmin); + *xmax=*xmax-*xmin; + *xmin=0; + } + if(*ymin<0) { + decalVal(y1,point_nb1,-*ymin); + decalVal(y2,point_nb2,-*ymin); + *ymax=*ymax-*ymin; + *ymin=0; + } +} + +/*Decale les points et la fenetre circulaire (semis bivarie)*/ +void decalCirc2(int point_nb1,double *x1, double *y1,int point_nb2,double *x2, double *y2, +double *x0, double *y0, double r0) { + int xmin=*x0-r0; + int ymin=*y0-r0; + if(xmin<0) { + decalVal(x1,point_nb1,-xmin); + decalVal(x2,point_nb2,-xmin); + *x0=*x0-xmin; + } + if(ymin<0) { + decalVal(y1,point_nb1,-ymin); + decalVal(y2,point_nb2,-ymin); + *y0=*y0-ymin; + } +} + +/*Decale les points et la fenetre rectangulaire + triangles (semis bivarie)*/ +void decalRectTri2(int point_nb1,double *x1, double *y1,int point_nb2,double *x2, double *y2, +double *xmin, double *xmax, double *ymin, double *ymax, +int tri_nb,double *ax, double *ay, double *bx, double *by, double *cx, double *cy) { + if(*xmin<0) { + decalVal(x1,point_nb1,-*xmin); + decalVal(x2,point_nb2,-*xmin); + decalVal(ax,tri_nb,-*xmin); + decalVal(bx,tri_nb,-*xmin); + decalVal(cx,tri_nb,-*xmin); + *xmax=*xmax-*xmin; + *xmin=0; + } + if(*ymin<0) { + decalVal(y1,point_nb1,-*ymin); + decalVal(y2,point_nb2,-*ymin); + decalVal(ay,tri_nb,-*ymin); + decalVal(by,tri_nb,-*ymin); + decalVal(cy,tri_nb,-*ymin); + *ymax=*ymax-*ymin; + *ymin=0; + } +} + +/*Decale les points et la fenetre circulaire + triangles (semis bivarie)*/ +void decalCircTri2(int point_nb1,double *x1, double *y1,int point_nb2,double *x2, double *y2, +double *x0, double *y0, double r0, +int tri_nb,double *ax, double *ay, double *bx, double *by, double *cx, double *cy) { + int xmin=*x0-r0; + int ymin=*y0-r0; + if(xmin<0) { + decalVal(x1,point_nb1,-xmin); + decalVal(x2,point_nb2,-xmin); + decalVal(ax,tri_nb,-xmin); + decalVal(bx,tri_nb,-xmin); + decalVal(cx,tri_nb,-xmin); + *x0=*x0-xmin; + } + if(ymin<0) { + decalVal(y1,point_nb1,-ymin); + decalVal(y2,point_nb2,-ymin); + decalVal(ay,tri_nb,-ymin); + decalVal(by,tri_nb,-ymin); + decalVal(cy,tri_nb,-ymin); + *y0=*y0-ymin; + } +} + +/*Decale les points d'echantillonnages (pour density)*/ +void decalSample(int sample_nb,double *x, double *y, double xmin, double ymin) { + if(xmin<0) { + decalVal(x,sample_nb,-xmin); + } + if(ymin<0) { + decalVal(y,sample_nb,-ymin); + } +} + +/*memory allocation for a table with variable row length*/ +double** taballoca(int a,int *b) +{ + double **t; + int i; + t = (double ** ) malloc (a * sizeof (double*)); + for (i=0;i<a;i++) + { + t[i]=(double *)malloc(b[i+1] * a * sizeof(double)); + } + return t; +} + +/*create a table with variable row length*/ +void complete_tab(int point_nb,double **xx,double **yy,int *type,int *compt,int *l, double *x,double *y){ + int i; + for(i=0;i<point_nb;i++) + { + xx[type[i]-1][compt[type[i]]]=x[i]; + yy[type[i]-1][compt[type[i]]]=y[i]; + //Rprintf("%d,%d ::: %f, %f\n",type[i]-1,compt[type[i]],x[i],y[i]); + compt[type[i]]++; + } + return ; +} + diff --git a/src/adssub.h b/src/adssub.h new file mode 100755 index 0000000000000000000000000000000000000000..baf055427c247eb30c5652e57437eeb17856aa6d --- /dev/null +++ b/src/adssub.h @@ -0,0 +1,33 @@ +#include <time.h> +#include <stdlib.h> +#include <limits.h> +#include <R_ext/PrtUtil.h> + +double Pi(); +void progress(int,int*, int); +/*double alea ();*/ +void freeintvec (int *); +void freetab (double **); +void freevec (double *); +void taballoc (double ***,int,int); +void tabintalloc (int ***,int,int); +void freeinttab (int **); +void vecalloc (double **vec, int n); +void vecintalloc (int **vec, int n); +double bacos(double a); +void decalVal(double *,int,double); +void decalRect(int,double *,double *,double *,double *,double *,double *); +void decalCirc(int,double *,double *,double *,double *,double); +void decalRectTri(int,double *,double *,double *,double *,double *,double *, + int,double *,double *,double *,double *,double *,double *); +void decalCircTri(int,double *,double *,double *,double *,double, + int,double *,double *,double *,double *,double *,double *); +void decalRect2(int,double *,double *,int,double *,double *,double *,double *,double *,double *); +void decalCirc2(int,double *,double *,int,double *,double *,double *,double *,double); +void decalRectTri2(int,double *,double *,int,double *,double *,double *,double *,double *,double *, + int,double *,double *,double *,double *,double *,double *); +void decalCircTri2(int,double *,double *,int,double *,double *,double *,double *,double,int, + double *,double *,double *,double *,double *,double *); +void decalSample(int,double *,double *,double,double); +double** taballoca(int,int *); +void complete_tab(int,double **,double **,int *,int *,int *,double *,double *); diff --git a/src/spatstatsub.f b/src/spatstatsub.f new file mode 100755 index 0000000000000000000000000000000000000000..f186cb82af40012e8ef725635872b4f2faab5e75 --- /dev/null +++ b/src/spatstatsub.f @@ -0,0 +1,47 @@ +C Output from Public domain Ratfor, version 1.0 + subroutine inpoly(x,y,xp,yp,npts,nedges,score,onbndry) + implicit double precision(a-h,o-z) + dimension x(npts), y(npts), xp(nedges), yp(nedges), score(npts) + logical onbndry(npts) + zero = 0.d0 + half = 0.5d0 + one = 1.d0 + do23000 i = 1,nedges + x0 = xp(i) + y0 = yp(i) + if(i .eq. nedges)then + x1 = xp(1) + y1 = yp(1) + else + x1 = xp(i+1) + y1 = yp(i+1) + endif + dx = x1 - x0 + dy = y1 - y0 + do23004 j = 1,npts + xcrit = (x(j) - x0)*(x(j) - x1) + if(xcrit .le. zero)then + if(xcrit .eq. zero)then + contrib = half + else + contrib = one + endif + ycrit = y(j)*dx - x(j)*dy + x0*dy - y0*dx + if((dx .lt. 0 .and. ycrit .ge. zero) .or. (dx .gt. zero .and. ycri + *t .lt. zero))then + score(j) = score(j) - sign(one,dx)*contrib + onbndry(j) = onbndry(j) .or. (ycrit .eq. zero) + else + if(dx .eq. zero)then + if(x(j) .eq. x0)then + ycrit = (y(j) - y0)*(y(j) - y1) + onbndry(j) = onbndry(j) .or. (ycrit .le. zero) + endif + endif + endif + endif +23004 continue +23000 continue + return + end + diff --git a/src/triangulate.c b/src/triangulate.c new file mode 100755 index 0000000000000000000000000000000000000000..3a58f2d629cef6f8cd6fce3f71746df08fe0acb5 --- /dev/null +++ b/src/triangulate.c @@ -0,0 +1,2128 @@ +#include "triangulate.h" +#include "adssub.h" +#include <sys/time.h> +#include <string.h> +#include <math.h> +#include <R.h> +#define CROSS_SINE(v0, v1) ((v0).x * (v1).y - (v1).x * (v0).y) +#define LENGTH(v0) (sqrt((v0).x * (v0).x + (v0).y * (v0).y)) +#ifdef __STDC__ +extern double log2(double); +#else +extern double log2(); +#endif + +node_t qs[QSIZE]; /* Query structure */ +trap_t tr[TRSIZE]; /* Trapezoid structure */ +segment_t seg[SEGSIZE]; /* Segment table */ + +static int q_idx; +static int tr_idx; + +static int choose_idx; +static int permute[SEGSIZE]; + +static monchain_t mchain[TRSIZE]; /* Table to hold all the monotone */ + /* polygons . Each monotone polygon */ + /* is a circularly linked list */ + +static vertexchain_t vert[SEGSIZE]; /* chain init. information. This */ + /* is used to decide which */ + /* monotone polygon to split if */ + /* there are several other */ + /* polygons touching at the same */ + /* vertex */ + +static int mon[SEGSIZE]; /* contains position of any vertex in */ + /* the monotone chain for the polygon */ +static int visited[TRSIZE]; +static int chain_idx, op_idx, mon_idx; + + +static int triangulate_single_polygon(int, int, int, int**); +static int traverse_polygon(int, int, int, int); + +/* Function returns TRUE if the trapezoid lies inside the polygon */ +static int inside_polygon(t) + trap_t *t; +{ + int rseg = t->rseg; + + if (t->state == ST_INVALID) + return 0; + + if ((t->lseg <= 0) || (t->rseg <= 0)) + return 0; + + if (((t->u0 <= 0) && (t->u1 <= 0)) || + ((t->d0 <= 0) && (t->d1 <= 0))) /* triangle */ + return (_greater_than(&seg[rseg].v1, &seg[rseg].v0)); + + return 0; +} + + +/* return a new mon structure from the table */ +static int newmon() +{ + return ++mon_idx; +} + + +/* return a new chain element from the table */ +static int new_chain_element() +{ + return ++chain_idx; +} + + +static double get_angle(vp0, vpnext, vp1) + point_t *vp0; + point_t *vpnext; + point_t *vp1; +{ + point_t v0, v1; + + v0.x = vpnext->x - vp0->x; + v0.y = vpnext->y - vp0->y; + + v1.x = vp1->x - vp0->x; + v1.y = vp1->y - vp0->y; + + if (CROSS_SINE(v0, v1) >= 0) /* sine is positive */ + return DOT(v0, v1)/LENGTH(v0)/LENGTH(v1); + else + return (-1.0 * DOT(v0, v1)/LENGTH(v0)/LENGTH(v1) - 2); +} + + +/* (v0, v1) is the new diagonal to be added to the polygon. Find which */ +/* chain to use and return the positions of v0 and v1 in p and q */ +static int get_vertex_positions(v0, v1, ip, iq) + int v0; + int v1; + int *ip; + int *iq; +{ + vertexchain_t *vp0, *vp1; + register int i; + double angle, temp; + int tp=0, tq=0; + + vp0 = &vert[v0]; + vp1 = &vert[v1]; + + /* p is identified as follows. Scan from (v0, v1) rightwards till */ + /* you hit the first segment starting from v0. That chain is the */ + /* chain of our interest */ + + angle = -4.0; + for (i = 0; i < 4; i++) + { + if (vp0->vnext[i] <= 0) + continue; + if ((temp = get_angle(&vp0->pt, &(vert[vp0->vnext[i]].pt), + &vp1->pt)) > angle) + { + angle = temp; + tp = i; + } + } + + *ip = tp; + + /* Do similar actions for q */ + + angle = -4.0; + for (i = 0; i < 4; i++) + { + if (vp1->vnext[i] <= 0) + continue; + if ((temp = get_angle(&vp1->pt, &(vert[vp1->vnext[i]].pt), + &vp0->pt)) > angle) + { + angle = temp; + tq = i; + } + } + + *iq = tq; + + return 0; +} + + +/* v0 and v1 are specified in anti-clockwise order with respect to + * the current monotone polygon mcur. Split the current polygon into + * two polygons using the diagonal (v0, v1) + */ +static int make_new_monotone_poly(mcur, v0, v1) + int mcur; + int v0; + int v1; +{ + int p, q, ip, iq; + int mnew = newmon(); + int i, j, nf0, nf1; + vertexchain_t *vp0, *vp1; + + vp0 = &vert[v0]; + vp1 = &vert[v1]; + + get_vertex_positions(v0, v1, &ip, &iq); + + p = vp0->vpos[ip]; + q = vp1->vpos[iq]; + + /* At this stage, we have got the positions of v0 and v1 in the */ + /* desired chain. Now modify the linked lists */ + + i = new_chain_element(); /* for the new list */ + j = new_chain_element(); + + mchain[i].vnum = v0; + mchain[j].vnum = v1; + + mchain[i].next = mchain[p].next; + mchain[mchain[p].next].prev = i; + mchain[i].prev = j; + mchain[j].next = i; + mchain[j].prev = mchain[q].prev; + mchain[mchain[q].prev].next = j; + + mchain[p].next = q; + mchain[q].prev = p; + + nf0 = vp0->nextfree; + nf1 = vp1->nextfree; + + vp0->vnext[ip] = v1; + + vp0->vpos[nf0] = i; + vp0->vnext[nf0] = mchain[mchain[i].next].vnum; + vp1->vpos[nf1] = j; + vp1->vnext[nf1] = v0; + + vp0->nextfree++; + vp1->nextfree++; + +#ifdef DEBUG + Rprintf("make_poly: mcur = %d, (v0, v1) = (%d, %d)\n", + mcur, v0, v1); + Rprintf("next posns = (p, q) = (%d, %d)\n", p, q); +#endif + + mon[mcur] = p; + mon[mnew] = i; + return mnew; +} + +/* Main routine to get monotone polygons from the trapezoidation of + * the polygon. + */ + +int monotonate_trapezoids(n) + int n; +{ + register int i; + int tr_start; + + memset((void *)vert, 0, sizeof(vert)); + memset((void *)visited, 0, sizeof(visited)); + memset((void *)mchain, 0, sizeof(mchain)); + memset((void *)mon, 0, sizeof(mon)); + + /* First locate a trapezoid which lies inside the polygon */ + /* and which is triangular */ + for (i = 0; i < TRSIZE; i++) + if (inside_polygon(&tr[i])) + break; + tr_start = i; + + /* Initialise the mon data-structure and start spanning all the */ + /* trapezoids within the polygon */ + +#if 0 + for (i = 1; i <= n; i++) + { + mchain[i].prev = i - 1; + mchain[i].next = i + 1; + mchain[i].vnum = i; + vert[i].pt = seg[i].v0; + vert[i].vnext[0] = i + 1; /* next vertex */ + vert[i].vpos[0] = i; /* locn. of next vertex */ + vert[i].nextfree = 1; + } + mchain[1].prev = n; + mchain[n].next = 1; + vert[n].vnext[0] = 1; + vert[n].vpos[0] = n; + chain_idx = n; + mon_idx = 0; + mon[0] = 1; /* position of any vertex in the first */ + /* chain */ + +#else + + for (i = 1; i <= n; i++) + { + mchain[i].prev = seg[i].prev; + mchain[i].next = seg[i].next; + mchain[i].vnum = i; + vert[i].pt = seg[i].v0; + vert[i].vnext[0] = seg[i].next; /* next vertex */ + vert[i].vpos[0] = i; /* locn. of next vertex */ + vert[i].nextfree = 1; + } + + chain_idx = n; + mon_idx = 0; + mon[0] = 1; /* position of any vertex in the first */ + /* chain */ + +#endif + + /* traverse the polygon */ + if (tr[tr_start].u0 > 0) + traverse_polygon(0, tr_start, tr[tr_start].u0, TR_FROM_UP); + else if (tr[tr_start].d0 > 0) + traverse_polygon(0, tr_start, tr[tr_start].d0, TR_FROM_DN); + + /* return the number of polygons created */ + return newmon(); +} + + +/* recursively visit all the trapezoids */ +static int traverse_polygon(mcur, trnum, from, dir) + int mcur; + int trnum; + int from; + int dir; +{ + if ((trnum <= 0) || visited[trnum]) return 0; + trap_t *t = &tr[trnum]; + int mnew; + int v0, v1; + int retval=0; + int do_switch = FALSE; + + //if ((trnum <= 0) || visited[trnum]) return 0; + + visited[trnum] = TRUE; + + /* We have much more information available here. */ + /* rseg: goes upwards */ + /* lseg: goes downwards */ + + /* Initially assume that dir = TR_FROM_DN (from the left) */ + /* Switch v0 and v1 if necessary afterwards */ + + + /* special cases for triangles with cusps at the opposite ends. */ + /* take care of this first */ + if ((t->u0 <= 0) && (t->u1 <= 0)) + { + if ((t->d0 > 0) && (t->d1 > 0)) /* downward opening triangle */ + { + v0 = tr[t->d1].lseg; + v1 = t->lseg; + if (from == t->d1) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + } + } + else + { + retval = SP_NOSPLIT; /* Just traverse all neighbours */ + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + } + } + + else if ((t->d0 <= 0) && (t->d1 <= 0)) + { + if ((t->u0 > 0) && (t->u1 > 0)) /* upward opening triangle */ + { + v0 = t->rseg; + v1 = tr[t->u0].rseg; + if (from == t->u1) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + } + } + else + { + retval = SP_NOSPLIT; /* Just traverse all neighbours */ + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + } + } + + else if ((t->u0 > 0) && (t->u1 > 0)) + { + if ((t->d0 > 0) && (t->d1 > 0)) /* downward + upward cusps */ + { + v0 = tr[t->d1].lseg; + v1 = tr[t->u0].rseg; + retval = SP_2UP_2DN; + if (((dir == TR_FROM_DN) && (t->d1 == from)) || + ((dir == TR_FROM_UP) && (t->u1 == from))) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + } + } + else /* only downward cusp */ + { + if (_equal_to(&t->lo, &seg[t->lseg].v1)) + { + v0 = tr[t->u0].rseg; + v1 = seg[t->lseg].next; + + retval = SP_2UP_LEFT; + if ((dir == TR_FROM_UP) && (t->u0 == from)) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + } + } + else + { + v0 = t->rseg; + v1 = tr[t->u0].rseg; + retval = SP_2UP_RIGHT; + if ((dir == TR_FROM_UP) && (t->u1 == from)) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + } + } + } + } + else if ((t->u0 > 0) || (t->u1 > 0)) /* no downward cusp */ + { + if ((t->d0 > 0) && (t->d1 > 0)) /* only upward cusp */ + { + if (_equal_to(&t->hi, &seg[t->lseg].v0)) + { + v0 = tr[t->d1].lseg; + v1 = t->lseg; + retval = SP_2DN_LEFT; + if (!((dir == TR_FROM_DN) && (t->d0 == from))) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + } + } + else + { + v0 = tr[t->d1].lseg; + v1 = seg[t->rseg].next; + + retval = SP_2DN_RIGHT; + if ((dir == TR_FROM_DN) && (t->d1 == from)) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + } + } + } + else /* no cusp */ + { + if (_equal_to(&t->hi, &seg[t->lseg].v0) && + _equal_to(&t->lo, &seg[t->rseg].v0)) + { + v0 = t->rseg; + v1 = t->lseg; + retval = SP_SIMPLE_LRDN; + if (dir == TR_FROM_UP) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + } + } + else if (_equal_to(&t->hi, &seg[t->rseg].v1) && + _equal_to(&t->lo, &seg[t->lseg].v1)) + { + v0 = seg[t->rseg].next; + v1 = seg[t->lseg].next; + + retval = SP_SIMPLE_LRUP; + if (dir == TR_FROM_UP) + { + do_switch = TRUE; + mnew = make_new_monotone_poly(mcur, v1, v0); + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->d0, trnum, TR_FROM_UP); + } + else + { + mnew = make_new_monotone_poly(mcur, v0, v1); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mnew, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mnew, t->u1, trnum, TR_FROM_DN); + } + } + else /* no split possible */ + { + retval = SP_NOSPLIT; + traverse_polygon(mcur, t->u0, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d0, trnum, TR_FROM_UP); + traverse_polygon(mcur, t->u1, trnum, TR_FROM_DN); + traverse_polygon(mcur, t->d1, trnum, TR_FROM_UP); + } + } + } + + return retval; +} + + +/* For each monotone polygon, find the ymax and ymin (to determine the */ +/* two y-monotone chains) and pass on this monotone polygon for greedy */ +/* triangulation. */ +/* Take care not to triangulate duplicate monotone polygons */ + +int triangulate_monotone_polygons(nvert, nmonpoly, op) + int nvert; + int nmonpoly; + int **op; +{ + register int i; + point_t ymax, ymin; + int p, vfirst, posmax, posmin, v; + int vcount, processed; + +#ifdef DEBUG + for (i = 0; i < nmonpoly; i++) + { + Rprintf("\n\nPolygon %d: ", i); + vfirst = mchain[mon[i]].vnum; + p = mchain[mon[i]].next; + Rprintf ("%d ", mchain[mon[i]].vnum); + while (mchain[p].vnum != vfirst) + { + Rprintf("%d ", mchain[p].vnum); + p = mchain[p].next; + } + } + Rprintf("\n"); +#endif + + op_idx = 0; + for (i = 0; i < nmonpoly; i++) + { + vcount = 1; + processed = FALSE; + vfirst = mchain[mon[i]].vnum; + ymax = ymin = vert[vfirst].pt; + posmax = posmin = mon[i]; + mchain[mon[i]].marked = TRUE; + p = mchain[mon[i]].next; + while ((v = mchain[p].vnum) != vfirst) + { + if (mchain[p].marked) + { + processed = TRUE; + break; /* break from while */ + } + else + mchain[p].marked = TRUE; + + if (_greater_than(&vert[v].pt, &ymax)) + { + ymax = vert[v].pt; + posmax = p; + } + if (_less_than(&vert[v].pt, &ymin)) + { + ymin = vert[v].pt; + posmin = p; + } + p = mchain[p].next; + vcount++; + } + + if (processed) /* Go to next polygon */ + continue; + + if (vcount == 3) /* already a triangle */ + { + op[op_idx][0] = mchain[p].vnum; + op[op_idx][1] = mchain[mchain[p].next].vnum; + op[op_idx][2] = mchain[mchain[p].prev].vnum; + op_idx++; + } + else /* triangulate the polygon */ + { + v = mchain[mchain[posmax].next].vnum; + if (_equal_to(&vert[v].pt, &ymin)) + { /* LHS is a single line */ + triangulate_single_polygon(nvert, posmax, TRI_LHS, op); + } + else + triangulate_single_polygon(nvert, posmax, TRI_RHS, op); + } + } + +#ifdef DEBUG + for (i = 0; i < op_idx; i++) + Rprintf("tri #%d: (%d, %d, %d)\n", i, op[i][0], op[i][1], + op[i][2]); +#endif + return op_idx; +} + + +/* A greedy corner-cutting algorithm to triangulate a y-monotone + * polygon in O(n) time. + * Joseph O-Rourke, Computational Geometry in C. + */ +static int triangulate_single_polygon(nvert, posmax, side, op) + int nvert; + int posmax; + int side; + int **op; +{ + register int v; + int rc[SEGSIZE], ri = 0; /* reflex chain */ + int endv, tmp, vpos; + + if (side == TRI_RHS) /* RHS segment is a single segment */ + { + rc[0] = mchain[posmax].vnum; + tmp = mchain[posmax].next; + rc[1] = mchain[tmp].vnum; + ri = 1; + + vpos = mchain[tmp].next; + v = mchain[vpos].vnum; + + if ((endv = mchain[mchain[posmax].prev].vnum) == 0) + endv = nvert; + } + else /* LHS is a single segment */ + { + tmp = mchain[posmax].next; + rc[0] = mchain[tmp].vnum; + tmp = mchain[tmp].next; + rc[1] = mchain[tmp].vnum; + ri = 1; + + vpos = mchain[tmp].next; + v = mchain[vpos].vnum; + + endv = mchain[posmax].vnum; + } + + while ((v != endv) || (ri > 1)) + { + if (ri > 0) /* reflex chain is non-empty */ + { + if (CROSS(vert[v].pt, vert[rc[ri - 1]].pt, + vert[rc[ri]].pt) > 0) + { /* convex corner: cut if off */ + op[op_idx][0] = rc[ri - 1]; + op[op_idx][1] = rc[ri]; + op[op_idx][2] = v; + op_idx++; + ri--; + } + else /* non-convex */ + { /* add v to the chain */ + ri++; + rc[ri] = v; + vpos = mchain[vpos].next; + v = mchain[vpos].vnum; + } + } + else /* reflex-chain empty: add v to the */ + { /* reflex chain and advance it */ + rc[++ri] = v; + vpos = mchain[vpos].next; + v = mchain[vpos].vnum; + } + } /* end-while */ + + /* reached the bottom vertex. Add in the triangle formed */ + op[op_idx][0] = rc[ri - 1]; + op[op_idx][1] = rc[ri]; + op[op_idx][2] = v; + op_idx++; + ri--; + + return 0; +} + + +/*teste le sens du polygone*/ +int testclock(double *x,double *y,int last) { + double ymi; + int i,rang; + double d,ang1,ang2; + + ymi=y[1]; + rang=1; + for(i=1;i<=last;i++) + { if(y[i]<ymi) + { ymi=y[i]; + rang=i; + } + } + + if(rang==1) + { d=sqrt((x[1]-x[last])*(x[1]-x[last])+(y[1]-y[last])*(y[1]-y[last])); + ang1=bacos((x[1]-x[last])/d); + + d=sqrt((x[1]-x[2])*(x[1]-x[2])+(y[1]-y[2])*(y[1]-y[2])); + ang2=bacos((x[1]-x[2])/d); + } + else if(rang==last) + { d=sqrt((x[last]-x[last-1])*(x[last]-x[last-1])+(y[last]-y[last-1])*(y[last]-y[last-1])); + ang1=bacos((x[last]-x[last-1])/d); + + d=sqrt((x[last]-x[1])*(x[last]-x[1])+(y[last]-y[1])*(y[last]-y[1])); + ang2=bacos((x[last]-x[1])/d); + } + else + { d=sqrt((x[rang]-x[rang-1])*(x[rang]-x[rang-1])+(y[rang]-y[rang-1])*(y[rang]-y[rang-1])); + ang1=bacos((x[rang]-x[rang-1])/d); + + d=sqrt((x[rang]-x[rang+1])*(x[rang]-x[rang+1])+(y[rang]-y[rang+1])*(y[rang]-y[rang+1])); + ang2=bacos((x[rang]-x[rang+1])/d); + } + + if (ang1>ang2) return 1; /*clockwise order*/ + else return 0; /*anti-clockwise order*/ +} + + +/* Generate a random permutation of the segments 1..n */ +/*int generate_random_ordering(int n) { + int lig, i,j, k; + double z; + choose_idx = 1; + for (i = 1; i <= n; i++) + permute[i]=i; + lig = permute[0]; + for (i=1; i<=lig-1; i++) + { j=lig-i+1; + k = (int) (j*alea()+1); + if (k>j) k=j; + z = permute[j]; + permute[j]=permute[k]; + permute[k] = z; + } + return 0; +}*/ +int generate_random_ordering(int n) { + int lig, i,j, k; + double z; + GetRNGstate(); + choose_idx = 1; + for (i = 1; i <= n; i++) + permute[i]=i; + lig = permute[0]; + for (i=1; i<=lig-1; i++) + { j=lig-i+1; + k = (int) (j*unif_rand()+1); + if (k>j) k=j; + z = permute[j]; + permute[j]=permute[k]; + permute[k] = z; + } + PutRNGstate(); + return 0; +} + +/* Return the next segment in the generated random ordering of all the */ +/* segments in S */ +int choose_segment() { +#ifdef DEBUG + Rprintf("choose_segment: %d\n", permute[choose_idx]); +#endif + return permute[choose_idx++]; +} + +#ifdef STANDALONE +/* Read in the list of vertices from infile */ +int read_segments(filename, genus) + char *filename; + int *genus; +{ + FILE *infile; + int ccount; + register int i; + int ncontours, npoints, first, last; + + if ((infile = fopen(filename, "r")) == NULL) + { + perror(filename); + return -1; + } + + fscanf(infile, "%d", &ncontours); + if (ncontours <= 0) + return -1; + + /* For every contour, read in all the points for the contour. The */ + /* outer-most contour is read in first (points specified in */ + /* anti-clockwise order). Next, the inner contours are input in */ + /* clockwise order */ + + ccount = 0; + i = 1; + + while (ccount < ncontours) + { + int j; + + fscanf(infile, "%d", &npoints); + first = i; + last = first + npoints - 1; + for (j = 0; j < npoints; j++, i++) + { + fscanf(infile, "%lf%lf", &seg[i].v0.x, &seg[i].v0.y); + if (i == last) + { + seg[i].next = first; + seg[i].prev = i-1; + seg[i-1].v1 = seg[i].v0; + } + else if (i == first) + { + seg[i].next = i+1; + seg[i].prev = last; + seg[last].v1 = seg[i].v0; + } + else + { + seg[i].prev = i-1; + seg[i].next = i+1; + seg[i-1].v1 = seg[i].v0; + } + + seg[i].is_inserted = FALSE; + } + + ccount++; + } + + *genus = ncontours - 1; + return i-1; +} + +#endif + + +/* Get log*n for given n */ +int math_logstar_n(n) + int n; +{ + register int i; + double v; + + for (i = 0, v = (double) n; v >= 1; i++) + v = log2(v); + + return (i - 1); +} + + +int math_N(n, h) + int n; + int h; +{ + register int i; + double v; + + for (i = 0, v = (int) n; i < h; i++) + v = log2(v); + + return (int) ceil((double) 1.0*n/v); +} + + +/* Return a new node to be added into the query tree */ +static int newnode() +{ + if (q_idx < QSIZE) + return q_idx++; + else + { + Rprintf("newnode: Query-table overflow\n"); + return -1; + } +} + +/* Return a free trapezoid */ +static int newtrap() +{ + if (tr_idx < TRSIZE) + { + tr[tr_idx].lseg = -1; + tr[tr_idx].rseg = -1; + tr[tr_idx].state = ST_VALID; + return tr_idx++; + } + else + { + Rprintf("newtrap: Trapezoid-table overflow\n"); + return -1; + } +} + + +/* Return the maximum of the two points into the yval structure */ +static int _max(yval, v0, v1) + point_t *yval; + point_t *v0; + point_t *v1; +{ + if (v0->y > v1->y + C_EPS) + *yval = *v0; + else if (FP_EQUAL(v0->y, v1->y)) + { + if (v0->x > v1->x + C_EPS) + *yval = *v0; + else + *yval = *v1; + } + else + *yval = *v1; + + return 0; +} + + +/* Return the minimum of the two points into the yval structure */ +static int _min(yval, v0, v1) + point_t *yval; + point_t *v0; + point_t *v1; +{ + if (v0->y < v1->y - C_EPS) + *yval = *v0; + else if (FP_EQUAL(v0->y, v1->y)) + { + if (v0->x < v1->x) + *yval = *v0; + else + *yval = *v1; + } + else + *yval = *v1; + + return 0; +} + + +int _greater_than(v0, v1) + point_t *v0; + point_t *v1; +{ + if (v0->y > v1->y + C_EPS) + return TRUE; + else if (v0->y < v1->y - C_EPS) + return FALSE; + else + return (v0->x > v1->x); +} + + +int _equal_to(v0, v1) + point_t *v0; + point_t *v1; +{ + return (FP_EQUAL(v0->y, v1->y) && FP_EQUAL(v0->x, v1->x)); +} + +int _greater_than_equal_to(v0, v1) + point_t *v0; + point_t *v1; +{ + if (v0->y > v1->y + C_EPS) + return TRUE; + else if (v0->y < v1->y - C_EPS) + return FALSE; + else + return (v0->x >= v1->x); +} + +int _less_than(v0, v1) + point_t *v0; + point_t *v1; +{ + if (v0->y < v1->y - C_EPS) + return TRUE; + else if (v0->y > v1->y + C_EPS) + return FALSE; + else + return (v0->x < v1->x); +} + + +/* Initilialise the query structure (Q) and the trapezoid table (T) + * when the first segment is added to start the trapezoidation. The + * query-tree starts out with 4 trapezoids, one S-node and 2 Y-nodes + * + * 4 + * ----------------------------------- + * \ + * 1 \ 2 + * \ + * ----------------------------------- + * 3 + */ + +static int init_query_structure(segnum) + int segnum; +{ + int i1, i2, i3, i4, i5, i6, i7, root; + int t1, t2, t3, t4; + segment_t *s = &seg[segnum]; + + q_idx = tr_idx = 1; + memset((void *)tr, 0, sizeof(tr)); + memset((void *)qs, 0, sizeof(qs)); + + i1 = newnode(); + qs[i1].nodetype = T_Y; + _max(&qs[i1].yval, &s->v0, &s->v1); /* root */ + root = i1; + + qs[i1].right = i2 = newnode(); + qs[i2].nodetype = T_SINK; + qs[i2].parent = i1; + + qs[i1].left = i3 = newnode(); + qs[i3].nodetype = T_Y; + _min(&qs[i3].yval, &s->v0, &s->v1); /* root */ + qs[i3].parent = i1; + + qs[i3].left = i4 = newnode(); + qs[i4].nodetype = T_SINK; + qs[i4].parent = i3; + + qs[i3].right = i5 = newnode(); + qs[i5].nodetype = T_X; + qs[i5].segnum = segnum; + qs[i5].parent = i3; + + qs[i5].left = i6 = newnode(); + qs[i6].nodetype = T_SINK; + qs[i6].parent = i5; + + qs[i5].right = i7 = newnode(); + qs[i7].nodetype = T_SINK; + qs[i7].parent = i5; + + t1 = newtrap(); /* middle left */ + t2 = newtrap(); /* middle right */ + t3 = newtrap(); /* bottom-most */ + t4 = newtrap(); /* topmost */ + + tr[t1].hi = tr[t2].hi = tr[t4].lo = qs[i1].yval; + tr[t1].lo = tr[t2].lo = tr[t3].hi = qs[i3].yval; + tr[t4].hi.y = (double) (INFINITY); + tr[t4].hi.x = (double) (INFINITY); + tr[t3].lo.y = (double) -1* (INFINITY); + tr[t3].lo.x = (double) -1* (INFINITY); + tr[t1].rseg = tr[t2].lseg = segnum; + tr[t1].u0 = tr[t2].u0 = t4; + tr[t1].d0 = tr[t2].d0 = t3; + tr[t4].d0 = tr[t3].u0 = t1; + tr[t4].d1 = tr[t3].u1 = t2; + + tr[t1].sink = i6; + tr[t2].sink = i7; + tr[t3].sink = i4; + tr[t4].sink = i2; + + tr[t1].state = tr[t2].state = ST_VALID; + tr[t3].state = tr[t4].state = ST_VALID; + + qs[i2].trnum = t4; + qs[i4].trnum = t3; + qs[i6].trnum = t1; + qs[i7].trnum = t2; + + s->is_inserted = TRUE; + return root; +} + + +/* Retun TRUE if the vertex v is to the left of line segment no. + * segnum. Takes care of the degenerate cases when both the vertices + * have the same y--cood, etc. + */ + +static int is_left_of(segnum, v) + int segnum; + point_t *v; +{ + segment_t *s = &seg[segnum]; + double area; + + if (_greater_than(&s->v1, &s->v0)) /* seg. going upwards */ + { + if (FP_EQUAL(s->v1.y, v->y)) + { + if (v->x < s->v1.x) + area = 1.0; + else + area = -1.0; + } + else if (FP_EQUAL(s->v0.y, v->y)) + { + if (v->x < s->v0.x) + area = 1.0; + else + area = -1.0; + } + else + area = CROSS(s->v0, s->v1, (*v)); + } + else /* v0 > v1 */ + { + if (FP_EQUAL(s->v1.y, v->y)) + { + if (v->x < s->v1.x) + area = 1.0; + else + area = -1.0; + } + else if (FP_EQUAL(s->v0.y, v->y)) + { + if (v->x < s->v0.x) + area = 1.0; + else + area = -1.0; + } + else + area = CROSS(s->v1, s->v0, (*v)); + } + + if (area > 0.0) + return TRUE; + else + return FALSE; +} + + + +/* Returns true if the corresponding endpoint of the given segment is */ +/* already inserted into the segment tree. Use the simple test of */ +/* whether the segment which shares this endpoint is already inserted */ + +static int inserted(segnum, whichpt) + int segnum; + int whichpt; +{ + if (whichpt == FIRSTPT) + return seg[seg[segnum].prev].is_inserted; + else + return seg[seg[segnum].next].is_inserted; +} + +/* This is query routine which determines which trapezoid does the + * point v lie in. The return value is the trapezoid number. + */ + +int locate_endpoint(v, vo, r) + point_t *v; + point_t *vo; + int r; +{ + node_t *rptr = &qs[r]; + + switch (rptr->nodetype) + { + case T_SINK: + return rptr->trnum; + + case T_Y: + if (_greater_than(v, &rptr->yval)) /* above */ + return locate_endpoint(v, vo, rptr->right); + else if (_equal_to(v, &rptr->yval)) /* the point is already */ + { /* inserted. */ + if (_greater_than(vo, &rptr->yval)) /* above */ + return locate_endpoint(v, vo, rptr->right); + else + return locate_endpoint(v, vo, rptr->left); /* below */ + } + else + return locate_endpoint(v, vo, rptr->left); /* below */ + + case T_X: + if (_equal_to(v, &seg[rptr->segnum].v0) || + _equal_to(v, &seg[rptr->segnum].v1)) + { + if (FP_EQUAL(v->y, vo->y)) /* horizontal segment */ + { + if (vo->x < v->x) + return locate_endpoint(v, vo, rptr->left); /* left */ + else + return locate_endpoint(v, vo, rptr->right); /* right */ + } + + else if (is_left_of(rptr->segnum, vo)) + return locate_endpoint(v, vo, rptr->left); /* left */ + else + return locate_endpoint(v, vo, rptr->right); /* right */ + } + else if (is_left_of(rptr->segnum, v)) + return locate_endpoint(v, vo, rptr->left); /* left */ + else + return locate_endpoint(v, vo, rptr->right); /* right */ + + default: + Rprintf("Haggu !!!!!\n"); + break; + } + return 0; +} + + +/* Thread in the segment into the existing trapezoidation. The + * limiting trapezoids are given by tfirst and tlast (which are the + * trapezoids containing the two endpoints of the segment. Merges all + * possible trapezoids which flank this segment and have been recently + * divided because of its insertion + */ + +static int merge_trapezoids(segnum, tfirst, tlast, side) + int segnum; + int tfirst; + int tlast; + int side; +{ + int t, tnext, cond; + int ptnext; + + /* First merge polys on the LHS */ + t = tfirst; + while ((t > 0) && _greater_than_equal_to(&tr[t].lo, &tr[tlast].lo)) + { + if (side == S_LEFT) + cond = ((((tnext = tr[t].d0) > 0) && (tr[tnext].rseg == segnum)) || + (((tnext = tr[t].d1) > 0) && (tr[tnext].rseg == segnum))); + else + cond = ((((tnext = tr[t].d0) > 0) && (tr[tnext].lseg == segnum)) || + (((tnext = tr[t].d1) > 0) && (tr[tnext].lseg == segnum))); + + if (cond) + { + if ((tr[t].lseg == tr[tnext].lseg) && + (tr[t].rseg == tr[tnext].rseg)) /* good neighbours */ + { /* merge them */ + /* Use the upper node as the new node i.e. t */ + + ptnext = qs[tr[tnext].sink].parent; + + if (qs[ptnext].left == tr[tnext].sink) + qs[ptnext].left = tr[t].sink; + else + qs[ptnext].right = tr[t].sink; /* redirect parent */ + + + /* Change the upper neighbours of the lower trapezoids */ + + if ((tr[t].d0 = tr[tnext].d0) > 0) { + if (tr[tr[t].d0].u0 == tnext) { + tr[tr[t].d0].u0 = t; + } + else { + if (tr[tr[t].d0].u1 == tnext) { + tr[tr[t].d0].u1 = t; + } + } + } + + if ((tr[t].d1 = tr[tnext].d1) > 0) { + if (tr[tr[t].d1].u0 == tnext) { + tr[tr[t].d1].u0 = t; + } + else { + if (tr[tr[t].d1].u1 == tnext) { + tr[tr[t].d1].u1 = t; + } + } + } + + tr[t].lo = tr[tnext].lo; + tr[tnext].state = ST_INVALID; /* invalidate the lower */ + /* trapezium */ + } + else /* not good neighbours */ + t = tnext; + } + else /* do not satisfy the outer if */ + t = tnext; + + } /* end-while */ + + return 0; +} + + +/* Add in the new segment into the trapezoidation and update Q and T + * structures. First locate the two endpoints of the segment in the + * Q-structure. Then start from the topmost trapezoid and go down to + * the lower trapezoid dividing all the trapezoids in between . + */ + +static int add_segment(segnum) + int segnum; +{ + segment_t s; + int tu, tl, sk, tfirst, tlast, tnext; + int tfirstr=0, tlastr=0, tfirstl, tlastl; + int i1, i2, t, tn; + point_t tpt; + int tritop = 0, tribot = 0, is_swapped = 0; + int tmptriseg,tmpseg=0; + + s = seg[segnum]; + if (_greater_than(&s.v1, &s.v0)) /* Get higher vertex in v0 */ + { + int tmp; + tpt = s.v0; + s.v0 = s.v1; + s.v1 = tpt; + tmp = s.root0; + s.root0 = s.root1; + s.root1 = tmp; + is_swapped = TRUE; + } + + if ((is_swapped) ? !inserted(segnum, LASTPT) : + !inserted(segnum, FIRSTPT)) /* insert v0 in the tree */ + { + int tmp_d; + + tu = locate_endpoint(&s.v0, &s.v1, s.root0); + tl = newtrap(); /* tl is the new lower trapezoid */ + tr[tl].state = ST_VALID; + tr[tl] = tr[tu]; + tr[tu].lo.y = tr[tl].hi.y = s.v0.y; + tr[tu].lo.x = tr[tl].hi.x = s.v0.x; + tr[tu].d0 = tl; + tr[tu].d1 = 0; + tr[tl].u0 = tu; + tr[tl].u1 = 0; + + if (((tmp_d = tr[tl].d0) > 0) && (tr[tmp_d].u0 == tu)) + tr[tmp_d].u0 = tl; + if (((tmp_d = tr[tl].d0) > 0) && (tr[tmp_d].u1 == tu)) + tr[tmp_d].u1 = tl; + + if (((tmp_d = tr[tl].d1) > 0) && (tr[tmp_d].u0 == tu)) + tr[tmp_d].u0 = tl; + if (((tmp_d = tr[tl].d1) > 0) && (tr[tmp_d].u1 == tu)) + tr[tmp_d].u1 = tl; + + /* Now update the query structure and obtain the sinks for the */ + /* two trapezoids */ + + i1 = newnode(); /* Upper trapezoid sink */ + i2 = newnode(); /* Lower trapezoid sink */ + sk = tr[tu].sink; + + qs[sk].nodetype = T_Y; + qs[sk].yval = s.v0; + qs[sk].segnum = segnum; /* not really reqd ... maybe later */ + qs[sk].left = i2; + qs[sk].right = i1; + + qs[i1].nodetype = T_SINK; + qs[i1].trnum = tu; + qs[i1].parent = sk; + + qs[i2].nodetype = T_SINK; + qs[i2].trnum = tl; + qs[i2].parent = sk; + + tr[tu].sink = i1; + tr[tl].sink = i2; + tfirst = tl; + } + else /* v0 already present */ + { /* Get the topmost intersecting trapezoid */ + tfirst = locate_endpoint(&s.v0, &s.v1, s.root0); + tritop = 1; + } + + + if ((is_swapped) ? !inserted(segnum, FIRSTPT) : + !inserted(segnum, LASTPT)) /* insert v1 in the tree */ + { + int tmp_d; + + tu = locate_endpoint(&s.v1, &s.v0, s.root1); + + tl = newtrap(); /* tl is the new lower trapezoid */ + tr[tl].state = ST_VALID; + tr[tl] = tr[tu]; + tr[tu].lo.y = tr[tl].hi.y = s.v1.y; + tr[tu].lo.x = tr[tl].hi.x = s.v1.x; + tr[tu].d0 = tl; + tr[tu].d1 = 0; + tr[tl].u0 = tu; + tr[tl].u1 = 0; + + if (((tmp_d = tr[tl].d0) > 0) && (tr[tmp_d].u0 == tu)) + tr[tmp_d].u0 = tl; + if (((tmp_d = tr[tl].d0) > 0) && (tr[tmp_d].u1 == tu)) + tr[tmp_d].u1 = tl; + + if (((tmp_d = tr[tl].d1) > 0) && (tr[tmp_d].u0 == tu)) + tr[tmp_d].u0 = tl; + if (((tmp_d = tr[tl].d1) > 0) && (tr[tmp_d].u1 == tu)) + tr[tmp_d].u1 = tl; + + /* Now update the query structure and obtain the sinks for the */ + /* two trapezoids */ + + i1 = newnode(); /* Upper trapezoid sink */ + i2 = newnode(); /* Lower trapezoid sink */ + sk = tr[tu].sink; + + qs[sk].nodetype = T_Y; + qs[sk].yval = s.v1; + qs[sk].segnum = segnum; /* not really reqd ... maybe later */ + qs[sk].left = i2; + qs[sk].right = i1; + + qs[i1].nodetype = T_SINK; + qs[i1].trnum = tu; + qs[i1].parent = sk; + + qs[i2].nodetype = T_SINK; + qs[i2].trnum = tl; + qs[i2].parent = sk; + + tr[tu].sink = i1; + tr[tl].sink = i2; + tlast = tu; + } + else /* v1 already present */ + { /* Get the lowermost intersecting trapezoid */ + tlast = locate_endpoint(&s.v1, &s.v0, s.root1); + tribot = 1; + } + + /* Thread the segment into the query tree creating a new X-node */ + /* First, split all the trapezoids which are intersected by s into */ + /* two */ + + t = tfirst; /* topmost trapezoid */ + + while ((t > 0) && + _greater_than_equal_to(&tr[t].lo, &tr[tlast].lo)) + /* traverse from top to bot */ + { + int t_sav, tn_sav; + sk = tr[t].sink; + i1 = newnode(); /* left trapezoid sink */ + i2 = newnode(); /* right trapezoid sink */ + + qs[sk].nodetype = T_X; + qs[sk].segnum = segnum; + qs[sk].left = i1; + qs[sk].right = i2; + + qs[i1].nodetype = T_SINK; /* left trapezoid (use existing one) */ + qs[i1].trnum = t; + qs[i1].parent = sk; + + qs[i2].nodetype = T_SINK; /* right trapezoid (allocate new) */ + qs[i2].trnum = tn = newtrap(); + tr[tn].state = ST_VALID; + qs[i2].parent = sk; + + if (t == tfirst) + tfirstr = tn; + if (_equal_to(&tr[t].lo, &tr[tlast].lo)) + tlastr = tn; + + tr[tn] = tr[t]; + tr[t].sink = i1; + tr[tn].sink = i2; + t_sav = t; + tn_sav = tn; + + /* error */ + + if ((tr[t].d0 <= 0) && (tr[t].d1 <= 0)) /* case cannot arise */ + { + Rprintf("add_segment: error\n"); + break; + } + + /* only one trapezoid below. partition t into two and make the */ + /* two resulting trapezoids t and tn as the upper neighbours of */ + /* the sole lower trapezoid */ + + else if ((tr[t].d0 > 0) && (tr[t].d1 <= 0)) + { /* Only one trapezoid below */ + if ((tr[t].u0 > 0) && (tr[t].u1 > 0)) + { /* continuation of a chain from abv. */ + if (tr[t].usave > 0) /* three upper neighbours */ + { + if (tr[t].uside == S_LEFT) + { + tr[tn].u0 = tr[t].u1; + tr[t].u1 = -1; + tr[tn].u1 = tr[t].usave; + + tr[tr[t].u0].d0 = t; + tr[tr[tn].u0].d0 = tn; + tr[tr[tn].u1].d0 = tn; + } + else /* intersects in the right */ + { + tr[tn].u1 = -1; + tr[tn].u0 = tr[t].u1; + tr[t].u1 = tr[t].u0; + tr[t].u0 = tr[t].usave; + + tr[tr[t].u0].d0 = t; + tr[tr[t].u1].d0 = t; + tr[tr[tn].u0].d0 = tn; + } + + tr[t].usave = tr[tn].usave = 0; + } + else /* No usave.... simple case */ + { + tr[tn].u0 = tr[t].u1; + tr[t].u1 = tr[tn].u1 = -1; + tr[tr[tn].u0].d0 = tn; + } + } + else + { /* fresh seg. or upward cusp */ + int tmp_u = tr[t].u0; + int td0, td1; + if (((td0 = tr[tmp_u].d0) > 0) && + ((td1 = tr[tmp_u].d1) > 0)) + { /* upward cusp */ + if ((tr[td0].rseg > 0) && + !is_left_of(tr[td0].rseg, &s.v1)) + { + tr[t].u0 = tr[t].u1 = tr[tn].u1 = -1; + tr[tr[tn].u0].d1 = tn; + } + else /* cusp going leftwards */ + { + tr[tn].u0 = tr[tn].u1 = tr[t].u1 = -1; + tr[tr[t].u0].d0 = t; + } + } + else /* fresh segment */ + { + tr[tr[t].u0].d0 = t; + tr[tr[t].u0].d1 = tn; + } + } + + if (FP_EQUAL(tr[t].lo.y, tr[tlast].lo.y) && + FP_EQUAL(tr[t].lo.x, tr[tlast].lo.x) && tribot) + { /* bottom forms a triangle */ + + if (is_swapped) + tmptriseg = seg[segnum].prev; + else + tmptriseg = seg[segnum].next; + + if ((tmptriseg > 0) && is_left_of(tmptriseg, &s.v0)) + { + /* L-R downward cusp */ + tr[tr[t].d0].u0 = t; + tr[tn].d0 = tr[tn].d1 = -1; + } + else + { + /* R-L downward cusp */ + tr[tr[tn].d0].u1 = tn; + tr[t].d0 = tr[t].d1 = -1; + } + } + else + { + if ((tr[tr[t].d0].u0 > 0) && (tr[tr[t].d0].u1 > 0)) + { + if (tr[tr[t].d0].u0 == t) /* passes thru LHS */ + { + tr[tr[t].d0].usave = tr[tr[t].d0].u1; + tr[tr[t].d0].uside = S_LEFT; + } + else + { + tr[tr[t].d0].usave = tr[tr[t].d0].u0; + tr[tr[t].d0].uside = S_RIGHT; + } + } + tr[tr[t].d0].u0 = t; + tr[tr[t].d0].u1 = tn; + } + + t = tr[t].d0; + } + + + else if ((tr[t].d0 <= 0) && (tr[t].d1 > 0)) + { /* Only one trapezoid below */ + if ((tr[t].u0 > 0) && (tr[t].u1 > 0)) + { /* continuation of a chain from abv. */ + if (tr[t].usave > 0) /* three upper neighbours */ + { + if (tr[t].uside == S_LEFT) + { + tr[tn].u0 = tr[t].u1; + tr[t].u1 = -1; + tr[tn].u1 = tr[t].usave; + + tr[tr[t].u0].d0 = t; + tr[tr[tn].u0].d0 = tn; + tr[tr[tn].u1].d0 = tn; + } + else /* intersects in the right */ + { + tr[tn].u1 = -1; + tr[tn].u0 = tr[t].u1; + tr[t].u1 = tr[t].u0; + tr[t].u0 = tr[t].usave; + + tr[tr[t].u0].d0 = t; + tr[tr[t].u1].d0 = t; + tr[tr[tn].u0].d0 = tn; + } + + tr[t].usave = tr[tn].usave = 0; + } + else /* No usave.... simple case */ + { + tr[tn].u0 = tr[t].u1; + tr[t].u1 = tr[tn].u1 = -1; + tr[tr[tn].u0].d0 = tn; + } + } + else + { /* fresh seg. or upward cusp */ + int tmp_u = tr[t].u0; + int td0, td1; + if (((td0 = tr[tmp_u].d0) > 0) && + ((td1 = tr[tmp_u].d1) > 0)) + { /* upward cusp */ + if ((tr[td0].rseg > 0) && + !is_left_of(tr[td0].rseg, &s.v1)) + { + tr[t].u0 = tr[t].u1 = tr[tn].u1 = -1; + tr[tr[tn].u0].d1 = tn; + } + else + { + tr[tn].u0 = tr[tn].u1 = tr[t].u1 = -1; + tr[tr[t].u0].d0 = t; + } + } + else /* fresh segment */ + { + tr[tr[t].u0].d0 = t; + tr[tr[t].u0].d1 = tn; + } + } + + if (FP_EQUAL(tr[t].lo.y, tr[tlast].lo.y) && + FP_EQUAL(tr[t].lo.x, tr[tlast].lo.x) && tribot) + { /* bottom forms a triangle */ + if (is_swapped) + tmptriseg = seg[segnum].prev; + else + tmptriseg = seg[segnum].next; + + if ((tmpseg > 0) && is_left_of(tmpseg, &s.v0)) + { + /* L-R downward cusp */ + tr[tr[t].d1].u0 = t; + tr[tn].d0 = tr[tn].d1 = -1; + } + else + { + /* R-L downward cusp */ + tr[tr[tn].d1].u1 = tn; + tr[t].d0 = tr[t].d1 = -1; + } + } + else + { + if ((tr[tr[t].d1].u0 > 0) && (tr[tr[t].d1].u1 > 0)) + { + if (tr[tr[t].d1].u0 == t) /* passes thru LHS */ + { + tr[tr[t].d1].usave = tr[tr[t].d1].u1; + tr[tr[t].d1].uside = S_LEFT; + } + else + { + tr[tr[t].d1].usave = tr[tr[t].d1].u0; + tr[tr[t].d1].uside = S_RIGHT; + } + } + tr[tr[t].d1].u0 = t; + tr[tr[t].d1].u1 = tn; + } + + t = tr[t].d1; + } + + /* two trapezoids below. Find out which one is intersected by */ + /* this segment and proceed down that one */ + + else + { + tmpseg = tr[tr[t].d0].rseg; + double y0, yt; + point_t tmppt; + int i_d0, i_d1; + + i_d0 = i_d1 = FALSE; + if (FP_EQUAL(tr[t].lo.y, s.v0.y)) + { + if (tr[t].lo.x > s.v0.x) + i_d0 = TRUE; + else + i_d1 = TRUE; + } + else + { + tmppt.y = y0 = tr[t].lo.y; + yt = (y0 - s.v0.y)/(s.v1.y - s.v0.y); + tmppt.x = s.v0.x + yt * (s.v1.x - s.v0.x); + + if (_less_than(&tmppt, &tr[t].lo)) + i_d0 = TRUE; + else + i_d1 = TRUE; + } + + /* check continuity from the top so that the lower-neighbour */ + /* values are properly filled for the upper trapezoid */ + + if ((tr[t].u0 > 0) && (tr[t].u1 > 0)) + { /* continuation of a chain from abv. */ + if (tr[t].usave > 0) /* three upper neighbours */ + { + if (tr[t].uside == S_LEFT) + { + tr[tn].u0 = tr[t].u1; + tr[t].u1 = -1; + tr[tn].u1 = tr[t].usave; + + tr[tr[t].u0].d0 = t; + tr[tr[tn].u0].d0 = tn; + tr[tr[tn].u1].d0 = tn; + } + else /* intersects in the right */ + { + tr[tn].u1 = -1; + tr[tn].u0 = tr[t].u1; + tr[t].u1 = tr[t].u0; + tr[t].u0 = tr[t].usave; + + tr[tr[t].u0].d0 = t; + tr[tr[t].u1].d0 = t; + tr[tr[tn].u0].d0 = tn; + } + + tr[t].usave = tr[tn].usave = 0; + } + else /* No usave.... simple case */ + { + tr[tn].u0 = tr[t].u1; + tr[tn].u1 = -1; + tr[t].u1 = -1; + tr[tr[tn].u0].d0 = tn; + } + } + else + { /* fresh seg. or upward cusp */ + int tmp_u = tr[t].u0; + int td0, td1; + if (((td0 = tr[tmp_u].d0) > 0) && + ((td1 = tr[tmp_u].d1) > 0)) + { /* upward cusp */ + if ((tr[td0].rseg > 0) && + !is_left_of(tr[td0].rseg, &s.v1)) + { + tr[t].u0 = tr[t].u1 = tr[tn].u1 = -1; + tr[tr[tn].u0].d1 = tn; + } + else + { + tr[tn].u0 = tr[tn].u1 = tr[t].u1 = -1; + tr[tr[t].u0].d0 = t; + } + } + else /* fresh segment */ + { + tr[tr[t].u0].d0 = t; + tr[tr[t].u0].d1 = tn; + } + } + + if (FP_EQUAL(tr[t].lo.y, tr[tlast].lo.y) && + FP_EQUAL(tr[t].lo.x, tr[tlast].lo.x) && tribot) + { + /* this case arises only at the lowest trapezoid.. i.e. + tlast, if the lower endpoint of the segment is + already inserted in the structure */ + + tr[tr[t].d0].u0 = t; + tr[tr[t].d0].u1 = -1; + tr[tr[t].d1].u0 = tn; + tr[tr[t].d1].u1 = -1; + + tr[tn].d0 = tr[t].d1; + tr[t].d1 = tr[tn].d1 = -1; + + tnext = tr[t].d1; + } + else if (i_d0) + /* intersecting d0 */ + { + tr[tr[t].d0].u0 = t; + tr[tr[t].d0].u1 = tn; + tr[tr[t].d1].u0 = tn; + tr[tr[t].d1].u1 = -1; + + /* new code to determine the bottom neighbours of the */ + /* newly partitioned trapezoid */ + + tr[t].d1 = -1; + + tnext = tr[t].d0; + } + else /* intersecting d1 */ + { + tr[tr[t].d0].u0 = t; + tr[tr[t].d0].u1 = -1; + tr[tr[t].d1].u0 = t; + tr[tr[t].d1].u1 = tn; + + /* new code to determine the bottom neighbours of the */ + /* newly partitioned trapezoid */ + + tr[tn].d0 = tr[t].d1; + tr[tn].d1 = -1; + + tnext = tr[t].d1; + } + + t = tnext; + } + + tr[t_sav].rseg = tr[tn_sav].lseg = segnum; + } /* end-while */ + + /* Now combine those trapezoids which share common segments. We can */ + /* use the pointers to the parent to connect these together. This */ + /* works only because all these new trapezoids have been formed */ + /* due to splitting by the segment, and hence have only one parent */ + + tfirstl = tfirst; + tlastl = tlast; + merge_trapezoids(segnum, tfirstl, tlastl, S_LEFT); + merge_trapezoids(segnum, tfirstr, tlastr, S_RIGHT); + + seg[segnum].is_inserted = TRUE; + return 0; +} + + +/* Update the roots stored for each of the endpoints of the segment. + * This is done to speed up the location-query for the endpoint when + * the segment is inserted into the trapezoidation subsequently + */ +static int find_new_roots(segnum) + int segnum; +{ + segment_t *s = &seg[segnum]; + + if (s->is_inserted) + return 0; + + s->root0 = locate_endpoint(&s->v0, &s->v1, s->root0); + s->root0 = tr[s->root0].sink; + + s->root1 = locate_endpoint(&s->v1, &s->v0, s->root1); + s->root1 = tr[s->root1].sink; + return 0; +} + + +/* Main routine to perform trapezoidation */ +int construct_trapezoids(nseg) + int nseg; +{ + register int i; + int root, h; + + /* Add the first segment and get the query structure and trapezoid */ + /* list initialised */ + + root = init_query_structure(choose_segment()); + + for (i = 1; i <= nseg; i++) + seg[i].root0 = seg[i].root1 = root; + + for (h = 1; h <= math_logstar_n(nseg); h++) + { + for (i = math_N(nseg, h -1) + 1; i <= math_N(nseg, h); i++) + add_segment(choose_segment()); + + /* Find a new root for each of the segment endpoints */ + for (i = 1; i <= nseg; i++) + find_new_roots(i); + } + + for (i = math_N(nseg, math_logstar_n(nseg)) + 1; i <= nseg; i++) + add_segment(choose_segment()); + + return 0; +} + + + + +static int initialise(n) + int n; +{ + register int i; + + for (i = 1; i <= n; i++) + seg[i].is_inserted = FALSE; + + generate_random_ordering(n); + + return 0; +} + + +/* Input specified as contours. + * Outer contour must be anti-clockwise. + * All inner contours must be clockwise. + * + * Every contour is specified by giving all its points in order. No + * point shoud be repeated. i.e. if the outer contour is a square, + * only the four distinct endpoints shopudl be specified in order. + * + * ncontours: #contours + * cntr: An array describing the number of points in each + * contour. Thus, cntr[i] = #points in the i'th contour. + * vertices: Input array of vertices. Vertices for each contour + * immediately follow those for previous one. Array location + * vertices[0] must NOT be used (i.e. i/p starts from + * vertices[1] instead. The output triangles are + * specified w.r.t. the indices of these vertices. + * triangles: Output array to hold triangles. + * + * Enough space must be allocated for all the arrays before calling + * this routine + */ + + +int triangulate_polygon(ncontours, cntr, vertices, triangles) + int ncontours; + int cntr[]; + double **vertices; + int **triangles; +{ + register int i; + int nmonpoly, ccount, npoints, genus; + int n; + + memset((void *)seg, 0, sizeof(seg)); + ccount = 0; + i = 1; + + while (ccount < ncontours) + { + int j; + int first, last; + + npoints = cntr[ccount]; + first = i; + last = first + npoints - 1; + for (j = 0; j < npoints; j++, i++) + { + seg[i].v0.x = vertices[i][0]; + seg[i].v0.y = vertices[i][1]; + + if (i == last) + { + seg[i].next = first; + seg[i].prev = i-1; + seg[i-1].v1 = seg[i].v0; + } + else if (i == first) + { + seg[i].next = i+1; + seg[i].prev = last; + seg[last].v1 = seg[i].v0; + } + else + { + seg[i].prev = i-1; + seg[i].next = i+1; + seg[i-1].v1 = seg[i].v0; + } + + seg[i].is_inserted = FALSE; + } + + ccount++; + } + + genus = ncontours - 1; + n = i-1; + + initialise(n); + construct_trapezoids(n); + nmonpoly = monotonate_trapezoids(n); + triangulate_monotone_polygons(n, nmonpoly, triangles); + + return 0; +} + + +/* This function returns TRUE or FALSE depending upon whether the + * vertex is inside the polygon or not. The polygon must already have + * been triangulated before this routine is called. + * This routine will always detect all the points belonging to the + * set (polygon-area - polygon-boundary). The return value for points + * on the boundary is not consistent!!! + */ + +int is_point_inside_polygon(vertex) + double vertex[2]; +{ + point_t v; + int trnum, rseg; + trap_t *t; + + v.x = vertex[0]; + v.y = vertex[1]; + + trnum = locate_endpoint(&v, &v, 1); + t = &tr[trnum]; + + if (t->state == ST_INVALID) + return FALSE; + + if ((t->lseg <= 0) || (t->rseg <= 0)) + return FALSE; + rseg = t->rseg; + return _greater_than_equal_to(&seg[rseg].v1, &seg[rseg].v0); +} + diff --git a/src/triangulate.h b/src/triangulate.h new file mode 100755 index 0000000000000000000000000000000000000000..baa3568cb55ce5d23f2a95c9547d6b612802f090 --- /dev/null +++ b/src/triangulate.h @@ -0,0 +1,170 @@ +#ifndef _triangulate_h +#define _triangulate_h + +#include <sys/types.h> +#include <stdlib.h> +#include <stdio.h> + + +typedef struct { + double x, y; +} point_t, vector_t; + + +/* Segment attributes */ + +typedef struct { + point_t v0, v1; /* two endpoints */ + int is_inserted; /* inserted in trapezoidation yet ? */ + int root0, root1; /* root nodes in Q */ + int next; /* Next logical segment */ + int prev; /* Previous segment */ +} segment_t; + + +/* Trapezoid attributes */ + +typedef struct { + int lseg, rseg; /* two adjoining segments */ + point_t hi, lo; /* max/min y-values */ + int u0, u1; + int d0, d1; + int sink; /* pointer to corresponding in Q */ + int usave, uside; /* I forgot what this means */ + int state; +} trap_t; + + +/* Node attributes for every node in the query structure */ + +typedef struct { + int nodetype; /* Y-node or S-node */ + int segnum; + point_t yval; + int trnum; + int parent; /* doubly linked DAG */ + int left, right; /* children */ +} node_t; + + +typedef struct { + int vnum; + int next; /* Circularly linked list */ + int prev; /* describing the monotone */ + int marked; /* polygon */ +} monchain_t; + + +typedef struct { + point_t pt; + int vnext[4]; /* next vertices for the 4 chains */ + int vpos[4]; /* position of v in the 4 chains */ + int nextfree; +} vertexchain_t; + + +/* Node types */ + +#define T_X 1 +#define T_Y 2 +#define T_SINK 3 + + +#define SEGSIZE 200 /* max# of segments. Determines how */ + /* many points can be specified as */ + /* input. If your datasets have large */ + /* number of points, increase this */ + /* value accordingly. */ + +#define QSIZE 8*SEGSIZE /* maximum table sizes */ +#define TRSIZE 4*SEGSIZE /* max# trapezoids */ + + +#define TRUE 1 +#define FALSE 0 + + +#define FIRSTPT 1 /* checking whether pt. is inserted */ +#define LASTPT 2 + + +#define INFINITY 1<<30 +#define C_EPS 1.0e-7 /* tolerance value: Used for making */ + /* all decisions about collinearity or */ + /* left/right of segment. Decrease */ + /* this value if the input points are */ + /* spaced very close together */ + + +#define S_LEFT 1 /* for merge-direction */ +#define S_RIGHT 2 + + +#define ST_VALID 1 /* for trapezium state */ +#define ST_INVALID 2 + + +#define SP_SIMPLE_LRUP 1 /* for splitting trapezoids */ +#define SP_SIMPLE_LRDN 2 +#define SP_2UP_2DN 3 +#define SP_2UP_LEFT 4 +#define SP_2UP_RIGHT 5 +#define SP_2DN_LEFT 6 +#define SP_2DN_RIGHT 7 +#define SP_NOSPLIT -1 + +#define TR_FROM_UP 1 /* for traverse-direction */ +#define TR_FROM_DN 2 + +#define TRI_LHS 1 +#define TRI_RHS 2 + + +#define MAX(a, b) (((a) > (b)) ? (a) : (b)) +#define MIN(a, b) (((a) < (b)) ? (a) : (b)) + +#define CROSS(v0, v1, v2) (((v1).x - (v0).x)*((v2).y - (v0).y) - \ + ((v1).y - (v0).y)*((v2).x - (v0).x)) + +#define DOT(v0, v1) ((v0).x * (v1).x + (v0).y * (v1).y) + +#define FP_EQUAL(s, t) (fabs(s - t) <= C_EPS) + +#define TRUE 1 +#define FALSE 0 + + +/* Global variables */ + +extern node_t qs[QSIZE]; /* Query structure */ +extern trap_t tr[TRSIZE]; /* Trapezoid structure */ +extern segment_t seg[SEGSIZE]; /* Segment table */ + + +/* Functions */ + +extern int triangulate_polygon(int, int *, double**,int**); +extern int is_point_inside_polygon(double *); + +int triangulate_polygon(int, int [], double**, int**); + +int testclock(double *,double *,int); + +extern int monotonate_trapezoids(int); +extern int triangulate_monotone_polygons(int, int, int**); + +extern int _greater_than(point_t *, point_t *); +extern int _equal_to(point_t *, point_t *); +extern int _greater_than_equal_to(point_t *, point_t *); +extern int _less_than(point_t *, point_t *); +extern int locate_endpoint(point_t *, point_t *, int); +extern int construct_trapezoids(int); + +extern int generate_random_ordering(int); +extern int choose_segment(void); +extern int read_segments(char *, int *); +extern int math_logstar_n(int); +extern int math_N(int, int); + +#endif /* triangulate_h */ + diff --git a/src/util.c b/src/util.c new file mode 100755 index 0000000000000000000000000000000000000000..c6e6a236a617c2db3bb5188b710a2891ea10afbf --- /dev/null +++ b/src/util.c @@ -0,0 +1,80 @@ +#include "adssub.h" +#include "triangulate.h" + +int triangulate(int *npoly, int *tabpt, int *nptTot,double *vertX, double *vertY, int *ntri, +double *X1, double *Y1,double *X2, double *Y2,double *X3, double *Y3) { + int i,j,k,l; + int **triangles; + double **vertices; + double *x,*y; + tabintalloc(&triangles,*ntri,3); + taballoc(&vertices,*nptTot+1,2); + l=0; + for(i=0;i<*npoly;i++) { + int npt=tabpt[i]; + vecalloc(&x,npt+1); + vecalloc(&y,npt+1); + for(j=1;j<=npt;j++) { + k=j+l-1; + x[j]=vertX[k]; + y[j]=vertY[k]; + } + if(i==0) { + if(testclock(x,y,npt)) { /*clockwise order*/ + k=npt; + for(j=1;j<=npt;j++) { + vertices[j+l][0]=x[k]; + vertices[j+l][1]=y[k]; + k--; + } + } + else { /*anti-clockwise order*/ + for(j=1;j<=npt;j++) { + vertices[j+l][0]=x[j]; + vertices[j+l][1]=y[j]; + } + } + } + else { + if(!testclock(x,y,npt)) { /*anti-clockwise order*/ + k=npt; + for(j=1;j<=npt;j++) { + vertices[j+l][0]=x[k]; + vertices[j+l][1]=y[k]; + k--; + } + } + else { /*clockwise order*/ + for(j=1;j<=npt;j++) { + vertices[j+l][0]=x[j]; + vertices[j+l][1]=y[j]; + } + } + } + l+=npt; + freevec(x); + freevec(y); + } + + /*Test de l'unicite des points*/ + for(i=2;i<=*nptTot;i++) { + for(j=1;j<i;j++) { + if((vertices[i][0]==vertices[j][0])&&(vertices[i][1]==vertices[j][1])) { + Rprintf("Error : Duplicate input vertices\n"); + return -1; + } + } + } + triangulate_polygon(*npoly,tabpt,vertices,triangles); + for(i=0;i<*ntri;i++) { + X1[i]=vertices[triangles[i][2]][0]; + Y1[i]=vertices[triangles[i][2]][1]; + X2[i]=vertices[triangles[i][1]][0]; + Y2[i]=vertices[triangles[i][1]][1]; + X3[i]=vertices[triangles[i][0]][0]; + Y3[i]=vertices[triangles[i][0]][1]; + } + freeinttab(triangles); + freetab(vertices); + return 0; +}