deldir/0000755000176000001440000000000012477242213011551 5ustar ripleyusersdeldir/inst/0000755000176000001440000000000012367073033012526 5ustar ripleyusersdeldir/inst/READ_ME0000644000176000001440000002112011621163455013541 0ustar ripleyusers Version 0.0-9 (??? 2 June 2009) Added a new function tile.centroids() --- which does the obvious. Motivated by an inquiry from Leandro Moreira. Version 0.0-8 (4 April 2009) Removed the labels from the x and y vectors in the tile descriptions produced by tile.list. These labels (which were the row numbers in the dirsgs data frame returned by deldir()) served no useful purpose and were potentially confusing. ***************************** Versions 0.0-2 through 0.0-7 were not tracked here. :-( Simply forgot about doing this. I thouroughly *intend* [ :-) ] to get the archives from CRAN and try to document the changes. Recent ones involved fixing bugs in and adding features to the tile.list() and plot.tile.list() functions. ***************************** Version 0.0-1 (21 February 2002) This version is simply an adaptation of the Splus version of the package to R. ***************************** Version date: 14 February 2002. This version supercedes the version dated 24 April 1999. ***************************** The changes from the version dated 24 April 1999 to the version dated 14 February 2002 were: A bug in the procedure for eliminating duplicated points was fixed. Thanks go to Dr. Berwin Turlach of the Department of Maths and Stats at the University of Western Australia, for spotting this bug. ***************************** The changes from the version dated 26 October 1998 to the version dated 24 April 1999 were: (1) The function mipd(), stored in mipd.sf, and the corresponding Fortran subroutine mipd, stored in mipd.r, have been replaced by mnnd() in mnnd.sf and mnnd in mnnd.r. The function mipd calculated the mean interpoint distance, to be used in constructing dummy point structures of a certain type. After some reflection it became apparent that the mean interpoint distance was much too large for the intended purpose, and that a more appropriate value was the ``mean nearest neighbour distance'' which is calculated by the new function. This new value is now used in constructing dummy point structures. Note that the operative result is that the resulting dummy point structures contain many more points than before. The old value caused large numbers of the dummy points to fall outside the data window and therefore to be clipped. ***************************** The changes from the version dated 6 December 1996 to the version dated 26 October 1998 were: (1) A ratfor/Fortran routine named ``inside'' has been renamed ``dldins'' to avoid conflict with a name built in to some versions of Splus. (2) Some minor corrections have been made to dangerous infelicities in a piece of the ratfor/Fortran code. (3) The dynamic loading procedure has been changed to use dyn.load.shared so that the package is easily usable on IRIX systems as well as under SunOS/Solaris. (4) The package has been adjusted slightly so that it can easily be installed as a section of a library. In particular, the dynamic loading is now done by the .First.lib() function rather than from within deldir() itself; reference to an environment variable DYN_LOAD_LIB is no longer needed. ***************************** This package computes and plots the Dirichlet (Voronoi) tesselation and the Delaunay triangulation of a set of of data points and possibly a superimposed ``grid'' of dummy points. The tesselation is constructed with respect to the whole plane by suspending it from ideal points at infinity. ORIGINALLY PROGRAMMED BY: Rolf Turner in 1987/88, while with the Division of Mathematics and Statistics, CSIRO, Sydney, Australia. Re-programmed by Rolf Turner to adapt the implementation from a stand-alone Fortran program to an S function, while visiting the University of Western Australia, May 1995. Further revised December 1996, October 1998, April 1999, and February 2002. Adapted to an R package 21 February 2002. Current address of the author: Department of Mathematics and Statistics, University of New Brunswick, P.O. Box 4400, Fredericton, New Brunswick, Canada E3B 5A3 Email: rolf@math.unb.ca The author gratefully acknowledges the contributions, assistance, and guidance of Mark Berman, of D.M.S., CSIRO, in collaboration with whom this project was originally undertaken. The author also acknowledges much useful advice from Adrian Baddeley, formerly of D.M.S. CSIRO (now Professor of Statistics at the University of Western Australia). Daryl Tingley of the Department of Mathematics and Statistics, University of New Brunswick provided some helpful insight. Special thanks are extended to Alan Johnson, of the Alaska Fisheries Science Centre, who supplied two data sets which were extremely valuable in tracking down some errors in the code. Don MacQueen, of Lawrence Livermore National Lab, wrote an Splus driver function for the old stand-alone version of this software. That driver, which was available on Statlib, is now deprecated in favour of this current package. Don also collaborated in the preparation of this current package. Bill Dunlap of MathSoft Inc. tracked down a bug which was making the deldir() function crash on some systems, and pointed out some other improvements to be made. Berwin Turlach of the Department of Maths and Stats at the University of Western Australia pointed out a bug in the procedure for eliminating duplicated points. ***************************** The man directory, contains, in addition to the R documentation files deldir.Rd and plot.deldir.Rd: (a) This READ_ME file. (b) A file err.list, containing a list of meanings of possible error numbers which could be returned. NONE of these errors should ever actually happen except for errors 4, 14, and 15. These relate to insufficient dimensioning, and if they occur, the driver increases the dimensions and tries again (informing you of this fact). (c) A file ex.out containing a printout of the object returned by running the example given in the help file for deldir. The src directory contains many, many *.f (Fortran) files, which get compiled and dynamically loaded. The Fortran code is ponderous --- it was automatically generated from Ratfor code, which was pretty ponderous to start with. It is quite possibly very kludgy aw well --- i.e. a good programmer could make it ***much*** more efficient I'm sure. It contains all sorts of checking for anomalous situations which probably can/will never occur. These checks basically reflect my pessimism and fervent belief in Murphy's Law. The program was also designed with a particular application in mind, in which we wished to superimpose a grid of dummy points onto the actual data points which we were triangulating. This fact adds slightly to the complication of the code. ***************************** Here follows a brief description of the package: (1) The function deldir computes the Delaunay Triangulation (and hence the Dirichlet Tesselation) of a planar point set according to the second (iterative) algorithm of Lee and Schacter, International Journal of Computer and Information Sciences, Vol. 9, No. 3, 1980, pages 219 to 242. The tesselation/triangulation is made to be **** with respect to the whole plane **** by `suspending' it from `ideal' points (-Inf,-Inf), (Inf,-Inf) (Inf,Inf), and (-Inf,Inf). (2) The tesselation/triangulation is also enclosed in a finite rectangle with corners (xmin,ymax) * ------------------------ * (xmax,ymax) | | | | | | | | | | (xmin,ymin) * ------------------------ * (xmax,ymin) The boundaries of this rectangle truncate some Dirichlet tiles, in particular any infinite ones. This rectangle is referred to elsewhere as `the' rectangular window. === (2) The function plot.deldir is a method for plot. I.e. it may be invoked simply by typing ``plot(x)'' provided that ``x'' is an object of class ``deldir'' (as produced by the function deldir). The plot (by default) consists of the edges of the Delaunay triangles (solid lines) and the edges of the Dirichlet tiles (dotted lines). By default the real data points are indicated by circles, and the dummy points are indicated by triangles. deldir/inst/code.discarded/0000755000176000001440000000000011654722226015364 5ustar ripleyusersdeldir/inst/code.discarded/ind.dup.R0000644000176000001440000000067611621163455017056 0ustar ripleyusersind.dup <- function(x,y,rw=NULL,frac=0.0001) { # # Function ind.dup to calculate the indices of data pairs # which duplicate earlier ones. (Returns a logical vector; # true for such indices, false for the rest.) # if(is.null(rw)) rw <- c(0,1,0,1) n <- length(x) rslt <- .Fortran( 'inddup', x=as.double(x), y=as.double(y), n=as.integer(n), rw=as.double(rw), frac=as.double(frac), dup=logical(n), PACKAGE='deldir' ) rslt$dup } deldir/inst/code.discarded/triang.list.R.save0000644000176000001440000000404311621163455020700 0ustar ripleyuserstriang.list <- function (object) { stopifnot(inherits(object,"deldir")) a <- object$delsgs[, 5] b <- object$delsgs[, 6] tlist <- matrix(integer(0), 0, 3) for(i in seq(nrow(object$summary))) { # find all Delaunay neighbours of i jj <- c(b[a==i], a[b==i]) jj <- sort(unique(jj)) # select those with a higher index than i jj <- jj[jj > i] # find pairs of neighbours which are Delaunay neighbours # (thus, triangles where the first numbered vertex is i) if(length(jj) > 0) for(j in jj) { kk <- c(b[a == j], a[b == j]) kk <- kk[(kk %in% jj) & (kk > j)] if(length(kk) > 0) for(k in kk) # add (i,j,k) to list of triangles (i < j < k) tlist <- rbind(tlist, c(i, j, k)) } } x <- object$summary[,"x"] y <- object$summary[,"y"] xtri <- matrix(x[tlist], nrow(tlist), 3) ytri <- matrix(y[tlist], nrow(tlist), 3) ztri <- ytri - min(y) dx <- cbind(xtri[, 2] - xtri[, 1], xtri[, 3] - xtri[, 2], xtri[, 1] - xtri[, 3]) zm <- cbind(ztri[, 1] + ztri[, 2], ztri[, 2] + ztri[, 3], ztri[, 3] + ztri[, 1]) negareas <- apply(dx * zm, 1, sum) clockwise <- (negareas > 0) if (any(clockwise)) { xc <- xtri[clockwise,,drop=FALSE] yc <- ytri[clockwise,,drop=FALSE] xtri[clockwise, ] <- xc[, c(1, 3, 2)] ytri[clockwise, ] <- yc[, c(1, 3, 2)] } rslt <- list() K <- 0 for(i in 1:nrow(xtri)) { tmp <- .Fortran( "intri", x=as.double(xtri[i,]), y=as.double(ytri[i,]), u=as.double(x), v=as.double(y), n=as.integer(length(x)), okay=logical(3*length(x)), xxx=double(3*length(x)), PACKAGE="deldir") # okay <- matrix(tmp$okay,ncol=3) xxx <- matrix(tmp$xxx,ncol=3) ok <- apply(okay,1,any) chk <- apply(xxx,1,function(x){any(x<=0)}) if(!isTRUE(all.equal(ok,chk))) browser() # if(all(ok)) { K <- K+1 rslt[[K]] <- data.frame(x=xtri[i,],y=ytri[i,]) } } attr(rslt,"rw") <- object$rw class(rslt) <- "triang.list" rslt } deldir/inst/code.discarded/trigraf1.r.save0000644000176000001440000000312611621163455020222 0ustar ripleyusers# # trigraf.r # Code adapted from C code in trigraf.c, from the spatstat package # by Adrian Baddeley. # subroutine trigraf(nv, ne, ie, je, nt, it, jt, kt, scratch) # # nv --- number of points being triangulated. # ne --- number of triangle edges # ie and je --- vectors of indices of ends of each edge # nt --- number of triangles assumed to be at most ne # it, jt, kt --- vectors of indices of vertices of triangles # scratch --- integer vector of lenght at least ne. # integer scratch(1) dimension ie(1), je(1), it(1), jt(1), kt(1) do i = 1,nv { # Find triangles involving vertex 'i' in which 'i' is the # lowest-numbered vertex. # First, find vertices j > i connected to i. nj = 1 do m = 1, ne { if(ie[m] == i) { j = je[m] if(j > i) { jj[nj] = j nj = nj+1 } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[nj] = j nj = nj+1 } } } # Determine which pairs of vertices j, k are joined by an edge; # and save triangles (i,j,k). if(nj > 1) { # Sort jj in ascending order do mj = 1,nj { j = jj[mj] do mk = mj+1,nj { k = jj[mk] if(k < j) { # Swap. jj[mk] = j jj[mj] = k j = k } } } do mj = 1,nj { j = jj[mj] do mk = mj+1,nj { k = jj[mk]; if(j != k) { # Run through edges to determine whether j, k are neighbours. for(m = 0; m < Ne; m++) { do m = 1,ne { if((ie[m] == j & je[m] == k) | (ie[m] == k & je[m] == j)) { # Add (i, j, k) to list of triangles. it[nt] = i jt[nt] = j kt[nt] = k nt = nt+1 } } } } } } } } deldir/inst/code.discarded/inddup.r0000644000176000001440000000054411621163455017032 0ustar ripleyuserssubroutine inddup(x,y,n,rw,frac,dup) implicit double precision(a-h,o-z) logical dup(n) dimension x(n), y(n), rw(4) xtol = frac*(rw(2)-rw(1)) ytol = frac*(rw(4)-rw(3)) dup(1) = .false. do i = 2,n { dup(i) = .false. do j = 1,i-1 { dx = abs(x(i)-x(j)) dy = abs(y(i)-y(j)) if(dx < xtol & dy < ytol) { dup(i) = .true. break } } } return end deldir/inst/code.discarded/trigraf.r0000644000176000001440000000311411621163455017201 0ustar ripleyusers# Fast version of trigraf assuming that # ie(m) < je(m) # ie[is in ascending order # je is in ascending order within ie, # that is, je(ie==i) is in ascending order for each fixed i. # Code adapted from C code in trigraf.c, from the spatstat package # by Adrian Baddeley. # subroutine trigraf(nv, ne, ie, je, nt, it, jt, kt) # # nv --- number of points being triangulated. # ne --- number of triangle edges # ie and je --- vectors of indices of ends of each edge # nt --- number of triangles assumed to be at most ne # it, jt, kt --- vectors of indices of vertices of triangles # integer firstedge, lastedge; dimension ie(1), je(1), it(1), jt(1), kt(1) # Initialise output. nt = 1 lastedge = 0 while(lastedge < ne) { # Consider next vertex i. # The edges (i,j) with i < j appear contiguously in the edge list. firstedge = lastedge + 1 i = ie(firstedge) do m = firstedge+1,ne { if ( ie(m) != i ) break } lastedge = m-1 # Consider each pair j, k of neighbours of i, where i < j < k. # Scan entire edge list to determine whether j, k are joined by an edge. # If so, save triangle (i,j,k) if(lastedge > firstedge) { do mj = firstedge,lastedge-1 { j = je(mj) do mk = firstedge+1,lastedge { k = je(mk) # Run through edges to determine whether j, k are neighbours. do m = 1,ne { if(ie(m) >= j) break } while(m <= ne & ie(m) == j) { if(je(m) == k) { # Add (i, j, k) to list of triangles. it(nt) = i; jt(nt) = j; kt(nt) = k; nt = nt+1 } m = m+1 } } } } } return end deldir/inst/code.discarded/trigraf.c0000644000176000001440000000737311621163455017175 0ustar ripleyusers/* trigraf.c $Revision: 1.2 $ $Date: 2009/02/20 19:24:30 $ trigraf() Form list of all triangles in a planar graph, given list of edges trigrafS() Faster version when input data are sorted. */ void trigraf(nv, ne, ie, je, nt, it, jt, kt, scratch) /* inputs */ int *nv; /* number of graph vertices */ int *ne; /* number of edges */ int *ie, *je; /* vectors of indices of ends of each edge */ /* scratch area */ int *scratch; /* integer vector, at least 'ne' in length */ /* output */ int *nt; /* number of triangles (assumed <= ne) */ int *it, *jt, *kt; /* vectors of indices of vertices of triangles */ { int Nv, Ne, Nt; int Nj, m, i, j, k, mj, mk; int *jj; Nv = *nv; Ne = *ne; /* initialise storage */ jj = scratch; Nt = 0; for(i=0; i < Nv; i++) { /* Find triangles involving vertex 'i' in which 'i' is the lowest-numbered vertex */ /* First, find vertices j > i connected to i */ Nj = 0; for(m = 0; m < Ne; m++) { if(ie[m] == i) { j = je[m]; if(j > i) { jj[Nj] = j; Nj++; } } else if(je[m] == i) { j = ie[m]; if(j > i) { jj[Nj] = j; Nj++; } } } /* Determine which pairs of vertices j, k are joined by an edge; save triangles (i,j,k) */ if(Nj > 1) { /* Sort jj in ascending order */ for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(k < j) { /* swap */ jj[mk] = j; jj[mj] = k; j = k; } } } for(mj = 0; mj < Nj-1; mj++) { j = jj[mj]; for(mk = mj+1; mk < Nj; mk++) { k = jj[mk]; if(j != k) { /* Run through edges to determine whether j, k are neighbours */ for(m = 0; m < Ne; m++) { if((ie[m] == j && je[m] == k) || (ie[m] == k && je[m] == j)) { /* add (i, j, k) to list of triangles */ it[Nt] = i; jt[Nt] = j; kt[Nt] = k; Nt++; } } } } } } } *nt = Nt; } /* faster version of trigraf() assuming that ie[m] < je[m] ie[] is in ascending order je[] is in ascending order within ie[], that is, je[ie[]=i] is in ascending order for each fixed i */ void trigrafS(nv, ne, ie, je, nt, it, jt, kt) /* inputs */ int *nv; /* number of graph vertices */ int *ne; /* number of edges */ int *ie, *je; /* vectors of indices of ends of each edge */ /* output */ int *nt; /* number of triangles (assumed <= ne) */ int *it, *jt, *kt; /* vectors of indices of vertices of triangles */ { int Nv, Ne, Nt; int m, i, j, k, mj, mk; int firstedge, lastedge; Nv = *nv; Ne = *ne; /* initialise output */ Nt = 0; lastedge = -1; while(lastedge + 1 < Ne) { /* Consider next vertex i. The edges (i,j) with i < j appear contiguously in the edge list. */ firstedge = lastedge + 1; i = ie[firstedge]; for(m= firstedge+1; m < Ne && ie[m] == i; m++) ; lastedge = m-1; /* Consider each pair j, k of neighbours of i, where i < j < k. Scan entire edge list to determine whether j, k are joined by an edge. If so, save triangle (i,j,k) */ if(lastedge > firstedge) { for(mj = firstedge; mj < lastedge; mj++) { j = je[mj]; for(mk = firstedge+1; mk <= lastedge; mk++) { k = je[mk]; /* Run through edges to determine whether j, k are neighbours */ for(m = 0; m < Ne && ie[m] < j; m++) ; while(m < Ne && ie[m] == j) { if(je[m] == k) { /* add (i, j, k) to list of triangles */ it[Nt] = i; jt[Nt] = j; kt[Nt] = k; Nt++; } m++; } } } } } *nt = Nt; } deldir/inst/code.discarded/intri.r.save0000644000176000001440000000134011621163455017624 0ustar ripleyuserssubroutine intri(x,y,u,v,n,okay,xxx) # # Test whether any of the points (u(i),v(i)) are inside the triangle # whose vertices are specified by the vectors x and y. # implicit double precision(a-h,o-z) dimension x(3), y(3), u(n), v(n) dimension xxx(n,3) logical okay(n,3), inside zero = 0.d0 # Check on order (clockwise or anticlockwise). s = 1.d0 a = x(2) - x(1) b = y(2) - y(1) c = x(3) - x(1) d = y(3) - y(1) cp = a*d - b*c if(cp < 0) s = -s do i = 1,n { do j = 1,3 { jp = j+1 if(jp==4) jp = 1 # Take addition modulo 3. a = x(jp) - x(j) b = y(jp) - y(j) c = u(i) - x(j) d = v(i) - y(j) cp = s*(a*d - b*c) xxx(i,j) = cp if(cp <= 0) okay(i,j) = .true. else okay(i,j) = .false. } } return end deldir/inst/err.list0000644000176000001440000000322411621163455014214 0ustar ripleyusers Error list: =========== nerror = 1: Contradictory adjacency lists. Error in adjchk. nerror = 2: Number of points jumbled. Error in binsrt. nerror = 3: Vertices of 'triangle' are collinear and vertex 2 is not between 1 and 3. Error in circen. nerror = 4: Number of adjacencies too large. Error in insrt. (Automatically adjusted for in deldir().) nerror = 5: Adjacency list of i is empty, and so cannot contain j. Error in pred. nerror = 6: Adjacency list of i does not contain j. Error in pred. nerror = 7: Indicator ijk is out of range. (This CAN'T happen!) Error in qtest. nerror = 8: Fell through all six cases. Something must be totally stuffed up. Error in stoke. nerror = 9: Adjacency list of i is empty, and so cannot contain j. Error in succ. nerror = 10: Adjacency list of i does not contain j. Error in succ. nerror = 11: No triangles to find. Error in trifnd. nerror = 12: Vertices of triangle are collinear. Error in dirseg. nerror = 13: Vertices of triangle are collinear. Error in dirout. nerror = 14: Number of Delaunay segments exceeds alloted space. Error in delseg. (Automatically adjusted for in deldir().) nerror = 15: Number of Dirichlet segments exceeds alloted space. Error in dirseg. (Automatically adjusted for in deldir().) nerror = 16: Line from midpoint to circumcenter does not intersect rectangle boundary; but it HAS to!!! Error in dirseg. nerror = 17: Line from midpoint to circumcenter does not intersect rectangle boundary; but it HAS to!!! Error in dirout. deldir/inst/ratfor/0000755000176000001440000000000012367274321014026 5ustar ripleyusersdeldir/inst/ratfor/intri.r0000644000176000001440000000144311621163455015335 0ustar ripleyuserssubroutine intri(x,y,u,v,n,okay) # # Test whether any of the points (u(i),v(i)) are inside the triangle # whose vertices are specified by the vectors x and y. # Called by .Fortran() from triang.list.R. # implicit double precision(a-h,o-z) dimension x(3), y(3), u(n), v(n) logical okay, inside zero = 0.d0 # Check on order (clockwise or anticlockwise). s = 1.d0 a = x(2) - x(1) b = y(2) - y(1) c = x(3) - x(1) d = y(3) - y(1) cp = a*d - b*c if(cp < 0) s = -s do i = 1,n { inside = .true. do j = 1,3 { jp = j+1 if(jp==4) jp = 1 # Take addition modulo 3. a = x(jp) - x(j) b = y(jp) - y(j) c = u(i) - x(j) d = v(i) - y(j) cp = s*(a*d - b*c) if(cp <= zero) { inside = .false. break } } if(inside) { okay = .false. return } } okay = .true. return end deldir/inst/ratfor/qtest1.r0000644000176000001440000000360711621163455015435 0ustar ripleyuserssubroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) # The Lee-Schacter test for the LOP (all points are real, # i.e. non-ideal). If the LOP is ***not*** satisfied (i.e. if # vertex j is inside the circumcircle of vertices h, i, and k) then the # diagonals should be swapped, i.e. shdswp ("should-swap") is true. # Called by qtest. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) integer h logical shdswp # The vertices of the quadrilateral are labelled # h, i, j, k in the anticlockwise direction, h # being the point of central interest. # Make sure the quadrilateral is convex, so that # it makes sense to swap the diagonal. # call acchk(i,j,k,shdswp,x,y,ntot,eps) # if(!shdswp) return # # 23 July 2011: # The foregoing test is a load of dingos' kidneys. (1) It is # unnecessary, and (2) it is wrong! (1) If the LOP is not satisfied # (the only circumstance under which there should be a swap) then the # quadrilateral ***must*** be convex, and so swapping can sensibly # take place. (2) The vertices i, j, k in will ***always*** be in # anticlockwise order, since the vertices h, i, j, k of the quadrilateral # are in such order and i is connected to k, whence j can't be inside # the triangle ihk. So the test does nothing. But then it didn't need # to do anything. # Get the coordinates of vertices h and j. xh = x(h) yh = y(h) xj = x(j) yj = y(j) # Find the centre of the circumcircle of vertices h, i, k. call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror) if(nerror>0) return if(shdswp) return # The points h, i, and k are colinear, so # the circumcircle has `infinite radius', so # (xj,yj) is definitely inside. # Check whether (xj,yj) is inside the circle of centre # (x0,y0) and radius r = dist[(x0,y0),(xh,yh)] a = x0-xh b = y0-yh r2 = a*a+b*b a = x0-xj b = y0-yj ch = a*a + b*b if(ch0) return if(value) { kseg = kseg+1 if(kseg > ndel) { nerror = 14 return } delsgs(1,kseg) = x(i) delsgs(2,kseg) = y(i) delsgs(3,kseg) = x(j) delsgs(4,kseg) = y(j) delsgs(5,kseg) = i1 delsgs(6,kseg) = j1 } } } ndel = kseg return end deldir/inst/ratfor/dirout.r0000644000176000001440000000756112367273250015530 0ustar ripleyuserssubroutine dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,ind,eps,nerror) # Output the description of the Dirichlet tile centred at point # i for i = 1, ..., npd. Do this in the original order of the # points, not in the order into which they have been bin-sorted. # Called by master. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsum(npd,3), ind(npd), rw(4) logical collin, intfnd, bptab, bptcd, rwu # Note that at this point some Delaunay neighbours may be # `spurious'; they are the corners of a `large' rectangle in which # the rectangular window of interest has been suspended. This # large window was brought in simply to facilitate output concerning # the Dirichlet tesselation. They were added to the triangulation # in the routine `dirseg' which ***must*** therefore be called before # this routine (`dirout') is called. (Likewise `dirseg' must be called # ***after*** `delseg' and `delout' have been called.) # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) do i1 = 1,npd { area = 0. # Initialize the area of the ith tile to zero. nbpt = 0 # Initialize the number of boundary points of # the ith tile to zero. npt = 0 # Initialize the number of tile boundaries to zero. i = ind(i1) np = nadj(i,0) # Output the point number, its coordinates, and the number of # its Delaunay neighbours == the number of boundary segments in # its Dirichlet tile. # For each Delaunay neighbour, find the circumcentres of the # triangles on each side of the segment joining point i to that # neighbour. do j1 = 1,np { j = nadj(i,j1) call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror>0) return if(collin) { nerror = 13 return } call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror>0) return if(collin) { nerror = 13 return } # Increment the area of the current Dirichlet # tile (intersected with the rectangular window) by applying # Stokes' Theorem to the segment of tile boundary joining # (a,b) to (c,d). (Note that the direction is anti-clockwise.) call stoke(a,b,c,d,rw,tmp,sn,eps,nerror) if(nerror > 0) return area = area+sn*tmp # If a circumcentre is outside the rectangular window, replace # it with the intersection of the rectangle boundary with the # line joining the two circumcentres. Then output # the number of the current Delaunay neighbour and # the two circumcentres (or the points with which # they have been replaced). # Note: rwu = "right way up". xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi!=yj) { slope = (xi - xj)/(yj - yi) rwu = .true. } else { slope = 0.d0 rwu = .false. } call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab) if(intfnd) { call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd) if(!intfnd) { nerror = 17 return } if(bptab & bptcd) { xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xminmadj) { # Watch out for over-writing!!! nerror = 4 return } while(kk>kj) { nadj(i,kk) = nadj(i,kk-1) kk = kk-1 } nadj(i,kj) = j nadj(i,0) = n+1 return end deldir/inst/ratfor/master.r0000644000176000001440000000407012133355646015506 0ustar ripleyuserssubroutine master(x,y,sort,rw,npd,ntot,nadj,madj,ind,tx,ty,ilst,eps, delsgs,ndel,delsum,dirsgs,ndir,dirsum,nerror) # Master subroutine: # One subroutine to rule them all, # One subroutine to find them. # One subroutine to bring them all in, # And in the darkness bind them. implicit double precision(a-h,o-z) logical sort, adj dimension x(-3:ntot), y(-3:ntot) dimension nadj(-3:ntot,0:madj) dimension ind(npd), tx(npd), ty(npd), ilst(npd), rw(4) dimension delsgs(6,ndel), dirsgs(8,ndir) dimension delsum(npd,4), dirsum(npd,3) # Define one. one = 1.d0 # Sort the points into bins, the number of such being approx. sqrt(n). if(sort) { call binsrt(x,y,ntot,rw,npd,ind,tx,ty,ilst,nerror) if(nerror > 0) return } else { do i = 1,npd { ind(i) = i } } # Initialize the adjacency list; counts to 0, other entries to -99. do i = -3,ntot { nadj(i,0) = 0 do j = 1,madj { nadj(i,j) = -99 } } # Put the four ideal points into x and y and the adjacency list. # The ideal points are given pseudo-coordinates # (-1,-1), (1,-1), (1,1), and (-1,1). They are numbered as # 0 -1 -2 -3 # i.e. the numbers decrease anticlockwise from the # `bottom left corner'. x(-3) = -one y(-3) = one x(-2) = one y(-2) = one x(-1) = one y(-1) = -one x(0) = -one y(0) = -one do i = 1,4 { j = i-4 k = j+1 if(k>0) k = -3 call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror>0) return } # Put in the first of the point set into the adjacency list. do i = 1,4 { j = i-4 call insrt(1,j,nadj,madj,x,y,ntot,nerror,eps) if(nerror>0) return } # Now add the rest of the point set do j = 2,npd { call addpt(j,nadj,madj,x,y,ntot,eps,nerror) if(nerror>0) return } # Obtain the description of the triangulation. call delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,ind,nerror) if(nerror>0) return call delout(delsum,nadj,madj,x,y,ntot,npd,ind,nerror) if(nerror>0) return call dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ind,nerror) if(nerror>0) return call dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,ind,eps,nerror) return end deldir/inst/ratfor/initad.r0000644000176000001440000000225211621163455015457 0ustar ripleyuserssubroutine initad(j,nadj,madj,x,y,ntot,eps,nerror) # Initial adding-in of a new point j. # Called by addpt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) integer tau(3) # Find the triangle containing vertex j. call trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,nerror) if(nerror > 0) return # If the new point is on the edge of a triangle, detach the two # vertices of that edge from each other. Also join j to the vertex # of the triangle on the reverse side of that edge from the `found' # triangle (defined by tau) -- given that there ***is*** such a triangle. if(nedge!=0) { ip = nedge i = ip-1 if(i==0) i = 3 # Arithmetic modulo 3. call pred(k,tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror > 0) return call succ(kk,tau(ip),tau(i),nadj,madj,ntot,nerror) if(nerror > 0) return call delet(tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror > 0) return if(k==kk) call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } # Join the new point to each of the three vertices. do i = 1,3 { call insrt(j,tau(i),nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } return end deldir/inst/ratfor/swap.r0000644000176000001440000000240511621163455015161 0ustar ripleyuserssubroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror) # The segment k1->k2 is a diagonal of a quadrilateral # with a vertex at j (the point being added to the # triangulation). If the LOP is not satisfied, swap # it for the other diagonal. # Called by addpt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical shdswp # If vertices k1 and k2 are not connected there is no diagonal to swap. # This could happen if vertices j, k1, and k2 were colinear, but shouldn't. call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror) if(nerror > 0) return if(!shdswp) return # Get the other vertex of the quadrilateral. call pred(k,k1,k2,nadj,madj,ntot,nerror) # If these aren't the same, then if(nerror > 0) return call succ(kk,k2,k1,nadj,madj,ntot,nerror) # there is no other vertex. if(nerror > 0) return if(kk!=k) { shdswp = .false. return } # Check whether the LOP is satisified; i.e. whether # vertex k is outside the circumcircle of vertices j, k1, and k2 call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror) if(nerror > 0) return # Do the actual swapping. if(shdswp) { call delet(k1,k2,nadj,madj,ntot,nerror) if(nerror > 0) return call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } return end deldir/inst/ratfor/circen.r0000644000176000001440000000270111621163455015451 0ustar ripleyuserssubroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin,nerror) # Find the circumcentre (x0,y0) of the triangle with # vertices (x(i),y(i)), (x(j),y(j)), (x(k),y(k)). # Called by qtest1, dirseg, dirout. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) logical collin nerror = -1 # Get the coordinates. xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) # Check for collinearity ijk = 0 call cross(xt,yt,ijk,cprd) if(abs(cprd) < eps) collin = .true. else collin = .false. # Form the vector u from i to j, and the vector v from i to k, # and normalize them. a = x(j) - x(i) b = y(j) - y(i) c = x(k) - x(i) d = y(k) - y(i) c1 = sqrt(a*a+b*b) c2 = sqrt(c*c+d*d) a = a/c1 b = b/c1 c = c/c2 d = d/c2 # If the points are collinear, make sure that they're in the right # order --- i between j and k. if(collin) { alpha = a*c+b*d # If they're not in the right order, bring things to # a shuddering halt. if(alpha>0) { nerror = 3 return } # Collinear, but in the right order; think of this as meaning # that the circumcircle in question has infinite radius. return } # Not collinear; go ahead, make my circumcentre. (First, form # the cross product of the ***unit*** vectors, instead of the # ``normalized'' cross product produced by ``cross''.) crss = a*d - b*c x0 = x(i) + 0.5*(c1*d - c2*b)/crss y0 = y(i) + 0.5*(c2*a - c1*c)/crss return end deldir/inst/ratfor/delet.r0000644000176000001440000000072111621163455015303 0ustar ripleyuserssubroutine delet(i,j,nadj,madj,ntot,nerror) # Delete i and j from each other's adjacency lists. # Called by initad, swap. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) logical adj # First check that they're IN each other's lists. call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror > 0) return # Then do the actual deletion if they are. if(adj) { call delet1(i,j,nadj,madj,ntot) call delet1(j,i,nadj,madj,ntot) } return end deldir/inst/ratfor/binsrt.r0000644000176000001440000000451111621163455015510 0ustar ripleyuserssubroutine binsrt(x,y,ntot,rw,npd,ind,tx,ty,ilst,nerror) # Sort the data points into bins. # Called by master. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), tx(npd), ty(npd) dimension ind(npd), ilst(npd) dimension rw(4) nerror = -1 kdiv = 1+dble(npd)**0.25 # Round high. xkdiv = dble(kdiv) # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) w = xmax-xmin h = ymax-ymin # Number of bins is to be approx. sqrt(npd); thus number of subdivisions # on each side of rectangle is approx. npd**(1/4). dw = w/xkdiv dh = h/xkdiv # The width of each bin is dw; the height is dh. We shall move across # the rectangle from left to right, then up, then back from right to # left, then up, .... Note that kx counts the divisions from the left, # ky counts the divisions from the bottom; kx is incremented by ink, which # is +/- 1 and switches sign when ky is incremented; ky is always # incremented by 1. kx = 1 ky = 1 ink = 1 k = 0 do i = 1,npd { ilst(i) = 0 } # Keeps a list of those points already added while(ky<=kdiv) { # to the new list. do i = 1,npd { if(ilst(i)==1) next # The i-th point has already been added # to the new list. # If the i-th point is in the current bin, add it to the list. xt = x(i) yt = y(i) ix = 1+(xt-xmin)/dw if(ix>kdiv) ix = kdiv jy = 1+(yt-ymin)/dh if(jy>kdiv) jy = kdiv if(ix==kx&jy==ky) { k = k+1 ind(i) = k # Index i is the pos'n. of (x,y) in the tx(k) = xt # old list; k is its pos'n. in the new one. ty(k) = yt ilst(i) = 1 # Cross the i-th point off the old list. } } # Move to the next bin. kc = kx+ink if((1<=kc)&(kc<=kdiv)) kx = kc else { ky = ky+1 ink = -ink } } # Check that all points from old list have been added to the new, # with no spurious additions. if(k!=npd) { nerror = 2 return } # Copy the new sorted vector back on top of the old ones. do i = 1,npd { x(i) = tx(i) y(i) = ty(i) } return end deldir/inst/ratfor/dirseg.r0000644000176000001440000000746412367273000015472 0ustar ripleyuserssubroutine dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ind,nerror) # Output the endpoints of the segments of boundaries of Dirichlet # tiles. (Do it economically; each such segment once and only once.) # Called by master. implicit double precision(a-h,o-z) logical collin, adjace, intfnd, bptab, bptcd, goferit, rwu dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsgs(8,ndir), rw(4), ind(npd) nerror = -1 # Add in some dummy corner points, outside the actual window. # Far enough out so that no resulting tile boundaries intersect the # window. # Note that these dummy corners are needed by the routine `dirout' # but will screw things up for `delseg' and `delout'. Therefore # this routine (`dirseg') must be called ***before*** dirout, and # ***after*** delseg and delout. # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) a = xmax-xmin b = ymax-ymin c = sqrt(a*a+b*b) npd = ntot-4 nstt = npd+1 i = nstt x(i) = xmin-c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymax+c i = i+1 x(i) = xmin-c y(i) = ymax+c do j = nstt,ntot { call addpt(j,nadj,madj,x,y,ntot,eps,nerror) if(nerror > 0) return } # Put the segments into the array dirsgs. # For each distinct pair of (genuine) data points, find out if they are # adjacent. If so, find the circumcentres of the triangles lying on each # side of the segment joining them. kseg = 0 do i1 = 2,npd { i = ind(i1) do j1 = 1,i1-1 { j = ind(j1) call adjchk(i,j,adjace,nadj,madj,ntot,nerror) if(nerror > 0) return if(adjace) { call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror > 0) return if(collin) { nerror = 12 return } call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror > 0) return if(collin) { nerror = 12 return } # If a circumcentre is outside the rectangular window # of interest, draw a line joining it to the other # circumcentre. Find the intersection of this line with # the boundary of the window; for (a,b) and call the point # of intersection (ai,bi). For (c,d), call it (ci,di). # Note: rwu = "right way up". xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi!=yj) { slope = (xi - xj)/(yj - yi) rwu = .true. } else { slope = 0.d0 rwu = .false. } call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab) if(!intfnd) { nerror = 16 return } call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd) if(!intfnd) { nerror = 16 return } goferit = .false. if(bptab & bptcd) { xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xmin ndir) { nerror = 15 return } dirsgs(1,kseg) = ai dirsgs(2,kseg) = bi dirsgs(3,kseg) = ci dirsgs(4,kseg) = di dirsgs(5,kseg) = i1 dirsgs(6,kseg) = j1 if(bptab) dirsgs(7,kseg) = 1.d0 else dirsgs(7,kseg) = 0.d0 if(bptcd) dirsgs(8,kseg) = 1.d0 else dirsgs(8,kseg) = 0.d0 } } } } ndir = kseg return end deldir/inst/ratfor/qtest.r0000644000176000001440000000721211621163455015350 0ustar ripleyuserssubroutine qtest(h,i,j,k,shdswp,x,y,ntot,eps,nerror) # Test whether the LOP is satisified; i.e. whether vertex j # is outside the circumcircle of vertices h, i, and k of the # quadrilateral. Vertex h is the vertex being added; i and k are # the vertices of the quadrilateral which are currently joined; # j is the vertex which is ``opposite'' the vertex being added. # If the LOP is not satisfied, then shdswp ("should-swap") is true, # i.e. h and j should be joined, rather than i and k. I.e. if j # is outside the circumcircle of h, i, and k then all is well as-is; # *don't* swap ik for hj. If j is inside the circumcircle of h, # i, and k then change is needed so swap ik for hj. # Called by swap. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) integer h logical shdswp nerror = -1 # Look for ideal points. if(i<=0) ii = 1 else ii = 0 if(j<=0) jj = 1 else jj = 0 if(k<=0) kk = 1 else kk = 0 ijk = ii*4+jj*2+kk # All three corners other than h (the point currently being # added) are ideal --- so h, i, and k are co-linear; so # i and k shouldn't be joined, and h should be joined to j. # So swap. (But this can't happen, anyway!!!) # case 7: if(ijk==7) { shdswp = .true. return } # If i and j are ideal, find out which of h and k is closer to the # intersection point of the two diagonals, and choose the diagonal # emanating from that vertex. (I.e. if h is closer, swap.) # Unless swapping yields a non-convex quadrilateral!!! # case 6: if(ijk==6) { xh = x(h) yh = y(h) xk = x(k) yk = y(k) ss = 1 - 2*mod(-j,2) test = (xh*yk+xk*yh-xh*yh-xk*yk)*ss if(test>0.d0) shdswp = .true. else shdswp = .false. # Check for convexity: if(shdswp) call acchk(j,k,h,shdswp,x,y,ntot,eps) return } # Vertices i and k are ideal --- can't happen, but if it did, we'd # increase the minimum angle ``from 0 to more than 2*0'' by swapping ... # # 24/7/2011 --- I now think that the forgoing comment is misleading, # although it doesn't matter since it can't happen anyway. The # ``2*0'' is wrong. The ``new minimum angle would be min{alpha,beta} # where alpha and beta are the angles made by the line joining h # to j with (any) line with slope = -1. This will be greater than # 0 unless the line from h to j has slope = - 1. In this case h, # i, j, and k are all co-linear, so i and k should not be joined # (and h and j should be) so swapping is called for. If h, i, # j and j are not co-linear then the quadrilateral is definitely # convex whence swapping is OK. So let's say swap. # case 5: if(ijk==5) { shdswp = .true. return } # If i is ideal we'd increase the minimum angle ``from 0 to more than # 2*0'' by swapping, so just check for convexity: # case 4: if(ijk==4) { call acchk(j,k,h,shdswp,x,y,ntot,eps) return } # If j and k are ideal, this is like unto case 6. # case 3: if(ijk==3) { xi = x(i) yi = y(i) xh = x(h) yh = y(h) ss = 1 - 2*mod(-j,2) test = (xh*yi+xi*yh-xh*yh-xi*yi)*ss if(test>0.d0) shdswp = .true. else shdswp = .false. # Check for convexity: if(shdswp) call acchk(h,i,j,shdswp,x,y,ntot,eps) return } # If j is ideal we'd decrease the minimum angle ``from more than 2*0 # to 0'', by swapping; so don't swap. # case 2: if(ijk==2) { shdswp = .false. return } # If k is ideal, this is like unto case 4. # case 1: if(ijk==1) { call acchk(h,i,j,shdswp,x,y,ntot,eps) # This checks # for convexity. # (Was i,j,h,...) return } # If none of the `other' three corners are ideal, do the Lee-Schacter # test for the LOP. # case 0: if(ijk==0) { call qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) return } # default: # This CAN'T happen. nerror = 7 return end deldir/inst/ratfor/delout.r0000644000176000001440000000311511621163455015502 0ustar ripleyuserssubroutine delout(delsum,nadj,madj,x,y,ntot,npd,ind,nerror) # Put a summary of the Delaunay triangles with a vertex at point i, # for i = 1, ..., npd, into the array delsum. Do this in the original # order of the points, not the order into which they have been # bin-sorted. # Called by master. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension delsum(npd,4), ind(npd) do i1 = 1,npd { area = 0. # Initialize area of polygon consisting of triangles # with a vertex at point i. # Get the point number, its coordinates and the number of # (real) triangles emanating from it. i = ind(i1) np = nadj(i,0) xi = x(i) yi = y(i) npt = np do k = 1,np { kp = k+1 if(kp>np) kp = 1 if(nadj(i,k)<=0|nadj(i,kp)<=0) npt = npt-1 } # For each point in the adjacency list of point i, find its # successor, and the area of the triangle determined by these # three points. do j1 = 1,np { j = nadj(i,j1) if(j<=0) next xj = x(j) yj = y(j) call succ(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return if(k<=0) next xk = x(k) yk = y(k) call triar(xi,yi,xj,yj,xk,yk,tmp) # Downweight the area by 1/3, since each # triangle eventually appears 3 times over. area = area+tmp/3. } delsum(i1,1) = xi delsum(i1,2) = yi delsum(i1,3) = npt delsum(i1,4) = area } return end deldir/inst/ratfor/trifnd.r0000644000176000001440000000612411621163455015477 0ustar ripleyuserssubroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,nerror) # Find the triangle of the extant triangulation in which # lies the point currently being added. # Called by initad. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot), xt(3), yt(3) integer tau(3), temp(21) logical adjace nerror = -1 # The first point must be added to the triangulation before # calling trifnd. if(j==1) { nerror = 11 return } # Get the previous triangle: j1 = j-1 tau(1) = j1 tau(3) = nadj(j1,1) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot,nerror) if(nerror>0) return if(!adjace) { tau(3) = tau(2) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return } # Move to the adjacent triangle in the direction of the new # point, until the new point lies in this triangle. 1 continue ntau = 0 # This number will identify the triangle to be moved to. nedge = 0 # If the point lies on an edge, this number will identify that edge. do i = 1,3 { ip = i+1 if(ip==4) ip = 1 # Take addition modulo 3. # Get the coordinates of the vertices of the current side, # and of the point j which is being added: xt(1) = x(tau(i)) yt(1) = y(tau(i)) xt(2) = x(tau(ip)) yt(2) = y(tau(ip)) xt(3) = x(j) yt(3) = y(j) # Create indicator telling which of tau(i), tau(ip), and j # are ideal points. (The point being added, j, is ***never*** ideal.) if(tau(i)<=0) i1 = 1 else i1 = 0 if(tau(ip)<=0) j1 = 1 else j1 = 0 k1 = 0 ijk = i1*4+j1*2+k1 # Calculate the ``normalized'' cross product; if this is positive # then the point being added is to the left (as we move along the # edge in an anti-clockwise direction). If the test value is positive # for all three edges, then the point is inside the triangle. Note # that if the test value is very close to zero, we might get negative # values for it on both sides of an edge, and hence go into an # infinite loop. call cross(xt,yt,ijk,cprd) if(cprd >= eps) continue else if(cprd > -eps) nedge = ip else { ntau = ip break } } # We've played ring-around-the-triangle; now figure out the # next move: # case 0: All tests >= 0.; the point is inside; return. if(ntau==0) return # The point is not inside; work out the vertices of the triangle to which # to move. Notation: Number the vertices of the current triangle from 1 to 3, # anti-clockwise. Then "triangle i+1" is adjacent to the side from vertex i to # vertex i+1, where i+1 is taken modulo 3 (i.e. "3+1 = 1"). # case 1: Move to "triangle 1" if(ntau==1) { #tau(1) = tau(1) tau(2) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror > 0) return } # case 2: Move to "triangle 2" if(ntau==2) { #tau(1) = tau(1) tau(3) = tau(2) call pred(tau(2),tau(1),tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return } # case 3: Move to "triangle 3" if(ntau==3) { tau(1) = tau(3) #tau(2) = tau(2) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror > 0) return } # We've moved to a new triangle; check if the point being added lies # inside this one. go to 1 end deldir/inst/ratfor/addpt.r0000644000176000001440000000203111621163455015276 0ustar ripleyuserssubroutine addpt(j,nadj,madj,x,y,ntot,eps,nerror) # Add point j to the triangulation. # Called by master, dirseg. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical didswp # Put the new point in, joined to the vertices of its # enclosing triangle. call initad(j,nadj,madj,x,y,ntot,eps,nerror) if(nerror > 0) return # Look at each `gap', i.e. pair of adjacent segments # emanating from the new point; they form two sides of a # quadrilateral; see whether the extant diagonal of this # quadrilateral should be swapped with its alternative # (according to the LOP: local optimality principle). now = nadj(j,1) nxt = nadj(j,2) ngap = 0 repeat { call swap(j,now,nxt,didswp,nadj,madj,x,y,ntot,eps,nerror) if(nerror > 0) return n = nadj(j,0) if(!didswp) { # If no swap of diagonals now = nxt # move to the next gap. ngap = ngap+1 } call succ(nxt,j,now,nadj,madj,ntot,nerror) if(nerror > 0) return } until(ngap==n) return end deldir/inst/ratfor/pred.r0000644000176000001440000000157711621163455015152 0ustar ripleyuserssubroutine pred(kpr,i,j,nadj,madj,ntot,nerror) # Find the predecessor of j in the adjacency list of i. # Called by initad, trifnd, swap, dirseg, dirout. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) # If the adjacency list of i is empty, then clearly j has no predecessor # in this adjacency list. Something's wrong; stop. if(n==0) { nerror = 5 return } # The adjacency list of i is non-empty; search through it until j is found; # subtract 1 from the location of j, and find the contents of this new location do k = 1,n { if(j==nadj(i,k)) { km = k-1 if(km<1) km = n # Take km modulo n. (The adjacency list kpr = nadj(i,km) # is circular.) return } } # The adjacency list for i doesn't contain j. Something's wrong; stop. nerror = 6 return end deldir/inst/ratfor/testeq.r0000644000176000001440000000145311621163455015516 0ustar ripleyuserssubroutine testeq(a,b,eps,value) # Test for the equality of a and b in a fairly # robust way. # Called by trifnd, circen, stoke. implicit double precision(a-h,o-z) logical value # Define constants. one = 1.d0 ten = 1.d10 # If b is essentially 0, check whether a is essentially zero also. # The following is very sloppy! Must fix it! if(abs(b)<=eps) { if(abs(a)<=eps) value = .true. else value = .false. return } # Test if a is a `lot different' from b. (If it is # they're obviously not equal.) This avoids under/overflow # problems in dividing a by b. if(abs(a)>ten*abs(b)|abs(a)0) { do k = 1,ni { if(j==nadj(i,k)) { adj = .true. break } } } # Check if i is in the adjacency list of j. nj = nadj(j,0) if(nj>0) { do k = 1,nj { if(i==nadj(j,k)) { if(adj) return # Have j in i's list and i in j's. else { nerror = 1 return } } } } # If we get to here i is not in j's list. if(adj) { # If adj is true, then j IS in i's list. nerror = 1 return } return end deldir/inst/ratfor/makefor0000744000176000001440000000016411621163455015374 0ustar ripleyusers#! /bin/csh foreach file (*.r) set stem = `basename $file .r` ratfor $file > $stem.f /bin/mv $stem.f ../../src end deldir/inst/ratfor/mnnd.r0000644000176000001440000000056711621163455015152 0ustar ripleyuserssubroutine mnnd(x,y,n,dminbig,dminav) # # Mean nearest neighbour distance. Called by .Fortran() # from mnnd.R. # implicit double precision(a-h,o-z) dimension x(n), y(n) dminav = 0.d0 do i = 1,n { dmin = dminbig do j = 1,n { if(i!=j) { d = (x(i)-x(j))**2 + (y(i)-y(j))**2 if(d < dmin) dmin = d } } dminav = dminav + sqrt(dmin) } dminav = dminav/n return end deldir/inst/ratfor/succ.r0000644000176000001440000000157311621163455015151 0ustar ripleyuserssubroutine succ(ksc,i,j,nadj,madj,ntot,nerror) # Find the successor of j in the adjacency list of i. # Called by addpt, initad, trifnd, swap, delout, dirseg, dirout. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) # If the adjacency list of i is empty, then clearly j has no successor # in this adjacency list. Something's wrong; stop. if(n==0) { nerror = 9 return } # The adjacency list of i is non-empty; search through it until j is found; # add 1 to the location of j, and find the contents of this new location. do k = 1,n { if(j==nadj(i,k)) { kp = k+1 if(kp>n) kp = 1 # Take kp modulo n. (The adjacency list ksc = nadj(i,kp) # is circular.) return } } # The adjacency list doesn't contain j. Something's wrong. nerror = 10 return end deldir/inst/ratfor/triar.r0000644000176000001440000000040011621163455015321 0ustar ripleyuserssubroutine triar(x0,y0,x1,y1,x2,y2,area) # Calculate the area of a triangle with given # vertices, in anti clockwise direction. # Called by delout. implicit double precision(a-h,o-z) half = 0.5d0 area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)) return end deldir/inst/ratfor/delet1.r0000644000176000001440000000101311621163455015357 0ustar ripleyuserssubroutine delet1(i,j,nadj,madj,ntot) # Delete j from the adjacency list of i. # Called by delet. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) n = nadj(i,0) do k = 1,n { if(nadj(i,k)==j) { # Find j in the list; # then move everything back one notch. do kk = k,n-1 { nadj(i,kk) = nadj(i,kk+1) } nadj(i,n) = -99 # Changed from the confusing 0 value 25/7/2011. nadj(i,0) = n-1 return } } end deldir/inst/ratfor/locn.r0000644000176000001440000000264111621163455015144 0ustar ripleyuserssubroutine locn(i,j,kj,nadj,madj,x,y,ntot,eps) # Find the appropriate location for j in the adjacency list # of i. This is the index which j ***will*** have when # it is inserted into the adjacency list of i in the # appropriate place. Called by insrt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical before n = nadj(i,0) # If there is nothing already adjacent to i, then j will have place 1. if(n==0) { kj = 1 return } # Run through i's list, checking if j should come before each element # of that list. (I.e. if i, j, and k are in anti-clockwise order.) # If j comes before the kj-th item, but not before the (kj-1)-st, then # j should have place kj. do ks = 1,n { kj = ks k = nadj(i,kj) call acchk(i,j,k,before,x,y,ntot,eps) if(before) { km = kj-1 if(km==0) km = n k = nadj(i,km) call acchk(i,j,k,before,x,y,ntot,eps) if(before) next # If j is before 1 and after n, then it should # have place n+1. if(kj==1) kj = n+1 return } } # We've gone right through the list and haven't been before # the kj-th item ***and*** after the (kj-1)-st on any occasion. # Therefore j is before everything (==> place 1) or after # everything (==> place n+1). if(before) kj = 1 else kj = n+1 return end deldir/inst/ratfor/cross.r0000644000176000001440000000355411621163455015346 0ustar ripleyuserssubroutine cross(x,y,ijk,cprd) implicit double precision(a-h,o-z) dimension x(3), y(3) # Calculates a ``normalized'' cross product of the vectors joining # [x(1),y(1)] to [x(2),y(2)] and [x(3),y(3)] respectively. # The normalization consists in dividing by the square of the # shortest of the three sides of the triangle. This normalization is # for the purposes of testing for collinearity; if the result is less # than epsilon, the smallest of the sines of the angles is less than # epsilon. # Set constants zero = 0.d0 one = 1.d0 two = 2.d0 four = 4.d0 # Adjust the coordinates depending upon which points are ideal, # and calculate the squared length of the shortest side. # case 0: No ideal points; no adjustment necessary. if(ijk==0) { smin = -one do i = 1,3 { ip = i+1 if(ip==4) ip = 1 a = x(ip) - x(i) b = y(ip) - y(i) s = a*a+b*b if(smin < zero | s < smin) smin = s } } # case 1: Only k ideal. if(ijk==1) { x(2) = x(2) - x(1) y(2) = y(2) - y(1) x(1) = zero y(1) = zero cn = sqrt(x(2)**2+y(2)**2) x(2) = x(2)/cn y(2) = y(2)/cn smin = one } # case 2: Only j ideal. if(ijk==2) { x(3) = x(3) - x(1) y(3) = y(3) - y(1) x(1) = zero y(1) = zero cn = sqrt(x(3)**2+y(3)**2) x(3) = x(3)/cn y(3) = y(3)/cn smin = one } # case 3: Both j and k ideal (i not). if(ijk==3) { x(1) = zero y(1) = zero smin = 2 } # case 4: Only i ideal. if(ijk==4) { x(3) = x(3) - x(2) y(3) = y(3) - y(2) x(2) = zero y(2) = zero cn = sqrt(x(3)**2+y(3)**2) x(3) = x(3)/cn y(3) = y(3)/cn smin = one } # case 5: Both i and k ideal (j not). if(ijk==5) { x(2) = zero y(2) = zero smin = two } # case 6: Both i and j ideal (k not). if(ijk==6) { x(3) = zero y(3) = zero smin = two } # case 7: All three points ideal; no adjustment necessary. if(ijk==7) { smin = four } a = x(2)-x(1) b = y(2)-y(1) c = x(3)-x(1) d = y(3)-y(1) cprd = (a*d - b*c)/smin return end deldir/inst/ratfor/stoke.r0000644000176000001440000000756611621163455015351 0ustar ripleyuserssubroutine stoke(x1,y1,x2,y2,rw,area,s1,eps,nerror) # Apply Stokes' theorem to find the area of a polygon; # we are looking at the boundary segment from (x1,y1) # to (x2,y2), travelling anti-clockwise. We find the # area between this segment and the horizontal base-line # y = ymin, and attach a sign s1. (Positive if the # segment is right-to-left, negative if left to right.) # The area of the polygon is found by summing the result # over all boundary segments. # Just in case you thought this wasn't complicated enough, # what we really want is the area of the intersection of # the polygon with the rectangular window that we're using. # Called by dirout. implicit double precision(a-h,o-z) dimension rw(4) logical value zero = 0.d0 nerror = -1 # If the segment is vertical, the area is zero. call testeq(x1,x2,eps,value) if(value) { area = 0. s1 = 0. return } # Find which is the right-hand end, and which is the left. if(x1=xmax) { area = 0. return } # We're now looking at a trapezoidal region which may or may # not protrude above or below the horizontal strip bounded by # y = ymax and y = ymin. ybot = min(yl,yr) ytop = max(yl,yr) # Case 1; ymax <= ybot: # The `roof' of the trapezoid is entirely above the # horizontal strip. if(ymax<=ybot) { area = (xr-xl)*(ymax-ymin) return } # Case 2; ymin <= ybot <= ymax <= ytop: # The `roof' of the trapezoid intersects the top of the # horizontal strip (y = ymax) but not the bottom (y = ymin). if(ymin<=ybot&ymax<=ytop) { call testeq(slope,zero,eps,value) if(value) { w1 = 0. w2 = xr-xl } else { xit = xl+(ymax-yl)/slope w1 = xit-xl w2 = xr-xit if(slope<0.) { tmp = w1 w1 = w2 w2 = tmp } } area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin) return } # Case 3; ybot <= ymin <= ymax <= ytop: # The `roof' intersects both the top (y = ymax) and # the bottom (y = ymin) of the horizontal strip. if(ybot<=ymin&ymax<=ytop) { xit = xl+(ymax-yl)/slope xib = xl+(ymin-yl)/slope if(slope>0.) { w1 = xit-xib w2 = xr-xit } else { w1 = xib-xit w2 = xit-xl } area = 0.5*w1*(ymax-ymin)+w2*(ymax-ymin) return } # Case 4; ymin <= ybot <= ytop <= ymax: # The `roof' is ***between*** the bottom (y = ymin) and # the top (y = ymax) of the horizontal strip. if(ymin<=ybot&ytop<=ymax) { area = 0.5*(xr-xl)*((ytop-ymin)+(ybot-ymin)) return } # Case 5; ybot <= ymin <= ytop <= ymax: # The `roof' intersects the bottom (y = ymin) but not # the top (y = ymax) of the horizontal strip. if(ybot<=ymin&ymin<=ytop) { call testeq(slope,zero,eps,value) if(value) { area = 0. return } xib = xl+(ymin-yl)/slope if(slope>0.) w = xr-xib else w = xib-xl area = 0.5*w*(ytop-ymin) return } # Case 6; ytop <= ymin: # The `roof' is entirely below the bottom (y = ymin), so # there is no area contribution at all. if(ytop<=ymin) { area = 0. return } # Default; all stuffed up: nerror = 8 return end deldir/inst/ratfor/dldins.r0000644000176000001440000000462612367262117015476 0ustar ripleyuserssubroutine dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bpt) # Get a point ***inside*** the rectangular window on the ray from # one circumcentre to the next one. I.e. if the `next one' is # inside, then that's it; else find the intersection of this ray with # the boundary of the rectangle. # Called by dirseg, dirout. implicit double precision(a-h,o-z) dimension rw(4) logical intfnd, bpt, rwu # Note that (a,b) is the circumcentre of a Delaunay triangle, # and that slope is the slope of the ray joining (a,b) to the # corresponding circumcentre on the opposite side of an edge of that # triangle. When `dldins' is called by `dirout' it is possible # for the ray not to intersect the window at all. (The Delaunay # edge between the two circumcentres might be connected to a `fake # outer corner', added to facilitate constructing a tiling that # completely covers the actual window.) The variable `intfnd' acts # as an indicator as to whether such an intersection has been found. # The variable `bpt' acts as an indicator as to whether the returned # point (ai,bi) is a true circumcentre, inside the window (bpt == .false.), # or is the intersection of a ray with the boundary of the window # (bpt = .true.). intfnd = .true. bpt = .true. # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) # Check if (a,b) is inside the rectangle. if(xmin<=a&a<=xmax&ymin<=b&b<=ymax) { ai = a bi = b bpt = .false. return } # Look for appropriate intersections with the four lines forming # the sides of the rectangular window. # If not "the right way up" then the line joining the two # circumcentres is vertical. if(!rwu) { if(b < ymin) { ai = a bi = ymin if(xmin<=ai&ai<=xmax) return } if(b > ymax) { ai = a bi = ymax if(xmin<=ai&ai<=xmax) return } intfnd = .false. return } # Line 1: x = xmin. if(axmax) { ai = xmax bi = b + slope*(ai-a) if(ymin<=bi&bi<=ymax) return } # Line 4: y = ymax. if(b>ymax) { bi = ymax ai = a + (bi-b)/slope if(xmin<=ai&ai<=xmax) return } intfnd = .false. return end deldir/inst/ratfor/insrt.r0000644000176000001440000000133111621163455015343 0ustar ripleyuserssubroutine insrt(i,j,nadj,madj,x,y,ntot,nerror,eps) # Insert i and j into each other's adjacency list. # Called by master, initad, swap. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical adj # Check whether i and j are in each other's adjacency lists. call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror > 0) return if(adj) return # If not, find where in each list they should respectively be. call locn(i,j,kj,nadj,madj,x,y,ntot,eps) call locn(j,i,ki,nadj,madj,x,y,ntot,eps) # Put them in each other's lists in the appropriate position. call insrt1(i,j,kj,nadj,madj,ntot,nerror) if(nerror >0) return call insrt1(j,i,ki,nadj,madj,ntot,nerror) if(nerror >0) return return end deldir/inst/ratfor/acchk.r0000644000176000001440000000150511621163455015260 0ustar ripleyuserssubroutine acchk(i,j,k,anticl,x,y,ntot,eps) # Check whether vertices i, j, k, are in anti-clockwise order. # Called by locn, qtest, qtest1. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) logical anticl # Create indicator telling which of i, j, and k are ideal points. if(i<=0) i1 = 1 else i1 = 0 if(j<=0) j1 = 1 else j1 = 0 if(k<=0) k1 = 1 else k1 = 0 ijk = i1*4+j1*2+k1 # Get the coordinates of vertices i, j, and k. (Pseudo-coordinates for # any ideal points.) xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) # Get the ``normalized'' cross product. call cross(xt,yt,ijk,cprd) # If cprd is positive then (ij-cross-ik) is directed ***upwards*** # and so i, j, k, are in anti-clockwise order; else not. if(cprd > eps) anticl = .true. else anticl = .false. return end deldir/inst/ex.out0000644000176000001440000000530311621163455013674 0ustar ripleyusers$delsgs x1 y1 x2 y2 ind1 ind2 [1,] 3 3 2.3 2.3 2 1 [2,] 7 2 2.3 2.3 3 1 [3,] 7 2 3.0 3.0 3 2 [4,] 1 5 2.3 2.3 4 1 [5,] 1 5 3.0 3.0 4 2 [6,] 3 8 3.0 3.0 5 2 [7,] 3 8 7.0 2.0 5 3 [8,] 3 8 1.0 5.0 5 4 [9,] 8 9 7.0 2.0 6 3 [10,] 8 9 3.0 8.0 6 5 [11,] 0 0 2.3 2.3 7 1 [12,] 0 0 7.0 2.0 7 3 [13,] 0 0 1.0 5.0 7 4 [14,] 10 0 7.0 2.0 8 3 [15,] 10 0 8.0 9.0 8 6 [16,] 10 0 0.0 0.0 8 7 [17,] 0 10 1.0 5.0 9 4 [18,] 0 10 3.0 8.0 9 5 [19,] 0 10 8.0 9.0 9 6 [20,] 0 10 0.0 0.0 9 7 [21,] 10 10 8.0 9.0 10 6 [22,] 10 10 10.0 0.0 10 8 [23,] 10 10 0.0 10.0 10 9 $dirsgs x1 y1 x2 y2 ind1 ind2 bp1 bp2 1 1.650000 3.650000 4.560000 0.740000 2 1 FALSE FALSE 2 4.560000 0.740000 4.512766 0.000000 3 1 FALSE TRUE 3 5.750000 5.500000 4.560000 0.740000 3 2 FALSE FALSE 4 0.000000 2.855556 1.650000 3.650000 4 1 TRUE FALSE 5 1.650000 3.650000 3.500000 5.500000 4 2 FALSE FALSE 6 3.500000 5.500000 5.750000 5.500000 5 2 FALSE FALSE 7 5.750000 5.500000 6.058824 5.705882 5 3 FALSE FALSE 8 0.500000 7.500000 3.500000 5.500000 5 4 FALSE FALSE 9 6.058824 5.705882 10.000000 5.142857 6 3 FALSE TRUE 10 5.200000 10.000000 6.058824 5.705882 6 5 TRUE FALSE 11 2.300000 0.000000 0.000000 2.300000 7 1 TRUE TRUE 12 10.000000 3.250000 7.833333 0.000000 8 3 TRUE TRUE 13 0.000000 7.400000 0.500000 7.500000 9 4 TRUE FALSE 14 0.500000 7.500000 2.166667 10.000000 9 5 FALSE TRUE 15 8.750000 10.000000 10.000000 7.500000 10 6 TRUE TRUE $summary x y n.tri del.area del.wts n.tside nbpt dir.area dir.wts [1,] 2.3 2.3 4 4.500000 0.045000 4 4 9.092057 0.090921 [2,] 3.0 3.0 4 6.050000 0.060500 4 0 10.738500 0.107385 [3,] 7.0 2.0 6 18.666667 0.186667 5 4 23.318162 0.233182 [4,] 1.0 5.0 5 7.500000 0.075000 4 2 9.394167 0.093942 [5,] 3.0 8.0 5 15.000000 0.150000 5 2 18.055637 0.180556 [6,] 8.0 9.0 5 16.666667 0.166667 3 4 18.314811 0.183148 [7,] 0.0 0.0 4 8.450000 0.084500 1 2 2.645000 0.026450 [8,] 10.0 0.0 3 10.500000 0.105000 1 2 3.520833 0.035208 [9,] 0.0 10.0 4 7.666667 0.076667 2 2 3.358333 0.033583 [10,] 10.0 10.0 2 5.000000 0.050000 1 2 1.562500 0.015625 $n.data [1] 6 $n.dum [1] 4 $del.area [1] 100 $dir.area [1] 100 $rw [1] 0 10 0 10 attr(,"class") [1] "deldir" deldir/src/0000755000176000001440000000000012477161037012344 5ustar ripleyusersdeldir/src/dldins.f0000644000176000001440000000261012477161037013767 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bpt) implicit double precision(a-h,o-z) dimension rw(4) logical intfnd, bpt, rwu intfnd = .true. bpt = .true. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) if(xmin.le.a.and.a.le.xmax.and.ymin.le.b.and.b.le.ymax)then ai = a bi = b bpt = .false. return endif if(.not.rwu)then if(b .lt. ymin)then ai = a bi = ymin if(xmin.le.ai.and.ai.le.xmax)then return endif endif if(b .gt. ymax)then ai = a bi = ymax if(xmin.le.ai.and.ai.le.xmax)then return endif endif intfnd = .false. return endif if(a.lt.xmin)then ai = xmin bi = b + slope*(ai-a) if(ymin.le.bi.and.bi.le.ymax)then return endif endif if(b.lt.ymin)then bi = ymin ai = a + (bi-b)/slope if(xmin.le.ai.and.ai.le.xmax)then return endif endif if(a.gt.xmax)then ai = xmax bi = b + slope*(ai-a) if(ymin.le.bi.and.bi.le.ymax)then return endif endif if(b.gt.ymax)then bi = ymax ai = a + (bi-b)/slope if(xmin.le.ai.and.ai.le.xmax)then return endif endif intfnd = .false. return end deldir/src/master.f0000644000176000001440000000373012477161037014011 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine master(x,y,sort,rw,npd,ntot,nadj,madj,ind,tx,ty,ilst,ep *s, delsgs,ndel,delsum,dirsgs,ndir,dirsum,nerror) implicit double precision(a-h,o-z) logical sort, adj dimension x(-3:ntot), y(-3:ntot) dimension nadj(-3:ntot,0:madj) dimension ind(npd), tx(npd), ty(npd), ilst(npd), rw(4) dimension delsgs(6,ndel), dirsgs(8,ndir) dimension delsum(npd,4), dirsum(npd,3) one = 1.d0 if(sort)then call binsrt(x,y,ntot,rw,npd,ind,tx,ty,ilst,nerror) if(nerror .gt. 0)then return endif else do23004 i = 1,npd ind(i) = i 23004 continue 23005 continue endif do23006 i = -3,ntot nadj(i,0) = 0 do23008 j = 1,madj nadj(i,j) = -99 23008 continue 23009 continue 23006 continue 23007 continue x(-3) = -one y(-3) = one x(-2) = one y(-2) = one x(-1) = one y(-1) = -one x(0) = -one y(0) = -one do23010 i = 1,4 j = i-4 k = j+1 if(k.gt.0)then k = -3 endif call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror.gt.0)then return endif 23010 continue 23011 continue do23016 i = 1,4 j = i-4 call insrt(1,j,nadj,madj,x,y,ntot,nerror,eps) if(nerror.gt.0)then return endif 23016 continue 23017 continue do23020 j = 2,npd call addpt(j,nadj,madj,x,y,ntot,eps,nerror) if(nerror.gt.0)then return endif 23020 continue 23021 continue call delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,ind,nerror) if(nerror.gt.0)then return endif call delout(delsum,nadj,madj,x,y,ntot,npd,ind,nerror) if(nerror.gt.0)then return endif call dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ind,nerror) if(nerror.gt.0)then return endif call dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,ind,eps,nerror) return end deldir/src/insrt.f0000644000176000001440000000126012477161037013651 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine insrt(i,j,nadj,madj,x,y,ntot,nerror,eps) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical adj call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(adj)then return endif call locn(i,j,kj,nadj,madj,x,y,ntot,eps) call locn(j,i,ki,nadj,madj,x,y,ntot,eps) call insrt1(i,j,kj,nadj,madj,ntot,nerror) if(nerror .gt.0)then return endif call insrt1(j,i,ki,nadj,madj,ntot,nerror) if(nerror .gt.0)then return endif return end deldir/src/mnnd.f0000644000176000001440000000100512477161037013443 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine mnnd(x,y,n,dminbig,dminav) implicit double precision(a-h,o-z) dimension x(n), y(n) dminav = 0.d0 do23000 i = 1,n dmin = dminbig do23002 j = 1,n if(i.ne.j)then d = (x(i)-x(j))**2 + (y(i)-y(j))**2 if(d .lt. dmin)then dmin = d endif endif 23002 continue 23003 continue dminav = dminav + sqrt(dmin) 23000 continue 23001 continue dminav = dminav/n return end deldir/src/swap.f0000644000176000001440000000201412477161037013462 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical shdswp call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(.not.shdswp)then return endif call pred(k,k1,k2,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call succ(kk,k2,k1,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(kk.ne.k)then shdswp = .false. return endif call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror) if(nerror .gt. 0)then return endif if(shdswp)then call delet(k1,k2,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror .gt. 0)then return endif endif return end deldir/src/qtest1.f0000644000176000001440000000122612477161037013735 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) integer h logical shdswp xh = x(h) yh = y(h) xj = x(j) yj = y(j) call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror) if(nerror.gt.0)then return endif if(shdswp)then return endif a = x0-xh b = y0-yh r2 = a*a+b*b a = x0-xj b = y0-yj ch = a*a + b*b if(ch.lt.r2)then shdswp = .true. else shdswp = .false. endif return end deldir/src/circen.f0000644000176000001440000000171012477161037013755 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin,nerror) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) logical collin nerror = -1 xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) ijk = 0 call cross(xt,yt,ijk,cprd) if(abs(cprd) .lt. eps)then collin = .true. else collin = .false. endif a = x(j) - x(i) b = y(j) - y(i) c = x(k) - x(i) d = y(k) - y(i) c1 = sqrt(a*a+b*b) c2 = sqrt(c*c+d*d) a = a/c1 b = b/c1 c = c/c2 d = d/c2 if(collin)then alpha = a*c+b*d if(alpha.gt.0)then nerror = 3 return endif return endif crss = a*d - b*c x0 = x(i) + 0.5*(c1*d - c2*b)/crss y0 = y(i) + 0.5*(c2*a - c1*c)/crss return end deldir/src/testeq.f0000644000176000001440000000107412477161037014022 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine testeq(a,b,eps,value) implicit double precision(a-h,o-z) logical value one = 1.d0 ten = 1.d10 if(abs(b).le.eps)then if(abs(a).le.eps)then value = .true. else value = .false. endif return endif if(abs(a).gt.ten*abs(b).or.abs(a).lt.one*abs(b))then value = .false. return endif c = a/b if(abs(c-1.d0).le.eps)then value = .true. else value = .false. endif return end deldir/src/qtest.f0000644000176000001440000000327012477161037013655 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine qtest(h,i,j,k,shdswp,x,y,ntot,eps,nerror) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) integer h logical shdswp nerror = -1 if(i.le.0)then ii = 1 else ii = 0 endif if(j.le.0)then jj = 1 else jj = 0 endif if(k.le.0)then kk = 1 else kk = 0 endif ijk = ii*4+jj*2+kk if(ijk.eq.7)then shdswp = .true. return endif if(ijk.eq.6)then xh = x(h) yh = y(h) xk = x(k) yk = y(k) ss = 1 - 2*mod(-j,2) test = (xh*yk+xk*yh-xh*yh-xk*yk)*ss if(test.gt.0.d0)then shdswp = .true. else shdswp = .false. endif if(shdswp)then call acchk(j,k,h,shdswp,x,y,ntot,eps) endif return endif if(ijk.eq.5)then shdswp = .true. return endif if(ijk.eq.4)then call acchk(j,k,h,shdswp,x,y,ntot,eps) return endif if(ijk.eq.3)then xi = x(i) yi = y(i) xh = x(h) yh = y(h) ss = 1 - 2*mod(-j,2) test = (xh*yi+xi*yh-xh*yh-xi*yi)*ss if(test.gt.0.d0)then shdswp = .true. else shdswp = .false. endif if(shdswp)then call acchk(h,i,j,shdswp,x,y,ntot,eps) endif return endif if(ijk.eq.2)then shdswp = .false. return endif if(ijk.eq.1)then call acchk(h,i,j,shdswp,x,y,ntot,eps) return endif if(ijk.eq.0)then call qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) return endif nerror = 7 return end deldir/src/initad.f0000644000176000001440000000212412477161037013762 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine initad(j,nadj,madj,x,y,ntot,eps,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) integer tau(3) call trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,nerror) if(nerror .gt. 0)then return endif if(nedge.ne.0)then ip = nedge i = ip-1 if(i.eq.0)then i = 3 endif call pred(k,tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call succ(kk,tau(ip),tau(i),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call delet(tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(k.eq.kk)then call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) endif if(nerror .gt. 0)then return endif endif do23016 i = 1,3 call insrt(j,tau(i),nadj,madj,x,y,ntot,nerror,eps) if(nerror .gt. 0)then return endif 23016 continue 23017 continue return end deldir/src/triar.f0000644000176000001440000000034612477161037013637 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine triar(x0,y0,x1,y1,x2,y2,area) implicit double precision(a-h,o-z) half = 0.5d0 area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)) return end deldir/src/delout.f0000644000176000001440000000215612477161037014013 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine delout(delsum,nadj,madj,x,y,ntot,npd,ind,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension delsum(npd,4), ind(npd) do23000 i1 = 1,npd area = 0. i = ind(i1) np = nadj(i,0) xi = x(i) yi = y(i) npt = np do23002 k = 1,np kp = k+1 if(kp.gt.np)then kp = 1 endif if(nadj(i,k).le.0.or.nadj(i,kp).le.0)then npt = npt-1 endif 23002 continue 23003 continue do23008 j1 = 1,np j = nadj(i,j1) if(j.le.0)then goto 23008 endif xj = x(j) yj = y(j) call succ(k,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(k.le.0)then goto 23008 endif xk = x(k) yk = y(k) call triar(xi,yi,xj,yj,xk,yk,tmp) area = area+tmp/3. 23008 continue 23009 continue delsum(i1,1) = xi delsum(i1,2) = yi delsum(i1,3) = npt delsum(i1,4) = area 23000 continue 23001 continue return end deldir/src/cross.f0000644000176000001440000000311712477161037013646 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine cross(x,y,ijk,cprd) implicit double precision(a-h,o-z) dimension x(3), y(3) zero = 0.d0 one = 1.d0 two = 2.d0 four = 4.d0 if(ijk.eq.0)then smin = -one do23002 i = 1,3 ip = i+1 if(ip.eq.4)then ip = 1 endif a = x(ip) - x(i) b = y(ip) - y(i) s = a*a+b*b if(smin .lt. zero .or. s .lt. smin)then smin = s endif 23002 continue 23003 continue endif if(ijk.eq.1)then x(2) = x(2) - x(1) y(2) = y(2) - y(1) x(1) = zero y(1) = zero cn = sqrt(x(2)**2+y(2)**2) x(2) = x(2)/cn y(2) = y(2)/cn smin = one endif if(ijk.eq.2)then x(3) = x(3) - x(1) y(3) = y(3) - y(1) x(1) = zero y(1) = zero cn = sqrt(x(3)**2+y(3)**2) x(3) = x(3)/cn y(3) = y(3)/cn smin = one endif if(ijk.eq.3)then x(1) = zero y(1) = zero smin = 2 endif if(ijk.eq.4)then x(3) = x(3) - x(2) y(3) = y(3) - y(2) x(2) = zero y(2) = zero cn = sqrt(x(3)**2+y(3)**2) x(3) = x(3)/cn y(3) = y(3)/cn smin = one endif if(ijk.eq.5)then x(2) = zero y(2) = zero smin = two endif if(ijk.eq.6)then x(3) = zero y(3) = zero smin = two endif if(ijk.eq.7)then smin = four endif a = x(2)-x(1) b = y(2)-y(1) c = x(3)-x(1) d = y(3)-y(1) cprd = (a*d - b*c)/smin return end deldir/src/insrt1.f0000644000176000001440000000106712477161037013737 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine insrt1(i,j,kj,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) if(n.eq.0)then nadj(i,0) = 1 nadj(i,1) = j return endif kk = n+1 if(kk.gt.madj)then nerror = 4 return endif 23004 if(kk.gt.kj)then nadj(i,kk) = nadj(i,kk-1) kk = kk-1 goto 23004 endif 23005 continue nadj(i,kj) = j nadj(i,0) = n+1 return end deldir/src/dirout.f0000644000176000001440000000405312477161037014023 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,ind,eps,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsum(npd,3), ind(npd), rw(4) logical collin, intfnd, bptab, bptcd, rwu xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) do23000 i1 = 1,npd area = 0. nbpt = 0 npt = 0 i = ind(i1) np = nadj(i,0) do23002 j1 = 1,np j = nadj(i,j1) call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror.gt.0)then return endif if(collin)then nerror = 13 return endif call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror.gt.0)then return endif if(collin)then nerror = 13 return endif call stoke(a,b,c,d,rw,tmp,sn,eps,nerror) if(nerror .gt. 0)then return endif area = area+sn*tmp xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi.ne.yj)then slope = (xi - xj)/(yj - yi) rwu = .true. else slope = 0.d0 rwu = .false. endif call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab) if(intfnd)then call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd) if(.not.intfnd)then nerror = 17 return endif if(bptab .and. bptcd)then xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xmin.lt.xm.and.xm.lt.xmax.and.ymin.lt.ym.and.ym.lt.ymax)then nbpt = nbpt+2 npt = npt+1 endif else npt = npt + 1 if(bptab .or. bptcd)then nbpt = nbpt+1 endif endif endif 23002 continue 23003 continue dirsum(i1,1) = npt dirsum(i1,2) = nbpt dirsum(i1,3) = area 23000 continue 23001 continue return end deldir/src/succ.f0000644000176000001440000000100112477161037013440 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine succ(ksc,i,j,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) if(n.eq.0)then nerror = 9 return endif do23002 k = 1,n if(j.eq.nadj(i,k))then kp = k+1 if(kp.gt.n)then kp = 1 endif ksc = nadj(i,kp) return endif 23002 continue 23003 continue nerror = 10 return end deldir/src/locn.f0000644000176000001440000000144412477161037013451 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine locn(i,j,kj,nadj,madj,x,y,ntot,eps) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical before n = nadj(i,0) if(n.eq.0)then kj = 1 return endif do23002 ks = 1,n kj = ks k = nadj(i,kj) call acchk(i,j,k,before,x,y,ntot,eps) if(before)then km = kj-1 if(km.eq.0)then km = n endif k = nadj(i,km) call acchk(i,j,k,before,x,y,ntot,eps) if(before)then goto 23002 endif if(kj.eq.1)then kj = n+1 endif return endif 23002 continue 23003 continue if(before)then kj = 1 else kj = n+1 endif return end deldir/src/pred.f0000644000176000001440000000100012477161037013434 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine pred(kpr,i,j,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) if(n.eq.0)then nerror = 5 return endif do23002 k = 1,n if(j.eq.nadj(i,k))then km = k-1 if(km.lt.1)then km = n endif kpr = nadj(i,km) return endif 23002 continue 23003 continue nerror = 6 return end deldir/src/intri.f0000644000176000001440000000155712477161037013650 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine intri(x,y,u,v,n,okay) implicit double precision(a-h,o-z) dimension x(3), y(3), u(n), v(n) logical okay, inside zero = 0.d0 s = 1.d0 a = x(2) - x(1) b = y(2) - y(1) c = x(3) - x(1) d = y(3) - y(1) cp = a*d - b*c if(cp .lt. 0)then s = -s endif do23002 i = 1,n inside = .true. do23004 j = 1,3 jp = j+1 if(jp.eq.4)then jp = 1 endif a = x(jp) - x(j) b = y(jp) - y(j) c = u(i) - x(j) d = v(i) - y(j) cp = s*(a*d - b*c) if(cp .le. zero)then inside = .false. goto 23005 endif 23004 continue 23005 continue if(inside)then okay = .false. return endif 23002 continue 23003 continue okay = .true. return end deldir/src/trifnd.f0000644000176000001440000000405712477161037014007 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot), xt(3), yt( *3) integer tau(3), temp(21) logical adjace nerror = -1 if(j.eq.1)then nerror = 11 return endif j1 = j-1 tau(1) = j1 tau(3) = nadj(j1,1) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot,nerror) if(nerror.gt.0)then return endif if(.not.adjace)then tau(3) = tau(2) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif 1 continue ntau = 0 nedge = 0 do23010 i = 1,3 ip = i+1 if(ip.eq.4)then ip = 1 endif xt(1) = x(tau(i)) yt(1) = y(tau(i)) xt(2) = x(tau(ip)) yt(2) = y(tau(ip)) xt(3) = x(j) yt(3) = y(j) if(tau(i).le.0)then i1 = 1 else i1 = 0 endif if(tau(ip).le.0)then j1 = 1 else j1 = 0 endif k1 = 0 ijk = i1*4+j1*2+k1 call cross(xt,yt,ijk,cprd) if(cprd .ge. eps)then continue else if(cprd .gt. -eps)then nedge = ip else ntau = ip goto 23011 endif endif 23010 continue 23011 continue if(ntau.eq.0)then return endif if(ntau.eq.1)then tau(2) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif if(ntau.eq.2)then tau(3) = tau(2) call pred(tau(2),tau(1),tau(3),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif if(ntau.eq.3)then tau(1) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif go to 1 end deldir/src/adjchk.f0000644000176000001440000000127312477161037013742 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine adjchk(i,j,adj,nadj,madj,ntot,nerror) dimension nadj(-3:ntot,0:madj) logical adj nerror = -1 adj = .false. ni = nadj(i,0) if(ni.gt.0)then do23002 k = 1,ni if(j.eq.nadj(i,k))then adj = .true. goto 23003 endif 23002 continue 23003 continue endif nj = nadj(j,0) if(nj.gt.0)then do23008 k = 1,nj if(i.eq.nadj(j,k))then if(adj)then return else nerror = 1 return endif endif 23008 continue 23009 continue endif if(adj)then nerror = 1 return endif return end deldir/src/delet.f0000644000176000001440000000065112477161037013612 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine delet(i,j,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) logical adj call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(adj)then call delet1(i,j,nadj,madj,ntot) call delet1(j,i,nadj,madj,ntot) endif return end deldir/src/binsrt.f0000644000176000001440000000263012477161037014015 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine binsrt(x,y,ntot,rw,npd,ind,tx,ty,ilst,nerror) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), tx(npd), ty(npd) dimension ind(npd), ilst(npd) dimension rw(4) nerror = -1 kdiv = 1+dble(npd)**0.25 xkdiv = dble(kdiv) xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) w = xmax-xmin h = ymax-ymin dw = w/xkdiv dh = h/xkdiv kx = 1 ky = 1 ink = 1 k = 0 do23000 i = 1,npd ilst(i) = 0 23000 continue 23001 continue 23002 if(ky.le.kdiv)then do23004 i = 1,npd if(ilst(i).eq.1)then goto 23004 endif xt = x(i) yt = y(i) ix = 1+(xt-xmin)/dw if(ix.gt.kdiv)then ix = kdiv endif jy = 1+(yt-ymin)/dh if(jy.gt.kdiv)then jy = kdiv endif if(ix.eq.kx.and.jy.eq.ky)then k = k+1 ind(i) = k tx(k) = xt ty(k) = yt ilst(i) = 1 endif 23004 continue 23005 continue kc = kx+ink if((1.le.kc).and.(kc.le.kdiv))then kx = kc else ky = ky+1 ink = -ink endif goto 23002 endif 23003 continue if(k.ne.npd)then nerror = 2 return endif do23018 i = 1,npd x(i) = tx(i) y(i) = ty(i) 23018 continue 23019 continue return end deldir/src/addpt.f0000644000176000001440000000143112477161037013606 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine addpt(j,nadj,madj,x,y,ntot,eps,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical didswp call initad(j,nadj,madj,x,y,ntot,eps,nerror) if(nerror .gt. 0)then return endif now = nadj(j,1) nxt = nadj(j,2) ngap = 0 23002 continue call swap(j,now,nxt,didswp,nadj,madj,x,y,ntot,eps,nerror) if(nerror .gt. 0)then return endif n = nadj(j,0) if(.not.didswp)then now = nxt ngap = ngap+1 endif call succ(nxt,j,now,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif 23003 if(.not.(ngap.eq.n))goto 23002 23004 continue return end deldir/src/delet1.f0000644000176000001440000000067012477161037013674 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine delet1(i,j,nadj,madj,ntot) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) n = nadj(i,0) do23000 k = 1,n if(nadj(i,k).eq.j)then do23004 kk = k,n-1 nadj(i,kk) = nadj(i,kk+1) 23004 continue 23005 continue nadj(i,n) = -99 nadj(i,0) = n-1 return endif 23000 continue 23001 continue end deldir/src/stoke.f0000644000176000001440000000426412477161037013646 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine stoke(x1,y1,x2,y2,rw,area,s1,eps,nerror) implicit double precision(a-h,o-z) dimension rw(4) logical value zero = 0.d0 nerror = -1 call testeq(x1,x2,eps,value) if(value)then area = 0. s1 = 0. return endif if(x1.lt.x2)then xl = x1 yl = y1 xr = x2 yr = y2 s1 = -1. else xl = x2 yl = y2 xr = x1 yr = y1 s1 = 1. endif xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) slope = (yl-yr)/(xl-xr) x = max(xl,xmin) y = yl+slope*(x-xl) xl = x yl = y x = min(xr,xmax) y = yr+slope*(x-xr) xr = x yr = y if(xr.le.xmin.or.xl.ge.xmax)then area = 0. return endif ybot = min(yl,yr) ytop = max(yl,yr) if(ymax.le.ybot)then area = (xr-xl)*(ymax-ymin) return endif if(ymin.le.ybot.and.ymax.le.ytop)then call testeq(slope,zero,eps,value) if(value)then w1 = 0. w2 = xr-xl else xit = xl+(ymax-yl)/slope w1 = xit-xl w2 = xr-xit if(slope.lt.0.)then tmp = w1 w1 = w2 w2 = tmp endif endif area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin) return endif if(ybot.le.ymin.and.ymax.le.ytop)then xit = xl+(ymax-yl)/slope xib = xl+(ymin-yl)/slope if(slope.gt.0.)then w1 = xit-xib w2 = xr-xit else w1 = xib-xit w2 = xit-xl endif area = 0.5*w1*(ymax-ymin)+w2*(ymax-ymin) return endif if(ymin.le.ybot.and.ytop.le.ymax)then area = 0.5*(xr-xl)*((ytop-ymin)+(ybot-ymin)) return endif if(ybot.le.ymin.and.ymin.le.ytop)then call testeq(slope,zero,eps,value) if(value)then area = 0. return endif xib = xl+(ymin-yl)/slope if(slope.gt.0.)then w = xr-xib else w = xib-xl endif area = 0.5*w*(ytop-ymin) return endif if(ytop.le.ymin)then area = 0. return endif nerror = 8 return end deldir/src/delseg.f0000644000176000001440000000162312477161037013760 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,ind,nerror) implicit double precision(a-h,o-z) logical value integer tdel dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension delsgs(6,ndel), ind(npd) npd = ntot-4 kseg = 0 do23000 i1 = 2,npd i = ind(i1) do23002 j1 = 1,i1-1 j = ind(j1) call adjchk(i,j,value,nadj,madj,ntot,nerror) if(nerror.gt.0)then return endif if(value)then kseg = kseg+1 if(kseg .gt. ndel)then nerror = 14 return endif delsgs(1,kseg) = x(i) delsgs(2,kseg) = y(i) delsgs(3,kseg) = x(j) delsgs(4,kseg) = y(j) delsgs(5,kseg) = i1 delsgs(6,kseg) = j1 endif 23002 continue 23003 continue 23000 continue 23001 continue ndel = kseg return end deldir/src/dirseg.f0000644000176000001440000000573512477161037014002 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ind,ne *rror) implicit double precision(a-h,o-z) logical collin, adjace, intfnd, bptab, bptcd, goferit, rwu dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsgs(8,ndir), rw(4), ind(npd) nerror = -1 xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) a = xmax-xmin b = ymax-ymin c = sqrt(a*a+b*b) npd = ntot-4 nstt = npd+1 i = nstt x(i) = xmin-c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymax+c i = i+1 x(i) = xmin-c y(i) = ymax+c do23000 j = nstt,ntot call addpt(j,nadj,madj,x,y,ntot,eps,nerror) if(nerror .gt. 0)then return endif 23000 continue 23001 continue kseg = 0 do23004 i1 = 2,npd i = ind(i1) do23006 j1 = 1,i1-1 j = ind(j1) call adjchk(i,j,adjace,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(adjace)then call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror .gt. 0)then return endif if(collin)then nerror = 12 return endif call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror .gt. 0)then return endif if(collin)then nerror = 12 return endif xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi.ne.yj)then slope = (xi - xj)/(yj - yi) rwu = .true. else slope = 0.d0 rwu = .false. endif call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab) if(.not.intfnd)then nerror = 16 return endif call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd) if(.not.intfnd)then nerror = 16 return endif goferit = .false. if(bptab .and. bptcd)then xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xmin.lt.xm.and.xm.lt.xmax.and.ymin.lt.ym.and.ym.lt.ymax)then goferit = .true. endif endif if((.not.bptab).or.(.not.bptcd))then goferit = .true. endif if(goferit)then kseg = kseg + 1 if(kseg .gt. ndir)then nerror = 15 return endif dirsgs(1,kseg) = ai dirsgs(2,kseg) = bi dirsgs(3,kseg) = ci dirsgs(4,kseg) = di dirsgs(5,kseg) = i1 dirsgs(6,kseg) = j1 if(bptab)then dirsgs(7,kseg) = 1.d0 else dirsgs(7,kseg) = 0.d0 endif if(bptcd)then dirsgs(8,kseg) = 1.d0 else dirsgs(8,kseg) = 0.d0 endif endif endif 23006 continue 23007 continue 23004 continue 23005 continue ndir = kseg return end deldir/src/acchk.f0000644000176000001440000000131212477161037013561 0ustar ripleyusersC Output from Public domain Ratfor, version 1.0 subroutine acchk(i,j,k,anticl,x,y,ntot,eps) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) logical anticl if(i.le.0)then i1 = 1 else i1 = 0 endif if(j.le.0)then j1 = 1 else j1 = 0 endif if(k.le.0)then k1 = 1 else k1 = 0 endif ijk = i1*4+j1*2+k1 xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) call cross(xt,yt,ijk,cprd) if(cprd .gt. eps)then anticl = .true. else anticl = .false. endif return end deldir/NAMESPACE0000644000176000001440000000021212477157035012772 0ustar ripleyusers # Export everything exportPattern("*") S3method(plot,deldir) S3method(plot,tile.list) S3method(plot,triang.list) S3method("[",tile.list) deldir/R/0000755000176000001440000000000012477161025011753 5ustar ripleyusersdeldir/R/dumpts.R0000644000176000001440000000264111744370250013413 0ustar ripleyusersdumpts <- function(x,y,dpl,rw) { # # Function dumpts to append a sequence of dummy points to the # data points. # ndm <- 0 xd <- NULL yd <- NULL xmin <- rw[1] xmax <- rw[2] ymin <- rw[3] ymax <- rw[4] # Points on radii of circles emanating from data points: if(!is.null(dpl$nrad)) { nrad <- dpl$nrad # Number of radii from each data point. nper <- dpl$nper # Number of dummy points per radius. fctr <- dpl$fctr # Length of each radius = fctr * mean # interpoint distance. lrad <- fctr*mnnd(x,y)/nper theta <- 2*pi*(1:nrad)/nrad cs <- cos(theta) sn <- sin(theta) xt <- c(lrad*(1:nper)%o%cs) yt <- c(lrad*(1:nper)%o%sn) xd <- c(outer(x,xt,'+')) yd <- c(outer(y,yt,'+')) } # Ad hoc points passed over as part of dpl: if(!is.null(dpl$x)) { xd <- c(xd,dpl$x) yd <- c(yd,dpl$y) } # Delete dummy points outside the rectangular window. ndm <- length(xd) if(ndm >0) { drop <- (1:ndm)[xdxmax|ydymax] if(length(drop)>0) { xd <- xd[-drop] yd <- yd[-drop] } } # Rectangular grid: ndx <- dpl$ndx okx <- !is.null(ndx) && ndx > 0 ndy <- dpl$ndy oky <- !is.null(ndy) && ndy > 0 if(okx & oky) { xt <- if(ndx>1) seq(xmin,xmax,length=ndx) else 0.5*(xmin+xmax) yt <- if(ndy>1) seq(ymin,ymax,length=ndy) else 0.5*(ymin+ymax) xy <- expand.grid(x=xt,y=yt) xd <- c(xd,xy$x) yd <- c(yd,xy$y) } ndm <- length(xd) list(x=c(x,xd),y=c(y,yd),ndm=ndm) } deldir/R/triMat.R0000644000176000001440000000151612477140516013343 0ustar ripleyuserstriMat <- function (object) { # # Function triMat to list the indices of the vertices of each # Delaunay triangle in the triangulation of a planar point set. # The indices are listed as the rows of an n x 3 matrix where n is # the number of Delaunay triangles in the triangulation. # stopifnot(inherits(object, "deldir")) a <- object$delsgs[, 5] b <- object$delsgs[, 6] tlist <- matrix(integer(0), 0, 3) for (i in seq(nrow(object$summary))) { jj <- c(b[a == i], a[b == i]) jj <- sort(unique(jj)) jj <- jj[jj > i] if (length(jj) > 0) for (j in jj) { kk <- c(b[a == j], a[b == j]) kk <- kk[(kk %in% jj) & (kk > j)] if (length(kk) > 0) for (k in kk) tlist <- rbind(tlist, c(i, j, k)) } } tlist } deldir/R/plot.triang.list.R0000644000176000001440000000062212477134627015321 0ustar ripleyusersplot.triang.list <- function(x,showrect=FALSE,add=FALSE,xlab="x",ylab="y", main="",asp=1,...) { stopifnot(inherits(x,"triang.list")) rw <- attr(x,"rw") if(!add) { plot(0,0,type="n",xlim=rw[1:2],ylim=rw[3:4], xlab=xlab,ylab=ylab,main=main,asp=asp) } for(tri in x) { polygon(as.list(tri),...) } if(showrect) do.call(rect,as.list(rw)[c(1,3,2,4)]) invisible() } deldir/R/getCol.R0000644000176000001440000000074512222425535013316 0ustar ripleyusersgetCol <- function (x,warn=FALSE) { if(!inherits(x,"tile.list")) stop("Argument \"x\" must be of class \"tile.list\".\n") ccc <- unlist(sapply(x,function(u){u[["z"]]})) if(is.null(ccc)) return(NA) ccc <- try(apply(col2rgb(ccc, TRUE), 2, function(x){do.call(rgb, as.list(x/255))}),silent=TRUE) if(inherits(ccc,"try-error")){ if(warn) warn(paste("Cannot interpret the z-components of", "argument \"x\" as colours.\n")) return(NA) } ccc } deldir/R/deldir.R0000644000176000001440000002126712477134231013350 0ustar ripleyusersdeldir <- local({ EnvSupp <- new.env() function(x,y,dpl=NULL,rw=NULL,eps=1e-9,sort=TRUE, plotit=FALSE,digits=6,z=NULL, zdum=NULL, suppressMsge=FALSE,...) { # Function deldir # # Copyright (C) 1996 by T. Rolf Turner # # Permission to use, copy, modify, and distribute this software and # its documentation for any purpose and without fee is hereby # granted, provided that the above copyright notice appear in all # copies and that both that copyright notice and this permission # notice appear in supporting documentation. # # ORIGINALLY PROGRAMMED BY: Rolf Turner in 1987/88, while with the # Division of Mathematics and Statistics, CSIRO, Sydney, Australia. # Re-programmed by Rolf Turner to adapt the implementation from a # stand-alone Fortran program to an S function, while visiting the # University of Western Australia, May 1995. Further revised # December 1996. # # Function to compute the Delaunay Triangulation (and hence the # Dirichlet Tesselation) of a planar point set according to the # second (iterative) algorithm of Lee and Schacter, International # Journal of Computer and Information Sciences, Vol. 9, No. 3, 1980, # pages 219 to 242. # The triangulation is made to be with respect to the whole plane by # `suspending' it from `ideal' points # (-R,-R), (R,-R) (R,R), and (-R,R), where R --> infinity. # It is also enclosed in a finite rectangle (whose boundaries truncate any # infinite Dirichlet tiles) with corners (xmin,ymin) etc. This rectangle # is referred to elsewhere as `the' rectangular window. if(exists("deldirMsgeDone",envir=EnvSupp)) suppressMsge <- TRUE if(!suppressMsge){ mess <- paste("\n PLEASE NOTE: The components \"delsgs\"", "and \"summary\" of the\n object returned by deldir()", "are now DATA FRAMES rather than\n matrices (as they", "were prior to release 0.0-18).\n See help(\"deldir\").\n", "\n PLEASE NOTE: The process that deldir() uses for", "determining\n duplicated points has changed from that", "used in version\n 0.0-9 of this package (and previously).", "See help(\"deldir\").\n\n") message(mess) assign("deldirMsgeDone","xxx",envir=EnvSupp) } # If the first argument is a data frame, extract the column # named "z", if there is one, to be the "z weights". Remove # this column from the first argument. Extract the column named # "x", if there is one, to be the "x" coordinates, otherwise take # the "x" coordinates to be the first column which is isn't named # "y". Extract the column named "y", if there is one, to be the # "y" coordinates, otherwise take the "y" coordinates to be the # first column which is isn't named "x". if(is.data.frame(x)) { if(ncol(x) < 2) stop(paste("If \"x\" is a data frame it must have\n", "at least two columns.\n")) j <- match("z",names(x)) if(!is.na(j)) { if(is.null(z)) z <- x[,j] x <- x[,-j] } j <- match(c("x","y"),names(x)) if(all(is.na(j))) j <- 1:2 if(is.na(j[2])) j[2] <- if(j[1]==1) 2 else 1 if(is.na(j[1])) j[1] <- if(j[2]==1) 2 else 1 y <- x[,j[2]] x <- x[,j[1]] # If the first argument is a list (but not a data frame) extract # components x and y (and possibly z). } else if(is.list(x)) { if(all(!is.na(match(c('x','y'),names(x))))) { y <- x$y z <- if(is.null(z)) x$z else z x <- x$x } else { stop("Argument \"x\" is a list but lacks x and/or y components.\n") return() } } haveZ <- !is.null(z) # Check that lengths match. n <- length(x) if(n!=length(y)) stop("Lengths \"x\" and \"y\" do not match.\n") if(haveZ) { if(n!=length(z)) stop("Length of \"z\" does not match lengths of \"x\" and \"y\".\n") } # If a data window is specified, get its corner coordinates # and truncate the data by this window. if(!is.null(rw)) { xmin <- rw[1] xmax <- rw[2] ymin <- rw[3] ymax <- rw[4] drop <- (1:n)[xxmax|yymax] if(length(drop)>0) { x <- x[-drop] y <- y[-drop] if(haveZ) z <- z[-drop] n <- length(x) } } # If corners of the window are not specified, form them from # the minimum and maximum of the data +/- 10%: else { xmin <- min(x) xmax <- max(x) ymin <- min(y) ymax <- max(y) xdff <- xmax-xmin ydff <- ymax-ymin xmin <- xmin-0.1*xdff xmax <- xmax+0.1*xdff ymin <- ymin-0.1*ydff ymax <- ymax+0.1*ydff rw <- c(xmin,xmax,ymin,ymax) } # Add the dummy points: if(!is.null(dpl)) { dpts <- dumpts(x,y,dpl,rw) x <- dpts$x y <- dpts$y ndm <- length(x) - n if(haveZ) { if(!is.null(zdum)) { if(length(zdum) != ndm) stop("The z dummy points are of the wrong length.\n") } else { zdum <- rep(NA,ndm) } z <- c(z,zdum) } } else ndm <- 0 # Eliminate duplicate points: iii <- duplicatedxy(x,y) if(any(iii)) { kkk <- !iii ndm <- sum(kkk[-(1:n)]) n <- sum(kkk[1:n]) if(haveZ) { jjj <- duplicated(data.frame(x=x,y=y,z=z)) if(sum(jjj) < sum(iii)) { whinge <- paste("There were different z \"weights\" corresponding to\n", "duplicated points.\n",sep="") warning(whinge) } z <- z[kkk] } x <- x[kkk] y <- y[kkk] ind.orig <- which(!iii) } else ind.orig <- seq_along(iii) # Make space for the total number of points (real and dummy) as # well as 4 ideal points and 4 extra corner points which get used # (only) by subroutines dirseg and dirout in the ``output'' process # (returning a description of the triangulation after it has been # calculated): npd <- n + ndm ntot <- npd + 4 # ntot includes the 4 ideal points but # but NOT the 4 extra corners x <- c(rep(0,4),x,rep(0,4)) y <- c(rep(0,4),y,rep(0,4)) # Set up fixed dimensioning constants: ntdel <- 4*npd ntdir <- 3*npd # Set up dimensioning constants which might need to be increased: madj <- max(20,ceiling(3*sqrt(ntot))) tadj <- (madj+1)*(ntot+4) ndel <- madj*(madj+1)/2 tdel <- 6*ndel ndir <- ndel tdir <- 8*ndir # Call the master subroutine to do the work: repeat { tmp <- .Fortran( 'master', x=as.double(x), y=as.double(y), sort=as.logical(sort), rw=as.double(rw), npd=as.integer(npd), ntot=as.integer(ntot), nadj=integer(tadj), madj=as.integer(madj), ind=integer(npd), tx=double(npd), ty=double(npd), ilist=integer(npd), eps=as.double(eps), delsgs=double(tdel), ndel=as.integer(ndel), delsum=double(ntdel), dirsgs=double(tdir), ndir=as.integer(ndir), dirsum=double(ntdir), nerror=integer(1), PACKAGE='deldir' ) # Check for errors: nerror <- tmp$nerror if(nerror < 0) break else { if(nerror==4) { cat('nerror =',nerror,'\n') cat('Increasing madj and trying again.\n') madj <- ceiling(1.2*madj) tadj <- (madj+1)*(ntot+4) ndel <- max(ndel,madj*(madj+1)/2) tdel <- 6*ndel ndir <- ndel tdir <- 8*ndir } else if(nerror==14|nerror==15) { cat('nerror =',nerror,'\n') cat('Increasing ndel and ndir and trying again.\n') ndel <- ceiling(1.2*ndel) tdel <- 6*ndel ndir <- ndel tdir <- 8*ndir } else { cat('nerror =',nerror,'\n') return(invisible()) } } } # Collect up the results for return: ndel <- tmp$ndel delsgs <- round(t(as.matrix(matrix(tmp$delsgs,nrow=6)[,1:ndel])),digits) delsgs <- as.data.frame(delsgs) names(delsgs) <- c('x1','y1','x2','y2','ind1','ind2') delsum <- matrix(tmp$delsum,ncol=4) del.area <- sum(delsum[,4]) delsum <- round(cbind(delsum,delsum[,4]/del.area),digits) del.area <- round(del.area,digits) ndir <- tmp$ndir dirsgs <- round(t(as.matrix(matrix(tmp$dirsgs,nrow=8)[,1:ndir])),digits) dirsgs <- as.data.frame(dirsgs) dirsum <- matrix(tmp$dirsum,ncol=3) dir.area <- sum(dirsum[,3]) dirsum <- round(cbind(dirsum,dirsum[,3]/dir.area),digits) dir.area <- round(dir.area,digits) names(dirsgs) <- c('x1','y1','x2','y2','ind1','ind2','bp1','bp2') mode(dirsgs$bp1) <- 'logical' mode(dirsgs$bp2) <- 'logical' allsum <- as.data.frame(cbind(delsum,dirsum)) names(allsum) <- c('x','y','n.tri','del.area','del.wts', 'n.tside','nbpt','dir.area','dir.wts') if(haveZ) allsum <- cbind(allsum[,1:2],z=z,allsum[,3:9]) rw <- round(rw,digits) # Aw' done!!! rslt <- list(delsgs=delsgs,dirsgs=dirsgs,summary=allsum,n.data=n, n.dum=ndm,del.area=del.area,dir.area=dir.area,rw=rw, ind.orig=ind.orig) class(rslt) <- 'deldir' if(plotit) { plot(rslt,...) return(invisible(rslt)) } else return(rslt) } } ) deldir/R/plot.deldir.R0000644000176000001440000000421411744140555014320 0ustar ripleyusersplot.deldir <- function(x,add=FALSE,wlines=c('both','triang','tess'), wpoints=c('both','real','dummy','none'), number=FALSE,cex=1,nex=1,col=NULL,lty=NULL, pch=NULL,xlim=NULL,ylim=NULL,xlab='x',ylab='y', showrect=FALSE,...) { # # Function plot.deldir to produce a plot of the Delaunay triangulation # and Dirichlet tesselation of a point set, as produced by the # function deldir(). # # Check that x is of the appropriate class. if(!inherits(x, "deldir")) stop("Argument \"x\" is not of class deldir.\n") wlines <- match.arg(wlines) wpoints <- match.arg(wpoints) col <- if(is.null(col)) c(1,1,1,1,1) else rep(col,length.out=5) lty <- if(is.null(lty)) 1:2 else rep(lty,length.out=2) pch <- if(is.null(pch)) 1:2 else rep(pch,length.out=2) plot.del <- switch(wlines,both=TRUE,triang=TRUE,tess=FALSE) plot.dir <- switch(wlines,both=TRUE,triang=FALSE,tess=TRUE) plot.rl <- switch(wpoints,both=TRUE,real=TRUE,dummy=FALSE,none=FALSE) plot.dum <- switch(wpoints,both=TRUE,real=FALSE,dummy=TRUE,none=FALSE) delsgs <- x$delsgs dirsgs <- x$dirsgs n <- x$n.data rw <- x$rw if(plot.del) { x1<-delsgs[,1] y1<-delsgs[,2] x2<-delsgs[,3] y2<-delsgs[,4] } if(plot.dir) { u1<-dirsgs[,1] v1<-dirsgs[,2] u2<-dirsgs[,3] v2<-dirsgs[,4] } X<-x$summary[,"x"] Y<-x$summary[,"y"] if(!add) { pty.save <- par()$pty on.exit(par(pty=pty.save)) par(pty='s') if(is.null(xlim)) xlim <- rw[1:2] if(is.null(ylim)) ylim <- rw[3:4] plot(0,0,type='n',xlim=xlim,ylim=ylim, xlab=xlab,ylab=ylab,axes=FALSE,...) axis(side=1) axis(side=2) } if(plot.del) segments(x1,y1,x2,y2,col=col[1],lty=lty[1],...) if(plot.dir) segments(u1,v1,u2,v2,col=col[2],lty=lty[2],...) if(plot.rl) { x.real <- X[1:n] y.real <- Y[1:n] points(x.real,y.real,pch=pch[1],col=col[3],cex=cex,...) } if(plot.dum) { x.dumm <- X[-(1:n)] y.dumm <- Y[-(1:n)] points(x.dumm,y.dumm,pch=pch[2],col=col[4],cex=cex,...) } if(number) { xoff <- 0.02*diff(range(X)) yoff <- 0.02*diff(range(Y)) text(X+xoff,Y+yoff,1:length(X),cex=nex,col=col[5],...) } if(showrect) do.call(rect,as.list(x$rw)[c(1,3,2,4)]) invisible() } deldir/R/tilePerim.R0000644000176000001440000000044012222404341014013 0ustar ripleyuserstilePerim <- function(object,inclbdry=TRUE) { if(!inherits(object,"tile.list")) stop("Argument \"object\" must be of class \"tile.list\".\n") perims <- sapply(object,tilePerim0,inclbdry=inclbdry) list(perimeters=perims,totalPerim=sum(perims),meanPerim=mean(perims)) } deldir/R/First.R0000644000176000001440000000033112133366475013167 0ustar ripleyusers.onLoad <- function(lib, pkg) { library.dynam("deldir", pkg, lib) } .onAttach <- function(lib, pkg) { ver <- read.dcf(file.path(lib, pkg, "DESCRIPTION"), "Version") packageStartupMessage(paste(pkg, ver)) } deldir/R/declareGlobals.R0000644000176000001440000000040212435203463014772 0ustar ripleyusers# Utility file to add ".Last.make.date" to the list of global # variables, so as to avoid the "no visible binding" problem in # make.fun() that shows up if .Last.make.date does not exist. if(getRversion() >= "2.15.1") utils::globalVariables("polyclip") deldir/R/triang.list.R0000644000176000001440000000321412477141265014340 0ustar ripleyuserstriang.list <- function (object) { stopifnot(inherits(object,"deldir")) io <- object$ind.orig tlist <- triMat(object) x <- object$summary[,"x"] y <- object$summary[,"y"] if("z" %in% colnames(object$summary)) { z <- object$summary[,"z"] haveZ <- TRUE } else haveZ <- FALSE xtri <- matrix(x[tlist], nrow(tlist), 3) ytri <- matrix(y[tlist], nrow(tlist), 3) if(haveZ) ztri <- matrix(z[tlist], nrow(tlist), 3) ctri <- ytri - min(y) dx <- cbind(xtri[, 2] - xtri[, 1], xtri[, 3] - xtri[, 2], xtri[, 1] - xtri[, 3]) zm <- cbind(ctri[, 1] + ctri[, 2], ctri[, 2] + ctri[, 3], ctri[, 3] + ctri[, 1]) negareas <- apply(dx * zm, 1, sum) clockwise <- (negareas > 0) if (any(clockwise)) { xc <- xtri[clockwise,,drop=FALSE] yc <- ytri[clockwise,,drop=FALSE] tc <- tlist[clockwise,,drop=FALSE] if(haveZ) zc <- ztri[clockwise,,drop=FALSE] xtri[clockwise, ] <- xc[, c(1, 3, 2)] ytri[clockwise, ] <- yc[, c(1, 3, 2)] tlist[clockwise,] <- tc[, c(1, 3, 2)] if(haveZ) ztri[clockwise, ] <- zc[, c(1, 3, 2)] } rslt <- list() K <- 0 for(i in 1:nrow(xtri)) { tmp <- .Fortran( "intri", x=as.double(xtri[i,]), y=as.double(ytri[i,]), u=as.double(x), v=as.double(y), n=as.integer(length(x)), okay=logical(1), PACKAGE="deldir" ) if(tmp$okay) { K <- K+1 rslt[[K]] <- data.frame(ptNum=io[tlist[i,]],x=xtri[i,],y=ytri[i,]) if(haveZ) { rslt[[K]] <- cbind(rslt[[K]],z=ztri[i,]) } } } attr(rslt,"rw") <- object$rw class(rslt) <- "triang.list" rslt } deldir/R/get.cnrind.R0000644000176000001440000000032711621163455014132 0ustar ripleyusersget.cnrind <- function(x,y,rw) { x.crnrs <- rw[c(1,2,2,1)] y.crnrs <- rw[c(3,3,4,4)] M1 <- outer(x,x.crnrs,function(a,b){(a-b)^2}) M2 <- outer(y,y.crnrs,function(a,b){(a-b)^2}) MM <- M1 + M2 apply(MM,2,which.min) } deldir/R/tile.list.R0000644000176000001440000000311312455572613014010 0ustar ripleyuserstile.list <- function (object) { if (!inherits(object, "deldir")) stop("Argument \"object\" is not of class \"deldir\".\n") rw <- object$rw x.crnrs <- rw[c(1, 2, 2, 1)] y.crnrs <- rw[c(3, 3, 4, 4)] ddd <- object$dirsgs sss <- object$summary npts <- nrow(sss) x <- sss[["x"]] y <- sss[["y"]] z <- sss[["z"]] haveZ <- !is.null(z) i.crnr <- get.cnrind(x, y, rw) rslt <- list() for (i in 1:npts) { m <- as.matrix(rbind(ddd[ddd$ind1 == i, 1:4], ddd[ddd$ind2 == i, 1:4])) bp1 <- c(ddd[ddd$ind1 == i, 7], ddd[ddd$ind2 == i, 7]) bp2 <- c(ddd[ddd$ind1 == i, 8], ddd[ddd$ind2 == i, 8]) m1 <- cbind(m[, 1:2, drop = FALSE], 0 + bp1) m2 <- cbind(m[, 3:4, drop = FALSE], 0 + bp2) m <- rbind(m1, m2) pt <- unlist(sss[i, c("x", "y")]) theta <- atan2(m[, 2] - pt[2], m[, 1] - pt[1]) theta <- ifelse(theta > 0, theta, theta + 2 * pi) theta.0 <- sort(unique(theta)) mm <- m[match(theta.0, theta), ] xx <- mm[, 1] yy <- mm[, 2] bp <- as.logical(mm[, 3]) ii <- i.crnr %in% i xx <- c(xx, x.crnrs[ii]) yy <- c(yy, y.crnrs[ii]) bp <- c(bp, rep(TRUE, sum(ii))) rslt[[i]] <- acw(list(ptNum = i, pt = pt, x = unname(xx), y = unname(yy), bp = bp)) if(haveZ) rslt[[i]]["z"] <- z[i] } class(rslt) <- "tile.list" attr(rslt, "rw") <- object$rw rslt } "[.tile.list" <- function(x,i,...){ y <- unclass(x)[i] class(y) <- "tile.list" attr(y,"rw") <- attr(x,"rw") y } deldir/R/plot.tile.list.R0000644000176000001440000000635412477161024014771 0ustar ripleyusersplot.tile.list <- function (x, verbose = FALSE, close = FALSE, pch = 1, fillcol = getCol(x,warn=warn), col.pts=NULL, border=NULL, showpoints = TRUE, add = FALSE, asp = 1, clipp=NULL, xlab = "x", ylab = "y", main = "", warn=FALSE, ...) { object <- x if (!inherits(object, "tile.list")) stop("Argument \"object\" is not of class tile.list.\n") clip <- !is.null(clipp) n <- length(object) rw <- attr(object, "rw") rx <- rw[1:2] ry <- rw[3:4] x.pts <- unlist(lapply(object, function(w) { w$pt[1] })) y.pts <- unlist(lapply(object, function(w) { w$pt[2] })) if (!add) plot(0, 0, type = "n", asp = asp, xlim = rx, ylim = ry, xlab = xlab, ylab = ylab, main = main) fillcol <- apply(col2rgb(fillcol, TRUE), 2, function(x) { do.call(rgb, as.list(x/255)) }) fillcol <- rep(fillcol, length = length(object)) hexbla <- do.call(rgb, as.list(col2rgb("black", TRUE)/255)) hexwhi <- do.call(rgb, as.list(col2rgb("white", TRUE)/255)) if(is.null(col.pts)){ col.pts <- ifelse(fillcol == hexbla, hexwhi, hexbla) } else { col.pts <- apply(col2rgb(col.pts, TRUE), 2, function(x) { do.call(rgb, as.list(x/255)) }) col.pts <- rep(col.pts, length = length(object)) } if(is.null(border)) border <- if(all(fillcol == hexbla)) hexwhi else hexbla else if(length(border) > 1) stop("Argument \"border\" must be a scalar or NULL.\n") lnwid <- if(all(fillcol == hexbla)) 2 else 1 pch <- rep(pch,n) okn <- logical(n) for(i in 1:n) { if(clip) { if(requireNamespace("polyclip",quietly=TRUE)) { pgon <- polyclip::polyclip(object[[i]],clipp) ok <- length(pgon) > 0 } else { stop("Cannot clip the tiles; package \"polyclip\" not available.\n") } } else { pgon <- list(object[[i]]) ok <- TRUE } okn[i] <- ok inner <- !any(object[[i]]$bp) for(ii in seq(along=pgon)){ ptmp <- pgon[[ii]] polygon(ptmp,col=fillcol[i],border=NA) if (close | inner) { polygon(ptmp,col = NA, border = border, lwd = lnwid) } else { x <- ptmp$x y <- ptmp$y ni <- length(x) for (j in 1:ni) { jnext <- if (j < ni) j + 1 else 1 do.it <- mid.in(x[c(j, jnext)], y[c(j, jnext)], rx, ry) if (do.it) segments(x[j], y[j], x[jnext], y[jnext], col = border, lwd = lnwid) } } } if(ok & verbose) { if(showpoints) points(object[[i]]$pt[1], object[[i]]$pt[2], pch = pch[i], col = col.pts[i]) if(i < n) readline(paste("i = ",i,"; Go? ",sep="")) if(i == n) cat("i = ",i,"\n",sep="") } } if (showpoints & !verbose) points(x.pts[okn], y.pts[okn], pch = pch[okn], col = col.pts[okn]) invisible() } deldir/R/duplicatedxy.R0000644000176000001440000000043612035631164014574 0ustar ripleyusersduplicatedxy <- function(x,y) { if(is.list(x)) { if(all(!is.na(match(c('x','y'),names(x))))) { return(duplicated(as.data.frame(x))) } stop("Argument \"x\" is a list but lacks x and/or y components.\n") } duplicated(data.frame(x=x,y=y)) } deldir/R/tilePerim0.R0000644000176000001440000000061112222443522014077 0ustar ripleyuserstilePerim0 <- function (object,inclbdry=TRUE) { x <- object[["x"]] y <- object[["y"]] xx <- c(x,x[1]) yy <- c(y,y[1]) if(inclbdry) { ok <- rep(TRUE,length(x)) } else { bp1 <- object[["bp"]] bp2 <- c(bp1,bp1[1]) bpm <- cbind(bp1,bp2[-1]) ok <- !apply(bpm,1,all) } sum(sqrt(((xx[-1] - x)[ok])^2 + ((yy[-1] - y)[ok])^2)) } deldir/R/mnnd.R0000644000176000001440000000062111621163455013030 0ustar ripleyusersmnnd <- function(x,y) { # # Function mnnd to calculate the mean nearest neighbour distance # between the points whose coordinates are stored in x and y. # n <- length(x) if(n!=length(y)) stop('data lengths do not match') dmb <- (max(x)-min(x))**2 + (max(y)-min(y))**2 .Fortran( "mnnd", x=as.double(x), y=as.double(y), n=as.integer(n), dmb=as.double(dmb), d=double(1), PACKAGE='deldir' )$d } deldir/R/acw.R0000644000176000001440000000044611621163455012653 0ustar ripleyusersacw <- function(xxx) { xbar <- mean(xxx$x) ybar <- mean(xxx$y) theta <- atan2(xxx$y - ybar,xxx$x-xbar) theta <- ifelse(theta > 0, theta, theta + 2 * pi) theta.0 <- sort(unique(theta)) iii <- match(theta.0, theta) xxx$x <- xxx$x[iii] xxx$y <- xxx$y[iii] xxx$bp <- xxx$bp[iii] xxx } deldir/R/mid.in.R0000644000176000001440000000020211621163455013245 0ustar ripleyusersmid.in <- function(x,y,rx,ry) { xm <- 0.5*(x[1]+x[2]) ym <- 0.5*(y[1]+y[2]) (rx[1] < xm & xm < rx[2] & ry[1] < ym & ym < ry[2]) } deldir/R/tile.centroids.R0000644000176000001440000000061111621163455015021 0ustar ripleyuserstile.centroids <- function(xxx){ foo <- function (x,y) { x <- c(x,x[1]) y <- c(y,y[1]) n <- length(x) u <- x[-n]*y[-1] v <- x[-1]*y[-n] w <- x[-n]+x[-1] z <- y[-n]+y[-1] A <- 3*(sum(u)-sum(v)) Cx <- sum(w*(u-v))/A Cy <- sum(z*(u-v))/A c(Cx,Cy) } ccc <- lapply(xxx,function(x){foo(x$x,x$y)}) ccc <- as.data.frame(matrix(unlist(ccc),ncol=2,byrow=TRUE)) names(ccc) <- c("x","y") ccc } deldir/MD50000644000176000001440000001213412477242213012062 0ustar ripleyusersbacabed7f58be23af7c3a7625fd26751 *ChangeLog c96ab2e4ddcf0ab39b267cbd9aa22681 *DESCRIPTION 683737abff99cd3f5e8e289bc31eb9d4 *NAMESPACE 276c474998f3b1b2af301365f41b4171 *R/First.R 3bdbf4cf3acfd658268193724e0efdec *R/acw.R b6ce2424906cdb8aebd34022f238d57a *R/declareGlobals.R 8c92aca07af5e65d3b845c3b5514c7f0 *R/deldir.R f194a0f1c61521ea628b87b02c0c0977 *R/dumpts.R 993ce9e5a7e061fba1847c6f029def08 *R/duplicatedxy.R 3e37aaac8530922a03f0cc05eee1a13e *R/get.cnrind.R fb4fd373dd2a698f4b5db76ad9bd4a48 *R/getCol.R e55af1ae6eb1861a0e7e2ea8a68c8444 *R/mid.in.R 1b5b733f3c50e6d240bfadeef5917761 *R/mnnd.R 13c76fff4f354977a02f5f64881b6ec1 *R/plot.deldir.R 0b1bcbc9171acd92d1bbc65dacabf314 *R/plot.tile.list.R d2c672a1e243a6ee9446433850234456 *R/plot.triang.list.R 3d4ae286693d20b4f89a5f408d6d76fb *R/tile.centroids.R 15534d9c13ae945965f28e7d2e6e9e00 *R/tile.list.R 63589e2638a0b8a89eabb0b58e64bc0a *R/tilePerim.R 99a2662f5f54f53bee9917472c32d960 *R/tilePerim0.R bb19c9f800ac3e09edb7417f5b52b74f *R/triMat.R 78291d945e31feafbaa5c45e86014be2 *R/triang.list.R 35ba8c19c87b1fe11803fff4326a88fc *inst/READ_ME c2d0b8ca101bbeea7470b1e28f7f2e4d *inst/code.discarded/ind.dup.R 7a0cbe7ba69bc4d3758d7b467378a6a5 *inst/code.discarded/inddup.r 1f60d3bc69b6d8d796a54d974d6d6f02 *inst/code.discarded/intri.r.save 843738b219952df77db76cd139bea899 *inst/code.discarded/triang.list.R.save 26d9317ccd004187615ebfe12a4f8dd9 *inst/code.discarded/trigraf.c c945c2910fca08afeb14c565ae4222b7 *inst/code.discarded/trigraf.r b5e808eddb79d2d4be20441250910a4b *inst/code.discarded/trigraf1.r.save 6b9d8dec2bc172cb280aa76cf285b67b *inst/err.list b1e64b5aed9484584095ac4e02baea84 *inst/ex.out 32332f6b7cc4f78b3307c77566bb5a89 *inst/ratfor/acchk.r 920af4bece7f20672f4750e7bcd8cd2f *inst/ratfor/addpt.r 93ed44f787438449a98e24be66775d8b *inst/ratfor/adjchk.r d53c2495df9c4d1f4d3fcad81e10b801 *inst/ratfor/binsrt.r f6e55e5c74ed60b802cb2a827e597603 *inst/ratfor/circen.r 4d8cb727e99e8e068e0bbf6069491071 *inst/ratfor/cross.r 43bbe616653a6276af389d5af6ff212c *inst/ratfor/delet.r 2aa853d7aaac39e955f2c8d7f44bee60 *inst/ratfor/delet1.r 22b1b7d68d94d8d179663d3d7dbee446 *inst/ratfor/delout.r 5f7e60979680de4e62ca74de22c21baa *inst/ratfor/delseg.r a30c095ef8d652ea7b8c8ca3dcde6fd9 *inst/ratfor/dirout.r 978f7de7eb5c3f8ff107a698154c66c0 *inst/ratfor/dirseg.r 06828c7cda4fef9c5851f54025b4133e *inst/ratfor/dldins.r 75332c0a3586d888708d68a231c0c185 *inst/ratfor/initad.r 793f31965fd00d91904dc1145e5a5e95 *inst/ratfor/insrt.r 8d92aa51712ce4e98089b46daa29614f *inst/ratfor/insrt1.r dd4c320d81a0a2b46eb9f36eba612b82 *inst/ratfor/intri.r 5bad4291a0b880522b1fd6d62e7d7429 *inst/ratfor/locn.r b0b4711c3a3980c39a7251dde6d5dff4 *inst/ratfor/makefor 4cac87573b5b1816306c3860d25473b0 *inst/ratfor/master.r d03a4191bd92932b2738cf296f349033 *inst/ratfor/mnnd.r 62f8ee83f2883425442a31b7492c3fa1 *inst/ratfor/pred.r b2f36d395d489589d5bb834705f70f90 *inst/ratfor/qtest.r 3ddc366df61f495863bd31a50dfbc186 *inst/ratfor/qtest1.r a8636bf7b643eca192877bc38a6f2c87 *inst/ratfor/stoke.r 6d1ed8f4862aea3c6cd9a28179c51ddf *inst/ratfor/succ.r 26351de190d239680ba29f52cf2e5c0d *inst/ratfor/swap.r 24d5480cf4bdadf3689600d63d8de5e6 *inst/ratfor/testeq.r 728e4e2b3d69a1ea05c3373ce5c378f5 *inst/ratfor/triar.r dfb3a45af9e6414d3346857f860d753a *inst/ratfor/trifnd.r e74e24a1cafa5c4aa81952449601e8f3 *man/deldir-internal.Rd f47798538c9d99f1cdf8422e000ed8f6 *man/deldir.Rd e30e60bf7172012c960d939d20f8d3e0 *man/duplicatedxy.Rd 924b9d322e666d709743a5209a53f069 *man/plot.deldir.Rd 08b162a77fb6762ec67b6dc9ef0b4943 *man/plot.tile.list.Rd de04bbb5c7e4e9981f110ac46c87e982 *man/plot.triang.list.Rd 67517c4e79447506a4b8df8511caad90 *man/tile.centroids.Rd baccd85e842d73c0a81fceceaea9039b *man/tile.list.Rd 186b00fe8efd01a3841f51a548752b07 *man/tilePerim.Rd aa0b6e9482adec6c3b7b25451f49f490 *man/triMat.Rd 1331a2716e01038b4f003933e75047f9 *man/triang.list.Rd 81abe4431670564231ae774a03692ea2 *src/acchk.f 3b8d8e83cb031d112cf60c6652836777 *src/addpt.f f8fc78375577de4d02e4c9ac3892f2a7 *src/adjchk.f de044147dd6ebe0c4ff5bd0f6112203e *src/binsrt.f 7abd837fc805d557165605d207f2c8c3 *src/circen.f 1d9539393a7eeb798ca4ca0ca590a088 *src/cross.f 5e9063f9e7c81e10c8db3bc2cad0b291 *src/delet.f 09ad43b86616d7d5b73bcde6f80c97e9 *src/delet1.f fed96287bb1385ff76d76d3eeb5bfa70 *src/delout.f aa16e6342c8cb9171d7246b9fc8bb80c *src/delseg.f b2a36447f268463c835e9a1856b08174 *src/dirout.f 4e0014caa9d5a47af596147bbe94ea07 *src/dirseg.f cc02e9a59e41f094d87817e780189ce6 *src/dldins.f 21d927015f09e0a13b5bf21f51ceb575 *src/initad.f a17d1356bc31d8cdb942aea473242ca5 *src/insrt.f 33a636ee10efff1a859064df2b8fd952 *src/insrt1.f e18fafa0deba07c1037e6329dfb7e06e *src/intri.f 9d030b7b61f129ae1fb6be701238e69a *src/locn.f 880f3384d6cc39c3c62046c8ea0f875d *src/master.f 24db74c4705f2a26cad90ae228857f79 *src/mnnd.f f49e066dad7adee2e133fce591d2e3e3 *src/pred.f b04535a0aeecfabcc86325844d7fd8d3 *src/qtest.f abfc6d38833cf0001812e005fc54ef28 *src/qtest1.f 021ccd8c271bdb2944959cf3a67c59d4 *src/stoke.f 19921cf6a31a399ab133a88bd8ccacf0 *src/succ.f 0b1cae00f62c54e2dcd90206af448bfa *src/swap.f f00d6edb7917fb4fbd17531eb3cc04ff *src/testeq.f d8c122c9e40974c0d3b0438feb756361 *src/triar.f c9937767e3d3a2e9575e2e10d7e314b0 *src/trifnd.f deldir/DESCRIPTION0000644000176000001440000000132012477242213013253 0ustar ripleyusersPackage: deldir Version: 0.1-9 Date: 2015-03-09 Title: Delaunay Triangulation and Dirichlet (Voronoi) Tessellation Author: Rolf Turner Maintainer: Rolf Turner Depends: R (>= 0.99) Suggests: polyclip Description: Calculates the Delaunay triangulation and the Dirichlet or Voronoi tessellation (with respect to the entire plane) of a planar point set. Plots triangulations and tessellations in various ways. Clips tessellations to sub-windows. Calculates perimeters of tessellations. License: GPL (>= 2) URL: https://www.stat.auckland.ac.nz/~rolf/ Packaged: 2015-03-08 23:58:23 UTC; rolf NeedsCompilation: yes Repository: CRAN Date/Publication: 2015-03-09 07:58:19 deldir/ChangeLog0000644000176000001440000003504312477160512013331 0ustar ripleyusers Version 0.1-9 Uploaded to CRAN 09/03/2015. Removed period from end of title in the DESCRIPTION file. Changed NAMESPACE file to "register" S3 methods. Removed "require("polyclip") in plot.tile.list() and change code to use: if(requireNamespace("polyclip",quietly=TRUE)) .... instead. Changed URL from http://www.stat.auckland.ac.nz to https://www.stat.auckland.ac.nz in help files and in the DESCRIPTION file. The 4 foregoing changes made at the behest of Uwe Ligges. Done 09/03/2015. Version 0.1-8 Uploaded to CRAN 09/03/2015. Added a "[.tile.list" method so that tile lists can be subsetted and still retain their class and "rw" attribute. Prompted by an enquiry to R-help from Raphael Päbst, 15/01/2015. Done 09/03/2015. Added a component "ind.orig" to the object returned by deldir(). This consists of the indices of the points in the original set of (x,y) coordinates provided to the function (before any duplicated points were removed). Prompted by an enquiry from Daniel McCloy 29/12/14. He wanted the triangle descriptions produced by triang.list() to show these original indices --- as the help file claims they show --- rather than the indices in the set of coordinates after the removal of duplicates. Done 09/03/2015. Changed triang.list() to make use of the "original coordinates" referred to above. Done 09/03/2015. Revised plot.triang.list() so that it actually tries to plot the (x,y) coordinates of the triangle vertices rather than trying to use (ptNum,x) (!!!) as it previously did. The problem was caused by xy.coords(tri) using the first two columns of "tri" as the (x,y) coordinates rather than the columns named "x" and "y". I'm ***sure*** that plot.triang.list() *used* to work, i.e. that the columns named "x" and "y" were extracted. (If "tri" were a list, then components named "x" and "y" would be extracted, and since data frames are lists with components equal to the columns, I would have expected this to work, but it doesn't. Moreover the help for xy.coords() clearly says that it doesn't. Go figure.) Prompted by an enquiry from Yinghui Liu, 09/03/2015. Done 09/03/2015. Version 0.1-7 Uploaded to CRAN 26/11/2014 Fixed bug with respect to the z "weights"; if there were duplicated points, there was a mismatch of numbers between the z "weights" and the unique collection of points that deldir() works with. Fixed. Thanks to Ron Peterson for drawing this bug to my attention. Done 26/11/2014. Changed the procedure for issuing a message from the initial invocation of deldir() so that it no longer uses cat() but rather calls message(). Requested by Bob O'Hara. Done 21/08/2014. Added some material to the description of the "z" argument to deldir() to make it clear that these weights do not affect the tessellation and that deldir does *not* do weighted tessellation. (Prompted by an enquiry from Garry Gelade.) Done 26/08/2014. Version 0.1-6 Uploaded to CRAN 03/08/2014 Corrected the ratfor code dirseg.r and dirout.r. A rarely occuring bug was possible due to the way the code was previously written. The code made use of the ray joining a circumcentre to the midpoint of an edge of a Delaunay triangle. It is *possible* for the circumcentre and that midpoint to coincide. In such a case Fortran seemed to calculate the slope of the ray (zero over zero) to be equal to one. The result was wrong of course and an error with number nerror = 17 was (fortunately!) thrown. In retrospect it is "obvious" that the ray should have been taken to join the two circumcentres on opposite sides of the Delaunay edge. But since these two circumcentres could conceivably coincide it is better to take the slope of the ray to be the negative reciprocal of the slope of the Delaunay edge. The code now uses this slope. Thanks to Pierre Legendre for drawing this bug to my attention. Done 03/08/2014. Slight adjustment to plot.tile.list.R (so that when verbose=TRUE and showpoints=TRUE, the points get plotted "at the right time" rather than when the *next* tile gets plotted). Done 18/05/2014. Slight adjustment made to plot.tile.list.Rd Done 18/05/2014. Version 0.1-5 Uploaded to CRAN 02/02/2014 In the help for plot.tile.list() the call to this function that made use of the "clipp" argument has been wrapped in if(require(polyclip)) { ... } so as to avoid errors when the deldir package is used by older versions of R which do not provide the polyclip package. (Change made at the behest of Uwe Ligges.) Version 0.1-4 Uploaded to CRAN 31/01/2014 Fixed up an error in the handling of "x" and "y" coordinates and the "z" weights as columns of a data frame. The code asked for a third column of the data frame, and there might not be one. Error caught by the CRAN people when the ade4 package threw an error upon calling deldir. Changed the protocol so that: * the x coordinates are the column named "x" if there is one else the first column *not* named "y" or "z" * the y coordinates are the column named "y" if there is one else the first column *not* named "x" or "z" * the z weights are the column named "z" if there is one *and* if the z argument is NULL (else the z weights are left to be NULL. Version 0.1-3 Uploaded to CRAN 30/01/2014 Fixed up references to my web page to refer to my New Zealand web page. (28/01/2014) Adjusted code to allow the x argument of deldir() to be a data frame whose names do *not* necessarily include "x", "y", and "z". In this case the x coordinates are taken to be the first column of the data frame, the y coordinates to be the second column, and z to be the third column if that column exists. Version 0.1-2 Uploaded to CRAN 01/10/2013. Adjusted the behaviour of the function plot.tile.list() when verbose=TRUE, very slightly. Removed the use.gpclib argument to plot.tile.list() (in accordance with the new behaviour of spatstat). Version 0.1-1 Revised the function "plot.tile.list", changing the behaviour of the colouring of tiles and added the argument "clipwin". Request of Chris Triggs. Added the internal function "getCol". Added the arguments "border", "clipwin" and "warn", and eliminated the (redundant) argument "showrect". Added the function "tilePerim" and the internal function "tilePerim0". Request of Haozhe Zhang. Uploaded to CRAN 02 October 2013 Version 0.0-22 (17 April 2013) Fixed the dimensioning of delsgs, dirsgs, and ind in delsegs.r and dirsegs.r. Had used a "1" as the last dimension and this now throws a "subscript out of range" warning from the compiler. Version 0.0-21 (12 October 2012) Fixed glitch w.r.t. the z-argument of deldir() --- if "x" was a list with "x" and "y" components, and if "z" was supplied as a separate argument, then "z" got ignored. Added a "point number" component to the list produced for each Delaunay triangle by triang.list(). Added the function duplicatedxy() to determine duplicated points, to make it convenient for the user to eliminate duplicates from a point set before calling deldir(). Done at the request of Adrian Baddeley. Version 0.0-20 (07 September 2012) Removed the elaborate startup message referring to changes from previous versions of "deldir". Replaced this with message produced by deldir() itself, the first time that it is called in any given session. Added an argument "suppressMsge" to deldir() allowing the user to keep this message from appearing. Done at the request of Adrian Baddeley. Version 0.0-19 (23 April 2012) Added warnings in respect of change of "summary" and "delsgs" from matrices to data frames. Corrected spelling of "auxiliary" in various places. Fixed up the "see also"-s in tile.list() and plot.tile.list(). Fixed a typo in the help for plot.tile.list(). Fixed up the "see also" in the help for deldir(). Version 0.0-18 (21 April 2012) At the suggestion of Simon Greener, added the capacity to carry along "auxilliary" variables or "weights" associated with the points being triangulated. If supplied these weights appear as a third column of the data frames specifying the triangles in the triangulation, as produced by the function triang.list(). Version 0.0-17 (03 April 2012) Added the function triMat() at the suggestion of Robin Hankin. Fixed a glitch in the documentation of deldir() (in the Warning section). Tweaked the documentation of plot.tile.list(), plot.triang.list(), and tile.list(). Version 0.0-16 (04 November 2011) Fixed some minor errors in the documentation. Added a namespace. Version 0.0-15 (12 August 2011) Fixed a bug in triang.list(); occasionally triangles would appear in this list which were *not* Delaunay triangles but rather the union of three congtiguous such triangles. This now no longer happens. Fixed some minor infelicities in the Fortran (ratfor) code. Removed switch() statements from the ratfor code (and replaced them with a sequence of if's). It appears that the ratfor compiler that is currently available to me does not handle switch statements properly. The resulting Fortran code compiled and loaded but led to errors when run. ***************************** Version 0.0-14 (22 June 2011) Put the startup messages into packageStartupMessage() rather than catting them. At the request of Thierry Onkelinx. ***************************** Version 0.0-13 (29 November 2010) Renamed the directory inst/ratfor.discarded inst/code.discarded and moved the no-longer-used function ind.dup to that directory. Added a facility to plot.deldir() to plot the enclosing rectangle "rw". Added the same facility to plot.tile.list(). Added attribute "rw" to the object returned by tile.list() so that the foregoing facility can work. Added function triang.list(). Added function plot.triang.list(). Added arguments add, xlab, ylab, main, and asp to plot.tile.list(). ***************************** Version 0.0-12 (08 January 2009) Fixed a minor glitch in the .First.lib() function. I had a backspace coded into the message produced, and this upset Sweave. The backspace had been put in to get things to line up correctly. Re-arranged things (properly!) so that it is no longer needed. ***************************** Version 0.0-11 (09 December 2009) No change, really. A tweak that I made to the First() function in version 0.0-10, *without* changing the version number (psigh!) did not propagate to the Windoze and Mac OSX binaries. So version 0.0-11 is just the same as the tweaked realization of of version 0.0-10 but with the version number changed so that the tweak will propagate. ***************************** Version 0.0-10 (16 November 2009) Got rid of the call to ind.dup() which used a very rough bit of Fortran code to detect duplicated points, and replaced it with a call to duplicated(). (Bug pointed out by Bjarke Christensen.) ***************************** Version 0.0-9 (4 November 2009) Added a new function tile.centroids() --- which does the obvious. Motivated by an inquiry from Leandro Moreira. Added a ChangeLog ***************************** Version 0.0-8 (4 April 2009) Removed the labels from the x and y vectors in the tile descriptions produced by tile.list. These labels (which were the row numbers in the dirsgs data frame returned by deldir()) served no useful purpose and were potentially confusing. ***************************** Versions 0.0-2 through 0.0-7 were not tracked here. :-( Simply forgot about doing this. I thoroughly *intend* [ :-) ] to get the archives from CRAN and try to document the changes. Recent ones involved fixing bugs in and adding features to the tile.list() and plot.tile.list() functions. ***************************** Version 0.0-1 (21 February 2002) This version is simply an adaptation of the Splus version of the package to R. ============================================================================== The following items relate to the Splus versions of deldir ============================================================================== Version date: 14 February 2002. This version supercedes the version dated 24 April 1999. The changes from the version dated 24 April 1999 to the version dated 14 February 2002 were: A bug in the procedure for eliminating duplicated points was fixed. Thanks go to Dr. Berwin Turlach of the Department of Maths and Stats at the University of Western Australia, for spotting this bug. ***************************** Version date: 24 April 1999. This version supercedes the version dated 26 October 1998. The changes from the version dated 26 October 1998 to the version dated 24 April 1999 were: (1) The function mipd(), stored in mipd.sf, and the corresponding Fortran subroutine mipd, stored in mipd.r, have been replaced by mnnd() in mnnd.sf and mnnd in mnnd.r. The function mipd calculated the mean interpoint distance, to be used in constructing dummy point structures of a certain type. After some reflection it became apparent that the mean interpoint distance was much too large for the intended purpose, and that a more appropriate value was the ``mean nearest neighbour distance'' which is calculated by the new function. This new value is now used in constructing dummy point structures. Note that the operative result is that the resulting dummy point structures contain many more points than before. The old value caused large numbers of the dummy points to fall outside the data window and therefore to be clipped. ***************************** Version date: 26 October 1998. This version supercedes the version dated 6 December 1996. The changes from the version dated 6 December 1996 to the version dated 26 October 1998 were: (1) A ratfor/Fortran routine named ``inside'' has been renamed ``dldins'' to avoid conflict with a name built in to some versions of Splus. (2) Some minor corrections have been made to dangerous infelicities in a piece of the ratfor/Fortran code. (3) The dynamic loading procedure has been changed to use dyn.load.shared so that the package is easily usable on IRIX systems as well as under SunOS/Solaris. (4) The package has been adjusted slightly so that it can easily be installed as a section of a library. In particular, the dynamic loading is now done by the .First.lib() function rather than from within deldir() itself; reference to an environment variable DYN_LOAD_LIB is no longer needed. deldir/man/0000755000176000001440000000000012477157233012333 5ustar ripleyusersdeldir/man/deldir-internal.Rd0000644000176000001440000000100212455574751015674 0ustar ripleyusers\name{deldir-internal} \alias{[.tile.list} \alias{acw} \alias{dumpts} \alias{get.cnrind} \alias{getCol} \alias{mid.in} \alias{mnnd} \alias{tilePerim0} \title{Internal deldir functions} \description{ Internal deldir functions. } \usage{ \method{[}{tile.list}(x,i,\dots) acw(xxx) dumpts(x,y,dpl,rw) get.cnrind(x,y,rw) getCol(x,warn=FALSE) mid.in(x,y,rx,ry) mnnd(x,y) tilePerim0(object,inclbdry=TRUE) } \details{ These functions are auxiliary and are not intended to be called by the user. } \keyword{internal} deldir/man/triMat.Rd0000644000176000001440000000273512477157227014074 0ustar ripleyusers\name{triMat} \alias{triMat} \title{ Produce matrix of triangle vertex indices. } \description{ Lists the indices of the vertices of each Delaunay triangle in the triangulation of a planar point set. The indices are listed (in increasing numeric order) as the rows of an \eqn{n \times 3}{n x 3} matrix where \eqn{n} is the number of Delaunay triangles in the triangulation. } \usage{ triMat(object) } \arguments{ \item{object}{ An object of class \code{deldir} (as produced by the funtion \code{\link{deldir}()}) specifying the Delaunay triangulation and Dirichlet (Voronoi) tesselation of a planar point set. } } \details{ This function was suggested by Robin Hankin of the School of Mathematical and Computing Sciences at Auckland University of Technology. } \value{ An \eqn{n \times 3}{n x 3} matrix where \eqn{n} is the number of Delaunay triangles in the triangulation specified by \code{object}. The \eqn{i^{th}}{i-th} row consists of the indices (in the original list of points being triangulated) of vertices of the \eqn{i^{th}}{i-th} Delaunay triangle. The indices are listed in increasing numeric order in each row. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \seealso{ \code{\link{deldir}()} \code{\link{triang.list}()} \code{\link{plot.triang.list}()} } \examples{ set.seed(42) x <- runif(10) y <- runif(10) ddxy <- deldir(x,y) M <- triMat(ddxy) } \keyword{spatial} deldir/man/triang.list.Rd0000644000176000001440000000303412477157210015053 0ustar ripleyusers\name{triang.list} \alias{triang.list} \title{ Create a list of Delaunay triangles } \description{ From an object of class \dQuote{deldir} produces a list of the Delaunay triangles in the triangulation of a set of points in the plane. } \usage{ triang.list(object) } \arguments{ \item{object}{ An object of class \dQuote{deldir} as produced by \code{\link{deldir}()}. } } \value{ A list each of whose components is a \eqn{3 \times 2}{3 x 2} or \eqn{3 \times 3}{3 x 3} data frame corresponding to one of the Delaunay triangles specified by \dQuote{object}. The rows of each such data frame consist of the coordinates of the vertices of the corresponding Delaunay triangle, and possibly the values of the \dQuote{auxiliary} variable or \dQuote{weight} \code{z} associated with the vertices (if such values were supplied in the call to \code{deldir()}). The returned value has an attribute \dQuote{rw} consisting of the enclosing rectangle of the triangulation. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \note{ The code of this function was taken more-or-less directly from code written by Adrian Baddeley for the \dQuote{delaunay()} function in the \dQuote{spatstat} package. } \seealso{ \code{\link{deldir}()} \code{\link{plot.triang.list}()} \code{\link{tile.list}()} \code{\link{plot.tile.list}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) z <- sample(1:100,20) d <- deldir(x,y,z=z) ttt <- triang.list(d) } \keyword{spatial} deldir/man/plot.deldir.Rd0000644000176000001440000001020512477157140015035 0ustar ripleyusers\name{plot.deldir} \alias{plot.deldir} \title{ Plot objects produced by deldir } \description{ This is a method for plot. } \usage{ \method{plot}{deldir}(x,add=FALSE,wlines=c('both','triang','tess'), wpoints=c('both','real','dummy','none'), number=FALSE,cex=1,nex=1,col=NULL,lty=NULL, pch=NULL,xlim=NULL,ylim=NULL,xlab='x',ylab='y', showrect=FALSE,...) } \arguments{ \item{x}{ An object of class "deldir" as constructed by the function deldir. } \item{add}{ logical argument; should the plot be added to an existing plot? } \item{wlines}{ "which lines?". I.e. should the Delaunay triangulation be plotted (wlines='triang'), should the Dirichlet tessellation be plotted (wlines='tess'), or should both be plotted (wlines='both', the default) ? } \item{wpoints}{ "which points?". I.e. should the real points be plotted (wpoints='real'), should the dummy points be plotted (wpoints='dummy'), should both be plotted (wpoints='both', the default) or should no points be plotted (wpoints='none')? } \item{number}{ Logical argument, defaulting to \code{FALSE}; if \code{TRUE} then the points plotted will be labelled with their index numbers (corresponding to the row numbers of the matrix "summary" in the output of deldir). } \item{cex}{ The value of the character expansion argument cex to be used with the plotting symbols for plotting the points. } \item{nex}{ The value of the character expansion argument cex to be used by the text function when numbering the points with their indices. Used only if number=\code{TRUE}. } \item{col}{ the colour numbers for plotting the triangulation, the tesselation, the data points, the dummy points, and the point numbers, in that order; defaults to c(1,1,1,1,1). If fewer than five numbers are given, they are recycled. (If more than five numbers are given, the redundant ones are ignored.) } \item{lty}{ the line type numbers for plotting the triangulation and the tesselation, in that order; defaults to 1:2. If only one value is given it is repeated. (If more than two numbers are given, the redundant ones are ignored.) } \item{pch}{ the plotting symbols for plotting the data points and the dummy points, in that order; may be either integer or character; defaults to 1:2. If only one value is given it is repeated. (If more than two values are given, the redundant ones are ignored.) } \item{xlim}{ the limits on the x-axis. Defaults to rw[1:2] where rw is the rectangular window specification returned by deldir(). } \item{ylim}{ the limits on the y-axis. Defaults to rw[3:4] where rw is the rectangular window specification returned by deldir(). } \item{xlab}{ label for the x-axis. Defaults to \code{x}. Ignored if \code{add=TRUE}. } \item{ylab}{ label for the y-axis. Defaults to \code{y}. Ignored if \code{add=TRUE}. } \item{showrect}{ logical scalar; show the enclosing rectangle \code{rw} (see \code{\link{deldir}()}) be plotted? } \item{...}{ Further plotting parameters to be passed to \code{plot()} \code{segments()} or \code{points()}. Unlikely to be used. } } \section{Side Effects}{ A plot of the points being triangulated is produced or added to an existing plot. As well, the edges of the Delaunay triangles and/or of the Dirichlet tiles are plotted. By default the triangles are plotted with solid lines (lty=1) and the tiles with dotted lines (lty=2). } \details{ The points in the set being triangulated are plotted with distinguishing symbols. By default the real points are plotted as circles (pch=1) and the dummy points are plotted as triangles (pch=2). } \seealso{ \code{\link{deldir}()} } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \examples{ \dontrun{ try <- deldir(x,y,list(ndx=2,ndy=2),c(0,10,0,10)) plot(try) # deldir(x,y,list(ndx=4,ndy=4),plot=TRUE,add=TRUE,wl='te', col=c(1,1,2,3,4),num=TRUE) # Plots the tesselation, but does not save the results. try <- deldir(x,y,list(ndx=2,ndy=2),c(0,10,0,10),plot=TRUE,wl='tr', wp='n') # Plots the triangulation, but not the points, and saves the # returned structure. } } \keyword{ hplot } % Converted by Sd2Rd version 1.21. deldir/man/tile.centroids.Rd0000644000176000001440000000172712477157171015560 0ustar ripleyusers\name{tile.centroids} \Rdversion{1.1} \alias{tile.centroids} \title{ Compute centroids of Dirchlet (Voronoi) tiles } \description{ Given a list of Dirichlet tiles, as produced by \code{tile.list()}, produces a data frame consisting of the centroids of those tiles. } \usage{ tile.centroids(xxx) } \arguments{ \item{xxx}{A list of the tiles (produced by \code{tile.list()}) in a Dirichlet tessellation of a set of planar points.} } \value{ A data frame with two columns named \code{x} and \code{y}. Each row of this data frame consitutes the centroid of one of the Dirichlet tiles. } \references{ URL http://en.wikipedia.org/wiki/Centroid } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \seealso{ \code{\link{tile.list}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) d <- deldir(x,y) l <- tile.list(d) g <- tile.centroids(l) \dontrun{ plot(l,close=TRUE) points(g,pch=20,col="red") } } \keyword{ spatial } deldir/man/tilePerim.Rd0000644000176000001440000000332212477157203014551 0ustar ripleyusers\name{tilePerim} \alias{tilePerim} \title{ Calculate tile perimeters. } \description{ Calculates the perimeters of all of the Dirichlet (Voronoi) tiles in a tessellation of a set of planar points. Also calculates the sum and the mean of these perimeters. } \usage{ tilePerim(object,inclbdry=TRUE) } \arguments{ \item{object}{ An object of class \code{tile.list} (as produced by \code{\link{tile.list}()} specifying the Dirichlet (Voronoi) tiles in a tessellation of a set of planar points. } \item{inclbdry}{ Logical scalar. Should boundary segments (edges of tiles at least one of whose endpoints lies on the enclosing rectangle \code{rw} (see \code{\link{deldir}()}) be included in the perimeter? } } \value{ A list with components \item{perimeters}{ A vector consisting of the values of the perimeters of the Dirichlet tiles in the tessellation. } \item{totalPerim}{ The sum of \code{perimeters}. } \item{meanPerim}{ The mean of \code{perimeters}. } } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \note{ Function added at the request of Haozhe Zhang. } \seealso{ \code{\link{tile.list}()}, \code{\link{plot.tile.list}()} } \examples{ x <- runif(20) y <- runif(20) z <- deldir(x,y,rw=c(0,1,0,1)) w <- tile.list(z) p1 <- tilePerim(w) p0 <- tilePerim(w,inclbdry=FALSE) p1$totalPerim - p0$totalPerim # Get 4 = the perimeter of rw. ss <- apply(as.matrix(z$dirsgs[,1:4]),1, function(x){(x[1]-x[3])^2 + (x[2]-x[4])^2}) 2*sum(sqrt(ss)) - p0$totalPerim # Get 0; in tilePerim() each interior # edge is counted twice. } \keyword{spatial} deldir/man/duplicatedxy.Rd0000644000176000001440000000443412477157133015325 0ustar ripleyusers\name{duplicatedxy} \alias{duplicatedxy} \title{ Determine duplicated points. } \description{ Find which points among a given set are duplicates of others. } \usage{ duplicatedxy(x, y) } \arguments{ \item{x}{ Either a vector of \code{x} coordinates of a set of (two dimensional) points, or a list (or data frame) with columns \code{x} and \code{y} giving the coordinates of a set of such points. } \item{y}{ A vector of \code{y} coordinates of a set of (two dimensional) points. Ignored if \code{x} is a list or data frame. } } \details{ Often it is of interest to associate each Dirichlet tile in a tessellation of a planar point set with the point determining the tile. This becomes problematic if there are \emph{duplicate} points in the set being tessellated/triangulated. Duplicated points are automatically eliminated \dQuote{internally} by \code{deldir()} but the association between tiles and the indices of the original set of points is lost. If it \emph{is} of interest to associate Dirichlet tiles with the points determining them it is better to proceed by eliminating duplicate points to start with. This function provides a convenient way of doing so. } \value{ A logical vector of length equal to the (original) number of points being considered, with entries \code{TRUE} is the corresponding point is a duplicate of a point with a smaller index, and \code{FALSE} otherwise. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \note{ The real work is done by the base \bold{R} function \code{\link{duplicated}()}. } \section{Warning}{ Which indices will be considered to be indices of duplicated points (i.e. get \code{TRUE} values) will of course depend on the order in which the points are presented. } \seealso{ \code{\link{duplicated}()} \code{\link{deldir}()} } \examples{ set.seed(42) xy <- data.frame(x=runif(20),y=runif(20)) # Lots of duplicated points. xy <- rbind(xy,xy[sample(1:20,20,TRUE),]) # Scramble. ii <- sample(1:40,40) x <- xy$x[ii] y <- xy$y[ii] # Unduplicate! iii <- !duplicatedxy(x,y) xu <- x[iii] yu <- y[iii] # The i-th tile is determined by (xu[i],yu[i]): dxy <- deldir(xu,yu) } \keyword{ utilities } deldir/man/deldir.Rd0000644000176000001440000003431012477157126014067 0ustar ripleyusers\name{deldir} \alias{deldir} \title{ Delaunay triangulation and Dirichlet tessellation } \description{ This function computes the Delaunay triangulation (and hence the Dirichlet or Voronoi tesselation) of a planar point set according to the second (iterative) algorithm of Lee and Schacter --- see REFERENCES. The triangulation is made to be with respect to the whole plane by \code{suspending} it from so-called ideal points (-Inf,-Inf), (Inf,-Inf) (Inf,Inf), and (-Inf,Inf). The triangulation is also enclosed in a finite rectangular window. A set of dummy points may be added, in various ways, to the set of data points being triangulated. } \usage{ deldir(x, y, dpl=NULL, rw=NULL, eps=1e-09, sort=TRUE, plotit=FALSE, digits=6, z=NULL, zdum=NULL, suppressMsge=FALSE, \dots) } \arguments{ \item{x,y}{ The coordinates of the point set being triangulated. These can be given by two arguments x and y which are vectors or by a single argument x which is either a data frame or a generic list. If \code{x} is a data frame then the \code{x} coordinates of the points to be triangulated are taken to be the column of this data frame which is named \dQuote{x} if there is one, else the first column of the data frame which is not named either \dQuote{y} or \dQuote{z}. The \code{y} coordinates are taken to be the column of this data frame which is named \dQuote{y} if there is one, else the first column of the data frame which is not named either \dQuote{x} or \dQuote{x}. If there is a column named \dQuote{z} and if the argument \code{z} is NULL, then this the column named \dQuote{z} is taken to be the value of \code{z}. If \code{x} is a list (but not a data frame) then it must have components named \code{x} and \code{y}, and possibly a component named \code{z}. The \code{x} and \code{y} components give the \code{x} and \code{y} coordinates respectively of the points to be triangulated, and the component \code{z} if present (and if argument \code{z} is \code{NULL}) is taken to be the value of \code{z} (i.e. of a vector of \dQuote{auxiliary} values or \dQuote{weights} associated with the respective points). } \item{dpl}{ A list describing the structure of the dummy points to be added to the data being triangulated. The addition of these dummy points is effected by the auxiliary function dumpts(). The list may have components: \itemize{ \item \code{ndx}: The x-dimension of a rectangular grid; if either ndx or ndy is null, no grid is constructed. \item \code{ndy}: The y-dimension of the aforementioned rectangular grid. \item \code{nrad}: The number of radii or \dQuote{spokes}, emanating from each data point, along which dummy points are to be added. \item \code{nper}: The number of dummy points per spoke. \item \code{fctr}: A factor determining the length of each spoke; each spoke is of length equal to fctr times the mean nearest neighbour distance of the data. (This distance is calculated by the auxiliary function mnnd().) \item \code{x}: A vector of x-coordinates of \dQuote{ad hoc} dummy points \item \code{y}: A vector of the corresponding y-coordinates of \dQuote{ad hoc} dummy points } } \item{rw}{ The coordinates of the corners of the rectangular window enclosing the triangulation, in the order (xmin, xmax, ymin, ymax). Any data points (including dummy points) outside this window are discarded. If this argument is omitted, it defaults to values given by the range of the data, plus and minus 10 percent. } \item{eps}{ A value of epsilon used in testing whether a quantity is zero, mainly in the context of whether points are collinear. If anomalous errors arise, it is possible that these may averted by adjusting the value of eps upward or downward. } \item{sort}{ Logical argument; if \code{TRUE} (the default) the data (including dummy points) are sorted into a sequence of \dQuote{bins} prior to triangulation; this makes the algorithm slightly more efficient. Normally one would set sort equal to \code{FALSE} only if one wished to observe some of the fine detail of the way in which adding a point to a data set affected the triangulation, and therefore wished to make sure that the point in question was added last. Essentially this argument would get used only in a de-bugging process. } \item{plotit}{ Logical argument; if \code{TRUE} a plot is produced. The nature of the plot may be controlled by using the \code{\dots} argument to pass appropriate arguments to \code{plot.deldir()}. Without \dQuote{further instruction} a plot of the points being triangulated and of both the triangulation and the tessellation is produced; } \item{digits}{ The number of decimal places to which all numeric values in the returned list should be rounded. Defaults to 6. } \item{z}{ An optional vector of \dQuote{auxiliary} values or \dQuote{weights} associated with the respective points. (\bold{NOTE:} These \dQuote{weights} are values associated with the points and hence with the tiles of the tessellation produced. They \bold{DO NOT} affect the tessellation, i.e. the tessellation produced is the same as is it would be if there were no weights. The \code{deldir} package \bold{DOES NOT} do weighted tessellation.) If this argument is left \code{NULL} then it is taken to be the third column of \code{x}, if \code{x} is a data frame or to be the \code{z} component of \code{x} if \code{x} is a generic list. } \item{zdum}{ Values of \code{z} to be associated with any dummy points that are created. See \bold{Warnings}. } \item{suppressMsge}{ Logical scalar indicating whether a message (alerting the user to changes from previous versions of \code{deldir}) should be suppressed. } \item{...}{ Auxiliary arguments add, wlines, wpoints, number, nex, col, lty, pch, xlim, and ylim (and possibly other plotting parameters) may be passed to plot.deldir through \code{\dots} if plotit=\code{TRUE}. } } \value{ A list (of class \code{deldir}), invisible if plotit=\code{TRUE}, with components: \item{delsgs}{ a data frame with 6 columns. The first 4 entries of each row are the coordinates of the points joined by an edge of a Delaunay triangle, in the order (x1,y1,x2,y2). The last two entries are the indices of the two points which are joined. } \item{dirsgs}{ a data frame with 8 columns. The first 4 entries of each row are the coordinates of the endpoints of one the edges of a Dirichlet tile, in the order (x1,y1,x2,y2). The fifth and sixth entries are the indices of the two points, in the set being triangulated, which are separated by that edge. The seventh and eighth entries are logical values. The seventh indicates whether the first endpoint of the corresponding edge of a Dirichlet tile is a boundary point (a point on the boundary of the rectangular window). Likewise for the eighth entry and the second endpoint of the edge. } \item{summary}{ a data frame with 9 or 10 columns and \code{n.data + n.dum}rows (see below). The rows correspond to the points in the set being triangulated. The column names are \code{x} (the x-coordinate of the point), \code{y} (the y-coordinate), \code{z} (the auxiliary values or weights if these were specified), \code{n.tri} (the number of Delaunay triangles emanating from the point), \code{del.area} (1/3 of the total area of all the Delaunay triangles emanating from the point), \code{del.wts} (the corresponding entry of the \code{del.area} column divided by the sum of this column); \code{n.tside} (the number of sides --- within the rectangular window --- of the Dirichlet tile surrounding the point), \code{nbpt} (the number of points in which the Dirichlet tile intersects the boundary of the rectangular window), \code{dir.area} (the area of the Dirichlet tile surrounding the point), and \code{dir.wts} (the corresponding entry of the \code{dir.area} column divided by the sum of this column). Note that the factor of 1/3 associated with the del.area column arises because each triangle occurs three times --- once for each corner. } \item{n.data}{ the number of real (as opposed to dummy) points in the set which was triangulated, with any duplicate points eliminated. The first n.data rows of \code{summary} correspond to real points. } \item{n.dum}{ the number of dummy points which were added to the set being triangulated, with any duplicate points (including any which duplicate real points) eliminated. The last n.dum rows of \code{summary} correspond to dummy points. } \item{del.area}{ the area of the convex hull of the set of points being triangulated, as formed by summing the \code{del.area} column of \code{summary}. } \item{dir.area}{ the area of the rectangular window enclosing the points being triangulated, as formed by summing the \code{dir.area} column of \code{summary}. } \item{rw}{ the specification of the corners of the rectangular window enclosing the data, in the order (xmin, xmax, ymin, ymax). } \item{ind.orig}{A vector of the indices of the points (x,y) in the set of coordinates initially supplied to \code{deldir()} before duplicate points (if any) were removed. These coordinates are used by \code{\link{triang.list}()}. }} \section{Remark:}{ If ndx >= 2 and ndy >= 2, then the rectangular window IS the convex hull, and so the values of del.area and dir.area (if the latter is not \code{NULL}) are identical. } \section{Side Effects}{ If plotit==\code{TRUE} a plot of the triangulation and/or tessellation is produced or added to an existing plot. } \details{ This package is a (straightforward) adaptation of the Splus library section ``delaunay'' to R. That library section is an implementation of the Lee-Schacter algorithm, which was originally written as a stand-alone Fortran program in 1987/88 by Rolf Turner, while with the Division of Mathematics and Statistics, CSIRO, Sydney, Australia. It was re-written as an Splus function (using dynamically loaded Fortran code), by Rolf Turner while visiting the University of Western Australia, May, 1995. Further revisions were made December 1996. The author gratefully acknowledges the contributions, assistance, and guidance of Mark Berman, of D.M.S., CSIRO, in collaboration with whom this project was originally undertaken. The author also acknowledges much useful advice from Adrian Baddeley, formerly of D.M.S., CSIRO (now of CMIS, CSIRO and Adjunct Professor of Statistics at the University of Western Australia). Daryl Tingley of the Department of Mathematics and Statistics, University of New Brunswick provided some helpful insight. Special thanks are extended to Alan Johnson, of the Alaska Fisheries Science Centre, who supplied two data sets which were extremely valuable in tracking down some errors in the code. Don MacQueen, of Lawrence Livermore National Lab, wrote an Splus driver function for the old stand-alone version of this software. That driver, which was available on Statlib, is now deprecated in favour of the current package ``delaunay'' package. Don also collaborated in the preparation of that package. See the \code{ChangeLog} for information about further revisions and bug-fixes. } \section{Warnings}{ \enumerate{ \item The process for determining if points are duplicated changed between versions 0.1-9 and 0.1-10. Previously there was an argument \code{frac} for this function, which defaulted to 0.0001. Points were deemed to be duplicates if the difference in \code{x}-coordinates was less than \code{frac} times the width of \code{rw} and \code{y}-coordinates was less than \code{frac} times the height of \code{rw}. This process has been changed to one which uses \code{\link{duplicated}()} on the data frame whose columns are \code{x} and \code{y}. As a result it may happen that points which were previously eliminated as duplicates will no longer be eliminated. (And possibly vice-versa.) \item The components \code{delsgs} and \code{summary} of the value returned by \code{deldir()} are now \emph{data frames} rather than matrices. The component \code{summary} was changed to allow the \dQuote{auxiliary} values \code{z} to be of arbitrary mode (i.e. not necessarily numeric). The component \code{delsgs} was then changed for consistency. Note that the other \dQuote{matrix-like} component \code{dirsgs} has been a data frame since time immemorial. A message alerting the user to the foregoing two items is printed out the first time that \code{deldir()} is called with \code{suppressMsge=FALSE} in a given session. In succeeding calls to \code{deldir()} in the same session, no message is printed. (I.e. the \dQuote{alerting} message is printed \emph{at most once} in any given session.) The \dQuote{alerting} message is \emph{not} produced via the \code{warning()} function, so \code{suppressWarnings()} will \emph{not} suppress its appearance. To effect such suppression (necessary only on the first call to \code{deldir()} in a given session) one must set the \code{suppressMsge} argument of \code{deldir} equal to \code{TRUE}. \item If any dummy points are created, and if a vector \code{z}, of \dQuote{auxiliary} values or \dQuote{weights} associated with the points being triangulated, is supplied, then it is up to the user to supply the corresponding auxiliary values or weights associated with the dummy points. These values should be supplied as \code{zdum}. If \code{zdum} is not supplied then the auxiliary values or weights associated with the dummy points are all taken to be missing values (i.e. \code{NA}). } } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \references{ Lee, D. T., and Schacter, B. J. Two algorithms for constructing a Delaunay triangulation, Int. J. Computer and Information Sciences, Vol. 9, No. 3, 1980, pp. 219 -- 242. Ahuja, N. and Schacter, B. J. (1983). Pattern Models. New York: Wiley. } \seealso{ \code{\link{plot.deldir}()} \code{\link{tile.list}()} \code{\link{triang.list}()} } \examples{ # Puts dummy points at the corners of the rectangular # window, i.e. at (0,0), (10,0), (10,10), and (0,10) # An "alerting note" is printed. x <- c(2.3,3.0,7.0,1.0,3.0,8.0) y <- c(2.3,3.0,2.0,5.0,8.0,9.0) tv <- deldir(x,y,list(ndx=2,ndy=2),c(0,10,0,10)) # Plots the triangulation which was created (but not the tesselation). \dontrun{ tv <- deldir(x,y,list(ndx=2,ndy=2),c(0,10,0,10),plot=TRUE,wl='tr') } # Auxiliary values associated with points; 4 dummy points to be # added so 4 dummy "z-values" provided. z <- sample(1:100,6) zdum <- rep(-99,4) tv <- deldir(x,y,list(ndx=2,ndy=2),c(0,10,0,10),z=z,zdum=zdum) } \keyword{spatial} deldir/man/plot.triang.list.Rd0000644000176000001440000000440012477157153016034 0ustar ripleyusers\name{plot.triang.list} \alias{plot.triang.list} \title{ Plot Delaunay triangles } \description{ A method for \code{plot}. Plots the triangles of a Delaunay triangulation of a set of points in the plane.} \usage{ \method{plot}{triang.list}(x, showrect = FALSE, add = FALSE, xlab = "x", ylab = "y", main = "", asp = 1, ...) } \arguments{ \item{x}{ An object of class \dQuote{triang.list} as produced by \code{\link{triang.list}()}. } \item{showrect}{ Logical scalar; show the enclosing rectangle \code{rw} (see \code{\link{deldir}()}) be plotted? } \item{add}{ Logical scalar; should the plot of the triangles be added to an existing plot? } \item{xlab}{ Label for the \code{x}-axis. } \item{ylab}{ Label for the \code{y}-axis. } \item{main}{ A title for the plot (used only if \code{add} is \code{FALSE}). } \item{asp}{The aspect ratio of the plot; integer scalar or \code{NA}. Set this argument equal to \code{NA} to allow the data to determine the aspect ratio and hence to make the plot occupy the complete plotting region in both \code{x} and \code{y} directions. This is inadvisable; see the \bold{Warnings}.} \item{\dots}{ Arguments passed to \code{\link{polygon}()} which does the actual plotting of the triangles. } } \section{Warnings}{ The user is \emph{strongly advised} not to set the value of \code{asp} but rather to leave \code{asp} equal to its default value of \code{1}. Any other value distorts the tesselation and destroys the perpendicular appearance of lines which are indeed perpendicular. (And conversely can cause lines which are not perpendicular to appear as if they are.) The argument \code{asp} was added at the request of Zubin Dowlaty. } \value{ None. This function has the side effect of producing (or adding to) a plot. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \seealso{ \code{\link{deldir}()} \code{\link{plot.triang.list}()} \code{\link{tile.list}()} \code{\link{plot.tile.list}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) d <- deldir(x,y) ttt <- triang.list(d) plot(ttt,border="red",showrect=TRUE) sss <- tile.list(d) plot(sss) plot(ttt,add=TRUE,border="blue") } \keyword{ spatial } deldir/man/tile.list.Rd0000644000176000001440000000435012477157176014541 0ustar ripleyusers\name{tile.list} \alias{tile.list} \title{ Create a list of tiles in a tessellation } \description{ For each point in the set being tessellated produces a list entry describing the Dirichlet/Voronoi tile containing that point. } \usage{ tile.list(object) } \arguments{ \item{object}{ An object of class \code{deldir} as produced by the function \code{\link{deldir}()}.} } \value{ A list with one entry for each of the points in the set being tesselated. Each entry is in turn a list with components \item{pt}{The coordinates of the point whose tile is being described.} \item{x}{The \code{x} coordinates of the vertices of the tile, in anticlockwise order.} \item{y}{The \code{y} coordinates of the vertices of the tile, in anticlockwise order.} \item{bp}{Vector of logicals indicating whether the tile vertex is a ``real'' vertex, or a \emph{boundary point}, i.e. a point where the tile edge intersects the boundary of the enclosing rectangle} } \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \section{Acknowledgement}{ The author expresses sincere thanks to Majid Yazdani who found and pointed out a serious bug in \code{tile.list} in a previous version (0.0-5) of the \code{deldir} package. } \section{Warning}{ The set of vertices of each tile may be ``incomplete''. Only vertices which lie within the enclosing rectangle, and ``boundary points'' are listed. Note that the enclosing rectangle may be specified by the user in the call to \code{\link{deldir}()}. In contrast to some earlier versions of \code{deldir}, the corners of the enclosing rectangle are now include as vertices of tiles. I.e. a tile which in fact extends beyond the rectangular window and contains a corner of that window will have that corner added to its list of vertices. Thus the corresponding polygon is the intersection of the tile with the enclosing rectangle. } \seealso{ \code{\link{deldir}()}, \code{\link{plot.tile.list}()} \code{\link{triang.list}()} \code{\link{plot.triang.list}()} } \examples{ x <- runif(20) y <- runif(20) z <- deldir(x,y) w <- tile.list(z) z <- deldir(x,y,rw=c(0,1,0,1)) w <- tile.list(z) z <- deldir(x,y,rw=c(0,1,0,1),dpl=list(ndx=2,ndy=2)) w <- tile.list(z) } \keyword{spatial} deldir/man/plot.tile.list.Rd0000644000176000001440000001612212477157146015513 0ustar ripleyusers\name{plot.tile.list} \alias{plot.tile.list} \title{ Plot Dirchlet (Voronoi) tiles } \description{ A method for \code{plot}. Plots (sequentially) the tiles associated with each point in the set being tessellated. } \usage{ \method{plot}{tile.list}(x, verbose = FALSE, close = FALSE, pch = 1, fillcol = getCol(x,warn=warn),col.pts = NULL, border=NULL, showpoints = TRUE, add = FALSE, asp = 1, clipp = NULL, xlab = "x", ylab = "y", main = "", warn = FALSE, ...) } \arguments{ \item{x}{ A list of the tiles in a tessellation, as produced the function \code{\link{tile.list}()}.} \item{verbose}{ Logical scalar; if \code{TRUE} the tiles are plotted one at a time (with a ``Go?'' prompt after each) so that the process can be watched.} \item{close}{ Logical scalar; if \code{TRUE} the outer edges of of the tiles (i.e. the edges which are contained in the enclosing rectangle) are drawn. Otherwise tiles on the periphery of the tessellation are left ``open''.} \item{pch}{The plotting character (or vector of plotting characters) with which to plot the points of the pattern which was tessellated. Ignored if \code{showpoints} is \code{FALSE}.} \item{fillcol}{Optional vector (possibly of length 1, i.e. a scalar) whose entries can be interpreted as colours by \code{\link{col2rgb}()}. The \eqn{i}-th entry indicates with which colour to fill the \eqn{i}-th tile. Note that an \code{NA} entry indicates the use of no colour at all. This argument will be replicated to have length equal to the number of tiles. } \item{col.pts}{Optional vector like unto \code{fillcol} whose entries can be interpreted as colours by \code{\link{col2rgb}()}. The \eqn{i}-th entry indicates with which colour to plot the \eqn{i}-th point. This argument will be replicated to have length equal to the number of tiles. Ignored if \code{showpoints} is \code{FALSE}. } \item{border}{A \emph{scalar} indicating the colour with which to plot the tile boundaries. Defaults to black unless all of the fill colours specified by \code{fillcol} are black, in which case it defaults to white. If \code{length(border) > 1} then an error is given. } \item{showpoints}{Logical scalar; if \code{TRUE} the points of the pattern which was tesselated are plotted.} \item{add}{ Logical scalar; should the plot of the tiles be added to an existing plot? } \item{asp}{The aspect ratio of the plot; integer scalar or \code{NA}. Set this argument equal to \code{NA} to allow the data to determine the aspect ratio and hence to make the plot occupy the complete plotting region in both \code{x} and \code{y} directions. This is inadvisable; see the \bold{Warnings}.} \item{clipp}{An object specifying a polygon to which the tessellation being plotted should be clipped. It should consist either of: \itemize{ \item a list containing two components x and y giving the coordinates of the vertices of a single polygon. The last vertex should not repeat the first vertex. Or: \item a list of list(x,y) structures giving the coordinates of the vertices of several polygons. } If this argument is provided then the plot of the tessellation is \dQuote{clipped} to the polygon specified by \code{clipp}. } \item{xlab}{ Label for the \code{x}-axis (used only if \code{add} is \code{FALSE}).} \item{ylab}{ Label for the \code{y}-axis (used only if \code{add} is \code{FALSE}).} \item{main}{ A title for the plot (used only if \code{add} is \code{FALSE}).} \item{warn}{Logical scalar passed to the internal function \code{getCol()}. Should a warning be issued if the \code{z} components of the entries of \code{x} cannot all be interpreted as colours. See \bold{Details}. } \item{...}{ Optional arguments; not used. There for consistency with the generic \code{plot} function.} } \section{Warnings}{ \itemize{ \item The behaviour of this function with respect to \dQuote{clipping} has changed substantially since the previous release of \code{deldir}, i.e. 1.1-0. The argument \code{clipwin} has been re-named \code{clipp} (\dQuote{p} for \dQuote{polygon}). Clipping is now effected via the new package \code{polyclip}. The \code{spatstat} package is no longer used. The argument \code{use.gpclib} has been eliminated, since \code{gpclib} (which used to be called upon by \code{spatstat} has been superceded by \code{polyclip} which has an unrestrictive license. \item As of release 0.1-1 of the \code{deldir} package, the argument \code{fillcol} to this function \emph{replaces} the old argument \code{polycol}, but behaves somewhat differently. \item The argument \code{showrect} which was present in versions of this function prior to release 0.1-1 has been eliminated. It was redundant. \item As of release 0.1-1 the \code{col.pts} argument \emph{might} behave somewhat differently from how it behaved in the past. \item The arguments \code{border}, \code{clipp}, and \code{warn} are new as of release 0.1-1. \item Users, unless they \emph{really} understand what they are doing and why they are doing it, are \emph{strongly advised} not to set the value of \code{asp} but rather to leave \code{asp} equal to its default value of \code{1}. Any other value distorts the tesselation and destroys the perpendicular appearance of lines which are indeed perpendicular. (And conversely can cause lines which are not perpendicular to appear as if they are.) } } \section{Notes}{ \itemize{ \item If \code{clipp} is not \code{NULL} and \code{showpoints} is \code{TRUE} then it is possible that some of the points \dQuote{shown} will not fall inside any of the plotted tiles. (This will happen if the parts of the tiles in which they fall have been \dQuote{clipped} out.) If a tile is clipped out \emph{completely} then the point which determines that tile is \emph{not} plotted irrespective of the value of \code{showpoints}. \item The new behaviour in respect of the colours with which to fill the plotted tiles, and the argument \code{clipp} were added at the request of Chris Triggs. \item The argument \code{asp} was added at the request of Zubin Dowlaty. } } \value{NULL; side effect is a plot.} \author{Rolf Turner \email{r.turner@auckland.ac.nz} \url{https://www.stat.auckland.ac.nz/~rolf} } \seealso{ \code{\link{deldir}()}, \code{\link{tile.list}()} \code{\link{triang.list}()} \code{\link{plot.triang.list}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) z <- deldir(x,y,rw=c(0,1,0,1)) w <- tile.list(z) plot(w) ccc <- heat.colors(20) # Or topo.colors(20), or terrain.colors(20) # or cm.colors(20), or rainbow(20). plot(w,fillcol=ccc,close=TRUE) if(require(polyclip)) { CP <- list(x=c(0.49,0.35,0.15,0.20,0.35,0.42, 0.43,0.62,0.46,0.63,0.82,0.79), y=c(0.78,0.86,0.79,0.54,0.58,0.70, 0.51,0.46,0.31,0.20,0.37,0.54)) plot(w,clipp=CP,showpoints=FALSE,fillcol=topo.colors(20)) } } \keyword{ hplot }