deldir/0000755000176200001440000000000014567527702011534 5ustar liggesusersdeldir/NAMESPACE0000644000176200001440000000077614134623553012754 0ustar liggesusers # Export everything exportPattern("*") S3method(plot,deldir) S3method(plot,tile.list) S3method(plot,triang.list) S3method("[",tile.list) S3method("[",triang.list) S3method(divchain,default) S3method(divchain,deldir) S3method(plot,divchain) S3method(print,tileInfo) S3method(print,deldir) importFrom("grDevices", "col2rgb", "rgb") importFrom("graphics", "axis", "box", "par", "plot", "points", "polygon", "rect", "segments", "text", "title") importFrom("utils","packageVersion") useDynLib(deldir) deldir/ChangeLog0000644000176200001440000012370514567246361013315 0ustar liggesusers Version 2.0-4 27/02/2024 Added an informative (???) error message to handle the setting in which all points lie on a vertical or horizontal straight line (whence the rectangular window cannot be inferred from the data). Version 2.0-3 06/12/2023 Added the argument "axes" to plot.tile.list(), to permit the suppression of the plotting of axes marked with a numeric scale. Argument added at the request of Damon Tutunjia. Adjust the help file for plot.tile.list(). Changed the startup message. Also changed the nickname. Version 2.0-2 20/11/2023 Changed my (the maintainer's) email address to rolfturner@posteo.net. Made this change in the DESCRIPTION file and in the help files. Introduced a macro "\rolf" to go into the \author{ } field so that future changes can be effected simply by changing the macro. Version 2.0-2 is now up on CRAN. Version 2.0-1 20/11/2023 Corrected a couple of rather silly bugs (which took an enormous amount of time and effort to track down) in trifnd.f90 and stoke.f90. Both bugs involved incorrect Fortran 90 if/else syntax. Version 2.0-0 20/11/2023 Converted ratfor code to fortran 90 code (placing the latter into the "src" directory). Version 1.0-12 23/11/2023 While debugging the new Fortran 90 based version (see above) of this package it became clear that an if/else structure in trifnd.r was (although not actually wrong) ill-constructed. I corrected this defect, making the code consistent with the corresponding code in trifnd.f90. Version 1.0-11 18/11/2023 Changed insidePoly() so that tolerance can be specified by the used, rather than being hardwired to the value sqrt(.Machine$double.eps). This necessitated changing the structure of insidePoly.R so as *not* to use local(). Version 1.0-10 17/11/2023 Corrected a bug in insidePoly(); I had misunderstood the sanity check in spatstat.utils::inside.xypolygon(), which issues a *warning* if not all entries of "score" are 0 or 1, but describes this as being an "internal error". So I had made insidePoly() throw an error in this circumstances; I shouldn't have! The errors thrown are spurious. I have now changed the error to a warning, and added an argument "sanityCheck=FALSE"; the warning is issued only if sanityCheck is set to TRUE. Also introduced "%~%" (almost equal). Using this in place of "==" seems (???) to do a better job of determining boundary points correctly. Thanks to Huimin Wang whose enquiry about inexplicable crashes in tileInfo() disclosed the aforementioned bug.` Version 1.0-9 17/05/2023 Got rid of a spurious file tile.list.R that I had saved as a backup in the Deldir directory. Psigh!!! Version 1.0-8 30/04/2023 Added argument "id" to deldir(), allowing the user to specify a vector of identifiers/names for points. Added at the request of Jiangyao Chi. In view of the foregoing, the identifiers of points need no longer be numeric indices, whence some of the terminology in plot.deldir() and plot.tile.list() was no longer appropriate. Consequently: * changed name of argument "number" to "labelPts" in plot.deldir() and in plot.tile.list(). * changed name of argument "nex" to "lex" in plot.deldir(). * changed the name of the 4th component of the argument cmpnt_col in plot.deldir() from "num" to "labels". Added function getNbrs() to list the Delaunay neighbours of each point. Added at the request of Jiangyao Chi. Added functions insidePoly() and insideRect() to determine whether points are inside an "interior" region which may be specified either as a polygon or a rectangle. In the latter case the interior must be a subset of "rw", the rectangular window with respect to which the points are being triangulated/tessellated. Added the results of a call to getNbrs() to the output of tileInfo(); adjusted print.tileInfo() accordingly. Fixed a mild glitch in plot.tile.list(); the returned value was NULL if clipp was unspecified. Corrected the help for plot.tile.list() which had said that the returned value was always null. Tidied the code of plot.tile.list() a bit. Amended the help for plot.tile.list(). Adjusted message in First.R. Version 1.0-7 26/12/2021 The function tileInfo() threw an opaque error if all tiles were boundary tiles. Added an error trap so as to produce a more perspicuous error message. Thanks to Krisztina Konya of Ruhr-University Bochum who provided an example illustrating the need for this error trap. Version 1.0-6 23/10/2021 Fixed a bug that kept deldir() from working when "x" is a point pattern. Version 1.0-5 10/10/2021 Changed the protocol for "digging out" x and y, and "digging out" z. The rule now is: if the specified argument is found (located in the global environment, or given explicitly) then *use* it! Only if it is *not* found elsewhere should it be sought in the "x" argument. (This change was implemented after Duncan Murdoch convinced me to see the error of my previous ways.) Adjusted/corrected the processing of generic lists, as the x argument, in deldir() Re-wrote the discussion of the argument processing protocol in deldir.Rd, so as to make it properly reflect the current behaviour of the function. It is also hoped that the clarity of the discussion has been improved. Fixed various glitches and typos in the code and the help files. Version 1.0-4 06/10/2021 Fixed more bugs in deldir() w.r.t. argument processing, again pointed out to me by Duncan Murdoch. Fixed a bug in triang.list(); it crashed if there were not any actual triangles in the "triangulation"! Made an adjustment to plot.triang.list() (added an argument to specify a colour for the enclosing rectangle. Version 1.0-3 06/10/2021 Fixed bug in deldir() (more explicitly in digOutz()) that was pointed out to me by Duncan Murdoch. Version 1.0-2 05/10/2021 Adjusted plot.deldir() so that it no longer insists that cmpnt_lty be numeric, but also allows (as it should) the text strings "solid", "dashed", "dotted", "dotdash", "longdash", and "twodash". Version 1.0-1 30/09/2021 Modified deldir() so that if argument "x" is a data frame it is *NOT* required to have columns named "x" and "y". If there is no column named "x", the x-coordinates are taken to be the *first* column named neither "y" nor "z". Likewise if there is no column named "y", the y-coordinates are taken to be the *first* column that is named neither "x" nor "z" and is not equal to the column previously selected to be the x-coordinates. Also modified deldir() so that the "x" argument is allowed to be a matrix. The same convention that was used when "x" is a data frame is applied. This modification was made in response to an observation made by Jakob Bossek and makes use of a suggestion from Duncan Murdoch. Version 1.0-0 27/09/2021 Removed/eliminated all traces of the (basically useless) facility for incorporating dummy points into the triangulation/tessellation. This facility was a historical artefact that had hung around much too long. Made an adjustment to plot.tile.list(); it no longer throws an error if the border argument is of length greater than 1; it now simply uses the first entry. 29/09/2021 Ran the *.Rd files through ispell and found and corrected an embarrassing number of errors. Did not increment the version number. Version 0.2-13 26/09/2021 Made some adjustments to the syntax of deldir() to accommodate problems encountered with finding the "z" argument. Changed the position of "z" in the argument list (to follow "x" and "y"). Got rid of the message being issued on the first call, and the suppressMessage argument. Version 0.2-12 28/05/2021 Adjusted the application of "\dontrun{...}" in the help files, eliminating its unnecessary application in some instances, and replacinng it by "\donttest{...}" in one instance. Version 0.2-11 12/05/2021 Changed the terminology in the help and code comments so as to refer to the entries of the "z" argument as "tags" and not as "weights". The latter term is misleading. Adjusted divchain() so as not to insist that the "z" argument be a factor. It may now be a factor or a vector of any mode. If is not a factor then it is coerced into one. Added a "tags" component to the list returned by lawSummary(). (This was instigated by an enquiry from Art Stock.) Version 0.2-10 09/02/2021 Added the cvt() (Centroidal Voronoi Tiles) function at the request of Michaél Aupetit. Amended deldir() so that the returned object has attributes "round" (TRUE if argument "round" was TRUE) and "digits" (equal to the value of argument "digits" if "round" is TRUE, equal to NA otherwise.) Made some adjustments to the help for deldir() and plot.tile.list(). Changed the name of Vol.Tri.Points to volTriPoints, so as to make it more consistent with my usual naming conventions. Added the "\version" macro. 10/02/2021 Made some adjustments to the help for cvt(). 16/02/2021 Submitted to CRAN Version 0.2-9 16/01/2021 Fixed (???) a bug in doClip() revealed by reverse-dependent package visualFields. My logic (using almost.match()) was completely out to luntch. Got rid of almost.match() and introduced a new function findNewInOld() which I *think* does things right. Adjusted tile.list() so that when it clipps tiles it checks for the availability of the polyclip package (and throws an error if this package is not available). Adjusted the help for plot.tile.list(), doing the same re-arrangement of plotting colours in one of the examples, as is used in the help for tilePerim(). The re-arrangement serves to produce better contrasts between contiguous tiles. Version 0.2.8 09/01/2021 Changed the URL in the help for Vol.Tri.Points from http://www.gwsdat.net (insecure) to https://protect-au.mimecast.com/s/demRC91WzLH6qo3TorzN7?domain=gwsdat.net (kludgy but secure). Corrected a typo in the help for Vol.Tri.Points. Version 0.2-7 07/01/2021 Fixed a problem that the Debian compiler objected to; changed calls, in succ.r, to intpr() of the form "... -1,i,1)" to "... -1,ndi,1)" where ndi (dummy integer) is an integer array with ndi(1) = i. This is to satisfy the idiosynchrasies of the compiler that Debian uses. Added the Vol.Tri.Points data set provided by Wayne W. Jones Version 0.2-6 05/01/2021 Fixed bug whereby inadquate memory allocation for the adjacency list went undetected. Problem point out by Wayne Jones. Version 0.2-5 29/12/2020 Made adjustments to tile.list() so that the listed tile could be clipped by a specified polygon, in the same manner as that in which tiles were clipped in the past by plot.tile.list(). This adjustment was made at the request of Vasileia Papathanasopoulous. Note that plot.tile.list() retains the capacity to clip the tiles, but if the tiles have *already* been clipped by tile.list() then an error is thrown. Changed the default for the "warn" argment in plot.tile.list() from FALSE to TRUE. Made the necssary corresponding adjustments to tilePerim() so that it can handle clipped tiles. Added a "clipp" argument to tileInfo() so that the tiles in question can be clipped. Amended tileInfo() so that it now includes tile perimeters in the information summary produced. Adjusted naming conventions slightly so that names are of the form "pt.1", "pt.2", ..., rather than "tile.1", "tile.2", .... Version 0.2-4 09/11/2020 Fixed glitches in plot.deldir() --- replaced as.vector() by unlist(). If x is a list, as.vector(x) is the same as x!!! (A list *is* a vector!!!) Version 0.2-3 06/11/2020 Fixed up glitch in binsrt.R --- was still using "nerror", although this argument had been eliminated from the ratfor code in binsrt.r. Adjusted init.c appropriately. Eliminated redundant variables ntpm (succ.r) and anticl (swap.r). Submitted to CRAN 06/11/2020. Version 0.2-2 05/11/2020 Adjusted calls to intpr() in the Ratfor/Fortran, changing "... -1,0,0)" to "... -1,ndi,0)" where ndi (dummy integer) is an integer array. This is to satisfy the idiosynchrasies of the compiler that Debian uses. Tested using rhub, 05/11/2020, with the call: check("deldir_0.2-2.tar.gz",platform="debian-gcc-release") Tested OK. Submitted to CRAN 05/11/2020. Version 0.2-1 25/10/2020 --- 31/10/2020 Got rid of the kludgy "nerror" construction in the Fortran/Ratfor code and replaced it with appropriate use of calls to the rexit() subroutine. (See Writing R Extensions 6.2.1.) Since this is a fairly major change, I kicked the version number up from 0.1-* to 0.2-*. Tidied up this ChangeLog!!! Changed the procedure for producing messages when storage needs to be incremented so that it uses the message() function rather than cat(). Whence the user can suppress these messages, if it is so desired, by using suppressMessages(). Added comments to this effect to the help for deldir. Adjusted the "history" of the package in the help for deldir, to make it more appropriate to current circumstances. Amended the package startup messages. Removed the somewhat antiquated initial message that was put out by deldir on its initial call. Revised the DESCRIPTION to make the package depend on R >= 4.0.0. (Otherwise the calls to labelpr() cause a failure to load the package.) 01/11/2020 Revised the ratfor code to use intpr() and *not* labelpr(), so as not to cause undue hardship to those for whom upgrading to R >= 4.0.0 is not under their control. Backed off on making deldir depend on R >= 4.0.0. 02/11/2020 Added a "nickname" in First.R 04/11/2020 Commenced process of submitting to CRAN ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-29 07/09/2020 Changed the names of arguments "col" and "lty" of plot.deldir() to "cmpnt_col" and "cmpnt_lty" so that "col" (in particular) can be passed as a "..." argument. Restructured these arguments as *named* vectors or lists. Re-wrote the help file accordingly. Revised the examples for plot.deldir(). Added an argument "asp" (aspect ratio), defaulting to 1, to plot.deldir(). This should have been present all along. Dunno what I was thinking. Got rid of the call to par() setting pty="s"; dunno what I thought this was accomplishing. (Probably thought it was doing what setting asp=1 actually *is* doing. Adjusted the code so that one can effectively pass pty="s" as a "..." argument, so as to be able to reproduce old results *exactly*. Changed the "plotit" argument of deldir() to "plot"; the "plotit" name was a hangover from the dark ages. It has not been necessary, for decades, to avoid function names as the names of (non-function) arguments. Uploaded to CRAN 13/09/2020. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-28 15/07/2020 Removed a browser() call that I'd left lying around in deldir(). Grrrrrr!!!! Uploaded to CRAN 15/07/2020. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-27 15/07/2020 Fixed a bug in deldir(), w.r.t. the lengths of vectors x and y after duplicated points have been eliminated. (Revealed by CRAN having tested an example in the grapherator package, which depends on deldir. Added a data set "grapherXmpl" which is taken from the example in the grapherator package. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-26 14/07/2020 Fixed a bug in tile.list(); sometimes the edges of the tiles could be effectively of zero length, possibly resulting in an "invalid" tile. Added an argment minEdgeLength to tile.list() specifying the smallest value that an edge length can have. This defaults to sqrt(.Machine$double.eps) times the length of the diagonal of the rectangle. Thanks to Kodi Arfer for pointing out this problem. Added argument "round" (defaulting to TRUE) to deldir(). If round==FALSE then rounding is no longer done. Added function print.deldir() which prints out a a very brief description of an object of class "deldir" as returned by deldir(). Fixed a bug in deldir; if the points got clipped to a specified rectangular window ("rw") then "n", the number of points,` was wrong. Made corresponding adjustments to "ind.orig". ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-25 03/02/2020 Fixed up error message calls to intpr() which no longer work with the gcc 10 compiler. A call of the form call intpr("Point number =",-1,j,1) no longer works. One must do tmp(1) = j call intpr("Point number =",-1,tmp,1) i.e. the penultimate argument has to be a vector. Many thanks to Elliott Sales de Andrade for pointing out the problem and the fix. Uploaded to CRAN 03/02/2020 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-24 01/08/2019 Added a bit of clarification to the error message "Cannot find an enclosing triangle" in the trifnd subroutine. (Used intpr() to print out the number of the point being added. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-23 31/07/2019 Fixed a bug in storage allocation which arose (only) when the storage allocation had to be increased. Thanks to Frederic Pons (of "Service Risques Inondations Littoraux et Hydraulique") who provided a data set which revealed the bug (during the course of investigating error messages that were generated). Improved a couple of error messages produced by subroutines circen, qtest1 and trifnd. Submitted to CRAN 31/07/2019. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-22 23/06/2019 Added a "drop=FALSE" argument to the line mm <- m[match(theta.0, theta),] in tile.list.R, changing it to mm <- m[match(theta.0, theta),,drop=FALSE] to guard against an infelicity that *could* (???) arise if theta.0 turned out to have length 1. This was motivated by an error message that Vitor Sampaio received when he used adaptive.density() in spatstat. The error went away when he re-started R (!!!) but seemed to have been triggered by such an infelicity. I don't *think* theta.0 could ever have length 1 in real life, but the "drop=FALSE" doesn't hurt. Fixed an error in master.r that was introduced in version 0.1-16 when I fixed the bug in trifnd.r that was pointed out by Adam Dadvar. In adding a line to master.r I inadvertently deleted the line "if(nerror>0) return" after the call to the "addpt" subroutine. Consequenty the "madj" parameter/dimension did not get incremented when this was called for. As a result (the intricacies of which I have not investigated) a "nerror = 1" condition was induced later on. Thanks to Peter Bastian for pointing out the problem. Adjusted deldir() to throw a "graceful" error if there is only one point in the pattern and no dummy points. Previously this situation led to an un-graceful error. (Previously an error was thrown only if there were zero points in the pattern; this is insufficiently stringent.) Submitted to CRAN 05/07/2019. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-21 15/06/2019 Fixed yet another screw-up in init.c in src; the specifications for "master" were wrong (as a result of the removal of a couple of unused arguments from the "master" subroutine). Submitted to CRAN 15/06/2019. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-20 12/06/2019 Fixed several infelicities in the ratfor/fortran code in respect of variables being declared or appearing as arguments but never being used. Removed redundant fexit* files from src; these were generating spurious warnings (and should of course have been removed as soon as I switched from fexit* to rexit). Submitted to CRAN 14/06/2019. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-19 11/06/2019 Submitted to CRAN 11/06/2019. However it was never installed on CRAN due to problems arising from redundant fexit* files having been lying around in src. (See above.) Made substantial revision to the lawSummary function, after lengthy email discussions with Kai Xu. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-18 22/02/2019 Added the function lawSummary (at the request of Kai Xu). Changed trifnd.r to call rexit rather than calling fexit (which in turn calls fexitc). The subroutine rexit is (now) provided automatically by R. This change was made at the behest of Brian Ripley. Documented lawSummary(); revised this function in accordance with Kai Xu's suggestions. 04/06/2019. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-17 Corrected the help file for deldir; removed reference to "vi3" (which no longer exists) in the description of the "dirsgs" component of the object returned. Added in a new function lawSummary() at the request of Kai Xu. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-16 30/12/2018 Added error traps in trifnd.r to avoid going into an infinite loop when a certain sort of collinearity problem arises. Thanks to Adam Dadvar who drew my attention to the problem and provided a data set to illustrate the problem Added the data set "niProperties" (kindly provided by Adam Dadvar) to illustrate collinearity problems Further revised the help page for deldir, giving some explanation of the error traps and error numbers. Uploaded to CRAN 04/01/2019 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-15 01/04/2018 Changed the example in triMat.Rd to use the data with which Jay Call illustrated the bug in the former (buggy) version of triMat(). Added an "axes" argument to plot.deldir(), defaulting to FALSE. Made xlab and ylab default to "x" and "y" if axes is TRUE and to "" if axes is FALSE. Modified tile.list() (and the internal function acw() upon which it depends) for speed-up, at the suggestion of Jean-Romain Roussel. Registered S3 method "[.triang.list" (previously had methods plot.deldir, plot.tile.list, plot.triang.list, [.tile.list, divchain.default, divchain.deldir, plot.divchain and print.tileInfo registered, but "[.triang.list" had been omitted. Uploaded to CRAN 01/04/2018 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-14 20/03/2017 Corrected a mild infelicity in respect of the rownames of the "summary" component of the object returned by deldir. Made a corresponding adjustment to tile.list.R (triang.list.R was already OK) and tidied up the help files. Added a "..." argument to plot.tile.list() (to be passed on to points() and/or text()). Added function tileInfo to summarise information about tiles, at the request of John Bothwell. Added a facility to plot.tile.list() to append the point *numbers* to the plot, with a reasonably minimal amount of effort. Added a print method to objects of class "tileInfo". Made some corrections and amendments to the help files tile.list.Rd and plot.tile.list.Rd. Wrote help files for tileInfo() and print.tileInfo(). Made a minor adjustment to tileInfo(), making the "indivTiles" component of the returned value into a *named* list (with names of the form "tile.ptNum"). Adjusted the help file for tileInfo() accordingly. Rewrote triMat() after a bug in it was pointed out to me by Jay Call. Uploaded to CRAN 22/04/2017 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-13 21/07/2016. Corrected the rownames of the "summary" component of the object returned by deldir(). Previously these were the indices of the points in their bin-sorted order; when "allsum" gets sorted back into the order of the original points the rownames were retained, in their sorted order. This made them look anomalous. Thanks to Pablo Araya-Melo for pointing out this Added the function which.tile() at the request of "RAY". Documented the function which.tile() --- !!! problem. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-12 05/03/2016 Changed the "binsrt" procedure back to using Fortran/Ratfor code but with the code being called directly by .Fortran(), outside of the .Fortran() call to "master". Adjusted the code in binsrt.r to calculate "rind" as well as "ind". Uploaded to CRAN 06/03/2016. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-11 04/03/2016. Changed deldir to do "binsrt" in R code rather than Fortran/Ratfor. Thus we now get the Fortran code to work just with the re-ordered data as if they were the original data, and then adjust the order after the return from the Fortran call. Changed the code of deldir so that the data frame "dirsgs" in the returned list has two new columns "thirdv1" and "thirdv2" which along with "ind1" and "ind2" serve to provide unique identifiers for the endpoints of the tile edges. The code of deldir now explicitly recognises if the argument "x" is of class "ppp" (i.e. is a spatstat planar point pattern) and if "x" is marked and the marks are a vector or a factor and if "z" is NULL, then it sets z equal to the marks. Added function divchain() (generic), divchain.default() and divchain.deldir() to calculate the dividing chain for a tesslation that has been provided with a vector of categorical "weights". Also added a plot method plot.divchain() to plot dividing chains. Fixed the "rw" argument to accept a couple of forms other than c(xmin,xmax,ymin,ymax). Explicitly a spatstat "owin" object and a matrix such as determines a bounding box for a set of polygons in the "sp" package. (Suggestion of Michael Chirico, 23,24/09/2015.) ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-10 10/03/2015. Amended the examples in deldir.Rd to alleviate a possible point of confusion pointed out by Samuel Ackerman. Fixed some typos in deldir.Rd, duplicated.Rd, plot.tile.list.Rd and plot.triang.list.Rd. Added "point type" ("data" or "dummy") information to the lists produced by tile.list() and triang.list(). (This information is present only if there are dummy points specified in the call to deldir(). Fixed a few more glitches in the documentation. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-9 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. Uploaded to CRAN 09/03/2015. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-8 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. 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. Changed triang.list() to make use of the "original coordinates" referred to above. 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. Uploaded to CRAN 09/03/2015. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-7 26/08/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. 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. 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.) Uploaded to CRAN 26/11/2014 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-6 18/05/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. 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). Slight adjustment made to plot.tile.list.Rd Uploaded to CRAN 03/08/2014 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-5 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.) Uploaded to CRAN 02/02/2014 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-4 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. Uploaded to CRAN 31/01/2014 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-3 28/01/2014 Fixed up references to my web page to refer to my New Zealand web page. 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. Uploaded to CRAN 30/01/2014 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-2 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). Uploaded to CRAN 01/10/2013. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.1-1 02/10/2013 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/10/2013 ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.0-22 17/04/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/10/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/09/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/04/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/04/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/04/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/11/2011 Fixed some minor errors in the documentation. Added a namespace. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.0-15 12/08/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/06/2011 Put the startup messages into packageStartupMessage() rather than catting them. At the request of Thierry Onkelinx. ===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+===+=== Version 0.0-13 29/11/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/01/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/12/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/11/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/11/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/04/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/02/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/data/0000755000176200001440000000000014134624505012432 5ustar liggesusersdeldir/data/volTriPoints.rda0000644000176200001440000000535614567246576015631 0ustar liggesusersXyTS쫀( (c_&"FA !,.l.JDDBpE@..($wi{od7o\ P)M"DIbSDISxU1QM$FlPzx098lk4E['y^Q[`zʹc3PnI鹧TA؄K~}ʗ7AKnSiگ,q<ϾOjxD|ɗ﯎'^:APnrK^%lg7, `3X[{.v/x}bѼ'TzŹf FǜbXZrAޟbeZfYYdzxD>$Wd~F./fT\fh[B^>*-I֕~=]EGԧ+<ֲYw}n}v^ke,|4 ^Mˢԃ>1}~0_'gåuuy0 bnSDDYxB4U#th/+]]9+H rL2٠ fva LTNx.V+Aq5Z2mϫseO;i `IRk`kYǚ`92*>Ńqavr,Ţ`yFʦ30?s,˽E-`1bMuE i.˪M7/,EN7)kK㭸{y>*Rl+|gM][Eד| \(Ѕ@?-П8WF'=oWk|[avӾB_l*+߿ʔH~cm3]q;Jp o pyҒS Һ! ޶gW > j]AvH1@mYfDPOv}=]Ƌ.{ns}Oh7h${TtntIC|ΦCⓎNUYgґBv@^j9Vj(mI5Dʧkkkχɰ:H_o׻`9{7dǴ;@ (ȕY:l/>ݨ헆ͅjqTrriJۨi ܏o翀\_o?'4?aB0'|@J "@pxxO+)DVePHO&*gC~" w+'I<\dEUy3Ѿe۞k؀*v;|ݥ $"$ >h:Tz6?q(@+sNQS 7XG̴"z & U:QB gJt)|kѐ+.|uYo1%8*>C]I]%L9{oGUصk)tws`gɓ3lf ۳P3a\2`3>6~$w| o~ud|t2r/};%qnniS+z;5Xx,XVݔgrͬM&`-Ac#4СD6@XJEJs{n`#5pX QKsgb|+S)DqV*,̭̏ăK%o~kïsӕ:>׃GtΊ^HG] V+s 9|ZS|XScNOƩ{tx\0z];vF5ml!+Г}UW>OQ 5yWx#y34 MoJ9 LJא쫖%aҙR$oqC`.5Wv7yXqɵ!t ص=rYW%݀QUl,ͱkt9h8&EW3J鰱n <Ȅ3@Yx~N?cX|V,Q7]ŷv!rТpE DU1q?c_ /÷ߩa~G*>(ͯlWb0N*|3G?VWDw}E'7J&~+bx&*deldir/data/niProperties.rda0000644000176200001440000000623114567246576015631 0ustar liggesusers]Wy\ h[)p' mVZhlE!d" dT#W(1斴Rh~?}9Ys﮲Yk8abp,1P2,92<"02:$0``Hﳀx;1aHt;\j]um]]ӊ\or'\f }n@HHp<}V,o?MyDJ"<zj/\gE: `WPK 述J:_x ^#\3}=byU 6}<=ָɛT𮿯z-S{ezL0P"YozcI 1lw~Q\Iv^~D:G$wBcD4ОxXg#u5g@\*sZ}xہnԑ}iЛ^εGfGiڡ=S-#?R]!޷8{/sJJr9쯪/o"Tʶ`7Qbkjk:s~^؝T糓#ssCniQ6~<խz\'>Kpy/{7q?+7O ){?w#泩.1*}TA~<;)fK)˰EP"Wcide/㾿&^ #|,1׆ߏ߇<@ c ħ Ahd/-oTdg\\Wk?4bᇧUAL-}_"x sFt})цxR 𵣏K>lݧi^W 8kȃ5!P=i,yfQ/~7p!ZҀZ>{_Wi,*΁o".P^&T ɞqX+~feG|j`=,$Og`tf>rBfddFrh1S؀{+Ǽ>4~;Qvx\\L6"a?2W-wnD|S_hvb6_KS  _Q5n3w3vzKO"K/\q>/ OhzOh ̩hWs[C~mͣhOڞ%=E#uƴG[= [,C {߱I#IWb.}i3{Na?VgYW|:~;k ?띉֍`Z{(}ɐE=E8b`2S uizg,|',u Jh-2:ǫb؃%؟rq\;ڷ}` q݁/֫Ox4ԉeUCz!R}Gᔎ}z5Nߛ nRe5o'>|UʣܾRxB1=le&se;R*}&Е (Yd,IyL=u癶]h ԪqO M^k.'8Q| %(N7A@gY]ԇtHy. tDr3ivįH {#аvim1ŧg{\]6`@6~WhIa`;$O #{e;^Ul=3۠C޿}vvT<*wS]M7'~u5p16DŽI\ڼē1]rܯWW%"7] ?{b`QCROuW>xY4ݑAx6,jEI_ } 2Fn]8a _S$o2[iTof@<ǕyFX\4џ3BU;ʧR:kޞg;z#g?G{k?C+OJt:+c)M+)ٝLqX qe:Tg9FmU1PzO<6R*hkOc r]4 =Z{C㡚hg.'^@>N?7pdeldir/data/seaweed.rda0000644000176200001440000000232214567246576014560 0ustar liggesusers]wlWU(ZmEā#qĠ(*.;"* 5 GPPT -5%N۸@l&MsϽ{ϺqǏ_%"&nbZaSu[&e"3|]He^;G2 c? 1}{[,9\ g#/^sUOПƷ}l7!{G?{|k G_cƺK2Y<臲0d;ރf٫_ބm=8ÏȉC̺yfP\X4o9Xd27NW9 Ñ? ְ݄1w;$d2?z%.A\t.YC,bP{|V|c.vq#̷>t!U><&apiSn=:U|aSޘ1cy%:<^񓐬9y,sJCm֐Ê|+J~wtb;"xƏcݩ.]3%ߗ3OϜvqyې؋? ۿ=~p!܃-6gQs7 ۨeӡE} G/ʜⓍ`ӬŨ ˺aأQ`OB~ˉt r&rvLbo^23y',DoXFẸ}y'_CJ'*?u2}O5Y;=ʹU5zc2t_r^N׋skըU⧑/s7]De䃾 Joү[W][瑏k2Ǎ[e0({ z0:{V/GfN>5>0M{^e33wZV:p'pټF_ǡ#E} -U}ԎŽY?|cAw) W'&[Z |K |O약5Hzmc8qϣPς@nxBKo^s wr¹{© .|I!̎zy^̞ԉS2TFqtEWoh.,.J[7-3VMo17[>ij눾/D\滃W! deldir/data/toyPattern.rda0000644000176200001440000000210214567246576015310 0ustar liggesusersuU}Lg't✒ 7fAKؖHW=ڦU6}8uT溑8id:&ՀBRjF޹ $y~{=P\/SES,CS4#,-Q,"^2KyI,Fb +?5)R⍛EAV摔_]U' h$pV%3zN2ՂUd2j0nE9h:fM f XU՚F2@Yӊ/͂ZlE>]#! 3P5"T*)@Z|c(ce tKY)q8ĥ3dLFɉ6szWOo\uqi{GYxʇ:7́}.FIhI2`Vҟ$E$oٍ|/tCG*2 뽴1~h~># ".WxVأ `y/o{ӳsIkI}O=QB#A؂}$_{n=KFuG0xj _zя]E6/߹6oA,x볜>o̺67@-乳.o/jޏ<kD|/\ܧǁ{/¯ýGl-_$}uȺEޓ/yd߹h=:^\;|,G|)c3<["t`wۉC}uuJm@|13>߳>5ܣU=6EveP~_'9 6/ NV$-X?U4z6"npdPK@֊y= ⷂLP&"|2~qMoI; p|d +NyN30 il&N$a41:?cj*3v-' 5.[uxUPJU4o=sX7jDFUئ ? ekRK3ffs,5/ۇ_deldir/data/grapherXmpl.rda0000644000176200001440000000050714567246576015437 0ustar liggesusers r0b```b`afb`b2Y# 'N/J,H--a``+e`_ P` =tɀ col(ldm)] <- vldm ldm[row(ldm) <= col(ldm)] <- 0 ldm <- (ldm + t(ldm))/2 rownames(ldm) <- LETTERS[1:5] colnames(ldm) <- LETTERS[1:5] # Data to be triangulated. id <- c("A","B","C","D","E") x <- c(0.5,1,1,1.5,2) y <- c(5.5,3,7,6.5,5) dat_Huang <- data.frame(id = id, x = x, y = y) # Form the triangulation/tessellation. dH <- deldir(dat_Huang) # Plot the triangulation with line widths proportional # to "linguistic distances". all_col <- rainbow(100) i <- pmax(1,round(100*vldm/max(vldm))) use_col <- all_col[i] ind <- as.matrix(dH$delsgs[,c("ind1","ind2")]) lwv <- ldm[ind] lwv <- 10*lwv/max(lwv) plot(dH,wlines="triang",col=use_col,showpoints=FALSE, lw=lwv,asp=NA) with(dH,text(x,y,id,cex=1.5)) } \keyword{ hplot } deldir/man/plot.triang.list.Rd0000644000176200001440000000477014527537427016022 0ustar liggesusers\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, rectcol="black", ...) } \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{rectcol}{ Text string or integer specifying the colour in which the enclosing rectangle should be plotted. Ignored unless \code{showrect} is \code{TRUE}. } \item{\dots}{ Arguments passed to \code{\link{polygon}()} which does the actual plotting of the triangles. } } \section{Warnings}{ Users are \emph{strongly advised} not to set the value of \code{asp} (unless they really know what they are doing) 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 (who presumably knows what he is doing!). } \value{ None. This function has the side effect of producing (or adding to) a plot. } \author{\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,rectcol="green") sss <- tile.list(d) plot(sss) plot(ttt,add=TRUE,border="blue",showrect=TRUE,rectcol="red") } \keyword{ spatial } deldir/man/toyPattern.Rd0000644000176200001440000000146514134630075014741 0ustar liggesusers\name{toyPattern} \alias{toyPattern} \docType{data} \title{ A toy marked point pattern object, with 59 points. } \description{ A simulated object of class \code{"ppp"} provided for use in an example illustrating the application of \code{deldir()} to point pattern objects. } \usage{toyPattern} \format{ An object of class \code{"ppp"} consisting of a simulated marked point pattern. Entries include \tabular{ll}{ \code{x} \tab Cartesian \eqn{x}-coordinates \cr \code{y} \tab Cartesian \eqn{y}-coordinates \cr \code{marks} \tab factor with levels \code{"a","b","c","d"} } } \source{ Simulated. } \examples{ dtoy <- deldir(toyPattern) # "Tags" are the marks of the pattern. set.seed(42) dtoy.nt <- deldir(toyPattern,z=round(runif(59),2)) # Tags are numeric. } \keyword{datasets} deldir/man/print.tileInfo.Rd0000644000176200001440000000655714527537470015516 0ustar liggesusers\name{print.tileInfo} \alias{print.tileInfo} \title{ Print a summary of tile information. } \description{ Print a reasonably readable summary of an object of class \code{tileInfo} as produced by the \code{tileInfo()} function. } \usage{ \method{print}{tileInfo}(x, digits = 4, npl = 6, ...) } \arguments{ \item{x}{An object of class \code{tileInfo} as produced by the \code{tileInfo()} function. } \item{digits}{ Integer scalar. The (maximum) number of decimal digits to which the output is to be printed. } \item{npl}{ Integer scalar. \dQuote{Number per line}. It specifies the (maximum) number of values per line. Used (only) when printing the edge lengths component of \code{x}. It effects a tidy \dQuote{folding} of the printed vector of edge lengths of the tile associated with a given point. If you increase the value of \code{digits} you may wish to decrease the value of \code{npl}, and vice versa. } \item{\dots}{ Not used. Present for compatibility with the generic \code{print()} function. } } \details{ The list produced by \code{tileInfo()} is a bit messy and hard to comprehend, especially if there is a large number of tiles. This print method produces a screen display which is somewhat more perspicuous. There are four components to the display: \itemize{ \item A list, each entry of which is the vector of edge lengths of the tile. Each edge length is formatted to have a number of digits specified by the \code{digits} argument. Each list entry may be displayed over a number of lines. The first of these lines is prefixed by an \dQuote{informative} string indicating the point that determines the tile whose edge lengths are being printed. The string is formed from the identifier of the point. See \code{\link{deldir}()}, \code{\link{plot.deldir}()} and \code{\link{getNbrs}()}. The identifier may consist essentially of the index of the point in the sequence of points that is being tessellated. Succeeding lines, corresponding to the same list entry, are prefixed with a number of blanks so as to produce an aesthetically pleasing alignment. \item A table of the edge counts of the tiles. \item A simple print out of the areas of the tiles (rounded to a maximum of \code{digits} decimal digits). \item A simple print out of the perimeters of the tiles (rounded to a maximum of \code{digits} decimal digits). } This screen display is for \dQuote{looking at} only. In order to do further calculations on the output of \code{tileInfo} it is necessary to delve into the bowels of \code{x} and extract the relevant bits. } \value{ None. } \author{\rolf} \seealso{ \code{\link{tileInfo}()} } \examples{ set.seed(179) x <- runif(100) y <- runif(100) dxy <- deldir(x,y,rw=c(0,1,0,1)) ixy1 <- tileInfo(dxy) print(ixy1) ixy2 <- tileInfo(dxy,bndry=TRUE) print(ixy2) 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)) ixy3 <- tileInfo(dxy,clipp=CP) options(width=120) # And enlarge the console window. print(ixy3) # 33 tiles are retained. print(ixy3$perimeters$perComps) # The tiles for points 9 and 94 have # been split into two components. } } \keyword{ utilities } deldir/man/which.tile.Rd0000644000176200001440000000214214527537745014637 0ustar liggesusers\name{which.tile} \alias{which.tile} \title{ Determine the tile containing a given point. } \description{ Finds the Dirichlet/Voronoi tile, of a tessellation produced by \code{deldir()}, that contains a given point. } \usage{ which.tile(x, y, tl) } \arguments{ \item{x}{ The \code{x} coordinate of the point in question. } \item{y}{ The \code{y} coordinate of the point in question. } \item{tl}{ A tile list, as produced by the function \code{\link{tile.list}()} from a tessellation produced by \code{\link{deldir}()}. } } \details{ Just minimises the distance from the point in question to the points of the pattern determining the tiles. } \value{ An integer equal to the index of the tile in which the given point lies. } \author{\rolf} \seealso{ \code{\link{tile.list}()} \code{\link{deldir}()}. } \examples{ set.seed(42) x <- runif(20,0,100) y <- runif(20,0,100) dxy <- deldir(x,y) txy <- tile.list(dxy) i <- which.tile(30,50,txy) # The value of i here is 14. plot(txy,showpoints=FALSE) text(x,y,labels=1:length(txy),col="red") points(30,50,pch=20,col="blue") } \keyword{ spatial } deldir/man/seaweed.Rd0000644000176200001440000000211414423647140014177 0ustar liggesusers\name{seaweed} \alias{seaweed} \docType{data} \title{ seaweed } \description{ A data frame whose columns are the coordinates of the centroids of the cells in a seaweed frond. The points are estimates-by-eye of where the centroids of the cells occur. } \usage{data("seaweed")} \format{ A data frame with 266 observations on the following 2 variables. \describe{ \item{\code{x}}{The \eqn{x}-coordinates of the cell centroids.} \item{\code{y}}{The \eqn{y}-coordinates of the cell centroids.} } } \source{ These data were kindly supplied by Dr. John Bothwell of the Department of Biosciences, Durham University. The data were collected by Kevin Yun and Georgia Campbell, members of Dr. Bothwell's research group. } \examples{ # data(seaweed) # It is unnecessary to use \code{data} since \code{seaweed} is # a "first class object". It is "lazily loaded". dsw <- deldir(seaweed) isw <- tileInfo(dsw) # Expand the width of the terminal window. options(width=120) isw tsw <- tile.list(dsw) plot(tsw,labelPts=TRUE,col.lbls="red",cex=0.5,adj=0.5) } \keyword{datasets} deldir/man/plot.divchain.Rd0000644000176200001440000000336514527537355015350 0ustar liggesusers\name{plot.divchain} \alias{plot.divchain} \title{ Plot a dividing chain. } \description{ Plot the dividing chain of a Dirichlet tessellation. The tessellation must have been created from a set of points having associated categorical \dQuote{tags}. The dividing chain consists of those edges of Dirichlet tiles which separate points having different values of the given tags. } \usage{ \method{plot}{divchain}(x, add = FALSE, ...) } \arguments{ \item{x}{ An object of class \dQuote{divchain}. See \code{\link{divchain.deldir}()} for details. } \item{add}{ Logical scalar. It \code{add=TRUE} the plot of the dividing chain is added to an existing plot. } \item{\dots}{ Graphical parameters such as \code{main}, \code{xlab}, \code{col.main}, \code{col.lab}. In particular if \code{bty} is supplied (as a value other than \code{n}) a \dQuote{box} will be drawn around the plot that is formed when \code{add=FALSE}. Also a non-standard graphical parameter \code{boxcol} may be supplied which will be taken to be the colour with which the box is drawn. If a \code{col} argument is supplied, this determines the colour for plotting the segments constituting the dividing chain. } } \value{ None. } \author{\rolf} \note{ This function was created in response to a question asked on \code{stackoverflow.com} by a user named \dQuote{Dan}. } \seealso{ \code{\link{divchain}()} \code{\link{divchain.default}()} \code{\link{divchain.deldir}()} \code{\link{deldir}()} } \examples{ set.seed(42) x <- runif(50) y <- runif(50) z <- factor(kmeans(cbind(x,y),centers=4)$cluster) dc <- divchain(x,y,z,rw=c(0,1,0,1)) plot(dc,lwd=2,col="blue",bty="o") } \keyword{ spatial } deldir/man/divchain.Rd0000644000176200001440000000774414527537172014375 0ustar liggesusers\name{divchain} \alias{divchain} \alias{divchain.default} \alias{divchain.deldir} \title{ Dividing chain. } \description{ Create the \dQuote{dividing chain} of a Dirichlet tessellation. The tessellation must have been created from a set of points having associated \dQuote{tags}. The dividing chain consists of those edges of Dirichlet tiles which separate points having different values of the given tags. } \usage{ divchain(x, ...) \method{divchain}{default}(x, y, z, ...) \method{divchain}{deldir}(x, ...) } \arguments{ \item{x}{ Either an object specifying coordinates (in the case of the \code{"default"} method; see \code{\link{deldir}()} for details) or an object of class \dQuote{deldir}. In the latter case this object must have been created in such a way that the points of the set being tessellated have associate categorical \dQuote{tags}. That is, \code{\link{deldir}()} must have been called with a \code{z} argument or the \code{x} argument to \code{deldir()} must have had an appropriate component which could be taken to be \code{z}. Note that if the value of \code{z} that was used was not a factor, it is coerced to one. } \item{y}{ A numeric vector constituting the \eqn{y}-coordinates of the set of points being tessellated. See \code{\link{deldir}()} for details. Not used by the \code{"deldir"} method. } \item{z}{ A vector or factor specifying \dQuote{auxiliary} values or \dQuote{tags}. If this argument is left \code{NULL} then it is extracted, if possible, from the components of \code{x}. See \code{\link{deldir}()} for further details. If \code{z} is not a factor it is coerced to one. See \code{\link{deldir}()} for details. Not used by the \code{"deldir"} method. } \item{\dots}{ Arguments to be passed to \code{deldir()}. Not used by the \code{"deldir"} method. } } \value{ An object of class \dQuote{divchain} consisting of a data frame with columns named \dQuote{x0}, \dQuote{y0}, \dQuote{x1}, \dQuote{y1}, \dQuote{v01}, \dQuote{v02}, \dQuote{v03}, \dQuote{v11}, \dQuote{v12} and \dQuote{v13}. The columns named \dQuote{x0} and \dQuote{y0} consist of the coordinates of one endpoint of an edge of a Dirichlet tile and the columns named \dQuote{x1} and \dQuote{y1} consist of the coordinates of the other endpoint. The columns named \dQuote{vij}, i = 0, 1, j = 1, 2, 3, consist of the indices of the vertices of the Delaunay triangles whose circumcentres constitute the respective endpoints of the corresponding edge of a Dirichlet tile. The entries of column \dQuote{vi3} may (also) take the values $-1, -2, -3$, and $-4$. This will be the case if the circumcentre in question lay outside of the rectangular window \code{rw} (see \code{\link{deldir}()}) enclosing the points being tessellated. In these circumstances the corresponding endpoint of the tile edge is the intersection of the line joining the two circumcentres with the boundary of \code{rw}, and the numeric value of the entry of column \dQuote{vi3} indicates which side. The numbering follows the convention for numbering the sides of a plot region in \code{R}: 1 for the bottom side, 2 for the left side, 3 for the top side and 4 for the right side. Note that the triple of vertices uniquely identify the endpoint of the tile edge. The object has an attribute \code{rw} which is equal to the specification of the rectangular window within which the triangulation/tessellation in question was constructed. (See \code{\link{deldir}()}.) } \author{\rolf} \note{ This function was created in response to a question asked on \code{stackoverflow.com} by a user named \dQuote{Dan}. } \seealso{ \code{\link{deldir}()} \code{\link{plot.divchain}()} } \examples{ set.seed(42) x <- runif(50) y <- runif(50) z <- factor(kmeans(cbind(x,y),centers=4)$cluster) dc1 <- divchain(x,y,z,rw=c(0,1,0,1)) dxy <- deldir(x,y,z=z,rw=c(0,1,0,1)) dc2 <- divchain(dxy) } \keyword{ spatial } deldir/man/plot.tile.list.Rd0000644000176200001440000002465614536500367015471 0ustar liggesusers\name{plot.tile.list} \alias{plot.tile.list} \title{ Plot Dirichlet (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, col.lbls=NULL,border=NULL, showpoints = !labelPts, add = FALSE, asp = 1, clipp=NULL, xlab = "x", ylab = "y", main = "", axes=TRUE,warn=TRUE, labelPts=FALSE,adj=NULL,...) } \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 \dQuote{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 constitute parts of the edges of the enclosing rectangle) are drawn. Otherwise tiles on the periphery of the tessellation are left \dQuote{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 cause the tile to be left unfilled. This argument will be replicated to have length equal to the number of tiles. The default value is created (using the tile \dQuote{tags}, i.e. the \code{z} components of the tiles, if these exist) by the undocumented function \code{getCol()}. Note that if these \code{z} components are not present, then \code{getCol()} returns \code{NA}. } \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{col.lbls}{ Optional vector like unto \code{col.pts}. Determines the colours in which the point labels (see \code{labelPts} below) are plotted. This argument will be replicated to have length equal to the number of tiles. Ignored if \code{labelPts} is \code{FALSE}. } \item{border}{ A scalar that can be interpreted as a colour by \code{col2rgb()}, 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 only its first entry is used. } \item{showpoints}{Logical scalar; if \code{TRUE} the points of the pattern which was triangulated/tessellated are plotted. If \code{clipp} is specified, then only those points associated with non-empty clipped tiles are shown. Note that some such points will be external to the polygon \code{clipp} and that these \dQuote{external} points \emph{are} shown. } \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{axes}{ Logical scalar. Should axes (with a marked numeric scale) be plotted? This argument is used only if \code{add} is \code{FALSE}. It allows the plotting of such axes to be suppressed. The argument was added at the request of Damon Tutunjian. To suppress the plotting of axis \emph{labels} set \code{xlab=""} and/or \code{ylab=""}. } \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{Notes}.) } \item{labelPts}{Logical scalar; if \code{TRUE} the labels of the points determining the tiles are plotted in the tiles. Note that if \code{labelPts} is \code{TRUE} then \code{showpoints} defaults to \code{FALSE} } \item{adj}{The \dQuote{adjustment} argument to \code{text()}. If \code{labelPts} and \code{showpoints} are both \code{TRUE} it defaults to \code{-1} (so that the labels and point symbols are not superimposed). If \code{labelPts} is \code{TRUE} and \code{showpoints} is \code{FALSE} it defaults to \code{0}. If \code{labelPts} is \code{FALSE} it is ignored. } \item{...}{Optional arguments; may be passed to \code{points()} and \code{text()}. } } \section{Warnings}{ \itemize{ \item As of release 1.0-8 the argument \code{number} of \code{\link{plot.deldir}()} and \code{\link{plot.tile.list}()} was changed to \code{labelPts}. As a consequence the argument \code{col.num} of this function has had its name changed to \code{col.lbls}. \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 superseded 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.) The argument \code{asp} was added at the request of Zubin Dowlaty (who presumably knows what he's doing!). } } \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 If the \code{z} components of the entries of \code{x} exist but cannot all be interpreted as colours then the internal function \code{getCol()} returns \code{NA}. If \code{warn} is \code{TRUE} then a warning is issued. The function \code{getCol()} will also return \code{NA} (no warning is issued in this case) if there \emph{aren't} any \code{z} components. This circumstance will arise if no \code{z} argument was supplied in the call to \code{deldir()}. An \code{NA} value of \code{fillcol} results (as is indicated by the argument list entry for \code{fillcol}) in (all of) the tiles being left unfilled. \item The change from argument \code{polycol} to argument \code{fillcol}, and the resulting change in the way in which plotted tiles are filled with colours, was made as a result of a request from Chris Triggs. Likewise the argument \code{clipp} was added due to a request from Chris Triggs. } } \value{The list of tiles being plotted. This will be the input list of tiles specified by argument \code{x}, or this list clipped to the polygon \code{clipp} if the latter was specified. } \author{\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)) cul <- rainbow(10)[c(1,7,3:6,2,8:10)] # Rearranging colours to improve # the contrast between contiguous tiles. plot(w,clipp=CP,showpoints=FALSE,fillcol=cul) } plot(w,labelPts=TRUE,col.lbls="red") plot(w,labelPts=TRUE,col.lbls="red",cex=0.5) plot(w,showpoints=TRUE,labelPts=TRUE,col.pts="green",col.lbls="red") plot(w,axes=FALSE,xlab="",ylab="",close=TRUE) } \keyword{ hplot } deldir/man/volTriPoints.Rd0000644000176200001440000000301314124710521015225 0ustar liggesusers\name{volTriPoints} \alias{volTriPoints} \docType{data} \title{ Solute plume concentration data set. } \description{ Example solute plume concentration data set associated with the GWSDAT (\dQuote{GroundWater Spatiotemporal Data Analysis Tool}) project \url{https://protect-au.mimecast.com/s/demRC91WzLH6qo3TorzN7?domain=gwsdat.net}. The \code{deldir} package is used in this project as part of a numerical routine to estimate plume quantities (mass, average concentration and centre of mass). } \usage{volTriPoints} \format{ A data frame with 232 observations on the following 3 variables. \describe{ \item{\code{x}}{The \code{x}-coordinates of the centres of mass of the plumes.} \item{\code{y}}{The \code{y}-coordinates of the centres of mass of the plumes.} \item{\code{z}}{The plume concentrations.} } } \details{ This data set played a critical role in revealing a bug in the Fortran code underlying the \code{deldir()} function. } \source{ These data were kindly provided by Wayne W. Jones of the GWSDAT project. The data set was originally named \code{Vol.Tri.Points}; the name was changed so as to be more consistent with my usual naming conventions. } \references{ Jones, W. R., Spence, M. J., Bowman, A. W., Evers, L. and Molinari, D. A. (2014). A software tool for the spatiotemporal analysis and reporting of groundwater monitoring data. \emph{Environmental Modelling & Software} \bold{55}, pp. 242--249. } \examples{ dvtp <- deldir(volTriPoints) plot(dvtp) } \keyword{datasets} deldir/man/triang.list.Rd0000644000176200001440000000425414527537671015043 0ustar liggesusers\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 3}{3 x 3} or \eqn{3 \times 4}{3 x 4} data frame corresponding to one of the Delaunay triangles specified by \dQuote{object}. The rows of each such data frame correspond to the vertices of the corresponding Delaunay triangle. The columns are: \itemize{ \item \code{ptNum} (the index of the point in the original sequence of points that is being triangulated. Note that if a point is one of a set of \emph{duplicated} points then \code{ptNum} is the \emph{first} of the indices of the points in this set.) \item \code{x} (the \eqn{x}-coordinate of the vertex) \item \code{y} (the \eqn{y}-coordinate of the vertex) \item \code{z} (the \dQuote{auxiliary value} or \dQuote{tag} \code{z} associated with the vertex; present only 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} \section{Warning}{ There may not actually \bold{be} any triangles determined by \code{object}, in which case this function returns an empty list with an \code{"rw"} attribute. See \bold{Examples}. } \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) d1 <- deldir(x,y,z=z) t1 <- triang.list(d1) # A "triangulation" with no triangles! d2 <- deldir(x=1:10,y=11:20) plot(d2) t2 <- triang.list(d2) plot(t2,showrect=TRUE,rectcol="blue") # Pretty boring! } \keyword{spatial} deldir/man/tilePerim.Rd0000644000176200001440000000557714527537641014545 0ustar liggesusers\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}. } \item{perComps}{ A list whose entries are vectors consisting of the \dQuote{components} of the perimeters of each tile. If/when the tiles are clipped, some tiles may be subdivided by the clipping into discontiguous parts. The components referred to above are the perimeters of this parts. If no subdivision has occurred then the vector in question has a single entry equal to the perimeter of the corresponding tile. If subdivision has occurred then the perimeter of the tile is the sum of the perimeters of the components. } } \author{\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. 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)) wc <- tile.list(z,clipp=CP) p2 <- tilePerim(wc) # Doesn't matter here if inclbdry is TRUE or FALSE. p2$perComps[["pt.6"]] # The tile for point 6 has got subdivided into # two parts, a tetrahedron and a triangle. cul <- rainbow(10)[c(1,7,3:6,2,8:10)] # Rearranging colours to improve # the contrast between contiguous tiles. plot(wc,labelPts=TRUE,fillcol=cul) } } \keyword{spatial} deldir/man/lawSummary.Rd0000644000176200001440000001242614527537270014741 0ustar liggesusers\name{lawSummary} \alias{lawSummary} \title{ Produce a Lewis-Aboav-Weaire summary of a tessellation. } \description{ Produce a summary of a Dirichlet (Voronoi) tessellation in terms of parameters relevant to Lewis's law and Aboav-Weaire's law. Note that \dQuote{law} in the function name corresponds to \dQuote{Lewis-Aboav-Weaire}. } \usage{ lawSummary(object) } \arguments{ \item{object}{ An object of class \code{"deldir"} as returned by the function \code{deldir()}. } } \details{ Tiles are stripped away from the tessellation in \dQuote{layers}. Layer 1 consists of \dQuote{boundary} tiles, i.e. tiles having at least one vertex on the enclosing rectangle (determined by the \code{rw} argument of \code{\link{deldir}()}). Layer 2 consists of tiles which are neighbours of tiles in layer 1 (i.e. tiles determined by points that are Delaunay neighbours of points determining the tiles in layer 1). Layer 3 consists of tiles which are neighbours of tiles in layer 2. The parameters of interest in respect of the Lewis-Aboav-Weaire summary are then calculated in terms of the tiles that remain after the three layers have been stripped away, which will be referred to as \dQuote{interior} tiles. These parameters are: \itemize{ \item the areas of each of the interior tiles \item the number of edges of each of the interior tiles \item the number of edges of all neighbouring tiles of each of the interior tiles. } Note that the neighbouring tiles of the interior tiles may include tiles which are \emph{not themselves} interior tiles (i.e. tiles which are in layer 3). This function was created at the request of Kai Xu (Fisheries College, Jimei University, Xiamen, Fujian, China 361021). } \value{ If no tiles remain after the three layers have been stripped away, then the returned value is \code{NULL}. Otherwise the returned value is a list with components calculated in terms of the remaining (\dQuote{interior}) tiles. These components are: \itemize{ \item \code{tile.vertices} A list whose entries are data frames giving the coordinates of the vertices of the interior tiles. \item \code{tile.areas} A vector of the areas of the interior tiles in the tessellation in question. \item{tile.tags} A vector or factor whose values are the \dQuote{tags} of the interior tiles. The \dQuote{original} of this object (the \dQuote{tags} associated with all of the tiles) is provided as the \code{z} argument to \code{deldir()}. The \code{tile.tags} component of the value returned by \code{lawSummary()} is present only if \code{deldir()} was called with a (non-\code{NULL}) value of the \code{z} argument. \item \code{num.edges} A vector of the number of edges of each such tile. \item \code{num.nbr.edges} A list with a component for each point, in the set being tessellated, whose corresponding tile is an interior tile. Each component of this list is the vector of the number of edges of the interior tiles determined by points which are Delaunay neighbours of the point corresponding to the list component in question. \item \code{totnum.nbr.edges} A vector whose entries consist of the sums of the vectors in the foregoing list. } The returned list also has attributes as follows: \itemize{ \item \code{i1} An integer vector whose entries are in the indices of the tiles in layer 1. \item \code{i2} An integer vector whose entries are in the indices of the tiles in layer 2. \item \code{i3} An integer vector whose entries are in the indices of the tiles in layer 3. \item \code{i.kept} An integer vector whose entries are in the indices of the tiles that are kept, i.e. those that remain after the three layers have been stripped away. } } \author{\rolf} \seealso{ \code{\link{tile.list}()} \code{\link{tile.centroids}()} } \examples{ # A random pattern: set.seed(42) xy1 <- data.frame(x=runif(400,0,20),y=runif(400,0,20)) dxy1 <- deldir(xy1) ldxy1 <- lawSummary(dxy1) tl1 <- tile.list(dxy1) plot(0,0,type="n",xlim=c(-2,35),ylim=c(0,20),asp=1,xlab="x",ylab="y",bty="l") plot(tl1,showpoints=FALSE,add=TRUE) points(xy1[attr(ldxy1,"i1"),],pch=20,col="yellow") points(xy1[attr(ldxy1,"i2"),],pch=20,col="blue") points(xy1[attr(ldxy1,"i3"),],pch=20,col="green") points(xy1[attr(ldxy1,"i.kept"),],pch=20,col="red") legend("right",pch=20,col=c("yellow","blue","green","red"), legend=c("layer 1","layer 2","layer 3","interior")) # A highly structured pattern (example due to Kai Xu): set.seed(115) x <- c(rep(1:20,10),rep((1:20)+0.5,10)) y <- c(rep(1:10,each=20),rep((1:10)+0.5,each=20))*sqrt(3) a <- runif(400,0,2*pi) b <- runif(400,-1,1) x <- x+0.1*cos(a)*b y <- y+0.1*sin(a)*b xy2 <- data.frame(x,y) dxy2 <- deldir(xy2) ldxy2 <- lawSummary(dxy2) tl2 <- tile.list(dxy2) plot(0,0,type="n",xlim=c(-2,35),ylim=c(0,20),asp=1,xlab="x",ylab="y",bty="l") plot(tl2,showpoints=FALSE,add=TRUE) points(xy2[attr(ldxy2,"i1"),],pch=20,col="yellow") points(xy2[attr(ldxy2,"i2"),],pch=20,col="blue") points(xy2[attr(ldxy2,"i3"),],pch=20,col="green") points(xy2[attr(ldxy2,"i.kept"),],pch=20,col="red") legend("right",pch=20,col=c("yellow","blue","green","red"), legend=c("layer 1","layer 2","layer 3","interior")) } \keyword{spatial} deldir/man/tileArea.Rd0000644000176200001440000000300414527537530014315 0ustar liggesusers\name{tileArea} \alias{tileArea} \title{ Area of a Dirichlet tile. } \description{ Calculates the area of a Dirichlet tile, applying a discrete version of Stoke's theorem. } \usage{ tileArea(x, y, rw) } \arguments{ \item{x}{ The \code{x}-coordinates of the vertices of the tile, in \bold{anticlockwise} direction. The last coordinate should \bold{not} repeat the first. } \item{y}{ The \code{y}-coordinates of the vertices of the tile, in \bold{anticlockwise} direction. The last coordinate should \bold{not} repeat the first. } \item{rw}{ A vector of length 4 specifying the rectangular window in which the relevant tessellation was constructed. See \code{\link{deldir}()} for more detail. Actually this can be any rectangle containing the tile in question. } } \details{ The heavy lifting is done by the Fortran subroutine \code{stoke()} which is called by the \code{.Fortran()} function. } \value{ A positive scalar. } \author{\rolf} \seealso{ \code{\link{deldir}()} \code{\link{tilePerim}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) z <- deldir(x,y,rw=c(0,1,0,1)) w <- tile.list(z) with(w[[1]],tileArea(x,y,rw=z$rw)) sapply(w,function(x,rw){tileArea(x$x,x$y,attr(w,"rw"))}) x <- c(0.613102,0.429294,0.386023,0.271880,0.387249,0.455900,0.486101) y <- c(0.531978,0.609665,0.597780,0.421738,0.270596,0.262953,0.271532) # The vertices of the Dirichlet tile for point 6. tileArea(x,y,rw=c(0,1,0,1)) tileArea(x,y,rw=c(-1,2,-3,4)) # Same as above. } \keyword{ utilities } deldir/man/duplicatedxy.Rd0000644000176200001440000000453214527537221015272 0ustar liggesusers\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()}. The association between tiles and the indices of the original set of points is now preserved by the component \code{ind.orig} of the object returned by \code{deldir()}. However confusion could still arise. If it is of interest to associate Dirichlet tiles with the points determining them, then it is better to proceed by eliminating duplicate points to start with. This function (\code{duplicatedxy()}) 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} if the corresponding point is a duplicate of a point with a smaller index, and \code{FALSE} otherwise. } \author{\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/tile.list.Rd0000644000176200001440000001316414527537621014507 0ustar liggesusers\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,minEdgeLength=NULL,clipp=NULL) } \arguments{ \item{object}{ An object of class \code{deldir} as produced by the function \code{\link{deldir}()}.} \item{minEdgeLength}{ Positive numeric scalar specifying the minimum length that an edge of a tile may have. It is used to eliminate edges that are effectively of zero length, which can cause tiles to be \dQuote{invalid}. This argument defaults to \code{sqrt(.Machine$double.eps)} time the diameter (length of the diagonal) of the \dQuote{rectangular window} associated with the tessellation. This rectangular window is available as the \code{rw} component of \code{object}. } \item{clipp}{An object specifying a polygon to which the tessellation, whose tiles are being determined, 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 tiles in the list that is produced are \dQuote{clipped} to the polygon specified by \code{clipp}. Empty tiles (those which do not intersect the polygon specified by \code{clipp}) are omitted. The clipping process may subdivide some of the tiles into two or more discontiguous parts. } } \value{ A list with one entry for each of the points in the set being tessellated, or for each of the tiles that are retained after clipping if \code{clipp} is not \code{NULL}. Each entry is in turn a list with a number of components. These components always include: \item{ptNum}{The index of the point in the original sequence of points that is being tessellated. Note that if a point is one of a set of \emph{duplicated} points then \code{ptNum} is the \emph{first} of the indices of the points in this set.} \item{pt}{The coordinates of the point whose tile is being described.} \item{area}{The area of the tile.} If the tile in question has \emph{not} been subdivided by the clipping process then the list components also include: \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.} If the tile in question \emph{has} been subdivided then the list does not have the foregoing three components but rather has a component \code{tileParts} which is in turn a list of length equal to the number of parts into which the tile was subdivided. Each component of \code{tileParts} is yet another list with four components \code{x}, \code{y}, \code{bp} and \code{area} as described above and as are appropriate for the part in question. \item{z}{The \dQuote{auxiliary value} or \dQuote{tag} associated with the \code{pt}; present only if such values were supplied in the call to \code{deldir()}.} } \author{\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 included 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{ set.seed(42) 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) 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)) wc <- tile.list(z,clipp=CP) # 10 tiles are retained; the third tile, # corresponding to point 6, is # subdivided into two parts. # Determine the tiles on the border of a clipping region. # Example due to Huimin Wang. set.seed(112) x <- runif(100) y <- runif(100) dxy <- deldir(x,y) txy <- tile.list(dxy) chind <- chull(x,y) bdry <- list(x=x[chind],y=y[chind]) ctxy <- tile.list(dxy,clipp=bdry) inside <- lapply(ctxy,function(tile,bdry){insidePoly(tile$x,tile$y,bdry)}, bdry=bdry) border <- sapply(inside,function(x){any(!x) | any(attr(x,"on.boundary"))}) plot(ctxy[border],main="Border tiles") } } \keyword{spatial} deldir/man/deldir-internal.Rd0000644000176200001440000000161414526003713015637 0ustar liggesusers\name{deldir-internal} \alias{[.tile.list} \alias{[.triang.list} \alias{acw} \alias{binsrtR} \alias{doClip} \alias{findNewInOld} \alias{get.cnrind} \alias{getCol} \alias{insidePoly} \alias{insideRect} \alias{mid.in} \alias{mnndR} \alias{prelimtlist} \alias{tilePerim0} \alias{verGetter} \title{Internal deldir functions} \description{ Internal deldir functions. } \usage{ \method{[}{tile.list}(x,i,\dots) \method{[}{triang.list}(x,i,\dots) acw(xxx) doClip(object,clipp,rw) binsrtR(x,y,rw) findNewInOld(xnew,xold,ynew,yold,tolerance=sqrt(.Machine$double.eps)) get.cnrind(x,y,rw) getCol(x,warn=FALSE) insidePoly(x,y,pgon,sanityCheck=FALSE,tolerance=sqrt(.Machine$double.eps)) insideRect(x,y,rect,rw) mid.in(x,y,rx,ry) mnndR(x,y) prelimtlist(object) tilePerim0(object,inclbdry=TRUE) verGetter() } \details{ These functions are auxiliary and are not intended to be called by the user. } \keyword{internal} deldir/man/grapherXmpl.Rd0000644000176200001440000000215013703441262015050 0ustar liggesusers\name{grapherXmpl} \alias{grapherXmpl} \docType{data} \title{ grapherXmpl } \description{ A data set taken from an example in the grapherator package. This data set demonstrates handling a data set with duplicated points. } \usage{grapherXmpl} \format{ A data frame with 250 observations on the following 2 variables. \describe{ \item{\code{x}}{a numeric vector} \item{\code{y}}{a numeric vector} } } \details{ There are 25 duplicated points, so the net number of observations is 225. These data constitute a structure (named \code{coordinates}) generated internally in the function \code{addEdgesDelaunay}. The call is to be found in the examples in the help file for the \code{plot.grapherator()} in the \code{grapherator} package. The relevant example initially threw an error, revealing a bug in \code{deldir()} that was triggered when there were duplicated points in the data. } \source{ The \code{grapherator} package, \url{https://CRAN.R-project.org/package=grapherator} } \examples{ dgX <- deldir(grapherXmpl) # Now works!!!` } \keyword{datasets} deldir/DESCRIPTION0000644000176200001440000000153614567527702013247 0ustar liggesusersPackage: deldir Version: 2.0-4 Date: 2024-02-27 Title: Delaunay Triangulation and Dirichlet (Voronoi) Tessellation Author: Rolf Turner Maintainer: Rolf Turner Depends: R (>= 3.5.0) Suggests: polyclip Imports: graphics, grDevices 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. Summarises information about the tiles of the tessellation. Calculates the centroidal Voronoi (Dirichlet) tessellation using Lloyd's algorithm. LazyData: true ByteCompile: true License: GPL (>= 2) NeedsCompilation: yes Packaged: 2024-02-27 02:48:30 UTC; rolf Repository: CRAN Date/Publication: 2024-02-28 04:00:02 UTC deldir/src/0000755000176200001440000000000014567246576012332 5ustar liggesusersdeldir/src/intri.f900000644000176200001440000000162314525001431013746 0ustar liggesuserssubroutine 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) integer :: okay logical 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) then inside = .false. exit endif enddo if(inside) then okay = 0 return endif enddo okay = 1 end subroutine intri deldir/src/locn.f900000644000176200001440000000261414526547315013576 0ustar liggesuserssubroutine 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) then kj = 1 return endif ! 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) then km = kj-1 if(km==0) km = n k = nadj(i,km) call acchk(i,j,k,before,x,y,ntot,eps) ! Got here. if(.not.before) then ! If j is before 1 and after n, then it should ! have place n+1. if(kj==1) kj = n+1 return endif endif enddo ! 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) then kj = 1 else kj = n+1 endif end subroutine locn deldir/src/qtest.f900000644000176200001440000001011714526547461014002 0ustar liggesuserssubroutine qtest(h,i,j,k,shdswp,x,y,ntot,eps) ! 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) dimension :: ndi(1) integer :: h logical :: shdswp ! Set dummy integer for call to intpr(...). ndi(1) = 0 ! Look for ideal points. if(i<=0) then ii = 1 else ii = 0 endif if(j<=0) then jj = 1 else jj = 0 endif if(k<=0) then kk = 1 else kk = 0 endif 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) then shdswp = .true. return endif ! 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) 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>0.d0) then shdswp = .true. else shdswp = .false. endif ! Check for convexity: if(shdswp) call acchk(j,k,h,shdswp,x,y,ntot,eps) return endif ! 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) then shdswp = .true. return endif ! 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) then call acchk(j,k,h,shdswp,x,y,ntot,eps) return endif ! If j and k are ideal, this is like unto case 6. ! case 3: if(ijk==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>0.d0) then shdswp = .true. else shdswp = .false. endif ! Check for convexity: if(shdswp) call acchk(h,i,j,shdswp,x,y,ntot,eps) return endif ! 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) then shdswp = .false. return endif ! If k is ideal, this is like unto case 4. ! case 1: if(ijk==1) then call acchk(h,i,j,shdswp,x,y,ntot,eps) ! This checks ! for convexity. ! (Was i,j,h,...) return endif ! If none of the `other' three corners are ideal, do the Lee-Schacter ! test for the LOP. ! case 0: if(ijk==0) then call qtest1(h,i,j,k,x,y,ntot,eps,shdswp) return endif ! default: ! This CAN'T happen! call intpr("Indicator ijk is out of range.",-1,ndi,0) call intpr("This CAN'T happen!",-1,ndi,0) call rexit("Bailing out of qtest.") end subroutine qtest deldir/src/trifnd.f900000644000176200001440000001026014527510421014112 0ustar liggesuserssubroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri) ! 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) dimension :: ndi(1) integer :: tau(3) logical :: adjace, anticl ! The first point must be added to the triangulation before ! calling trifnd. if(j==1) then call intpr("No triangles to find.",-1,ndi,0) call rexit("Bailing out of trifnd.") endif ! 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) call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot) if(.not.adjace) then tau(3) = tau(2) call pred(tau(2),j1,tau(3),nadj,madj,ntot) endif ! Move to the adjacent triangle in the direction of the new ! point, until the new point lies in this triangle. ktri = 0 do ! Check that the vertices of the triangle listed in tau are ! in anticlockwise order. (If they aren't then reverse the order; ! if they are *still* not in anticlockwise order, theh alles ! upgefucken ist; throw an error.) call acchk(tau(1),tau(2),tau(3),anticl,x,y,ntot,eps) if(.not.anticl) then call acchk(tau(3),tau(2),tau(1),anticl,x,y,ntot,eps) if(.not.anticl) then ndi(1) = j call intpr("Point number =",-1,ndi,1) call intpr("Previous triangle:",-1,tau,3) call intpr("Both vertex orderings are clockwise.",-1,ndi,0) call intpr("See help for deldir.",-1,ndi,0) call rexit("Bailing out of trifnd.") else ivtmp = tau(3) tau(3) = tau(1) tau(1) = ivtmp endif endif 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) then i1 = 1 else i1 = 0 endif if(tau(ip)<=0) then j1 = 1 else j1 = 0 endif 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) then continue else if(cprd > -eps) then nedge = ip else ntau = ip exit endif endif enddo ! 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) then tau(2) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot) endif ! case 2: Move to "triangle 2" if(ntau==2) then tau(3) = tau(2) call pred(tau(2),tau(1),tau(3),nadj,madj,ntot) endif ! case 3: Move to "triangle 3" if(ntau==3) then tau(1) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot) endif ! We've moved to a new triangle; check if the point being added lies ! inside this one. ktri = ktri + 1 if(ktri > ntri) then ndi(1) = j call intpr("Point being added:",-1,ndi,1) call intpr("Cannot find an enclosing triangle.",-1,ndi,0) call intpr("See help for deldir.",-1,ndi,0) call rexit("Bailing out of trifnd.") endif enddo end subroutine trifnd deldir/src/delet.f900000644000176200001440000000066214524772357013745 0ustar liggesuserssubroutine delet(i,j,nadj,madj,ntot) ! 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) ! Then do the actual deletion if they are. if(adj) then call delet1(i,j,nadj,madj,ntot) call delet1(j,i,nadj,madj,ntot) endif return end deldir/src/acchk.f900000644000176200001440000000164114517543231013704 0ustar liggesuserssubroutine 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) then i1 = 1 else i1 = 0 endif if(j<=0) then j1 = 1 else j1 = 0 endif if(k<=0) then k1 = 1 else k1 = 0 endif 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) then anticl = .true. else anticl = .false. endif end subroutine acchk deldir/src/delseg.f900000644000176200001440000000171314525525544014104 0ustar liggesuserssubroutine delseg(delsgs,ndel,nadj,madj,nn,x,y,ntot,incSeg) ! Output the endpoints of the line segments joining the ! vertices of the Delaunay triangles. ! Called by master. implicit double precision(a-h,o-z) logical :: value dimension :: nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension :: delsgs(6,ndel) ! Initialise incSeg incSeg = 0 ! For each distinct pair of points i and j, if they are adjacent ! then put their endpoints into the output array. nn = ntot-4 kseg = 0 do i = 2,nn do j = 1,i-1 call adjchk(i,j,value,nadj,madj,ntot) if(value) then kseg = kseg+1 if(kseg > ndel) then incSeg = 1 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) = i delsgs(6,kseg) = j endif enddo enddo ndel = kseg end subroutine delseg deldir/src/insrt.f900000644000176200001440000000136514525000106013761 0ustar liggesuserssubroutine insrt(i,j,nadj,madj,x,y,ntot,eps,incAdj) ! 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) 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,incAdj) if(incAdj==1) return call insrt1(j,i,ki,nadj,madj,ntot,incAdj) if(incAdj==1) return ! This seems unnecessary; check on this. end subroutine insrt deldir/src/triar.f900000644000176200001440000000046214524771445013764 0ustar liggesuserssubroutine triar(x0,y0,x1,y1,x2,y2,area) ! Calculate the area of a triangle with given vertices. Called ! by delout (so that the vertices are presented in the anticlockwise ! direction). implicit double precision(a-h,o-z) half = 0.5d0 area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)) end subroutine triar deldir/src/mnnd.f900000644000176200001440000000066314526533430013572 0ustar liggesuserssubroutine 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 .ne. j) then d = (x(i)-x(j))**2 + (y(i)-y(j))**2 if(d < dmin) dmin = d endif enddo dminav = dminav + sqrt(dmin) enddo dminav = dminav/n return end deldir/src/stoke.f900000644000176200001440000000774014527522111013761 0ustar liggesuserssubroutine stoke(x1,y1,x2,y2,rw,area,s1,eps) ! 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) dimension :: ndi(1) logical :: value ! Set dummy integer for call to intpr(...). ndi(1) = 0 zero = 0.d0 ! If the segment is vertical, the area is zero. call testeq(x1,x2,eps,value) if(value) then area = 0.d0 s1 = 0.d0 return endif ! Find which is the right-hand end, and which is the left. if(x1=xmax) then area = 0.d0 return endif ! 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) then area = (xr-xl)*(ymax-ymin) return endif ! 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 .and. ymax<=ytop) then call testeq(slope,zero,eps,value) if(value) then w1 = 0.d0 w2 = xr-xl else xit = xl+(ymax-yl)/slope w1 = xit-xl w2 = xr-xit if(slope<0.d0) then tmp = w1 w1 = w2 w2 = tmp endif endif area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin) return endif ! 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 .and. ymax<=ytop) then xit = xl+(ymax-yl)/slope xib = xl+(ymin-yl)/slope if(slope>0.d0) then w1 = xit-xib w2 = xr-xit else w1 = xib-xit w2 = xit-xl endif area = 0.5d0*w1*(ymax-ymin)+w2*(ymax-ymin) return endif ! 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 .and. ytop<=ymax) then area = 0.5d0*(xr-xl)*((ytop-ymin)+(ybot-ymin)) return endif ! 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 .and. ymin<=ytop) then call testeq(slope,zero,eps,value) if(value) then area = 0. return endif xib = xl+(ymin-yl)/slope if(slope>0.d0) then w = xr-xib else w = xib-xl endif area = 0.5*w*(ytop-ymin) return endif ! Case 6; ytop <= ymin: ! The `roof' is entirely below the bottom (y = ymin), so ! there is no area contribution at all. if(ytop<=ymin) then area = 0. return endif ! Default; all stuffed up: call intpr("Fell through all six cases.",-1,ndi,0) call intpr("Something is totally stuffed up!",-1,ndi,0) call intpr("Chaos and havoc in stoke.",-1,ndi,0) call rexit("Bailing out of stoke.") end subroutine stoke deldir/src/init.c0000644000176200001440000000245713771771500013433 0ustar liggesusers#include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Fortran calls */ extern void F77_NAME(binsrt)(double *, double *, double *, int *, int *, int *, double *, double *, int *); extern void F77_NAME(intri)(double *, double *, double *, double *, int *, int *); extern void F77_NAME(master)(double *, double *, double *, int *, int *, int *, int *, double *, double *, int *, double *, double *, int *, double *, int *, int *); extern void F77_NAME(mnnd)(double *, double *, int *, double *, double *); extern void F77_NAME(stoke)(double *, double *, double *, double *, double *, double *, double *, double *); static const R_FortranMethodDef FortranEntries[] = { {"binsrt", (DL_FUNC) &F77_NAME(binsrt), 9}, {"intri", (DL_FUNC) &F77_NAME(intri), 6}, {"master", (DL_FUNC) &F77_NAME(master), 16}, {"mnnd", (DL_FUNC) &F77_NAME(mnnd), 5}, {"stoke", (DL_FUNC) &F77_NAME(stoke), 8}, {NULL, NULL, 0} }; void R_init_deldir(DllInfo *dll) { R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } deldir/src/insrt1.f900000644000176200001440000000152514526545660014064 0ustar liggesuserssubroutine insrt1(i,j,kj,nadj,madj,ntot,incAdj) ! Insert j into the adjacency list of i. ! Called by insrt. implicit double precision(a-h,o-z) dimension :: nadj(-3:ntot,0:madj) ! Initialise incAdj. incAdj = 0 ! Variable kj is the index which j ***will*** ! have when it is inserted into the adjacency list of i in ! the appropriate position. ! If the adjacency list of i had no points just stick j into the list. n = nadj(i,0) if(n==0) then nadj(i,0) = 1 nadj(i,1) = j return endif ! If the adjacency list had some points, move everything ahead of the ! kj-th place one place forward, and put j in position kj. kk = n+1 if(kk>madj) then ! Watch out for over-writing!!! incAdj = 1 return endif do nadj(i,kk) = nadj(i,kk-1) kk = kk-1 if(kk <= kj) exit enddo nadj(i,kj) = j nadj(i,0) = n+1 end subroutine insrt1 deldir/src/qtest1.f900000644000176200001440000000650014526534513014056 0ustar liggesuserssubroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp) ! 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), xt(3), yt(3), indv(3) dimension :: itmp(1) dimension :: xtmp(1) dimension :: ndi(1) integer :: h logical :: shdswp, collin ! Set dummy integer for call to intpr(...). ndi(1) = 0 ! 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 dingoes' 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. ! Check for collinearity of points h, i and k. xt(1) = x(h) yt(1) = y(h) xt(2) = x(i) yt(2) = y(i) xt(3) = x(k) yt(3) = y(k) nid = 0 ! nid = number of ideal points. call cross(xt,yt,nid,cprd) collin = (abs(cprd) < eps) ! Does this work??? ! If the points are collinear, make sure that they're in the right ! order --- h between i and k. if(collin) then ! Form the vector u from h to i, and the vector v from h to k, ! and normalize them. a = xt(2) - xt(1) b = yt(2) - yt(1) c = xt(3) - xt(1) d = yt(3) - yt(1) c1 = sqrt(a*a+b*b) c2 = sqrt(c*c+d*d) a = a/c1 b = b/c1 c = c/c2 d = d/c2 alpha = a*c+b*d ! If they're not in the right order, bring things to ! a shuddering halt. if(alpha>0) then itmp(1) = 1 indv(1) = i indv(2) = j indv(3) = k itmp(1) = h call intpr("Point being added, h:",-1,itmp,1) call intpr("now, other vertex, nxt:",-1,indv,3) xtmp(1) = alpha call dblepr("Test value:",-1,xtmp,1) call intpr("Points are collinear but h is not between i and k.",-1,ndi,0) call rexit("Bailing out of qtest1.") endif ! Collinear, and in the right order; think of this as meaning ! that the circumcircle in question has infinite radius. shdswp = .true. endif ! 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) 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(ch ymax) then ai = a bi = ymax nedge = 3 if(xmin<=ai .and. ai<=xmax) return endif intfnd = .false. return endif ! Line 1: x = xmin. if(axmax) then ai = xmax bi = b + slope*(ai-a) nedge = 4 if(ymin<=bi .and. bi<=ymax) return endif ! Line 4: y = ymax. if(b>ymax) then bi = ymax ai = a + (bi-b)/slope nedge = 3 if(xmin<=ai .and. ai<=xmax) return endif intfnd = .false. end subroutine dldins deldir/src/adjchk.f900000644000176200001440000000210114526546065014057 0ustar liggesuserssubroutine adjchk(i,j,adj,nadj,madj,ntot) ! Check if vertices i and j are adjacent. ! Called by insrt, delet, trifnd, swap, delseg, dirseg. dimension :: nadj(-3:ntot,0:madj) logical :: adj dimension :: ndi(1) ! Set dummy integer for call to intpr(...). ndi(1) = 0 ! Check if j is in the adjacency list of i. adj = .false. ni = nadj(i,0) if(ni>0) then do k = 1,ni if(j==nadj(i,k)) then adj = .true. exit endif enddo endif ! Check if i is in the adjacency list of j. nj = nadj(j,0) if(nj>0) then do k = 1,nj if(i==nadj(j,k)) then if(adj) then return ! Have j in i's list and i in j's. else call intpr("Contradictory adjacency lists.",-1,ndi,0) call rexit("Bailing out of adjchk.") endif endif enddo endif ! If we get to here i is not in j's list. if(adj) then ! If adj is true, then j IS in i's list. call intpr("Contradictory adjacency lists.",-1,ndi,0) call rexit("Bailing out of adjchk.") endif end subroutine adjchk deldir/src/pred.f900000644000176200001440000000215714526533742013576 0ustar liggesuserssubroutine pred(kpr,i,j,nadj,madj,ntot) ! 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) dimension :: ndi(1) ! Set dummy integer for call to intpr(...). ndi(1) = 0 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) then call intpr("Adjacency list of i is empty, and so cannot contain j.",-1,ndi,0) call rexit("Bailing out of pred.") endif ! 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)) then km = k-1 if(km<1) km = n ! Take km modulo n. (The adjacency list kpr = nadj(i,km) ! is circular.) return endif enddo ! The adjacency list for i doesn't contain j. Something's wrong; stop. call intpr("Adjacency list of i does not contain j.",-1,ndi,0) call rexit("Bailing out of pred.") end subroutine pred deldir/src/succ.f900000644000176200001440000000225614526547654013610 0ustar liggesuserssubroutine succ(ksc,i,j,nadj,madj,ntot) ! 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) dimension :: ndi(1) ! Set dummy integer for call to intpr(...). ndi(1) = 0 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) then call intpr("Adjacency list of i is empty, and so cannot contain j.",-1,ndi,0) call rexit("Bailing out of succ.") endif ! 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)) then kp = k+1 if(kp>n) kp = 1 ! Take kp modulo n. (The adjacency list ksc = nadj(i,kp) ! is circular.) return endif enddo ! The adjacency list doesn't contain j. Something's wrong. ndi(1) = i call intpr("i =",-1,ndi,1) ndi(1) = j call intpr("j =",-1,ndi,1) call intpr("Adjacency list of i does not contain j.",-1,ndi,0) call rexit("Bailing out of succ.") end subroutine succ deldir/src/circen.f900000644000176200001440000000354014525520745014102 0ustar liggesuserssubroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin) ! 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) dimension :: indv(3) ! To facillitate a lucid error message. dimension :: xtmp(1) dimension :: ndi(1) logical :: collin ! Set dummy integer for call to intpr(...). ndi(1) = 0 ! 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) then collin = .true. else collin = .false. endif ! 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) then alpha = a*c+b*d ! If they're not in the right order, bring things to ! a shuddering halt. if(alpha>0) then indv(1) = i indv(2) = j indv(3) = k call intpr("Point numbers:",-1,indv,3) xtmp(1) = alpha call dblepr("Test value:",-1,xtmp,1) call intpr("Points are collinear but in the wrong order.",-1,ndi,0) call rexit("Bailing out of circen.") endif ! Collinear, but in the right order; think of this as meaning ! that the circumcircle in question has infinite radius. return endif ! 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 end subroutine circen deldir/src/delout.f900000644000176200001440000000262014525525157014133 0ustar liggesuserssubroutine delout(delsum,nadj,madj,x,y,ntot,nn) ! Put a summary of the Delaunay triangles with a vertex at point i, ! for i = 1, ..., nn, 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(nn,4) do i = 1,nn area = 0.d0 ! Initialize area of polygon consisting of triangles ! with a vertex at point i. ! Get the coordinates of the point and the number of ! (real) triangles emanating from it. 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 .or. nadj(i,kp)<=0) npt = npt-1 enddo ! 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) cycle xj = x(j) yj = y(j) call succ(k,i,j,nadj,madj,ntot) if(k<=0) cycle 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.d0 enddo delsum(i,1) = xi delsum(i,2) = yi delsum(i,3) = npt delsum(i,4) = area enddo end subroutine delout deldir/src/initad.f900000644000176200001440000000205414527007362014103 0ustar liggesuserssubroutine initad(j,nadj,madj,x,y,ntot,eps,ntri,incAdj) ! 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,ntri) ! 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 .ne. 0) then ip = nedge i = ip-1 if(i==0) i = 3 ! Arithmetic modulo 3. call pred(k,tau(i),tau(ip),nadj,madj,ntot) call succ(kk,tau(ip),tau(i),nadj,madj,ntot) call delet(tau(i),tau(ip),nadj,madj,ntot) if(k==kk) call insrt(j,k,nadj,madj,x,y,ntot,eps,incAdj) if(incAdj==1) return endif ! Join the new point to each of the three vertices. do i = 1,3 call insrt(j,tau(i),nadj,madj,x,y,ntot,eps,incAdj) enddo end subroutine initad deldir/src/testeq.f900000644000176200001440000000155114526544134014143 0ustar liggesuserssubroutine 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) then if(abs(a)<=eps) then value = .true. else value = .false. endif return endif ! 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) .or. abs(a) ndir) then incSeg = 1 return endif dirsgs(1,kseg) = ai dirsgs(2,kseg) = bi dirsgs(3,kseg) = ci dirsgs(4,kseg) = di dirsgs(5,kseg) = i dirsgs(6,kseg) = j 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 if(bptab) then dirsgs(9,kseg) = -nedgeab else dirsgs(9,kseg) = k endif if(bptcd) then dirsgs(10,kseg) = -nedgecd else dirsgs(10,kseg) = l endif endif endif enddo enddo ndir = kseg end subroutine dirseg deldir/src/binsrt.f900000644000176200001440000000465014526545612014144 0ustar liggesuserssubroutine binsrt(x,y,rw,nn,ind,rind,tx,ty,ilst) ! Sort the data points into bins. ! Called by master. implicit double precision(a-h,o-z) dimension :: x(nn), y(nn), tx(nn), ty(nn) integer :: rind(nn) dimension :: ind(nn), ilst(nn) dimension :: rw(4) dimension :: ndi(1) ! Set dummy integer for call to intpr(...). ndi(1) = 0 kdiv = int(1+dble(nn)**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(nn); thus number of subdivisions ! on each side of rectangle is approx. nn**(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,nn ! Keeps a list of those points already added ilst(i) = 0 ! to the new list. enddo do do i = 1,nn if(ilst(i) .ne. 1) then ! If the i-th point is in the current bin, add it to the list. xt = x(i) yt = y(i) ix = int(1+(xt-xmin)/dw) if(ix>kdiv) ix = kdiv jy = int(1+(yt-ymin)/dh) if(jy>kdiv) jy = kdiv if(ix==kx .and. jy==ky) then k = k+1 ind(i) = k ! Index i is the pos'n. of (x,y) in the rind(k) = i ! old list; k is its pos'n. in the new one. tx(k) = xt ty(k) = yt ilst(i) = 1 ! Cross the i-th point off the old list. endif endif enddo ! Move to the next bin. kc = kx+ink if((1<=kc) .and. (kc<=kdiv)) then kx = kc else ky = ky+1 ink = -ink endif if(ky > kdiv) exit enddo ! Check that all points from old list have been added to the new, ! with no spurious additions. if(k .ne. nn) then call intpr("Mismatch between number of points",-1,ndi,0) call intpr("and number of sorted points.",-1,ndi,0) call rexit("Bailing out of binsrt.") endif ! Copy the new sorted vectors back on top of the old ones. do i = 1,nn x(i) = tx(i) y(i) = ty(i) enddo end subroutine binsrt deldir/src/swap.f900000644000176200001440000000222214526547704013612 0ustar liggesuserssubroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,incAdj) ! 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) if(.not.shdswp) return ! Get the other vertex of the quadrilateral. call pred(k,k1,k2,nadj,madj,ntot) ! If these aren't the same, then call succ(kk,k2,k1,nadj,madj,ntot) ! there is no other vertex. if(kk .ne. k) then shdswp = .false. return endif ! 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) ! Do the actual swapping. if(shdswp) then call delet(k1,k2,nadj,madj,ntot) call insrt(j,k,nadj,madj,x,y,ntot,eps,incAdj) if(incAdj==1) return endif end subroutine swap deldir/src/master.f900000644000176200001440000000371014527007310014117 0ustar liggesuserssubroutine master(x,y,rw,nn,ntot,nadj,madj,eps,delsgs,ndel,delsum,& dirsgs,ndir,dirsum,incAdj,incSeg) ! 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. ! Note: "incAdj" <--> increase size of adjacency list. ! "incSeg" <--> increase size of storage for segments. implicit double precision(a-h,o-z) dimension :: x(-3:ntot), y(-3:ntot) dimension :: nadj(-3:ntot,0:madj) dimension :: rw(4) dimension :: delsgs(6,ndel), dirsgs(10,ndir) dimension :: delsum(nn,4), dirsum(nn,3) ! Define one. one = 1.d0 ! 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 enddo enddo ! 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,eps,incAdj) if(incAdj==1) return enddo ! 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,eps,incAdj) if(incAdj==1) return enddo ntri = 4 ! Now add the rest of the point set do j = 2,nn call addpt(j,nadj,madj,x,y,ntot,eps,ntri,incAdj) if(incAdj==1) return ntri = ntri + 3 enddo ! Obtain the description of the triangulation. call delseg(delsgs,ndel,nadj,madj,nn,x,y,ntot,incSeg) if(incSeg==1) return call delout(delsum,nadj,madj,x,y,ntot,nn) call dirseg(dirsgs,ndir,nadj,madj,nn,x,y,ntot,rw,eps,ntri,incAdj,incSeg) if(incAdj==1 .or. incSeg==1) return call dirout(dirsum,nadj,madj,x,y,ntot,nn,rw,eps) end subroutine master deldir/R/0000755000176200001440000000000014567246472011737 5ustar liggesusersdeldir/R/mid.in.R0000644000176200001440000000020211621163455013215 0ustar liggesusersmid.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/divchain.R0000644000176200001440000000007213433106407013626 0ustar liggesusersdivchain <- function(x,...) { UseMethod("divchain") } deldir/R/divchain.deldir.R0000644000176200001440000000154714046627063015107 0ustar liggesusersdivchain.deldir <- function (x,...) { # z <- x$summary$z if(is.null(z)) { xc <- deparse(substitute(x)) whinge <- paste("The class \"deldir\" object",xc,"was created without\n", "a tag argument \"z\" being supplied.\n") stop(whinge) } z <- factor(z) ddd <- x$dirsgs ddd <- ddd[z[ddd$ind1] != z[ddd$ind2],] id1 <- as.matrix(ddd[,c("ind1","ind2","thirdv1")]) id2 <- as.matrix(ddd[,c("ind1","ind2","thirdv2")]) id1 <- t(apply(id1,1,function(x){if(x[3] > 0) sort(x) else c(sort(x[1:2]),x[3])})) id2 <- t(apply(id2,1,function(x){if(x[3] > 0) sort(x) else c(sort(x[1:2]),x[3])})) rslt <- cbind(ddd[,1:4],id1,id2) names(rslt) <- c("x0","y0","x1","y1","v01","v02","v03","v11","v12","v13") class(rslt) <- c("divchain","data.frame") attr(rslt,"rw") <- x$rw rslt } deldir/R/tilePerim.R0000644000176200001440000000067513772463366014024 0ustar liggesuserstilePerim <- function(object,inclbdry=TRUE) { if(!inherits(object,"tile.list")) stop("Argument \"object\" must be of class \"tile.list\".\n") perims <- lapply(object,tilePerim0,inclbdry=inclbdry) perComps <- lapply(perims,function(x){attr(x,"perComps")}) perims <- unlist(perims) rslt <- list(perimeters=perims,totalPerim=sum(perims), meanPerim=mean(perims),perComps=perComps) rslt } deldir/R/print.tileInfo.R0000644000176200001440000000316014424044752014753 0ustar liggesusersprint.tileInfo <- function(x,digits=4,npl=6,...) { # # Matrix of edge lengths: lel <- lapply(x$indivTiles,function(u){u$edgeLengths}) nel <- sapply(lel,length) pNs <- names(x$indivTiles) m <- length(nel) n <- max(nel) ld <- ceiling(log10(max(unlist(lel)))) + digits + 1 fmt <- paste0("%",ld,".",digits,"f") nms <- paste0("point ",sub("pt.","",pNs),": ") npad <- max(nchar(nms)) pad <- paste(rep(" ",npad),collapse="") cat("\nEdge lengths:\n") cat("=============\n") for(i in 1:m) { xxx <- sprintf(fmt,lel[[i]]) irpt <- 0 repeat{ buff <- rep(" ",nchar(pad) - nchar(nms[i])) buff <- paste(buff,collapse="") lhe <- paste0(nms[i],buff) if(irpt==0) cat(lhe ) else cat(pad) ibit <- min(npl,length(xxx)) yyy <- xxx[1:ibit] xxx <- xxx[-(1:ibit)] cat(yyy,"\n") irpt <- 1 if(length(xxx)==0) break } } # Table of edgecounts: tec <- x$tabEdgeCounts names(attr(tec,"dimnames")) <- "" mode(tec) <- "character" tec <- c(" ",tec) cat("\nTable of edge counts:\n") cat("=====================\n\n") print(tec,quote=FALSE) # Areas: cat("\nTile areas:\n") cat("===========\n\n") print(round(x$Areas,digits=digits)) cat("\n") # Perimeters: cat("\nTile perimeters:\n") cat("================\n\n") print(round(x$perimeters$perimeters,digits=digits)) cat("\n") # Neighbours: cat("\nDelaunay neighbours of tile centres:\n") cat("=====================================\n\n") nbrs <- x$nbrs nms <- names(nbrs) nms <- sub("pt.","",nms) for(i in 1:length(nbrs)) { cat("point ",nms[i]," has neighbours: ",paste(nbrs[[i]],collapse=" "),"\n",sep="") } cat("\n") invisible() } deldir/R/tilePerim0.R0000644000176200001440000000133013772477363014073 0ustar liggesuserstilePerim0 <- function (object,inclbdry=TRUE) { ncomp <- attr(object,"ncomp") if(is.null(ncomp)) ncomp <- 1 tobj <- if(ncomp==1) list(object) else object$tileParts peri <- numeric(ncomp) for(i in 1:ncomp) { tmp <- tobj[[i]] x <- tmp[["x"]] y <- tmp[["y"]] xx <- c(x,x[1]) yy <- c(y,y[1]) if(inclbdry) { ok <- rep(TRUE,length(x)) } else { bp1 <- tmp[["bp"]] bp2 <- c(bp1,bp1[1]) bpm <- cbind(bp1,bp2[-1]) ok <- !apply(bpm,1,all) } peri[i] <- sum(sqrt(((xx[-1] - x)[ok])^2 + ((yy[-1] - y)[ok])^2)) } perTot <- sum(peri) attr(perTot,"perComps") <- peri perTot } deldir/R/insideRect.R0000644000176200001440000000157014423433352014140 0ustar liggesusersinsideRect <- function(x,y,rect,rw) { # Check that rect is a rectangle. if(!(is.numeric(rect) & length(rect) == 4)) { whinge <- paste0("Argument \"rect\", if not NULL, must", " be a numeric vector of length 4.\n") stop(whinge) } # Check that rect is a subset of rw and satifies rect[1] <= rect[2] # and rect[3] <= rect[4]. ok1 <- rw[1] <= rect[1] & rect[1] <= rect[2] & rect[2] <= rw[2] ok2 <- rw[3] <= rect[3] & rect[3] <= rect[4] & rect[4] <= rw[4] if(!(ok1 & ok2)) { whinge <- paste0("Argument \"rect\" must determine a subset of", " the rectangular\n window with respect to which", " the points were triangulated/tessellated.\n") stop(whinge) } # All is as it should be; determine which points are inside "rect". okx <- rect[1] <= x & x <= rect[2] oky <- rect[3] <= y & y <= rect[4] okx & oky } deldir/R/which.tile.R0000644000176200001440000000024212760230632014076 0ustar liggesuserswhich.tile <- function(x,y,tl){ u <- c(x,y) nt <- length(tl) d2 <- numeric(nt) for(i in 1:nt) { d2[i] <- sum((u-tl[[i]]$pt)^2) } which.min(d2) } deldir/R/getCol.R0000644000176200001440000000075014124233717013264 0ustar liggesusersgetCol <- 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) warning(paste("Cannot interpret the z-components of", "argument \"x\" as colours.\n")) return(NA) } ccc } deldir/R/plot.deldir.R0000644000176200001440000001435614423651003014270 0ustar liggesusersplot.deldir <- local({ fixColours <- function(cmpnt_col) { cmpnt_nms <- c("tri","tess","points","labels","rect") if(is.null(cmpnt_col)) { cmpnt_col <- rep(1,5) names(cmpnt_col) <- cmpnt_nms } else { cmpnt_col <- unlist(cmpnt_col) if(length(cmpnt_col) > 5) cmpnt_col <- cmpnt_col[1:5] if(!is.null(names(cmpnt_col))) { if(!all(names(cmpnt_col) %in% cmpnt_nms)) { stop("Argument \"cmpnt_col\" has incorrect names.\n") } ctmp <- rep(NA,5) names(ctmp) <- cmpnt_nms ctmp[names(cmpnt_col)] <- cmpnt_col cmpnt_col <- ctmp } else { cmpnt_col <- rep(cmpnt_col,length.out=5) names(cmpnt_col) <- cmpnt_nms } if(any(is.na(cmpnt_col))) { mde <- mode(cmpnt_col) switch(EXPR=mde, character={cmpnt_col[is.na(cmpnt_col)] <- palette()[1]}, numeric={cmpnt_col[is.na(cmpnt_col)] <- 1}, stop("Argument \"cmpnt_col\" is of an inappropriate mode.\n") ) } } cmpnt_col } fixLines <- function(cmpnt_lty) { lty_nms <- c("tri","tess") if(is.null(cmpnt_lty)) { cmpnt_lty <- 1:2 names(cmpnt_lty) <- lty_nms } else { cmpnt_lty <- unlist(cmpnt_lty) if(length(cmpnt_lty) > 2) cmpnt_lty <- cmpnt_lty[1:2] if(mode(cmpnt_lty) == "numeric") { if(!all(cmpnt_lty %in% 1:6)) { whinge <- paste("Numeric values of \"cmpnt_lty\" must", "be integers between 1 and 6.\n") stop(whinge) } } else if(mode(cmpnt_lty) == "character") { linetypes <- c("solid","dashed","dotted","dotdash", "longdash","twodash") if(!all(cmpnt_lty %in% linetypes)) { whinge <- paste0("Text string values of \"cmpnt_lty\" must ", "be one of the strings\n",paste(linetypes,collapse=", "), ".\n") stop(whinge) } } else { whinge <- paste0("Argument \"cmpnt_lty\" must be of mode either", " \"numeric\" or \"character\".\n") stop(whinge) } if(!is.null(names(cmpnt_lty))) { if(!all(names(cmpnt_lty) %in% lty_nms)) { stop("Argument \"cmpnt_lty\" has incorrect names.\n") } ltmp <- rep(NA,2) names(ltmp) <- lty_nms ltmp[names(cmpnt_lty)] <- cmpnt_lty cmpnt_lty <- ltmp dflt <- if(mode(cmpnt_lty) == "character") "solid" else 1 if(any(is.na(cmpnt_lty))) { cmpnt_lty[is.na(cmpnt_lty)] <- dflt } } else { cmpnt_lty <- rep(cmpnt_lty,length.out=2) names(cmpnt_lty) <- lty_nms } } cmpnt_lty } function(x,add=FALSE,wlines=c('both','triang','tess'), showpoints=TRUE,labelPts=FALSE,cex=1,lex=1, cmpnt_col=NULL,cmpnt_lty=NULL,pch=1, xlim=NULL,ylim=NULL,axes=FALSE, xlab=if(axes) 'x' else '', ylab=if(axes) 'y' else'', showrect=FALSE,asp=1,...) { # # 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 for use of the defunct argument name "number". ccc <- match.call() i <- match("number",names(ccc)) if(!is.na(i)) { if("labelPts" %in% names(ccc)) { whinge <- paste0("Both \"labelPts\" and the defunct argument", " \"number\" have been\n specified. Do not use", " the defunct argument \"number\". Use\n", " \"labelPts\" only.\n") stop(whinge) } whinge <- paste0("The argument name \"number\" is defunct. Please", " use \"labelPts\"\n instead.\n") warning(whinge) names(ccc)[i] <- "labelPts" return(eval(ccc)) } # Carry on. # 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) cmpnt_col <- fixColours(cmpnt_col) cmpnt_lty <- fixLines(cmpnt_lty) plot.del <- switch(wlines,both=TRUE,triang=TRUE,tess=FALSE) plot.dir <- switch(wlines,both=TRUE,triang=FALSE,tess=TRUE) 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] } else { x1 <- y1 <- x2 <- y2 <- numeric(0) } if(plot.dir) { u1<-dirsgs[,1] v1<-dirsgs[,2] u2<-dirsgs[,3] v2<-dirsgs[,4] } else { u1 <- v1 <- u2 <- v2 <- numeric(0) } X<-x$summary[,"x"] Y<-x$summary[,"y"] if(!add) { if(is.null(xlim)) xlim <- rw[1:2] if(is.null(ylim)) ylim <- rw[3:4] x.all <- c(x1,x2,u1,u2,X) y.all <- c(y1,y2,v1,v2,Y) pty <- list(...)$pty if(!is.null(pty)) { OP <- par(pty=pty) on.exit(par(OP)) } plot(x.all,y.all,type='n',xlim=xlim,ylim=ylim, xlab=xlab,ylab=ylab,axes=axes,asp=asp) } if(plot.del) { dotargs <- list(...) if(is.null(dotargs$col)) dotargs$col <- cmpnt_col[1] if(is.null(dotargs$lty)) dotargs$lty <- cmpnt_lty[1] arhgs <- c(list(x1,y1,x2,y2),dotargs) do.call(segments,arhgs) } if(plot.dir) { dotargs <- list(...) if(is.null(dotargs$col)) dotargs$col <- cmpnt_col[2] if(is.null(dotargs$lty)) dotargs$lty <- cmpnt_lty[2] arhgs <- c(list(u1,v1,u2,v2),dotargs) do.call(segments,arhgs) } if(showpoints) { dotargs <- list(...) dotargs$pch <- NULL dotargs$cex <- NULL do.call(points,c(list(x=X,y=Y,pch=pch,col=cmpnt_col[3],cex=cex),dotargs)) } if(labelPts) { xoff <- 0.02*diff(range(X)) yoff <- 0.02*diff(range(Y)) dotargs <- list(...) dotargs$ces <- NULL dotargs$col <- NULL lbls <- x$summary[["id"]] if(is.null(lbls)) lbls <- 1:nrow(x$summary) do.call(text,c(list(x=X+xoff,y=Y+yoff,labels=lbls,cex=lex, col=cmpnt_col[4]),dotargs)) } if(showrect) do.call(rect,c(as.list(x$rw)[c(1,3,2,4)],list(border=cmpnt_col[5]))) invisible() } }) deldir/R/triMat.R0000644000176200001440000000032213076540340013300 0ustar liggesuserstriMat <- function(object){ tl <- triang.list(object) vl <- lapply(tl,function(x){x[,"ptNum"]}) vl <- lapply(vl,sort) tm <- matrix(unlist(vl),byrow=TRUE,ncol=3) return(tm[order(tm[,1]),]) } deldir/R/lawSummary.R0000644000176200001440000000552714046637122014220 0ustar liggesuserslawSummary <- function(object) { # # Function to produce a summary of a Dirichlet (Voronoi) # tessellation in terms of parameters relevant to Lewis's law # and Aboav-Weaire's law. Note that "law" in the function name # corresponds to "Lewis-Aboav-Weaire. # # The parameters of interest are: # * the areas of each of the interior Dirichlet tiles # * the number of edges of each of the interior Dirichlet tiles # * the number of edges of all neighbouring tiles of # each of the interior Dirichlet tiles. # # This function was created at the request of Kai Xu # (Fisheries College, Jimei University, Xiamen, Fujian, China 361021). # dnbrs <- function(dsgs) { # Delaunay neighbours. iii <- dsgs[,c("ind1","ind2")] uind <- with(iii,sort(unique(c(ind1,ind2)))) rslt <- lapply(uind,function(i,m){sort(c(m[m[,1]==i,2],m[m[,2]==i,1]))},m=iii) names(rslt) <- uind rslt } dsgs <- object$dirsgs nbrs <- dnbrs(dsgs) # Layer 1; tiles whose edges have vertices on the boundary. ex1 <- apply(dsgs[,c("bp1","bp2")],1,any) dout1 <- dsgs[ex1,] iout1 <- as.character(unique(c(dout1[,"ind1"],dout1[,"ind2"]))) # Layer 2: tiles having vertices that are Delaunay neighbours # of vertices of tiles in Layer 1. nb1 <- as.character(unique(unlist(nbrs[iout1]))) # Layer 3: tiles having vertices that are Delaunay neighbours # of vertices of tiles in Layer 2. iout2 <- setdiff(nb1,iout1) nb2 <- as.character(unique(unlist(nbrs[iout2]))) iout3 <- setdiff(nb2,union(iout1,iout2)) # Keepers. smry <- object$summary nms.all <- rownames(object$summary) iout.12 <- union(iout1,iout2) iout.123 <- union(iout.12,iout3) nms.12 <- setdiff(nms.all,iout.12) nms.123 <- setdiff(nms.all,iout.123) if(!length(nms.123)) return(NULL) smry.123 <- smry[nms.123,] smry.12 <- smry[nms.12,] tile.areas <- smry.123$dir.area names(tile.areas) <- nms.123 tile.tags <- smry.123$z if(!is.null(tile.tags)) { names(tile.tags) <- nms.123 } num.edges <- smry.12$n.tside names(num.edges) <- nms.12 i.12 <- as.numeric(nms.12) i.123 <- as.numeric(nms.123) nbrs.12 <- lapply(nbrs,function(x,iok){intersect(x,iok)},iok=i.12) nbrs.123 <- lapply(nbrs.12[i.123],as.character) num.nbr.edges <- lapply(nbrs.123,function(k,x){x[k]},x=num.edges) totnum.nbr.edges <- sapply(num.nbr.edges,sum) num.edges <- num.edges[nms.123] tl <- tile.list(object)[i.123] tv <- lapply(tl,function(x){data.frame(x=x$x,y=x$y)}) names(tv) <- nms.123 rslt <- list(tile.vertices=tv,tile.areas=tile.areas) if(!is.null(tile.tags)) { rslt <- c(rslt,list(tile.tags=tile.tags)) } rslt <- c(rslt,list(num.edges=num.edges,num.nbr.edges=num.nbr.edges, totnum.nbr.edges=totnum.nbr.edges)) attr(rslt,"i1") <- as.numeric(iout1) attr(rslt,"i2") <- as.numeric(iout2) attr(rslt,"i3") <- as.numeric(iout3) attr(rslt,"i.kept") <- i.123 rslt } deldir/R/cvt.R0000644000176200001440000000233014010357232012630 0ustar liggesuserscvt <- function(object,stopcrit=c("change","maxit"),tol=NULL, maxit=100,verbose=FALSE) { # # Centroidal Voronoi Tessellation (by Lloyd's algorithm). # if(inherits(object,"deldir")) { l <- tile.list(object) rw <- object$rw } else if(inherits(object,"tile.list")) { l <- object rw <- attr(object,"rw") } else { whinge <- paste0("Argument \"object\" must be of class either\n", " \"deldir\" or \"tile.list\".\n") stop(whinge) } stopcrit <- match.arg(stopcrit) if(stopcrit=="change") { if(is.null(tol)) tol <- sqrt(.Machine$double.eps) } g <- tile.centroids(l) K <- 0 repeat { K <- K+1 pts <- lapply(l,function(x){x$pt}) pts <- as.data.frame(matrix(unlist(pts),byrow=TRUE,ncol=2)) names(pts) <- c("x","y") dv2 <- (pts$x - g$x)^2 + (pts$y - g$y)^2 dm <- sqrt(max(dv2)) if(verbose & K%%10 == 0) { cat("iteration:",K,"change:",dm,"\n") } if(stopcrit=="change") { if(dm < tol) break } else { if(K >= maxit) break } d <- try(deldir(g,rw=rw,round=FALSE)) if(inherits(d,"try-error")) browser() l <- tile.list(d) g <- tile.centroids(l) } if(verbose & K%%10 != 0) cat("\n") list(centroids=g,tiles=l) } deldir/R/binsrt.R0000644000176200001440000000106413751123527013351 0ustar liggesusersbinsrtR <- function(x,y,rw) { n <- length(x) ind <- rep(0,n) rslt <- .Fortran("binsrt", x=as.double(x), y=as.double(y), rw=as.double(rw), n=as.integer(n), ind=as.integer(ind), rind=as.integer(ind), tx=double(n), ty=double(n), ilst=integer(n), PACKAGE="deldir" ) list(x=rslt$tx,y=rslt$ty,ind=rslt$ind,rind=rslt$rind) } deldir/R/tile.centroids.R0000644000176200001440000000072714010335032014764 0ustar liggesuserstile.centroids <- function(tl){ # # "tl" <--> "tile list". # coit <- function (x,y) { # # "coit" <--> "centroid of individual tile". # 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(tl,function(x){coit(x$x,x$y)}) ccc <- as.data.frame(matrix(unlist(ccc),ncol=2,byrow=TRUE)) names(ccc) <- c("x","y") ccc } deldir/R/duplicatedxy.R0000644000176200001440000000043612035631164014544 0ustar liggesusersduplicatedxy <- 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/prelimtlist.R0000644000176200001440000000173014127272715014422 0ustar liggesusersprelimtlist <- function(object) { # # prelimtlist <--> "preliminary triangle list" # The ("preliminary") matrix produced by this function may contain # rows which are indices of the vertices of triangles which are # formed by the union of three contiguous Delaunay triangles and # which are not themselves Delaunay triangles. # stopifnot(inherits(object, "deldir")) a <- object$delsgs[, 5] b <- object$delsgs[, 6] prelist <- matrix(integer(0), 0, 3) for (i in seq(length.out=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) { prelist <- rbind(prelist, c(i, j, k)) } } } } } prelist } deldir/R/findNewInOld.R0000644000176200001440000000150214525302542014361 0ustar liggesusersfindNewInOld <- function(xnew,xold,ynew,yold,tolerance=sqrt(.Machine$double.eps)) { # # Check that x and y lengths match. if(length(xnew) != length(ynew) | length(xold) != length(yold)) stop("Mismatch in lengths of x and y sequences.\n") # If either the old or new sequence of points is empty, there # is nothing to find. if(!(length(xnew) & length(xold))) return(numeric(0)) # Set holder for found indices. ind <- numeric(length(xnew)) # Scale up tolerance if the "old" points are large in modulus. sfac <- max(1,mean(sqrt(xold^2+yold^2))) tol <- tolerance*sfac # Search for matches. for(i in seq_along(xnew)) { for(j in seq_along(xold)) { xok <- abs(xnew[i] - xold[j]) < tol yok <- abs(ynew[i] - yold[j]) < tol if(xok & yok) { ind[i] <- j break } } } ind } deldir/R/mnnd.R0000644000176200001440000000062213076573001012777 0ustar liggesusersmnndR <- 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/insidePoly.R0000644000176200001440000001007014526011170014153 0ustar liggesusersinsidePoly <- function(x,y,pgon,sanityCheck=FALSE, tolerance=sqrt(.Machine$double.eps)) { # This code is taken from the spatstat.utils function # inside.xypolygon() (the "interpreted" method), with minor # modifications, particularly in respect of the "sanity check". # # Also, in respect of determing boundary points, arrangements have # been made to allow conversion of` "==" to almost.equal() ("%~%"; # see below). This permits better determination of boundary points. # Check that pgon is of the appropriate form. if(inherits(pgon,"list")) { ok <- all(c("x","y") %in% names(pgon)) if(!ok) { stop("Argument \"pgon\" must be a list with components \"x\" and \"y\".\n") } xp <- pgon$x yp <- pgon$y ok1 <- is.numeric(xp) ok2 <- is.numeric(yp) ok3 <- length(xp) == length(yp) if(!(ok1 & ok2 & ok3)) { stop("The components of \"pgon\" are not of the correct form.\n") } } else { stop("Argument \"pgon\" must be a list determining a polygon.\n") } if(tolerance > 0) { almost.equal <- function(x, y) { abs(x - y) < tolerance } assign("tolerance",tolerance,envir=environment(almost.equal)) `%~%` <- function(x,y) almost.equal(x,y) } else { `%~%` <- `==` } full.npts <- npts <- length(x) nedges <- length(xp) # sic vx <- x%in%xp vy <- y%in%yp vv <- vx & vy retain <- !vv # Remove vertices from subsequent consideration; replace them later if(vertices.present <- !all(retain)) { x <- x[retain] y <- y[retain] npts <- sum(retain) } score <- numeric(npts) on.boundary <- rep.int(FALSE, npts) if(anyretain <- any(retain)) { for(i in 1:nedges) { x0 <- xp[i] y0 <- yp[i] x1 <- if(i == nedges) xp[1] else xp[i+1] y1 <- if(i == nedges) yp[1] else yp[i+1] dx <- x1 - x0 dy <- y1 - y0 if(dx < 0) { # upper edge xcriterion <- (x - x0) * (x - x1) consider <- (xcriterion <= 0) if(any(consider)) { ycriterion <- y[consider] * dx - x[consider] * dy + x0 * dy - y0 * dx # closed inequality contrib <- (ycriterion >= 0) * ifelse(xcriterion[consider] %~% 0, 1/2, 1) # positive edge sign score[consider] <- score[consider] + contrib # detect whether any point lies on this segment on.boundary[consider] <- on.boundary[consider] | (ycriterion %~% 0) } } else if(dx > 0) { # lower edge xcriterion <- (x - x0) * (x - x1) consider <- (xcriterion <= 0) if(any(consider)) { ycriterion <- y[consider] * dx - x[consider] * dy + x0 * dy - y0 * dx # open inequality contrib <- (ycriterion < 0) * ifelse(xcriterion[consider] %~% 0, 1/2, 1) # negative edge sign score[consider] <- score[consider] - contrib # detect whether any point lies on this segment on.boundary[consider] <- on.boundary[consider] | (ycriterion %~% 0) } } else { # vertical edge consider <- (x %~% x0) if(any(consider)) { # zero score # detect whether any point lies on this segment yconsider <- y[consider] ycriterion <- (yconsider - y0) * (yconsider - y1) on.boundary[consider] <- on.boundary[consider] | (ycriterion <= 0) } } } } # replace any polygon vertices that were temporarily removed if(vertices.present) { full.score <- numeric(full.npts) full.on.boundary <- rep.int(FALSE, full.npts) if(anyretain) { full.score[retain] <- score full.on.boundary[retain] <- on.boundary } full.score[vv] <- 1 full.on.boundary[vv] <- TRUE score <- full.score on.boundary <- full.on.boundary npts <- full.npts } # any point recognised as lying on the boundary gets score 1. score[on.boundary] <- 1 # Sanity Clause. if(sanityCheck) { if(!all((score == 0) | (score == 1))) warning("Some \"scores\" are neither equal to 0 nor to 1.\n") } # Aw' done! score <- as.logical(score) attr(score,"on.boundary") <- on.boundary score } deldir/R/verGetter.R0000644000176200001440000000015714010405273014007 0ustar liggesusersverGetter <- function(){ x <- utils::packageVersion("deldir") sub("^([^.]*\\.[^.]*)\\.(.*)$", "\\1-\\2", x) } deldir/R/tile.list.R0000644000176200001440000000527214525302720013756 0ustar liggesuserstile.list <- local({ edgeLengths <- function(x,y) { n <- length(x) el <- numeric(n) for(i in 1:n) { ii <- if(i < n) i+1 else 1 el[i] <- sqrt((x[i] - x[ii])^2 + (y[i] - y[ii])^2) } el } function (object,minEdgeLength=NULL,clipp=NULL) { if (!inherits(object, "deldir")) stop("Argument \"object\" is not of class \"deldir\".\n") rw <- object$rw if(is.null(minEdgeLength)) { drw <- sqrt((rw[2] - rw[1])^2 + (rw[4] - rw[3])^2) minEdgeLength <- drw*sqrt(.Machine$double.eps) } 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"]] id <- sss[["id"]] noid <- is.null(id) if(noid) id <- 1:nrow(sss) noz <- is.null(z) i.crnr <- get.cnrind(x, y, rw) ind.orig <- object$ind.orig rslt <- vector("list",npts) for (i in 1:npts) { filter1 <- ddd$ind1 == id[i] filter2 <- ddd$ind2 == id[i] subset <- ddd[which(filter1 | filter2),,drop=FALSE] m <- matrix(unlist(subset[, 1:4]), ncol = 4) bp1 <- subset[, 7] bp2 <- subset[, 8] m1 <- cbind(m[, 1:2, drop = FALSE], 0 + bp1) m2 <- cbind(m[, 3:4, drop = FALSE], 0 + bp2) m <- rbind(m1, m2) pt <- c(x = sss$x[i], y = sss$y[i]) theta <- atan2(m[, 2] - pt[2], m[, 1] - pt[1]) theta.0 <- sort(unique(theta)) mm <- m[match(theta.0, theta),,drop=FALSE] 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))) tmp <- list(ptNum = ind.orig[i], pt = pt, x = unname(xx), y = unname(yy), bp = bp, area = sss$dir.area[i]) tmp <- acw(tmp) bird <- edgeLengths(tmp$x,tmp$y) ok <- bird >= minEdgeLength tmp$x <- tmp$x[ok] tmp$y <- tmp$y[ok] tmp$bp <- tmp$bp[ok] rslt[[i]] <-acw(tmp) if(!noz) { rslt[[i]]["z"] <- z[i] } if(is.null(clipp)) { attr(rslt[[i]],"ncomp") <- 1 } } if(!is.null(clipp)) { if(requireNamespace("polyclip",quietly=TRUE)) { rslt <- lapply(rslt,doClip,clipp=clipp,rw=rw) } else { stop("Cannot clip the tiles; package \"polyclip\" not available.\n") } } ok <- !sapply(rslt,is.null) rslt <- rslt[ok] if(noid) { id <- paste0("pt.",id) } names(rslt) <- id[ok] class(rslt) <- "tile.list" attr(rslt, "rw") <- object$rw attr(rslt,"clipp") <- clipp return(rslt) } }) "[.tile.list" <- function(x,i,...){ y <- unclass(x)[i] class(y) <- "tile.list" attr(y,"rw") <- attr(x,"rw") y } deldir/R/First.R0000644000176200001440000000162314567246472013153 0ustar liggesusers.onAttach <- function(lib, pkg) { ver <- read.dcf(file.path(lib, pkg, "DESCRIPTION"), "Version") #nick <- "Nickname: \"Stack Smashing Detected\"" #nick <- "Nickname: \"Morpheus and Euripides\"" #nick <- "Nickname: \"Dyslexical Scoping\"" #nick <- "Nickname: \"Mendacious Cosmonaut\"" #nick <- "Nickname: \"Partial Distinction\"" #nick <- "Nickname: \"Mephistophelian Transition\"" nick <- "Nickname: \"Idol Comparison\"" #nick <- "Nickname: \"Perspicuous Ambivalence\"" #nick <- "Nickname: \"Cats are not required to wear seatbelts\"" #nick <- "Nickname: \"There weren't many available options\"" packageStartupMessage(paste(pkg, ver, " ",nick)) msg <- paste("\n The syntax of deldir() has changed since version", "\n 0.0-10. Read the help!!!.\n") packageStartupMessage(msg) } deldir/R/plot.tile.list.R0000644000176200001440000001203514536470361014737 0ustar liggesusersplot.tile.list <- function (x, verbose = FALSE, close = FALSE, pch = 1, fillcol = getCol(x,warn=warn), col.pts=NULL, col.lbls=NULL,border=NULL, showpoints = !labelPts, add = FALSE, asp = 1, clipp=NULL, xlab = "x", ylab = "y", main = "", axes=TRUE, warn=TRUE, labelPts=FALSE,adj=NULL,...) { # Check for use of the defunct argument name "number". ccc <- match.call() i <- match("number",names(ccc)) if(!is.na(i)) { if("labelPts" %in% names(ccc)) { whinge <- paste0("Both \"labelPts\" and the defunct argument", " \"number\" have been\n specified. Do not use", " the defunct argument \"number\". Use\n", " \"labelPts\" only.\n") stop(whinge) } whinge <- paste0("The argument name \"number\" is defunct. Please", " use \"labelPts\"\n instead.\n") warning(whinge) names(ccc)[i] <- "labelPts" return(eval(ccc)) } # Carry on. object <- x if (!inherits(object, "tile.list")) stop("Argument \"object\" is not of class tile.list.\n") clip <- !is.null(clipp) if(clip) { if(!is.null(attr(object,"clipp"))) { whinge <- paste0("Argument \"x\" is already clipped. Re-clip it\n", " if you want a different clipping polygon.\n") stop(whinge) if(!requireNamespace("polyclip",quietly=TRUE)) { stop("Cannot clip the tiles; package \"polyclip\" not available.\n") } } } 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, axes=axes) 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(col.lbls)){ col.lbls <- ifelse(fillcol == hexbla, hexwhi, hexbla) } else { col.lbls <- apply(col2rgb(col.lbls, TRUE), 2, function(x) { do.call(rgb, as.list(x/255)) }) col.lbls <- rep(col.lbls, length = length(object)) } if(is.null(border)) { border <- if(all(fillcol == hexbla)) hexwhi else hexbla } else if(length(border) > 1) border <- border[1] lnwid <- if(all(fillcol == hexbla)) 2 else 1 ptNms <- names(x) Adj <- adj if(is.null(Adj)) Adj <- if(showpoints) -1 else 0 pch <- rep(pch,n) pgons <- vector("list",n) icol <- 0 for(i in 1:n) { pgon <- if(clip) doClip(object[[i]],clipp,rw) else object[[i]] pgons[[i]] <- pgon if(is.null(pgon)) next icol <- icol+1 if(is.null(attr(pgon,"ncomp"))) attr(pgon,"ncomp") <- 1 if(attr(pgon,"ncomp") > 1) { pgon <- pgon$tileParts } else pgon <- list(pgon) for(ii in seq(along=pgon)){ ptmp <- pgon[[ii]] inner <- !any(ptmp$bp) polygon(ptmp,col=fillcol[icol],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(verbose) { if(showpoints) points(object[[i]]$pt[1], object[[i]]$pt[2], pch = pch[i], col = col.pts[i],...) if(labelPts) text(object[[i]]$pt[1], object[[i]]$pt[2], labels=ptNms[i], col = col.lbls[i],adj=Adj,...) if(i < n) readline(paste("i = ",i,"; Go? ",sep="")) if(i == n) cat("i = ",i,"\n",sep="") } } ok <- !sapply(pgons,is.null) if(showpoints & !verbose) points(x.pts[ok], y.pts[ok], pch = pch[ok], col = col.pts[ok],...) if (labelPts & !verbose) text(x.pts[ok], y.pts[ok], labels = ptNms[ok], col = col.lbls[ok], adj=Adj,...) pgons <- pgons[ok] pgons <- if(length(pgons)) pgons else NULL invisible(pgons) } deldir/R/plot.divchain.R0000644000176200001440000000103512666227531014614 0ustar liggesusersplot.divchain <- function (x, add = FALSE, ...) { dotargs <- list(...) bty <- dotargs$bty bxc <- dotargs$boxcol dotargs$boxcol <- NULL if (!add) { rw <- attr(x, "rw") plot(0, 0, type = "n", ann = FALSE, axes = FALSE, xlim = rw[1:2], ylim = rw[3:4]) if(is.null(bty)) bty <- "n" box(bty = bty, col=bxc) do.call(title,dotargs) } lapply(1:nrow(x), function(i, x) { do.call(segments, c(as.list(unname(x[i, 1:4])), dotargs)) }, x = x) invisible() } deldir/R/divchain.default.R0000644000176200001440000000036114046637773015272 0ustar liggesusersdivchain.default <- function (x,y,z,...) { # if(missing(z)) { if(inherits(x,"ppp")) z <- x$marks else stop("Argument \"z\" was not supplied .\n") } z <- factor(z) dd <- deldir(x,y,z=z,...) divchain(dd) } deldir/R/tileInfo.R0000644000176200001440000000700014423656132013615 0ustar liggesuserstileInfo <- function(object,bndry=FALSE,clipp=NULL) { # # Function to provide a summary of information about the tiles # of a Dirichlet (Voronoi) tessellation. # # First check that we really are looking at a tessellation/triangulation. if (!inherits(object, "deldir")) stop("Argument \"object\" is not of class \"deldir\".\n") # List the (possibly clipped) tiles in the tessellation. tl <- tile.list(object,clipp=clipp) # Required info: # * for each tile, the number of edges # * for each tile, a vector of the lengths of the edges # * for each tile, the vector of indices of the Delaunay neighbours # of the centre of the tile # * a tabulation of the numbers of edges of tiles # * a vector of all lengths of edges (with repetitions) # * a vector of lengths of _unique_ edges # * the area of each tile getEdges <- function(tile){ ncomp <- attr(tile,"ncomp") if(ncomp==1) { cmps <- list(tile) } else { cmps <- tile$tileParts } edges <- vector("list",ncomp) for(i in 1:ncomp) { tP <- cmps[[i]] x <- tP$x y <- tP$y x1 <- c(x,x[1]) y1 <- c(y,y[1]) hedges <- cbind(x1[-1],x,y1[-1],y) edges[[i]] <- t(apply(hedges,1,function(x){ o <- order(x[1:2],x[3:4]) c(x[1:2][o],x[3:4][o]) })) } edges <- do.call(rbind,edges) ledge <- apply(edges,1,function(x){sqrt((x[1]-x[2])^2 + (x[3]-x[4])^2)}) areas <- sapply(cmps,function(x){x$area}) list(edges=edges,edgeLengths=ledge,area=sum(areas),ptNum=tile$ptNum) } cnob <- function(tile) { # Check not on boundary. if(attr(tile,"ncomp")==1) { cmps <- list(tile) } else { cmps <- tile$tileParts } all(sapply(cmps,function(x){!any(x$bp)})) } ok <- sapply(tl,if(bndry) function(x){TRUE} else cnob) if(sum(ok)==0) { whinge <- paste0("All tiles are boundary tiles. To get a non-vacuous\n", " result, set bndry=TRUE.\n") stop(whinge) } xxx <- lapply(tl[ok],getEdges) ptNms <- object$summary[["id"]] if(is.null(ptNms)) { ptNums <- unname(sapply(xxx,function(x){x$ptNum})) ptNms <- paste0("pt.",1:nrow(object$summary)) } nms <- ptNms[ptNms %in% names(ok)][ok] names(xxx) <- nms # Extract and tabulate the edge counts. allnedge <- sapply(xxx,function(x){nrow(x$edges)}) tabnedge <- table(allnedge) # Extract and combine the edge lengths. Note that there # will be duplication since many edges are edges of *two* tiles. all.lengths <- unname(unlist(lapply(xxx,function(x){x$edgeLengths}))) # Extract the tile areas into a single vector. areas <- sapply(xxx,function(x){x$area}) # The lengths of unique edges. all.edges <- do.call(rbind,lapply(xxx,function(x){x$edges})) edupe <- duplicated(all.edges) ue <- all.lengths[!edupe] # Tile perimeters. perims <- tilePerim(tl[ok],inclbdry=bndry) names(perims$perimeters) <- nms # Delaunay neighbours of tile centres. nbrs <- getNbrs(object,interior=clipp) nms.ok <- intersect(nms,names(nbrs)) nbrs <- nbrs[nms.ok] # Pack up and go home. rslt <- list(indivTiles=xxx,allEdgeCounts=allnedge,tabEdgeCounts=tabnedge, allEdgeLengths=all.lengths,Areas=areas,uniqueEdgeLengths=ue, perimeters=perims,nbrs=nbrs) class(rslt) <- "tileInfo" rslt } deldir/R/doClip.R0000644000176200001440000000150214000433462013245 0ustar liggesusersdoClip <- function(object,clipp,rw) { pgon <- polyclip::polyclip(object,clipp) n <- length(pgon) if(n) { rslt <- object[c("ptNum","pt")] cmps <- vector("list",n) xold <- object$x yold <- object$y bpold <- object$bp for(ii in 1:n) { xnew <- pgon[[ii]]$x ynew <- pgon[[ii]]$y imtch <- findNewInOld(xnew,xold,ynew,yold) bp <- rep(FALSE,length(imtch)) bp[imtch!=0] <- bpold[imtch] area <- tileArea(xnew,ynew,rw) cmps[[ii]] <- list(x=xnew,y=ynew,bp=bp,area=area) } if(n==1) { rslt <- c(rslt,cmps[[1]]) } else { rslt <- c(rslt,list(tileParts=cmps)) } attr(rslt,"ncomp") <- n } else rslt <- NULL rslt } deldir/R/getNbrs.R0000644000176200001440000000202614525302664013454 0ustar liggesusersgetNbrs <- function(object,interior=NULL) { ddd <- object$dirsgs id <- object$summary[["id"]] noid <- is.null(id) if(noid) id <- 1:nrow(object$summary) if(is.null(interior)) { npts <- nrow(object$summary) } else { x <- object$summary[["x"]] y <- object$summary[["y"]] if(inherits(interior,"list")) { # "interior" is/should be a polygon ok <- insidePoly(x,y,interior) } else { rw <- object[["rw"]] ok <- insideRect(x,y,interior,rw) } id <- id[ok] npts <- length(id) } nbrs <- vector("list",npts) for(i in seq(along=id)) { filter1 <- ddd$ind1 == id[i] filter2 <- ddd$ind2 == id[i] subset <- ddd[which(filter1 | filter2),,drop=FALSE] nbrs[[i]] <- unname(apply(subset[,c("ind1","ind2")],1, function(x){x[x!=id[i]]})) } if(noid) { names(nbrs) <- paste0("pt.",id) } else { names(nbrs) <- id } nbrs } deldir/R/triang.list.R0000644000176200001440000000366514127272122014311 0ustar liggesuserstriang.list <- function (object) { stopifnot(inherits(object,"deldir")) io <- object$ind.orig tlist <- prelimtlist(object) if(nrow(tlist)==0) { rslt <- list() attr(rslt,"rw") <- object$rw class(rslt) <- "triang.list" return(rslt) } 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 seq(length.out=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=integer(1), PACKAGE="deldir" ) if(as.logical(tmp$okay)) { tmp <- data.frame(ptNum=io[tlist[i,]],x=xtri[i,],y=ytri[i,]) if(haveZ) tmp <- cbind(tmp,z=ztri[i,]) K <- K+1 rslt[[K]] <- tmp } } attr(rslt,"rw") <- object$rw class(rslt) <- "triang.list" rslt } "[.triang.list" <- function(x,i,...){ y <- unclass(x)[i] class(y) <- "triang.list" attr(y,"rw") <- attr(x,"rw") y } deldir/R/get.cnrind.R0000644000176200001440000000032711621163455014102 0ustar liggesusersget.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/plot.triang.list.R0000644000176200001440000000066414127275175015275 0ustar liggesusersplot.triang.list <- function(x,showrect=FALSE,add=FALSE,xlab="x",ylab="y", main="",asp=1,rectcol="black",...) { 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,c(as.list(rw)[c(1,3,2,4)],border=rectcol)) invisible() } deldir/R/print.deldir.R0000644000176200001440000000147714124241155014447 0ustar liggesusersprint.deldir <- function(x,digits=NULL,...) { cat("\n") cat("Delaunay triangulation and Dirchlet tessellation\n", "of",x$n.data," points.\n") cat("\n") if(is.null(digits)) { rw <- x$rw dirA <- x$dir.area delA <- x$del.area } else { rw <- round(x$rw,digits) dirA <- round(x$dir.area,digits) delA <- round(x$del.area,digits) } RW <- paste0("[",rw[1],",",rw[2],"]"," x ", "[",rw[3],",",rw[4],"]") cat("Enclosing rectangular window:\n") cat(RW,"\n") cat("\n") cat("Area of rectangular window (total area of\n") cat("Dirichlet tiles):\n") cat(dirA,"\n") cat("\n") cat("Area of convex hull of points (total area of\n") cat("Delaunay triangles):\n") cat(delA,"\n") cat("\n") invisible() } deldir/R/tileArea.R0000644000176200001440000000114213772175206013577 0ustar liggesuserstileArea <- function(x,y,rw) { n <- length(x) eps <- sqrt(.Machine$double.eps) area <- 0 for(i in 1:n) { ip <- if(i==n) 1 else i+1 tmp <- .Fortran( "stoke", x1=as.double(x[i]), y1=as.double(y[i]), x2=as.double(x[ip]), y2=as.double(y[ip]), rw=as.double(rw), area=double(1), s1=double(1), eps=as.double(eps), PACKAGE="deldir" ) area <- area+tmp[["area"]]*tmp[["s1"]] } area } deldir/R/acw.R0000644000176200001440000000050613260052670012615 0ustar liggesusersacw <- function(xxx) { xbar <- sum(xxx$x)/length(xxx$x) ybar <- sum(xxx$y)/length(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/deldir.R0000644000176200001440000003774714567245731013344 0ustar liggesusersdeldir <- local({ digOutz <- function(z1,znm,x) { if(inherits(z1,"try-error")) { # z not found, so the call can't # have been z=NULL! if(inherits(x,"matrix")) { if(znm %in% colnames(x)) return(x[,znm]) } if(znm %in% names(x)) return(x[[znm]]) whinge <- paste0("Object z = ",znm," not found.\n") stop(whinge) } if(is.null(z1)) return(NULL) # Here z1 is explicit vector, or a text string, equal to znm. # If the former return it; if the latter look for the # object named by that text string. if(!isTRUE(identical(z1,znm))) return(z1) z <- try(get(znm,pos=1),silent=TRUE) if(inherits(z,"try-error")) { if(inherits(x,"matrix")) { if(znm %in% colnames(x)) return(x[,znm]) } if(znm %in% names(x)) return(x[[znm]]) whinge <- paste0("Object z = ",znm," not found.\n") stop(whinge) } return(z) } digOutxy <- function(x,y,znm) { if(inherits(x,c("data.frame","matrix"))) { whatsit <- if(inherits(x,"data.frame")) "data frame" else "matrix" jj <- 1:ncol(x) vnms <- if(inherits(x,"data.frame")) names(x) else colnames(x) if(is.null(vnms)) vnms <- paste0("V",jj) jt <- jj[!(vnms %in% c("y",znm))] if(length(jt)==0) { whinge <- paste0("Argument \"x\" is a ",whatsit," but does not appear\n", " to contain the x-coordinates.\n") stop(whinge) } nomx <- min(jt) jx <- match("x",vnms,nomatch=nomx) vnms[jx] <- "x" y1 <- try(y,silent=TRUE) if(inherits(y1,"try-error") || is.null(y1)) { jy <- match("y",vnms) if(is.na(jy)) { jt <- jj[!(vnms %in% c("x",znm))] if(length(jt)==0) { whinge <- paste0("Argument \"x\" is a ",whatsit," but does not appear\n", " to contain the y-coordinates, nor is \"y\" to be\n", " found in the global environment.\n") stop(whinge) } jy <- min(jt) } return(list(x=x[,jx],y=x[,jy])) } return(list(x=x[,jx],y=y1)) } if(inherits(x,"list")) { if(!("x" %in% names(x))) { whinge <- paste0("When argument \"x\" is a generic list, it must have\n", " a component named \"x\". \n") stop(whinge) } y1 <- try(y,silent=TRUE) if(inherits(y1,"try-error") || is.null(y)) { y1 <- x[["y"]] } if(!is.null(y1)) return(list(x=x[["x"]],y=y1)) stop("Argument \"y\" not found.\n") } list(x=x,y=y) } function(x,y=NULL,z=NULL,rw=NULL,eps=1e-9,sort=TRUE,plot=FALSE, round=TRUE,digits=6,id=NULL,...) { # Function deldir 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. # # 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. # # 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. #cat("Fuck fuck fuck!!!\n") # Organise the x, y and possibly z arguments. if(inherits(x,"ppp")) { # If the first argument is an object of class "ppp", extract the x # and y coordinates from this object. If this object is "marked" # and if the marks are atomic (a vector or a factor) and z is NULL, # then set z equal to the marks. y1 <- try(y,silent=TRUE) if(!is.null(y1)) warning("Since \"x\" is of class \"ppp\", argument \"y\" is ignored.\n") if(is.null(z)) { marx <- x$marks ok <- !is.null(marx) & is.atomic(marx) if(ok) z <- marx } if(is.null(rw)) rw <- c(x$window$xrange, x$window$yrange) y <- x$y x <- x$x } else { z1 <- try(z,silent=TRUE) if(inherits(z1,"character") & length(z1)==1) { znm <- z1 } else { znm <- deparse(substitute(z)) } xyTemp <- digOutxy(x,y,znm) z <- digOutz(z1,znm,x) x <- xyTemp$x y <- xyTemp$y } haveZ <- !is.null(z) # Check that x and y are numeric. if(!is.numeric(x)) stop("The x-coordinates must be numeric.\n") if(!is.numeric(y)) stop("The y-coordinates must be numeric.\n") # Check that lengths match. n <- length(x) if(n!=length(y)) stop("Lengths of \"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") } # Check on the "id" argument. haveId <- !is.null(id) if(haveId) { if(any(duplicated(id))) stop("Argument \"id\", if supplied, must contain no duplicate values.\n") if(n!=length(id)) stop("Length of \"id\" does not match lengths of \"x\" and \"y\".\n") id <- as.character(id) } # If a data window is specified, turn it into a 4-tuple (if necessary). if(!is.null(rw)) { if(inherits(rw,"owin")) { xr <- rw$xrange yr <- rw$yrange rw <- c(xr,yr) # Apparently --- according to Michael Chirico 24/09/2015 --- the # following will accommodate the bounding box of a collection of # polygons as structured in the "sp" package. } else if(is.matrix(rw)) { rw <- as.vector(t(rw)) } # Check that rw is an appropriate 4-tuple. ok <- length(rw)==4 && (rw[1] < rw[2] & rw[3] < rw[4]) if(!ok) stop("The rectangula window rw is not of the appropriate form.\n") } # If a data window now exists, 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] ind.orig <- 1:n drop <- ind.orig[xxmax|yymax] if(length(drop)>0) { x <- x[-drop] y <- y[-drop] if(haveZ) z <- z[-drop] if(haveId) id <- id[-drop] ind.orig <- ind.orig[-drop] } } nn <- length(x) # Could be different from "n" if the data were # clipped to rw. # If the rectangular window is (still) not specified, form its corners # from the minimum and maximum of the data +/- 10%: if(is.null(rw)) { if(length(x)==0) stop("No points nor any rectangular window specified.\n") xmin <- min(x) xmax <- max(x) ymin <- min(y) ymax <- max(y) xdff <- xmax-xmin ydff <- ymax-ymin # Check for the setting in which all points lie on a vertical # or horizontal straight line. if(isTRUE(all.equal(xdff,0))) { whinge <- paste0("The x-range of the points is zero, whence a", " rectangular window\n cannot be inferred from", " the data. You must specify the rectangular\n", " window explicitly.\n") stop(whinge) } if(isTRUE(all.equal(ydff,0))) { whinge <- paste0("The y-range of the points is zero, whence a", " rectangular window\n cannot be inferred from", " the data. You must specify the rectangular\n", " window explicitly.\n") stop(whinge) } 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) ind.orig <- 1:n } # Eliminate duplicate points: iii <- duplicatedxy(x,y) if(any(iii)) { kkk <- !iii nn <- sum(kkk) if(haveZ) { jjj <- duplicated(data.frame(x=x,y=y,z=z)) if(sum(jjj) < sum(iii)) { whinge <- paste("There were different tags corresponding to\n", "duplicated points.\n",sep="") warning(whinge) } z <- z[kkk] } x <- x[kkk] y <- y[kkk] ind.orig <- ind.orig[!iii] } # Check there are sufficiently many points to triangulate/tessellate. if(nn <= 1) { whinge <- paste("There is at most one point inside the given\n", " rectangular window. Thus there are insufficiently\n", " many points to triangulate/tessellate.\n") stop(whinge) } # Sort the coordinates into "bins". There are approximately # sqrt(nn) such bins. The vector "ind" (index) keeps track of the # re-ordering; if ind[i] == j then i is the index of a point in # the original sequence of points and j is the index of the same # point in the bin sorted sequence. The vector "rind" (reverse # index) does the opposite; if rind[i] == j then i is the position # of a point in the bin sorted sequence and j is its position in # the original sequence. Thus ind[rind[k]] = k and rind[ind[k]] = k # for all k. So xs[ind] (where xs is the bin sorted sequence of # x's) is equal to x, the original sequence of x's. Likewise ys[ind] # (where ys is the bin sorted sequence of y's) is equal to y, the # original sequence of y's. Conversely x[rind] = xs and y[rind] = ys. # # Added 20/03/2017: I think I rather made a meal of this. The # vector of indices "rind" is just order(ind); ind is a permutation # of 1, 2, ..., nn. Thus rind[ind] = ind[rind] = 1, 2, ..., nn. # However there's no real harm done, so I won't change the shaganappi # code at this stage. if(sort) { xy <- binsrtR(x,y,rw) x <- xy$x y <- xy$y ind <- xy$ind rind <- xy$rind } else { ind <- 1:nn rind <- 1:nn } # Make space for the total number of points 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): ntot <- nn + 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*nn ntdir <- 3*nn # 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 <- 10*ndir # Call the master subroutine to do the work: repeat { tmp <- .Fortran( 'master', x=as.double(x), y=as.double(y), rw=as.double(rw), nn=as.integer(nn), ntot=as.integer(ntot), nadj=integer(tadj), madj=as.integer(madj), eps=as.double(eps), delsgs=double(tdel), ndel=as.integer(ndel), delsum=double(ntdel), dirsgs=double(tdir), ndir=as.integer(ndir), dirsum=double(ntdir), incAdj=integer(1), incSeg=integer(1), PACKAGE='deldir' ) # Check for problems with insufficient storage: incAdj <- tmp$incAdj incSeg <- tmp$incSeg if(incAdj==0 & incSeg==0) break if(incAdj==1) { nmadj <- ceiling(1.2*madj) wrds <- paste('Increasing madj from',madj,'to',nmadj, 'and trying again.') message(wrds) madj <- nmadj tadj <- (madj+1)*(ntot+4) ndel <- max(ndel,madj*(madj+1)/2) tdel <- 6*ndel ndir <- ndel tdir <- 10*ndir } if(incSeg==1) { nndel <- ceiling(1.2*ndel) wrds <-paste('Increasing ndel and ndir from',ndel, 'to',nndel,'and trying again.') message(wrds) ndel <- nndel tdel <- 6*ndel ndir <- ndel tdir <- 10*ndir } } # Collect up the results for return: ndel <- tmp$ndel delsgs <- if(round) { round(t(as.matrix(matrix(tmp$delsgs,nrow=6)[,1:ndel])),digits) } else { t(as.matrix(matrix(tmp$delsgs,nrow=6)[,1:ndel])) } 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 <- if(round) { round(cbind(delsum,delsum[,4]/del.area),digits) } else { cbind(delsum,delsum[,4]/del.area) } del.area <- if(round) round(del.area,digits) else del.area ndir <- tmp$ndir dirsgs <- if(round) { round(t(as.matrix(matrix(tmp$dirsgs,nrow=10)[,1:ndir])),digits) } else { t(as.matrix(matrix(tmp$dirsgs,nrow=10)[,1:ndir])) } dirsgs <- as.data.frame(dirsgs) dirsum <- matrix(tmp$dirsum,ncol=3) dir.area <- sum(dirsum[,3]) dirsum <- if(round) { round(cbind(dirsum,dirsum[,3]/dir.area),digits) } else { cbind(dirsum,dirsum[,3]/dir.area) } dir.area <- if(round) round(dir.area,digits) else dir.area names(dirsgs) <- c('x1','y1','x2','y2','ind1','ind2','bp1','bp2', 'thirdv1','thirdv2') 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') # The foregoing results are in terms of the indices of the bin sorted coordinates. # Put things in terms of the indices of the original coordinates. delsgs$ind1 <- rind[delsgs$ind1] delsgs$ind2 <- rind[delsgs$ind2] dirsgs$ind1 <- rind[dirsgs$ind1] dirsgs$ind2 <- rind[dirsgs$ind2] dirsgs$thirdv1 <- with(dirsgs,ifelse(thirdv1<0,thirdv1,rind[abs(thirdv1)])) dirsgs$thirdv2 <- with(dirsgs,ifelse(thirdv2<0,thirdv2,rind[abs(thirdv2)])) # If "id" was supplied, change the entries of "ind1", "ind2", "thirdv1", # and "thirdv2" to be the corresponding entries of "id". if(haveId) { delsgs$ind1 <- id[delsgs$ind1] delsgs$ind2 <- id[delsgs$ind2] dirsgs$ind1 <- id[dirsgs$ind1] dirsgs$ind2 <- id[dirsgs$ind2] dirsgs$thirdv1 <- with(dirsgs,ifelse(thirdv1<0,as.character(thirdv1), id[abs(thirdv1)])) dirsgs$thirdv2 <- with(dirsgs,ifelse(thirdv2<0,as.character(thirdv2), id[abs(thirdv2)])) } # The points in "allsum" appear in bin-sorted order; rearrange # the rows of "allsum" so that the points appear in the original order. allsum <- allsum[ind,] # The following is a furphy --- it just makes the rownames into # 1, 2, ..., n. At this point the rownames of "allsum" were # (1:n)[ind]. So we're getting (1:n)[ind][rind] = ind[rind] # = 1:n !!! # rownames(allsum) <- rownames(allsum)[rind] # So we could just set rownames(allsum) <- 1:nrow(allsum) and # get the same effect. However that does not take account of # *duplicated* points. So it is better to use ind.orig. Note that # the resulting rowname corresponding to a point is the index (in # the original sequence of points) of the *first* in its sequence # of duplicated points. rownames(allsum) <- ind.orig # Arrange for the tags and id to be in the summary, given # that they were supplied. dfz <- if(haveZ) { data.frame(z=z) } else { as.data.frame(matrix(nrow=nn,ncol=0)) } dfid <- if(haveId) { data.frame(id=id) } else { as.data.frame(matrix(nrow=nn,ncol=0)) } allsum <- cbind(allsum[,1:2],dfid,dfz,allsum[,3:9]) rw <- if(round) round(rw,digits) else rw # Aw' done!!! rslt <- list(delsgs=delsgs,dirsgs=dirsgs,summary=allsum,n.data=nn, del.area=del.area,dir.area=dir.area,rw=rw, ind.orig=ind.orig) attr(rslt,"round") <- round attr(rslt,"digits") <- if(round) digits else NA class(rslt) <- 'deldir' if(plot) { plot(rslt,...) return(invisible(rslt)) } else return(rslt) } }) deldir/MD50000644000176200001440000001362514567527702012053 0ustar liggesusers56d1a621937eae3fd2a33ae5ff85f9ef *ChangeLog 1098cca1f03a9b1db21839398223ea8f *DESCRIPTION 058da4b8b5765582931e43414bf5bdda *NAMESPACE 601630fdb6c4a59cc1bd89aa38476ba9 *R/First.R 73e1fe7de214e92456cd97ad52a32f44 *R/acw.R e3a2a2668bc0f9ef0d2d845c0a712c31 *R/binsrt.R cf63d30192e7000cdd0a5fd38bcabd94 *R/cvt.R 5aefed43ef8301aa000f6882feed90b0 *R/deldir.R e93cf566c9d47595ee8fd48fd53c49ff *R/divchain.R 55724ca4cc120c540362ffc357e7d961 *R/divchain.default.R 8ab92bd123378abf04a0914cb1606809 *R/divchain.deldir.R f6d5d36becffdd8bd826e8e30d238d94 *R/doClip.R 993ce9e5a7e061fba1847c6f029def08 *R/duplicatedxy.R 9a90e6cafc6be6e7495406fad3f2ff52 *R/findNewInOld.R 3e37aaac8530922a03f0cc05eee1a13e *R/get.cnrind.R 7ac5e391404ed5ad2a7b5baefea8848b *R/getCol.R d7d17898217f97bcbe26b2e1552abcda *R/getNbrs.R fd0e73709e85d6fdccad45986060c860 *R/insidePoly.R 1e0e008d404f4f1f69e2b0df576c5e31 *R/insideRect.R 320ac1e156ad1963ef9cd4cc76898a2b *R/lawSummary.R e55af1ae6eb1861a0e7e2ea8a68c8444 *R/mid.in.R 38cab98679b46834c875f24aa585652d *R/mnnd.R 5accef90c64ff886275c4fe62a59ddb4 *R/plot.deldir.R d6eab673058844acdc5ec31ba74cac63 *R/plot.divchain.R 3d6a1d80a7b6d17bd15b4b4a3500643b *R/plot.tile.list.R 327d64184bed6076edaf9d86a9e4f271 *R/plot.triang.list.R 308faf87e71c1788d1838a2dc3f32e2c *R/prelimtlist.R 41996f1dc81f416aaacd8dda6fb7eb52 *R/print.deldir.R cd616e5fa032575b5f475db9f90c8ea1 *R/print.tileInfo.R 472c848021e98255d4ef9e6e5d52a4f0 *R/tile.centroids.R d2303147a6cf7c544e884943fa5f5db6 *R/tile.list.R eb70467d05962c5635871397703be2b5 *R/tileArea.R e04ee5e389504bed1cbdc4ded6e1843c *R/tileInfo.R 0c1982687e466fe729585e28be79a783 *R/tilePerim.R e3ec05a142e1999d69087544c5380d4d *R/tilePerim0.R 0877e76d2988a0e49b6751dcb40953b5 *R/triMat.R 4b10ccee85f357f809e0b79f3bc05596 *R/triang.list.R 22f91c0e7fcf00097e75ea41d1652e93 *R/verGetter.R d7d6dfe03916e59bef1323472197b6a2 *R/which.tile.R eedd392aa8250a2c8b24bba36ad098d8 *data/grapherXmpl.rda 194d3053913b38fb35450882bc4c8166 *data/niProperties.rda eff7f334de6367523ba4d3b183b478c3 *data/seaweed.rda e4b449cca2f73f5f06eeaa3dd4bbedec *data/toyPattern.rda dd2c1020a36abc3f3e7a0fffa106f83d *data/volTriPoints.rda 3c54acc86ffad1135b71f8606ca25d87 *inst/READ_ME 293ae0ffd9cecfea1c0ed209c435254b *inst/code.discarded/collinChk.R 89af7f1d92321349b555a8494402f781 *inst/code.discarded/collincheck.f a8275b74f69979b3a41a4457f88ec09b *inst/code.discarded/collincheck.r f8ee4c06be766562bcb1b77441e6d0a6 *inst/code.discarded/fexitc.c e7bf17db270a13377c0a032f9bb7e2a4 *inst/code.discarded/fexitf.f c4504bd02330db4cad30761c06bd8727 *inst/code.discarded/fexitf.r c2d0b8ca101bbeea7470b1e28f7f2e4d *inst/code.discarded/ind.dup.R 7a0cbe7ba69bc4d3758d7b467378a6a5 *inst/code.discarded/inddup.r 6490ad9d3b6a5f9b44b79966ed8c7aeb *inst/code.discarded/init.c 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 ed46e23d86abafd7a3331ffaf6fbecf9 *inst/code.discarded/xsucc.f cc713629b2837d66f036d7063d0cf1d6 *man/cvt.Rd 83ff52450cec8a028afc8f380cf9d6dc *man/deldir-internal.Rd a9877580b5c8e41d81d05c366a3513db *man/deldir.Rd ba7168d05f65f45af6d1dc0f1d90bcb1 *man/divchain.Rd 58ca04827cbba4a2e241eff974f4ac77 *man/duplicatedxy.Rd b0a9e1b6079f137660e38582ac634df9 *man/getNbrs.Rd b4c81092e8fd5552ba4b24088301e95b *man/grapherXmpl.Rd 23c8406cd530e5246daaf4bfdfea6aea *man/lawSummary.Rd 3caee100044036646193fa9ae9046092 *man/macros/defns.Rd 2ce7fbea93478b4645c8061eb4966093 *man/niProperties.Rd 507bd0c5d40d641e71a3fa1359fb2285 *man/plot.deldir.Rd 1314a414f10ebe107addd1664a9ae6e8 *man/plot.divchain.Rd 37c19b129820ff30d2b22f594b0e8054 *man/plot.tile.list.Rd a75377ac21477529e112c55d80ae5354 *man/plot.triang.list.Rd 52f4e5f6414ebfd148d110ed61160a83 *man/print.deldir.Rd c2e6f6bd224b8559eca750136d8dce4d *man/print.tileInfo.Rd 0a772c80522c05df5c0be20a36072367 *man/seaweed.Rd bcb4e349026b8ab7be1d9d6187094068 *man/tile.centroids.Rd ce372b699cc384d87230a821dc14469a *man/tile.list.Rd 530f6029d986a87a7ddcfdc0e0ea497b *man/tileArea.Rd bf5d08bd9deb43161b51145ad6de20c4 *man/tileInfo.Rd 698a8bdd20fb9182cea300f964a43a4b *man/tilePerim.Rd 8232ad29072b60f257fd5ae8cd695554 *man/toyPattern.Rd 631f7ed0ad0adf79aa4cdad0a49b8598 *man/triMat.Rd 69749b250c979711ef2d3a0e0e89ec03 *man/triang.list.Rd f81bd0b754273c155b7100ddefdb8e0a *man/volTriPoints.Rd e0191573ec722a2bac8028adc8bc23e0 *man/which.tile.Rd e26eef9e320091c1116b1910534e6f6b *src/acchk.f90 89785d74fddf6eec48a9ce47960b46a9 *src/addpt.f90 44e248091e7bbcf8b4ef4e17821262a1 *src/adjchk.f90 cb17605b134eabb5b41bcd4dbd23810f *src/binsrt.f90 5d7358c90175e5ca7758c20e109bbaad *src/circen.f90 07735f31b654ce4f1b2fbf7fdbb5baa7 *src/cross.f90 514f258bdafa859e82f8edf0b8c930a8 *src/delet.f90 e77830e2225d9499d543d8698394cb55 *src/delet1.f90 82f43b684542de8daf87c1af68acbf84 *src/delout.f90 ad2ecd8127302ee67caf265963a07bee *src/delseg.f90 521b4157e37fe4c362c6201cbfc298bf *src/dirout.f90 95e39034dea0e51fbbc98954658f722f *src/dirseg.f90 7fdf012fc1b8d2dd33351910be2c5f30 *src/dldins.f90 0d5cdbb65423fc46dca03a5d69959c2a *src/init.c 129e1366784a1dcd2744ce6129858940 *src/initad.f90 43ac9cb1b67de946d412bac84ef0dad6 *src/insrt.f90 6a0047da1ddbc5c25929e92c0ae1fea1 *src/insrt1.f90 0095034bc1a0fca50972c2a7cc84b413 *src/intri.f90 287731b68406e424d4af1f527b50ee36 *src/locn.f90 881058d998f90f8c090b2a1d42b2f3db *src/master.f90 e4aa98993c8d0586d33dce863d08cb97 *src/mnnd.f90 70713ea858b05534336c39f1f7c25212 *src/pred.f90 24f67cbd50995da655a0a9d4ad705573 *src/qtest.f90 3b9366c29cec92d19462bbff5ab06b98 *src/qtest1.f90 f9c8da38fbf5920e2195b58c8e14ff8c *src/stoke.f90 831f3fa34dfbc21f4c7b80c551024755 *src/succ.f90 dd4c383593e9b67993fc287315118c0c *src/swap.f90 76ca000ffe60c8b82452be4416d0a22a *src/testeq.f90 5cfc298ba7fbb0d78e9a1d4a326cf188 *src/triar.f90 c7b8eacc6c4d514ed2fb9116f7e7e781 *src/trifnd.f90 deldir/inst/0000755000176200001440000000000014526551531012501 5ustar liggesusersdeldir/inst/code.discarded/0000755000176200001440000000000013745174033015334 5ustar liggesusersdeldir/inst/code.discarded/ind.dup.R0000644000176200001440000000067611621163455017026 0ustar liggesusersind.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/inddup.r0000644000176200001440000000054411621163455017002 0ustar liggesuserssubroutine 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/collincheck.f0000644000176200001440000000235513520003411017744 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine collincheck(nadj,madj,npts,x,y,ntot,eps) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) dimension nadj(-3:ntot,0:madj) logical collin, changed nerror = -1 changed = .false. 23000 continue do23003 j = 1,npts nj = nadj(j,0) do23005 k = 1,nj k1 = nadj(j,k) call succ(k2,j,k1,nadj,madj,ntot,nerror) if(nerror .gt. 0)then call intpr("Error number =",-1,nerror,1) call rexit("Error in succ, called from collincheck.") endif call crossutil(j,k1,k2,x,y,ntot,eps,collin) if(collin)then changed = .true. sd1 = (x(k1) - x(j))**2 + (y(k1) - y(j))**2 sd2 = (x(k2) - x(j))**2 + (y(k2) - y(j))**2 if(sd1 .lt. sd2)then kr = k2 else kr = k1 endif call delet(j,kr,nadj,madj,ntot,nerror) if(nerror .gt. 0)then call intpr("Error number =",-1,nerror,1) call rexit("Error in collincheck.") endif goto 23006 endif 23005 continue 23006 continue if(changed)then goto 23004 endif 23003 continue 23004 continue 23001 if(.not.(.not.changed))goto 23000 23002 continue return end deldir/inst/code.discarded/init.c0000644000176200001440000000235013745174033016443 0ustar liggesusers#include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Fortran calls */ extern void F77_NAME(binsrt)(double *, double *, double *, int *, int *, int *, double *, double *, int *, int *); extern void F77_NAME(intri)(double *, double *, double *, double *, int *, int *); extern void F77_NAME(master)(double *, double *, double *, int *, int *, int *, int *, double *, double *, int *, double *, double *, int *, double *, int *); extern void F77_NAME(mnnd)(double *, double *, int *, double *, double *); extern void F77_NAME(cross)(double *, double *, int *, double *); static const R_FortranMethodDef FortranEntries[] = { {"binsrt", (DL_FUNC) &F77_NAME(binsrt), 10}, {"intri", (DL_FUNC) &F77_NAME(intri), 6}, {"master", (DL_FUNC) &F77_NAME(master), 15}, {"mnnd", (DL_FUNC) &F77_NAME(mnnd), 5}, {"cross", (DL_FUNC) &F77_NAME(cross), 4}, {NULL, NULL, 0} }; void R_init_deldir(DllInfo *dll) { R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } deldir/inst/code.discarded/intri.r.save0000644000176200001440000000134011621163455017574 0ustar liggesuserssubroutine 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/code.discarded/fexitf.r0000644000176200001440000000011713412004553016771 0ustar liggesuserssubroutine fexit(msg) character*(*) msg nc = len(msg) call fexitc(msg, nc) end deldir/inst/code.discarded/trigraf.r0000644000176200001440000000311411621163455017151 0ustar liggesusers# 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.c0000644000176200001440000000737311621163455017145 0ustar liggesusers/* 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/fexitc.c0000644000176200001440000000041213412002250016735 0ustar liggesusers#include void F77_NAME(fexitc)(char *msg, int *nchar) { int nc = *nchar; char buf[256]; if(nc > 255) { warning("invalid character length in fexitc"); nc = 255; } strncpy(buf, msg, nc); buf[nc] = '\0'; error(buf); } deldir/inst/code.discarded/collinChk.R0000644000176200001440000000061113517175306017364 0ustar liggesuserscollinChk <- function(i,j,k,x,y,eps=NULL) { xt <- x[c(i,j,k)] yt <- y[c(i,j,k)] xx <- .Fortran( "cross", xt=as.double(xt), yt=as.double(yt), ijk=as.integer(0), cprd=double(1), PACKAGE='deldir' ) cprd <- xx$cprd if(is.null(eps)) eps <- sqrt(.Machine$double.eps) rslt <- abs(cprd) < eps attr(rslt,"crossproduct") <- cprd rslt } deldir/inst/code.discarded/xsucc.f0000644000176200001440000000156313507520555016635 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine xsucc(ksc,i,j,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) dimension junk(20) nerror = -1 n = nadj(i,0) if(n.eq.0)then nerror = 9 return endif do23002 k = 1,n junk(k) = nadj(i,k) 23002 continue 23003 continue call intpr("i =",-1,i,1) call intpr("adj. list of i:",-1,junk,n) do23004 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) call intpr("k =",-1,k,1) call intpr("kp =",-1,kp,1) call intpr("ksc =",-1,ksc,1) call intpr("junk(k) =",-1,junk(k),1) call intpr("junk(kp) =",-1,junk(kp),1) return endif 23004 continue 23005 continue nerror = 10 return end deldir/inst/code.discarded/collincheck.r0000644000176200001440000000333313520003122017754 0ustar liggesuserssubroutine collincheck(nadj,madj,npts,x,y,ntot,eps) # Collinearity check --- experimental. Runs through the adjacency # list to see if any of the putative triangles in the triangulation # that has so far been created are "degenerate", i.e. are actually # just three points lying on a straight line. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) dimension nadj(-3:ntot,0:madj) logical collin, changed nerror = -1 changed = .false. repeat { do j = 1,npts { nj = nadj(j,0) do k = 1,nj { k1 = nadj(j,k) call succ(k2,j,k1,nadj,madj,ntot,nerror) if(nerror > 0) { call intpr("Error number =",-1,nerror,1) call rexit("Error in succ, called from collincheck.") } # Check whether triangle j, k1, k2 is really a triangle. call crossutil(j,k1,k2,x,y,ntot,eps,collin) # If collinear, remove the triangle from the mix. if(collin) { changed = .true. # First determine which of k1 and k2 is closer to j. It # *should* be k1, but y'never know in these chaotic # circumstances. sd1 = (x(k1) - x(j))**2 + (y(k1) - y(j))**2 sd2 = (x(k2) - x(j))**2 + (y(k2) - y(j))**2 if(sd1 < sd2) { kr = k2 } else { kr = k1 } # Delete kr ("r" for "remove") from the adjacency list of j and j # from the adjacency list of kr. call delet(j,kr,nadj,madj,ntot,nerror) if(nerror > 0) { call intpr("Error number =",-1,nerror,1) call rexit("Error in collincheck.") } break } } if(changed) break } } until(!changed) return end deldir/inst/code.discarded/trigraf1.r.save0000644000176200001440000000312611621163455020172 0ustar liggesusers# # 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/fexitf.f0000644000176200001440000000023613500035005016751 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine fexit(msg) character*(*) msg nc = len(msg) call fexitc(msg, nc) end deldir/inst/code.discarded/triang.list.R.save0000644000176200001440000000404311621163455020650 0ustar liggesuserstriang.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/READ_ME0000644000176200001440000001113313745163045013520 0ustar liggesusers 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. This R package continues to be revised and updated from time to time. Current address of the author: Department of Statistics University of Auckland Private Bag 92019 Auckland 1142 New Zealand Email: r.turner@auckland.ac.nz 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 Curtin University in 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. Many others have contributed to the package over the years by pointing out bugs and suggesting fixes. Most of these contributors are acknowledged in the ChangeLog and possibly in the help files. I apologise to those whom I have overlooked or neglected to include. It's just ineptitude, not malice! The Fortran code contained in the src directory, is ponderous --- it was automatically generated from Ratfor code. This code can be found in the directory inst/ratfor. The Ratfor code was pretty ponderous to start with. It is quite possibly very kludgy as well --- i.e. a good programmer could make it ***much*** more efficient I'm sure. It contains all sorts of checking for anomalous situations most of 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 Mark Berman and I 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. ===