deldir/0000755000176200001440000000000013615764032011524 5ustar liggesusersdeldir/NAMESPACE0000644000176200001440000000066013260054315012735 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) importFrom("grDevices", "col2rgb", "rgb") importFrom("graphics", "axis", "box", "par", "plot", "points", "polygon", "rect", "segments", "text", "title") deldir/ChangeLog0000644000176200001440000005753513615620350013307 0ustar liggesusers Version 0.1-25 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. 03/02/2020. Version 0.1-24 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. (01/08/2019) Version 0.1-23 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 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. (23/06/2019) 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. (05/07/2019). 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.) (05/07/2019). Submitted to CRAN 05/07/2019. Version 0.1-21 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 Submitted to CRAN 14/06/2019. Fixed several infelicities in the ratfor/fortran code in respect of variables being declared or appearing as arguments but never being used. (12/06/2019) 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). Version 0.1-19 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. (11/06/2019) Version 0.1-18 Added the function lawSummary (at the request of Kai Xu) (22/02/2019). 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 02/06/2019. 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 Installed on CRAN 04/01/2019 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 (30/12/2018). Added the data set "niProperties" (kindly provided by Adam Dadvar) to illustrate collinearity problems (03/01/2019). Further revised the help page for deldir, giving some explanation of the error traps and error numbers. Version 0.1-15 Installed on CRAN 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. Version 0.1-14 Installed on CRAN 22/04/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. 20/03/2017. 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(). 21/03/2017 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. 27/03/2017 Rewrote triMat() after a bug in it was pointed out to me by Jay Call. 22/04/2017 Version 0.1-13 Never installed on CRAN (??? !!!) Documented the function which.tile() --- !!! Done 01/11/2016. Added the function which.tile() at the request of "RAY". Done 27/08/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 problem. Done 21/07/2016. Version 0.1-12 Installed on CRAN 06/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". Done 05/03/2016 Version 0.1-11 Never installed on CRAN 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. Done 04/03/2016. 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. Done 04/03/2016. 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. Done 04/03/2016. 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". Done 04/03/2016. Also added a plot method plot.divchain() to plot dividing chains. Done 04/03/2016. 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.) Done 04/03/2016. Version 0.1-10 Never installed on CRAN To do: Fix the "rw" argument to accept forms other than c(xmin,xmax,ymin,ymax). (Suggestion of Michael Chirico, 23,24/09/2015.) Amended the examples in deldir.Rd to alleviate a possible point of confusion pointed out by Samuel Ackerman. Done 01/08/2015. Fixed some typos in deldir.Rd, duplicated.Rd, plot.tile.list.Rd and plot.triang.list.Rd. Done 09/03/2015. 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(). Done 10/03/2015. Fixed a few more glitches in the documentation. Done 10/03/2015. Version 0.1-9 Uploaded to CRAN 09/03/2015. Removed period from end of title in the DESCRIPTION file. Changed NAMESPACE file to "register" S3 methods. Removed "require("polyclip") in plot.tile.list() and change code to use: if(requireNamespace("polyclip",quietly=TRUE)) .... instead. Changed URL from http://www.stat.auckland.ac.nz to https://www.stat.auckland.ac.nz in help files and in the DESCRIPTION file. The 4 foregoing changes made at the behest of Uwe Ligges. Done 09/03/2015. Version 0.1-8 Uploaded to CRAN 09/03/2015. Added a "[.tile.list" method so that tile lists can be subsetted and still retain their class and "rw" attribute. Prompted by an enquiry to R-help from Raphael Päbst, 15/01/2015. Done 09/03/2015. Added a component "ind.orig" to the object returned by deldir(). This consists of the indices of the points in the original set of (x,y) coordinates provided to the function (before any duplicated points were removed). Prompted by an enquiry from Daniel McCloy 29/12/14. He wanted the triangle descriptions produced by triang.list() to show these original indices --- as the help file claims they show --- rather than the indices in the set of coordinates after the removal of duplicates. Done 09/03/2015. Changed triang.list() to make use of the "original coordinates" referred to above. Done 09/03/2015. Revised plot.triang.list() so that it actually tries to plot the (x,y) coordinates of the triangle vertices rather than trying to use (ptNum,x) (!!!) as it previously did. The problem was caused by xy.coords(tri) using the first two columns of "tri" as the (x,y) coordinates rather than the columns named "x" and "y". I'm ***sure*** that plot.triang.list() *used* to work, i.e. that the columns named "x" and "y" were extracted. (If "tri" were a list, then components named "x" and "y" would be extracted, and since data frames are lists with components equal to the columns, I would have expected this to work, but it doesn't. Moreover the help for xy.coords() clearly says that it doesn't. Go figure.) Prompted by an enquiry from Yinghui Liu, 09/03/2015. Done 09/03/2015. Version 0.1-7 Uploaded to CRAN 26/11/2014 Fixed bug with respect to the z "weights"; if there were duplicated points, there was a mismatch of numbers between the z "weights" and the unique collection of points that deldir() works with. Fixed. Thanks to Ron Peterson for drawing this bug to my attention. Done 26/11/2014. Changed the procedure for issuing a message from the initial invocation of deldir() so that it no longer uses cat() but rather calls message(). Requested by Bob O'Hara. Done 21/08/2014. Added some material to the description of the "z" argument to deldir() to make it clear that these weights do not affect the tessellation and that deldir does *not* do weighted tessellation. (Prompted by an enquiry from Garry Gelade.) Done 26/08/2014. Version 0.1-6 Uploaded to CRAN 03/08/2014 Corrected the ratfor code dirseg.r and dirout.r. A rarely occuring bug was possible due to the way the code was previously written. The code made use of the ray joining a circumcentre to the midpoint of an edge of a Delaunay triangle. It is *possible* for the circumcentre and that midpoint to coincide. In such a case Fortran seemed to calculate the slope of the ray (zero over zero) to be equal to one. The result was wrong of course and an error with number nerror = 17 was (fortunately!) thrown. In retrospect it is "obvious" that the ray should have been taken to join the two circumcentres on opposite sides of the Delaunay edge. But since these two circumcentres could conceivably coincide it is better to take the slope of the ray to be the negative reciprocal of the slope of the Delaunay edge. The code now uses this slope. Thanks to Pierre Legendre for drawing this bug to my attention. Done 03/08/2014. Slight adjustment to plot.tile.list.R (so that when verbose=TRUE and showpoints=TRUE, the points get plotted "at the right time" rather than when the *next* tile gets plotted). Done 18/05/2014. Slight adjustment made to plot.tile.list.Rd Done 18/05/2014. Version 0.1-5 Uploaded to CRAN 02/02/2014 In the help for plot.tile.list() the call to this function that made use of the "clipp" argument has been wrapped in if(require(polyclip)) { ... } so as to avoid errors when the deldir package is used by older versions of R which do not provide the polyclip package. (Change made at the behest of Uwe Ligges.) Version 0.1-4 Uploaded to CRAN 31/01/2014 Fixed up an error in the handling of "x" and "y" coordinates and the "z" weights as columns of a data frame. The code asked for a third column of the data frame, and there might not be one. Error caught by the CRAN people when the ade4 package threw an error upon calling deldir. Changed the protocol so that: * the x coordinates are the column named "x" if there is one else the first column *not* named "y" or "z" * the y coordinates are the column named "y" if there is one else the first column *not* named "x" or "z" * the z weights are the column named "z" if there is one *and* if the z argument is NULL (else the z weights are left to be NULL. Version 0.1-3 Uploaded to CRAN 30/01/2014 Fixed up references to my web page to refer to my New Zealand web page. (28/01/2014) Adjusted code to allow the x argument of deldir() to be a data frame whose names do *not* necessarily include "x", "y", and "z". In this case the x coordinates are taken to be the first column of the data frame, the y coordinates to be the second column, and z to be the third column if that column exists. Version 0.1-2 Uploaded to CRAN 01/10/2013. Adjusted the behaviour of the function plot.tile.list() when verbose=TRUE, very slightly. Removed the use.gpclib argument to plot.tile.list() (in accordance with the new behaviour of spatstat). Version 0.1-1 Uploaded to CRAN 02 October 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. Version 0.0-22 (17 April 2013) Fixed the dimensioning of delsgs, dirsgs, and ind in delsegs.r and dirsegs.r. Had used a "1" as the last dimension and this now throws a "subscript out of range" warning from the compiler. Version 0.0-21 (12 October 2012) Fixed glitch w.r.t. the z-argument of deldir() --- if "x" was a list with "x" and "y" components, and if "z" was supplied as a separate argument, then "z" got ignored. Added a "point number" component to the list produced for each Delaunay triangle by triang.list(). Added the function duplicatedxy() to determine duplicated points, to make it convenient for the user to eliminate duplicates from a point set before calling deldir(). Done at the request of Adrian Baddeley. Version 0.0-20 (07 September 2012) Removed the elaborate startup message referring to changes from previous versions of "deldir". Replaced this with message produced by deldir() itself, the first time that it is called in any given session. Added an argument "suppressMsge" to deldir() allowing the user to keep this message from appearing. Done at the request of Adrian Baddeley. Version 0.0-19 (23 April 2012) Added warnings in respect of change of "summary" and "delsgs" from matrices to data frames. Corrected spelling of "auxiliary" in various places. Fixed up the "see also"-s in tile.list() and plot.tile.list(). Fixed a typo in the help for plot.tile.list(). Fixed up the "see also" in the help for deldir(). Version 0.0-18 (21 April 2012) At the suggestion of Simon Greener, added the capacity to carry along "auxilliary" variables or "weights" associated with the points being triangulated. If supplied these weights appear as a third column of the data frames specifying the triangles in the triangulation, as produced by the function triang.list(). Version 0.0-17 (03 April 2012) Added the function triMat() at the suggestion of Robin Hankin. Fixed a glitch in the documentation of deldir() (in the Warning section). Tweaked the documentation of plot.tile.list(), plot.triang.list(), and tile.list(). Version 0.0-16 (04 November 2011) Fixed some minor errors in the documentation. Added a namespace. Version 0.0-15 (12 August 2011) Fixed a bug in triang.list(); occasionally triangles would appear in this list which were *not* Delaunay triangles but rather the union of three congtiguous such triangles. This now no longer happens. Fixed some minor infelicities in the Fortran (ratfor) code. Removed switch() statements from the ratfor code (and replaced them with a sequence of if's). It appears that the ratfor compiler that is currently available to me does not handle switch statements properly. The resulting Fortran code compiled and loaded but led to errors when run. ***************************** Version 0.0-14 (22 June 2011) Put the startup messages into packageStartupMessage() rather than catting them. At the request of Thierry Onkelinx. ***************************** Version 0.0-13 (29 November 2010) Renamed the directory inst/ratfor.discarded inst/code.discarded and moved the no-longer-used function ind.dup to that directory. Added a facility to plot.deldir() to plot the enclosing rectangle "rw". Added the same facility to plot.tile.list(). Added attribute "rw" to the object returned by tile.list() so that the foregoing facility can work. Added function triang.list(). Added function plot.triang.list(). Added arguments add, xlab, ylab, main, and asp to plot.tile.list(). ***************************** Version 0.0-12 (08 January 2009) Fixed a minor glitch in the .First.lib() function. I had a backspace coded into the message produced, and this upset Sweave. The backspace had been put in to get things to line up correctly. Re-arranged things (properly!) so that it is no longer needed. ***************************** Version 0.0-11 (09 December 2009) No change, really. A tweak that I made to the First() function in version 0.0-10, *without* changing the version number (psigh!) did not propagate to the Windoze and Mac OSX binaries. So version 0.0-11 is just the same as the tweaked realization of of version 0.0-10 but with the version number changed so that the tweak will propagate. ***************************** Version 0.0-10 (16 November 2009) Got rid of the call to ind.dup() which used a very rough bit of Fortran code to detect duplicated points, and replaced it with a call to duplicated(). (Bug pointed out by Bjarke Christensen.) ***************************** Version 0.0-9 (4 November 2009) Added a new function tile.centroids() --- which does the obvious. Motivated by an inquiry from Leandro Moreira. Added a ChangeLog ***************************** Version 0.0-8 (4 April 2009) Removed the labels from the x and y vectors in the tile descriptions produced by tile.list. These labels (which were the row numbers in the dirsgs data frame returned by deldir()) served no useful purpose and were potentially confusing. ***************************** Versions 0.0-2 through 0.0-7 were not tracked here. :-( Simply forgot about doing this. I thoroughly *intend* [ :-) ] to get the archives from CRAN and try to document the changes. Recent ones involved fixing bugs in and adding features to the tile.list() and plot.tile.list() functions. ***************************** Version 0.0-1 (21 February 2002) This version is simply an adaptation of the Splus version of the package to R. ============================================================================== The following items relate to the Splus versions of deldir ============================================================================== Version date: 14 February 2002. This version supercedes the version dated 24 April 1999. The changes from the version dated 24 April 1999 to the version dated 14 February 2002 were: A bug in the procedure for eliminating duplicated points was fixed. Thanks go to Dr. Berwin Turlach of the Department of Maths and Stats at the University of Western Australia, for spotting this bug. ***************************** Version date: 24 April 1999. This version supercedes the version dated 26 October 1998. The changes from the version dated 26 October 1998 to the version dated 24 April 1999 were: (1) The function mipd(), stored in mipd.sf, and the corresponding Fortran subroutine mipd, stored in mipd.r, have been replaced by mnnd() in mnnd.sf and mnnd in mnnd.r. The function mipd calculated the mean interpoint distance, to be used in constructing dummy point structures of a certain type. After some reflection it became apparent that the mean interpoint distance was much too large for the intended purpose, and that a more appropriate value was the ``mean nearest neighbour distance'' which is calculated by the new function. This new value is now used in constructing dummy point structures. Note that the operative result is that the resulting dummy point structures contain many more points than before. The old value caused large numbers of the dummy points to fall outside the data window and therefore to be clipped. ***************************** Version date: 26 October 1998. This version supercedes the version dated 6 December 1996. The changes from the version dated 6 December 1996 to the version dated 26 October 1998 were: (1) A ratfor/Fortran routine named ``inside'' has been renamed ``dldins'' to avoid conflict with a name built in to some versions of Splus. (2) Some minor corrections have been made to dangerous infelicities in a piece of the ratfor/Fortran code. (3) The dynamic loading procedure has been changed to use dyn.load.shared so that the package is easily usable on IRIX systems as well as under SunOS/Solaris. (4) The package has been adjusted slightly so that it can easily be installed as a section of a library. In particular, the dynamic loading is now done by the .First.lib() function rather than from within deldir() itself; reference to an environment variable DYN_LOAD_LIB is no longer needed. deldir/data/0000755000176200001440000000000013413231437012427 5ustar liggesusersdeldir/data/niProperties.rda0000644000176200001440000000623213615622175015614 0ustar liggesusers]Wy\ h[)T&$6J (BHjJB(i̭hO%KQ={yswM`0,[`?&ÐJ;EDDD2lu )}po'Ə R6Z\[c༽{z+M씀ˬ{a1M>}'!΃;\ 7\\g8RIg_8༢Yv[,~`JWr rCRx8_X&^A<3V-\3}?w{/9l|t=y>ɛU𮟏z 䚠){eˤzL0Po؝X9#rrV@^IQv<< U`g[no&=;}d<\^"kn~gN!ΗL)v5K]_xxCpBv;w*%oɏGzZѭb%z I_=Q U'A`mqo_a|9d;;|;uƲT s#_<: {϶QTV Cqs٫4O7p)OcU}&d: 23 >_5SDF޸=($Ow`Xwf>Csbϭ2" woĽex1 ?Nn^?GbWkw.&+-ҔWT^ y.;UX$RcuQQsaǸo W-)ǜ&5IZڳ]hڍmoI{nY*=fD{C^;oKd#c`Ȟ?t~Hjcti!x ڟى0O4ȇ0,+oM{^cPz?5jWya/9V{އfE9Fd(7?أd]ڃ^G M=l{kW|AUoS Aki凚؟r\[ڷV`~ vV%/Ƴ_xtԉeMMzRm>#pLþe=E7?P) >|U̥ܱJ9{B=l"x8G% ^OQz +{j vW`t<٩,cs5AV~ݡdfbmCoPA~6B~Xлn#?q?:GGkh٭4Nz\Avt1w'vJ (GӹIp֛I@`x uYqBv;4۾Da(覗G[Sgߒ^/kOtʨsR\I;I{qw$FKU?Ցj|nfWfrI+,u\<OՒ@^Yk} 1Fnݬ=8a ^So$/R۩9Tog-󬰸hr'͏=LU;ƧZB:kg=G{[-?K"ߗ+xB3/<bppZ-6w:LtTNyXʤJ;LC_uy.ߗ$| !;Tg%2$:ܾ ţi&> Heݶ:Af;+ r1DsͷNn;iZѽLU4WYC_O ghOT..5W|TGNP+'WcQ"R3$bKur`bubU;6Ck.Pc;W"As=7hYOa89+)u$SWGQ>8q≫ay'BKvT?W7iՈ삆K\(o/P]߀US\w$ɏ;fmߖO|죽!Jqhqhdpb4;|TH|KañseRuմ7TI΍_N=YAtu9\THy$ўѺO$Yao꯱pDSض? _F>Sd>n-A{bpl/y(~L<_X64/天!V>qhPͿR@KUSns ]<^۲4ǖ7H~,3&c̘~_OO}|6E%"¶|adiՃdeldir/data/seaweed.rda0000644000176200001440000000232213615622175014542 0ustar liggesusers]wlWU(XmEā#qĠ(*.;"*j*lj+*5*A[Qk5JqׁMMsϽ{ϺcFUU41G0T :- mD|H2GD.2u/ #Vȫ c?r}{[/,ƶ\`g#!/^sUOПƷ}l7!-V{ס=5 #Ư1ngm%?Am#CX{(iyAȇX3دAoƶ.zGD ȡwb<C D(.oi}@_R\x?{2c㘛mG+^waȅ@_k؋nt;}2ۢ c){:q!V1=Ik>kX]1;8ߑ]gsJbP{p$)`Ï~ *)yFoq=s JHxwyU~<9b!wa6kaOB%BF~\~;:Sg<Dz|.璈˙Q[vcrӧgN;k$a6sn BeKuɆIbL|Wg]n;Q/'!rw9S9+c&MY{7(̀Ky^ J<Amb}F7D,#">ɼ!j VVよ@LhSM֎n @rO9rnzF^@=聜WӳjB}5ji:'\M=Q;ai?(f>뻰"{қ++UyyqVY. Ξcm#e-ɞ6xf>dS zoa3W]n, o6zq~ioB/8k>acq/u_SJև>"{e_ R^X7o%Ԇs?x3a*}К;­pxp© _\;3>g8uԇ;թ> 0}) \item \code{z} (the auxiliary values or \dQuote{weights}; present only if these were specified) \item \code{n.tri} (the number of Delaunay triangles emanating from the point) \item \code{del.area} (1/3 of the total area of all the Delaunay triangles emanating from the point) \item \code{del.wts} (the corresponding entry of the \code{del.area} column divided by the sum of this column) \item \code{n.tside} (the number of sides --- within the rectangular window --- of the Dirichlet tile surrounding the point) \item \code{nbpt} (the number of points in which the Dirichlet tile intersects the boundary of the rectangular window) \item \code{dir.area} (the area of the Dirichlet tile surrounding the point) \item \code{dir.wts} (the corresponding entry of the \code{dir.area} column divided by the sum of this column). } Note that the factor of 1/3 associated with the del.area column arises because each triangle occurs three times --- once for each corner. } \item{n.data}{ the number of real (as opposed to dummy) points in the set which was triangulated, with any duplicate points eliminated. The first n.data rows of \code{summary} correspond to real points. } \item{n.dum}{ the number of dummy points which were added to the set being triangulated, with any duplicate points (including any which duplicate real points) eliminated. The last n.dum rows of \code{summary} correspond to dummy points. } \item{del.area}{ the area of the convex hull of the set of points being triangulated, as formed by summing the \code{del.area} column of \code{summary}. } \item{dir.area}{ the area of the rectangular window enclosing the points being triangulated, as formed by summing the \code{dir.area} column of \code{summary}. } \item{rw}{ the specification of the corners of the rectangular window enclosing the data, in the order (xmin, xmax, ymin, ymax). } \item{ind.orig}{A vector of the indices of the points (x,y) in the set of coordinates initially supplied (as data points or as dummy points) to \code{deldir()} before duplicate points (if any) were removed. These indices are used by \code{\link{triang.list}()}. }} \section{Remark:}{ If ndx >= 2 and ndy >= 2, then the rectangular window IS the convex hull, and so the values of del.area and dir.area (if the latter is not \code{NULL}) are identical. } \section{Side Effects}{ If \code{plotit=TRUE} a plot of the triangulation and/or tessellation is produced or added to an existing plot. } \details{ This package is a (straightforward) adaptation of the Splus library section ``delaunay'' to R. That library section is an implementation of the Lee-Schacter algorithm, which was originally written as a stand-alone Fortran program in 1987/88 by Rolf Turner, while with the Division of Mathematics and Statistics, CSIRO, Sydney, Australia. It was re-written as an Splus function (using dynamically loaded Fortran code), by Rolf Turner while visiting the University of Western Australia, May, 1995. Further revisions were made December 1996. The author gratefully acknowledges the contributions, assistance, and guidance of Mark Berman, of D.M.S., CSIRO, in collaboration with whom this project was originally undertaken. The author also acknowledges much useful advice from Adrian Baddeley, formerly of D.M.S., CSIRO (now Professor of Statistics at Curtin University). Daryl Tingley of the Department of Mathematics and Statistics, University of New Brunswick provided some helpful insight. Special thanks are extended to Alan Johnson, of the Alaska Fisheries Science Centre, who supplied two data sets which were extremely valuable in tracking down some errors in the code. Don MacQueen, of Lawrence Livermore National Lab, wrote an Splus driver function for the old stand-alone version of this software. That driver, which was available on Statlib, is now deprecated in favour of the current package ``delaunay'' package. Don also collaborated in the preparation of that package. See the \code{ChangeLog} for information about further revisions and bug-fixes. } \section{Notes on error messages}{ In the underlying Fortran code, error traps have been set for 17 different errors, which are identified by an error number \code{nerror}. When one of these traps detects an error, the value of \code{nerror} is passed back along the call stack to the \code{R} function \code{deldir()} that calls the Fortran subroutines. (I.e. to \emph{this} function, the documentation of which you are currently reading.) The \code{deldir()} function then prints out a message and returns (invisibly) a \code{NULL} value. The message consists only of the value of \code{nerror}. A glossary of the meanings of the values of \code{nerror} is to be found in the file \code{err.list}, located in the top level of the package directory (\dQuote{folder} if you are a Windoze weenie). Note that the values 4, 14 and 15 of \code{nerror} do not cause \code{deldir()} to return a \code{NULL} value but rather cause a message to be printed, storage (memory) to be re-allocated (increased) and \code{deldir()} to be re-started so as to take advantage of the increased amount of storage. In version \code{0.1-16} of \code{deldir} a new error trap was introduced, and this new trap triggers a genuine error and does so in a direct and perspicuous manner. This new error trap relates to \dQuote{triangle problems}. It was drawn to my attention by Adam Dadvar (on 18 December, 2018) that in some data sets collinearity problems may cause the \dQuote{triangle finding} procedure, used by the algorithm to successively add new points to a tessellation, to go into an infinite loop. A symptom of the collinearity is that the vertices of a putative triangle appear \emph{not} to be in anticlockwise order irrespective of whether they are presented in the order \code{i, j, k} or \code{k, j, i}. The result of this anomaly is that the procedure keeps alternating between moving to \dQuote{triangle} \code{i, j, k} and moving to \dQuote{triangle} \code{k, j, i}, forever. The new error trap, set in \code{trifnd}, the triangle finding subroutine, detects such occurrences of \dQuote{clockwise in either orientation} vertices. The trap causes the \code{deldir()} function to throw an error rather than disappearing into a black hole. The error is thrown \dQuote{directly} rather than via passing a \code{nerror} number back up the call stack. The facility for triggering an error in this manner was not available when the \code{deldir} package was originally written. In the reasonably near future the \code{deldir} package will be adjusted so that all error traps throw errors in the \dQuote{direct} manner, and use of the \code{nerror} numbers will be eliminated. When an error of the \dQuote{triangle problems} nature occurs, a \emph{possible} remedy is to increase the value of the \code{eps} argument of \code{deldir()}. (See the \bold{Examples}.) There may conceiveably be other problems that lead to infinite loops and so I have put in another error trap to detect whether the procedure has inspected more triangles than actually exist, and if so to throw an error. Note that the strategy of increasing the value of \code{eps} is \emph{probably} the appropriate one in most (if not all) of the cases where errors of this nature arise. (Similarly this strategy is \emph{probably} the appropriate response to errors with \code{nerror} equal to 3, 12 and 13.) However it is impossible to be sure. The intricacy and numerical delicacy of triangulations is too great for anyone to be able to foresee all the possibilities that could arise. If there is any doubt as the appropriateness of the \dQuote{increase \code{eps}} strategy, the user is advised to do his or her best to explore the data set, graphically or by other means, and thereby determine what is actually going on and why problems are occurring. } \section{Warnings}{ \enumerate{ \item The process for determining if points are duplicated changed between versions 0.1-9 and 0.1-10. Previously there was an argument \code{frac} for this function, which defaulted to 0.0001. Points were deemed to be duplicates if the difference in \code{x}-coordinates was less than \code{frac} times the width of \code{rw} and \code{y}-coordinates was less than \code{frac} times the height of \code{rw}. This process has been changed to one which uses \code{\link{duplicated}()} on the data frame whose columns are \code{x} and \code{y}. As a result it may happen that points which were previously eliminated as duplicates will no longer be eliminated. (And possibly vice-versa.) \item The components \code{delsgs} and \code{summary} of the value returned by \code{deldir()} are now \emph{data frames} rather than matrices. The component \code{summary} was changed to allow the \dQuote{auxiliary} values \code{z} to be of arbitrary mode (i.e. not necessarily numeric). The component \code{delsgs} was then changed for consistency. Note that the other \dQuote{matrix-like} component \code{dirsgs} has been a data frame since time immemorial. A message alerting the user to the foregoing two items is printed out the first time that \code{deldir()} is called with \code{suppressMsge=FALSE} in a given session. In succeeding calls to \code{deldir()} in the same session, no message is printed. (I.e. the \dQuote{alerting} message is printed \emph{at most once} in any given session.) The \dQuote{alerting} message is \emph{not} produced via the \code{warning()} function, so \code{suppressWarnings()} will \emph{not} suppress its appearance. To effect such suppression (necessary only on the first call to \code{deldir()} in a given session) one must set the \code{suppressMsge} argument of \code{deldir} equal to \code{TRUE}. \item If any dummy points are created, and if a vector \code{z}, of \dQuote{auxiliary} values or \dQuote{weights} associated with the points being triangulated, is supplied, then it is up to the user to supply the corresponding auxiliary values or weights associated with the dummy points. These values should be supplied as \code{zdum}. If \code{zdum} is not supplied then the auxiliary values or weights associated with the dummy points are all taken to be missing values (i.e. \code{NA}). } } \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \references{ Lee, D. T., and Schacter, B. J. Two algorithms for constructing a Delaunay triangulation, Int. J. Computer and Information Sciences, Vol. 9, No. 3, 1980, pp. 219 -- 242. Ahuja, N. and Schacter, B. J. (1983). Pattern Models. New York: Wiley. } \seealso{ \code{\link{plot.deldir}()}, \code{\link{tile.list}()}, \code{\link{triang.list}()} } \examples{ x <- c(2.3,3.0,7.0,1.0,3.0,8.0) y <- c(2.3,3.0,2.0,5.0,8.0,9.0) # Let deldir() choose the rectangular window. dxy1 <- deldir(x,y) # User chooses the rectangular window. dxy2 <- deldir(x,y,rw=c(0,10,0,10)) # Put dummy points at the corners of the rectangular # window, i.e. at (0,0), (10,0), (10,10), and (0,10) dxy3 <- deldir(x,y,dpl=list(ndx=2,ndy=2),rw=c(0,10,0,10)) # Plot the triangulation created (but not the tesselation). \dontrun{ dxy2 <- deldir(x,y,rw=c(0,10,0,10),plot=TRUE,wl='tr') } # Auxiliary values associated with points; 4 dummy points to be # added so 4 dummy "z-values" provided. z <- c(1.63,0.79,2.84,1.56,0.22,1.07) zdum <- rep(42,4) dxy4 <- deldir(x,y,dpl=list(ndx=2,ndy=2),rw=c(0,10,0,10),z=z,zdum=zdum) # Example of collinearity error. \dontrun{ dniP <- deldir(niProperties) # Throws an error } dniP <- deldir(niProperties,eps=1e-8) # No error. } \keyword{spatial} deldir/man/triMat.Rd0000644000176200001440000000476513077012355014036 0ustar liggesusers\name{triMat} \alias{triMat} \title{ Produce matrix of triangle vertex indices. } \description{ Lists the indices of the vertices of each Delaunay triangle in the triangulation of a planar point set. The indices are listed (in increasing numeric order) as the rows of an \eqn{n \times 3}{n x 3} matrix where \eqn{n} is the number of Delaunay triangles in the triangulation. } \usage{ triMat(object) } \arguments{ \item{object}{ An object of class \code{deldir} (as produced by the funtion \code{\link{deldir}()}) specifying the Delaunay triangulation and Dirichlet (Voronoi) tesselation of a planar point set. } } \details{ This function was suggested by Robin Hankin of the School of Mathematical and Computing Sciences at Auckland University of Technology. } \value{ An \eqn{n \times 3}{n x 3} matrix where \eqn{n} is the number of Delaunay triangles in the triangulation specified by \code{object}. The \eqn{i^{th}}{i-th} row consists of the indices (in the original list of points being triangulated) of vertices of the \eqn{i^{th}}{i-th} Delaunay triangle. The indices are listed in increasing numeric order in each row. } \section{Note}{ Earlier versions of this function (prior to release 0.1-14 of \bold{deldir}) could sometimes give incorrect results. This happened if the union of three contiguous Delaunay triangles happened to constitute another triangle. This latter triangle would appear in the list of triangles produced by \code{triMat()} but is \emph{not} itself a Delaunay triangle. The updated version of \code{triMat()} now checks for this possibility and gives (\emph{I think!}) correct results. Many thanks to Jay Call, who pointed out this bug to me. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \seealso{ \code{\link{deldir}()} \code{\link{triang.list}()} \code{\link{plot.triang.list}()} } \examples{ # These are the data used by Jay Call to illustrate the bug # that appeared in a previous incarnation of triMat. xy <- data.frame( x = c(0.048,0.412,0.174,0.472,0.607,0.565,0.005,0.237,0.810,0.023), y = c(0.512,0.928,0.955,0.739,0.946,0.134,0.468,0.965,0.631,0.782) ) dxy <- deldir(xy) M <- triMat(dxy) plot(dxy,wlines="triang",num=TRUE,axes=FALSE,col=c(1,1,1,1,2)) # The triangle with vertices {4,5,8} was listed in the output of # the previous (buggy) version of triMat(). It is NOT a Delaunay # triangle and hence should NOT be listed. } \keyword{spatial} deldir/man/tileInfo.Rd0000644000176200001440000000463213066026032014333 0ustar liggesusers\name{tileInfo} \alias{tileInfo} \title{ Extract information from a tile list. } \description{ Produces a summary of information about the tiles in an object of class \code{deldir} as produced by the function \code{deldir()}. } \usage{ tileInfo(object, bndry = FALSE) } \arguments{ \item{object}{ An object of class \code{deldir} as produced by the function \code{deldir()}. } \item{bndry}{ Logical scalar. If \code{TRUE} then the \dQuote{boundary} tiles (those tiles having edges forming part of the \dQuote{rectangular window} enclosing the tessellation) are included in the summary. Otherwise they are not included. } } \value{ A list with components: \item{indivTiles}{This is itself a list with one entry for each tile in \dQuote{object}. It is in fact a \emph{named} list, the names being of form \code{tile.n}, where \code{n} is equal to the value of \code{ptNum} (see below) corresponding to the tile. The entries of \code{indivTiles} are themselves in turn lists with entries \code{edgeLengths} (a vector of the lengths of the edges of the tiles), \code{numEdges} (an integer equal to the number of edges of the tile), \code{area} (a positive number equal to the area of the tile) and \code{ptNum} (an integer equal to the number of the point determining the tile). Note that \code{ptNum} is the number of the point in the \emph{original} sequence of points that were tessellated.} \item{allEdgeCounts}{An integer vector of the edge counts (given by \code{numEdge} for each tile) of the tiles.} \item{tabEdgeCounts}{A table of \code{numEdge}.} \item{allEdgeLengths}{A vector of all of the tile edge lengths; a catenation of the \code{edgeLengths} components of the entries of \code{indivTiles}. Note that there will be many duplicate lengths since each tile edge is, in general, an edge of \emph{two} tiles.} \item{Areas}{A vector of the areas of the tiles.} \item{uniqueEdgeLengths}{A vector of the lengths of the tiles edges with the duplicates (which occur in \code{allEdgeLengths}) being eliminated. Each tile edge is represented only once.} } \author{Rolf Turner \email{r.turner@auckland.ac.nz} } \seealso{ \code{\link{deldir}()} \code{\link{tile.list}()} \code{\link{print.tileInfo}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) dxy <- deldir(x,y,rw=c(0,1,0,1)) ixy1 <- tileInfo(dxy) ixy2 <- tileInfo(dxy,bndry=TRUE) } \keyword{ spatial } deldir/man/plot.deldir.Rd0000644000176200001440000001071213077010614014777 0ustar liggesusers\name{plot.deldir} \alias{plot.deldir} \title{ Plot objects produced by deldir } \description{ This is a method for plot. } \usage{ \method{plot}{deldir}(x,add=FALSE,wlines=c('both','triang','tess'), wpoints=c('both','real','dummy','none'), number=FALSE,cex=1,nex=1,col=NULL,lty=NULL, pch=NULL,xlim=NULL,ylim=NULL,axes=FALSE, xlab=if(axes) 'x' else '',ylab=if(axes) 'y' else'', showrect=FALSE,...) } \arguments{ \item{x}{ An object of class "deldir" as constructed by the function deldir. } \item{add}{ logical argument; should the plot be added to an existing plot? } \item{wlines}{ "which lines?". I.e. should the Delaunay triangulation be plotted (wlines='triang'), should the Dirichlet tessellation be plotted (wlines='tess'), or should both be plotted (wlines='both', the default) ? } \item{wpoints}{ "Which points to plot?". I.e. should the real points be plotted (wpoints='real'), should the dummy points be plotted (wpoints='dummy'), should both be plotted (wpoints='both', the default) or should no points be plotted (wpoints='none')? } \item{number}{ Logical argument, defaulting to \code{FALSE}; if \code{TRUE} then the points plotted will be labelled with their index numbers (corresponding to the row numbers of the matrix "summary" in the output of deldir). } \item{cex}{ The value of the character expansion argument cex to be used with the plotting symbols for plotting the points. } \item{nex}{ The value of the character expansion argument cex to be used by the text function when numbering the points with their indices. Used only if number=\code{TRUE}. } \item{col}{ The colour numbers for plotting the triangulation, the tesselation, the data points, the dummy points, and the point numbers, in that order; defaults to c(1,1,1,1,1). If fewer than five numbers are given, they are recycled. (If more than five numbers are given, the redundant ones are ignored.) } \item{lty}{ The line type numbers for plotting the triangulation and the tesselation, in that order; defaults to 1:2. If only one value is given it is repeated. (If more than two numbers are given, the redundant ones are ignored.) } \item{pch}{ The plotting symbols for plotting the data points and the dummy points, in that order; may be either integer or character; defaults to 1:2. If only one value is given it is repeated. (If more than two values are given, the redundant ones are ignored.) } \item{xlim}{ The limits on the x-axis. Defaults to rw[1:2] where rw is the rectangular window specification returned by deldir(). } \item{ylim}{ The limits on the y-axis. Defaults to rw[3:4] where rw is the rectangular window specification returned by deldir(). } \item{axes}{ Logical scalar. Should axes be drawn on the plot? } \item{xlab}{ Label for the x-axis. Defaults to \code{x} if \code{axes} is \code{TRUE} and to the empty string if \code{axes} is \code{FALSE}. Ignored if \code{add=TRUE}. } \item{ylab}{ Label for the y-axis. Defaults to \code{y} if \code{axes} is \code{TRUE} and to the empty string if \code{axes} is \code{FALSE}. Ignored if \code{add=TRUE}. } \item{showrect}{ Logical scalar; show the enclosing rectangle \code{rw} (see \code{\link{deldir}()}) be plotted? } \item{...}{ Further plotting parameters to be passed to \code{plot()} \code{segments()} or \code{points()} or \code{text()}. Unlikely to be used. } } \section{Side Effects}{ A plot of the points being triangulated is produced or added to an existing plot. As well, the edges of the Delaunay triangles and/or of the Dirichlet tiles are plotted. By default the triangles are plotted with solid lines (lty=1) and the tiles with dotted lines (lty=2). } \details{ The points in the set being triangulated are plotted with distinguishing symbols. By default the real points are plotted as circles (pch=1) and the dummy points are plotted as triangles (pch=2). } \seealso{ \code{\link{deldir}()} } \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \examples{ \dontrun{ try <- deldir(x,y,list(ndx=2,ndy=2),c(0,10,0,10)) plot(try) # deldir(x,y,list(ndx=4,ndy=4),plot=TRUE,add=TRUE,wl='te', col=c(1,1,2,3,4),num=TRUE) # Plots the tesselation, but does not save the results. try <- deldir(x,y,list(ndx=2,ndy=2),c(0,10,0,10),plot=TRUE,wl='tr', wp='n') # Plots the triangulation, but not the points, and saves the # returned structure. } } \keyword{ hplot } % Converted by Sd2Rd version 1.21. deldir/man/plot.triang.list.Rd0000644000176200001440000000440312666722161016004 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, ...) } \arguments{ \item{x}{ An object of class \dQuote{triang.list} as produced by \code{\link{triang.list}()}. } \item{showrect}{ Logical scalar; show the enclosing rectangle \code{rw} (see \code{\link{deldir}()}) be plotted? } \item{add}{ Logical scalar; should the plot of the triangles be added to an existing plot? } \item{xlab}{ Label for the \code{x}-axis. } \item{ylab}{ Label for the \code{y}-axis. } \item{main}{ A title for the plot (used only if \code{add} is \code{FALSE}). } \item{asp}{The aspect ratio of the plot; integer scalar or \code{NA}. Set this argument equal to \code{NA} to allow the data to determine the aspect ratio and hence to make the plot occupy the complete plotting region in both \code{x} and \code{y} directions. This is inadvisable; see the \bold{Warnings}.} \item{\dots}{ Arguments passed to \code{\link{polygon}()} which does the actual plotting of the triangles. } } \section{Warnings}{ The user is \emph{strongly advised} not to set the value of \code{asp} but rather to leave \code{asp} equal to its default value of \code{1}. Any other value distorts the tesselation and destroys the perpendicular appearance of lines which are indeed perpendicular. (And conversely can cause lines which are not perpendicular to appear as if they are.) The argument \code{asp} was added at the request of Zubin Dowlaty. } \value{ None. This function has the side effect of producing (or adding to) a plot. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \seealso{ \code{\link{deldir}()}, \code{\link{plot.triang.list}()}, \code{\link{tile.list}()}, \code{\link{plot.tile.list}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) d <- deldir(x,y) ttt <- triang.list(d) plot(ttt,border="red",showrect=TRUE) sss <- tile.list(d) plot(sss) plot(ttt,add=TRUE,border="blue") } \keyword{ spatial } deldir/man/print.tileInfo.Rd0000644000176200001440000000436313064071165015474 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, ...) } \arguments{ \item{x}{An object of class \code{tileInfo} as produced by the \code{tileInfo()} function. } \item{digits}{ The (maximum) number of decimal digits to which the output is to be printed. } \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 three components to the display: \itemize{ \item A matrix, each row of which is the vector of edge lengths of the tile. The number of columns is the \emph{maximum} of the lengths of the edge length vectors. Rows corresponding to shorter vectors are filled in with blanks. The row names of the matrix indicate the number of the point corresponding to the tile. Note that this number is the index of the point in the original sequence of points that is being tessellated. \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). } 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. In order to get a decent looking display you may (if there are tiles with a large number of edges) need to widen the window in which you are displaying the output and increase the value of the \code{width} option. E.g. use \code{options(width=120)}. } \value{ None. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} } \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) } \keyword{ utilities } deldir/man/which.tile.Rd0000644000176200001440000000223713006011130014602 0ustar liggesusers\name{which.tile} \alias{which.tile} \title{ Determine the tile containing a given point. } \description{ Finds the Dirchlet/Voronoi tile of a tessellation produced by 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 Turner \email{r.turner@auckland.ac.nz} } \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}% use one of RShowDoc("KEYWORDS") deldir/man/seaweed.Rd0000644000176200001440000000211113413234350014165 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,number=TRUE,col.num="red",cex=0.5,adj=0.5) } \keyword{datasets} deldir/man/plot.divchain.Rd0000644000176200001440000000352312666722136015337 0ustar liggesusers\name{plot.divchain} \alias{plot.divchain} \title{ Plot a dividing chain. } \description{ Plot the dividing chain of a Dirchlet tesselation. The tessellation must have been created from a set of points having associated categorical \dQuote{weights}. The dividing chain consists of those edges of Dirichlet tiles which separate points having different values of the given weights. } \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 Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~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.Rd0000644000176200001440000000415312666722066014364 0ustar liggesusers\name{divchain} \alias{divchain} \title{ Dividing chain; generic. } \description{ Generic function for creating the \dQuote{dividing chain} of a Dirchlet tesselation. The tessellation must have been created from a set of points having associated categorical \dQuote{weights}. The dividing chain consists of those edges of Dirichlet tiles which separate points having different values of the given weights. } \usage{ divchain(x, ...) } \arguments{ \item{x}{ Either an object specifying coordinates or an object of class \dQuote{deldir}. } \item{\dots}{ Arguements to be passed to the appropriate method for this generic function. } } \details{ If \code{x} is a (numeric) vector it will be taken to be the \dQuote{x} coordinates of the points being tessellated. In this case the \dots\ arguments must contain a vector \code{y} specifying the \dQuote{y} coordinates. The \dots\ arguments must also contain a \emph{factor} \code{z} specifying the relevant \dQuote{weights} argument. The argument \code{x} may also be a data frame or list from which the coordinates and the weights will be extracted. See \code{\link{divchain.default}()} for details. If \code{x} is an object of class class \dQuote{deldir} then it must have been created with an appropriate (factor) \dQuote{weights} argument, otherwise an error is given. } \value{ An object of class \dQuote{divchain}. See \code{\link{divchain.deldir}()} for details. } \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~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.default}()} \code{\link{divchain.deldir}()} \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.Rd0000644000176200001440000002106313064136204015444 0ustar liggesusers\name{plot.tile.list} \alias{plot.tile.list} \title{ Plot Dirchlet (Voronoi) tiles } \description{ A method for \code{plot}. Plots (sequentially) the tiles associated with each point in the set being tessellated. } \usage{ \method{plot}{tile.list}(x, verbose = FALSE, close = FALSE, pch = 1, fillcol = getCol(x,warn=warn), col.pts=NULL, col.num=NULL,border=NULL, showpoints = !number, add = FALSE, asp = 1, clipp=NULL, xlab = "x", ylab = "y", main = "", warn=FALSE, number=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 ``Go?'' prompt after each) so that the process can be watched.} \item{close}{ Logical scalar; if \code{TRUE} the outer edges of of the tiles (i.e. the edges which are contained in the enclosing rectangle) are drawn. Otherwise tiles on the periphery of the tessellation are left ``open''.} \item{pch}{The plotting character (or vector of plotting characters) with which to plot the points of the pattern which was tessellated. Ignored if \code{showpoints} is \code{FALSE}.} \item{fillcol}{Optional vector (possibly of length 1, i.e. a scalar) whose entries can be interpreted as colours by \code{\link{col2rgb}()}. The \eqn{i}-th entry indicates with which colour to fill the \eqn{i}-th tile. Note that an \code{NA} entry cause the tile to be left unfilled. This argument will be replicated to have length equal to the number of tiles. } \item{col.pts}{Optional vector like unto \code{fillcol} whose entries can be interpreted as colours by \code{\link{col2rgb}()}. The \eqn{i}-th entry indicates with which colour to plot the \eqn{i}-th point. This argument will be replicated to have length equal to the number of tiles. Ignored if \code{showpoints} is \code{FALSE}. } \item{col.num}{Optional vector like unto \code{col.pts}. Determines the colours in which the point numbers (see \code{number} below). This argument will be replicated to have length equal to the number of tiles. Ignored if \code{number} is \code{FALSE}. } \item{border}{A \emph{scalar} indicating the colour with which to plot the tile boundaries. Defaults to black unless all of the fill colours specified by \code{fillcol} are black, in which case it defaults to white. If \code{length(border) > 1} then an error is given. } \item{showpoints}{Logical scalar; if \code{TRUE} the points of the pattern which was tesselated are plotted.} \item{add}{ Logical scalar; should the plot of the tiles be added to an existing plot? } \item{asp}{The aspect ratio of the plot; integer scalar or \code{NA}. Set this argument equal to \code{NA} to allow the data to determine the aspect ratio and hence to make the plot occupy the complete plotting region in both \code{x} and \code{y} directions. This is inadvisable; see the \bold{Warnings}.} \item{clipp}{An object specifying a polygon to which the tessellation being plotted should be clipped. It should consist either of: \itemize{ \item a list containing two components x and y giving the coordinates of the vertices of a single polygon. The last vertex should not repeat the first vertex. Or: \item a list of list(x,y) structures giving the coordinates of the vertices of several polygons. } If this argument is provided then the plot of the tessellation is \dQuote{clipped} to the polygon specified by \code{clipp}. } \item{xlab}{ Label for the \code{x}-axis (used only if \code{add} is \code{FALSE}).} \item{ylab}{ Label for the \code{y}-axis (used only if \code{add} is \code{FALSE}).} \item{main}{ A title for the plot (used only if \code{add} is \code{FALSE}).} \item{warn}{Logical scalar passed to the internal function \code{getCol()}. Should a warning be issued if the \code{z} components of the entries of \code{x} cannot all be interpreted as colours. See \bold{Notes}. } \item{number}{Logical scalar; if \code{TRUE} the numbers of the points determining the tiles are plotted in the tiles. Note that if \code{number} is \code{TRUE} then \code{showpoints} defaults to \code{FALSE} } \item{adj}{The \dQuote{adjustment} argument to \code{text()}. If \code{number} and \code{showpoints} are both \code{TRUE} it defaults to \code{-1} (so that the numbers and point symbols are not superimposed). If \code{number} is \code{TRUE} and \code{showpoints} is \code{FALSE} it defaults to \code{0}. If \code{number} is \code{FALSE} it is ignored. } \item{...}{Optional arguments; may be passed to \code{points()} and \code{text()}. } } \section{Warnings}{ \itemize{ \item The behaviour of this function with respect to \dQuote{clipping} has changed substantially since the previous release of \code{deldir}, i.e. 1.1-0. The argument \code{clipwin} has been re-named \code{clipp} (\dQuote{p} for \dQuote{polygon}). Clipping is now effected via the new package \code{polyclip}. The \code{spatstat} package is no longer used. The argument \code{use.gpclib} has been eliminated, since \code{gpclib} (which used to be called upon by \code{spatstat} has been superceded by \code{polyclip} which has an unrestrictive license. \item As of release 0.1-1 of the \code{deldir} package, the argument \code{fillcol} to this function \emph{replaces} the old argument \code{polycol}, but behaves somewhat differently. \item The argument \code{showrect} which was present in versions of this function prior to release 0.1-1 has been eliminated. It was redundant. \item As of release 0.1-1 the \code{col.pts} argument \emph{might} behave somewhat differently from how it behaved in the past. \item The arguments \code{border}, \code{clipp}, and \code{warn} are new as of release 0.1-1. \item Users, unless they \emph{really} understand what they are doing and why they are doing it, are \emph{strongly advised} not to set the value of \code{asp} but rather to leave \code{asp} equal to its default value of \code{1}. Any other value distorts the tesselation and destroys the perpendicular appearance of lines which are indeed perpendicular. (And conversely can cause lines which are not perpendicular to appear as if they are.) } } \section{Notes}{ \itemize{ \item If \code{clipp} is not \code{NULL} and \code{showpoints} is \code{TRUE} then it is possible that some of the points \dQuote{shown} will not fall inside any of the plotted tiles. (This will happen if the parts of the tiles in which they fall have been \dQuote{clipped} out.) If a tile is clipped out \emph{completely} then the point which determines that tile is \emph{not} plotted irrespective of the value of \code{showpoints}. \item If the \code{z} components of the entries of \code{x} cannot all be interpreted as colours (e.g. if there \emph{aren't} any \code{z} components, which will be the case if no such values were supplied in the call to \code{deldir()}) then the internal function \code{getCol()} returns \code{NA}. This 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 new behaviour in respect of the colours with which to fill the plotted tiles, and the argument \code{clipp} were added at the request of Chris Triggs. \item The argument \code{asp} was added at the request of Zubin Dowlaty. } } \value{NULL; side effect is a plot.} \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \seealso{ \code{\link{deldir}()}, \code{\link{tile.list}()}, \code{\link{triang.list}()}, \code{\link{plot.triang.list}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) z <- deldir(x,y,rw=c(0,1,0,1)) w <- tile.list(z) plot(w) ccc <- heat.colors(20) # Or topo.colors(20), or terrain.colors(20) # or cm.colors(20), or rainbow(20). plot(w,fillcol=ccc,close=TRUE) if(require(polyclip)) { CP <- list(x=c(0.49,0.35,0.15,0.20,0.35,0.42, 0.43,0.62,0.46,0.63,0.82,0.79), y=c(0.78,0.86,0.79,0.54,0.58,0.70, 0.51,0.46,0.31,0.20,0.37,0.54)) plot(w,clipp=CP,showpoints=FALSE,fillcol=topo.colors(20)) } plot(w,number=TRUE,col.num="red") plot(w,number=TRUE,col.num="red",cex=0.5) plot(w,showpoints=TRUE,number=TRUE,col.pts="green",col.num="red") } \keyword{ hplot } deldir/man/triang.list.Rd0000644000176200001440000000410713063625264015026 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}, \eqn{3 \times 4}{3 x 4} or \eqn{3 \times 5}{3 x 5} 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{ptType} (the type of the vertex; \dQuote{data} or \dQuote{dummy}; present only if there were any dummy points specified) \item \code{x} (the \eqn{x}-coordinate of the vertex) \item \code{y} (the \eqn{x}-coordinate of the vertex) \item \code{z} (the \dQuote{auxiliary value} or \dQuote{weight} \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 Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \note{ The code of this function was taken more-or-less directly from code written by Adrian Baddeley for the \dQuote{delaunay()} function in the \dQuote{spatstat} package. } \seealso{ \code{\link{deldir}()}, \code{\link{plot.triang.list}()}, \code{\link{tile.list}()}, \code{\link{plot.tile.list}()} } \examples{ set.seed(42) x <- runif(20) y <- runif(20) z <- sample(1:100,20) d <- deldir(x,y,z=z) ttt <- triang.list(d) } \keyword{spatial} deldir/man/tilePerim.Rd0000644000176200001440000000332212666722205014521 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}. } } \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \note{ Function added at the request of Haozhe Zhang. } \seealso{ \code{\link{tile.list}()}, \code{\link{plot.tile.list}()} } \examples{ x <- runif(20) y <- runif(20) z <- deldir(x,y,rw=c(0,1,0,1)) w <- tile.list(z) p1 <- tilePerim(w) p0 <- tilePerim(w,inclbdry=FALSE) p1$totalPerim - p0$totalPerim # Get 4 = the perimeter of rw. ss <- apply(as.matrix(z$dirsgs[,1:4]),1, function(x){(x[1]-x[3])^2 + (x[2]-x[4])^2}) 2*sum(sqrt(ss)) - p0$totalPerim # Get 0; in tilePerim() each interior # edge is counted twice. } \keyword{spatial} deldir/man/lawSummary.Rd0000644000176200001440000001156513477641712014744 0ustar liggesusers\name{lawSummary} \alias{lawSummary} \title{ Produce a Lewis-Aboav-Weaire summary of a tessellation. } \description{ Produce a summary of a Direchlet (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 coorinates 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 \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 Turner \email{r.turner@auckland.ac.nz} } \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/duplicatedxy.Rd0000644000176200001440000000466112666722111015271 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 Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \note{ The real work is done by the base \bold{R} function \code{\link{duplicated}()}. } \section{Warning}{ Which indices will be considered to be indices of duplicated points (i.e. get \code{TRUE} values) will of course depend on the order in which the points are presented. } \seealso{ \code{\link{duplicated}()}, \code{\link{deldir}()} } \examples{ set.seed(42) xy <- data.frame(x=runif(20),y=runif(20)) # Lots of duplicated points. xy <- rbind(xy,xy[sample(1:20,20,TRUE),]) # Scramble. ii <- sample(1:40,40) x <- xy$x[ii] y <- xy$y[ii] # Unduplicate! iii <- !duplicatedxy(x,y) xu <- x[iii] yu <- y[iii] # The i-th tile is determined by (xu[i],yu[i]): dxy <- deldir(xu,yu) } \keyword{ utilities } deldir/man/tile.list.Rd0000644000176200001440000000552013064056024014470 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) } \arguments{ \item{object}{ An object of class \code{deldir} as produced by the function \code{\link{deldir}()}.} } \value{ A list with one entry for each of the points in the set being tesselated. Each entry is in turn a list with components \item{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{ptType}{The \dQuote{type} of the \code{pt}, either \dQuote{data} or \dQuote{dummy}. Present only if any dummy points were specified in the call to \code{deldir()}.} \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.} \item{z}{The \dQuote{auxiliary value} or \dQuote{weight} associated with the \code{pt}; present only if such values were supplied in the call to \code{deldir()}.} \item{area}{The area of the tile.} } \author{Rolf Turner \email{r.turner@auckland.ac.nz} % \url{https://www.stat.auckland.ac.nz/~rolf} } \section{Acknowledgement}{ The author expresses sincere thanks to Majid Yazdani who found and pointed out a serious bug in \code{tile.list} in a previous version (0.0-5) of the \code{deldir} package. } \section{Warning}{ The set of vertices of each tile may be ``incomplete''. Only vertices which lie within the enclosing rectangle, and ``boundary points'' are listed. Note that the enclosing rectangle may be specified by the user in the call to \code{\link{deldir}()}. In contrast to some earlier versions of \code{deldir}, the corners of the enclosing rectangle are now include as vertices of tiles. I.e. a tile which in fact extends beyond the rectangular window and contains a corner of that window will have that corner added to its list of vertices. Thus the corresponding polygon is the intersection of the tile with the enclosing rectangle. } \seealso{ \code{\link{deldir}()}, \code{\link{plot.tile.list}()} \code{\link{triang.list}()} \code{\link{plot.triang.list}()} } \examples{ x <- runif(20) y <- runif(20) z <- deldir(x,y) w <- tile.list(z) z <- deldir(x,y,rw=c(0,1,0,1)) w <- tile.list(z) z <- deldir(x,y,rw=c(0,1,0,1),dpl=list(ndx=2,ndy=2)) w <- tile.list(z) } \keyword{spatial} deldir/man/deldir-internal.Rd0000644000176200001440000000120513076572733015647 0ustar liggesusers\name{deldir-internal} \alias{[.tile.list} \alias{[.triang.list} \alias{acw} \alias{binsrtR} \alias{dumpts} \alias{get.cnrind} \alias{getCol} \alias{mid.in} \alias{mnndR} \alias{prelimtlist} \alias{tilePerim0} \title{Internal deldir functions} \description{ Internal deldir functions. } \usage{ \method{[}{tile.list}(x,i,\dots) \method{[}{triang.list}(x,i,\dots) acw(xxx) dumpts(x,y,dpl,rw) binsrtR(x,y,rw) get.cnrind(x,y,rw) getCol(x,warn=FALSE) mid.in(x,y,rx,ry) mnndR(x,y) prelimtlist(object) tilePerim0(object,inclbdry=TRUE) } \details{ These functions are auxiliary and are not intended to be called by the user. } \keyword{internal} deldir/DESCRIPTION0000644000176200001440000000141313615764032013231 0ustar liggesusersPackage: deldir Version: 0.1-25 Date: 2020-02-03 Title: Delaunay Triangulation and Dirichlet (Voronoi) Tessellation Author: Rolf Turner Maintainer: Rolf Turner Depends: R (>= 0.99) 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. LazyData: true ByteCompile: true License: GPL (>= 2) NeedsCompilation: yes Packaged: 2020-02-02 19:35:25 UTC; rolf Repository: CRAN Date/Publication: 2020-02-03 09:30:02 UTC deldir/src/0000755000176200001440000000000013615622112012303 5ustar liggesusersdeldir/src/delet.f0000644000176200001440000000065213615621456013564 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine delet(i,j,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) logical adj call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(adj)then call delet1(i,j,nadj,madj,ntot) call delet1(j,i,nadj,madj,ntot) endif return end deldir/src/cross.f0000644000176200001440000000312213615621456013613 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine cross(x,y,ijk,cprd) implicit double precision(a-h,o-z) dimension x(3), y(3) zero = 0.d0 one = 1.d0 two = 2.d0 four = 4.d0 if(ijk.eq.0)then smin = -one do23002 i = 1,3 ip = i+1 if(ip.eq.4)then ip = 1 endif a = x(ip) - x(i) b = y(ip) - y(i) s = a*a+b*b if(smin .lt. zero .or. s .lt. smin)then smin = s endif 23002 continue 23003 continue endif if(ijk.eq.1)then x(2) = x(2) - x(1) y(2) = y(2) - y(1) x(1) = zero y(1) = zero cn = sqrt(x(2)**2+y(2)**2) x(2) = x(2)/cn y(2) = y(2)/cn smin = one endif if(ijk.eq.2)then x(3) = x(3) - x(1) y(3) = y(3) - y(1) x(1) = zero y(1) = zero cn = sqrt(x(3)**2+y(3)**2) x(3) = x(3)/cn y(3) = y(3)/cn smin = one endif if(ijk.eq.3)then x(1) = zero y(1) = zero smin = two endif if(ijk.eq.4)then x(3) = x(3) - x(2) y(3) = y(3) - y(2) x(2) = zero y(2) = zero cn = sqrt(x(3)**2+y(3)**2) x(3) = x(3)/cn y(3) = y(3)/cn smin = one endif if(ijk.eq.5)then x(2) = zero y(2) = zero smin = two endif if(ijk.eq.6)then x(3) = zero y(3) = zero smin = two endif if(ijk.eq.7)then smin = four endif a = x(2)-x(1) b = y(2)-y(1) c = x(3)-x(1) d = y(3)-y(1) cprd = (a*d - b*c)/smin return end deldir/src/master.f0000644000176200001440000000330613615621456013761 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine master(x,y,rw,npd,ntot,nadj,madj,eps,delsgs,ndel,delsum *, dirsgs,ndir,dirsum,nerror) 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(npd,4), dirsum(npd,3) one = 1.d0 do23000 i = -3,ntot nadj(i,0) = 0 do23002 j = 1,madj nadj(i,j) = -99 23002 continue 23003 continue 23000 continue 23001 continue x(-3) = -one y(-3) = one x(-2) = one y(-2) = one x(-1) = one y(-1) = -one x(0) = -one y(0) = -one do23004 i = 1,4 j = i-4 k = j+1 if(k.gt.0)then k = -3 endif call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror.gt.0)then return endif 23004 continue 23005 continue do23010 i = 1,4 j = i-4 call insrt(1,j,nadj,madj,x,y,ntot,nerror,eps) if(nerror.gt.0)then return endif 23010 continue 23011 continue ntri = 4 do23014 j = 2,npd call addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror.gt.0)then return endif ntri = ntri + 3 23014 continue 23015 continue call delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,nerror) if(nerror.gt.0)then return endif call delout(delsum,nadj,madj,x,y,ntot,npd,nerror) if(nerror.gt.0)then return endif call dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ntri,nerror) if(nerror.gt.0)then return endif call dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror) return end deldir/src/circen.f0000644000176200001440000000230013615621456013722 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin,nerror) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) dimension indv(3) dimension xtmp(1) logical collin nerror = -1 xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) ijk = 0 call cross(xt,yt,ijk,cprd) if(abs(cprd) .lt. eps)then collin = .true. else collin = .false. endif a = x(j) - x(i) b = y(j) - y(i) c = x(k) - x(i) d = y(k) - y(i) c1 = sqrt(a*a+b*b) c2 = sqrt(c*c+d*d) a = a/c1 b = b/c1 c = c/c2 d = d/c2 if(collin)then alpha = a*c+b*d if(alpha.gt.0)then 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 rexit("Points are collinear but in the wrong order.") endif return endif crss = a*d - b*c x0 = x(i) + 0.5*(c1*d - c2*b)/crss y0 = y(i) + 0.5*(c2*a - c1*c)/crss return end deldir/src/acchk.f0000644000176200001440000000131313615621456013533 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine acchk(i,j,k,anticl,x,y,ntot,eps) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) logical anticl if(i.le.0)then i1 = 1 else i1 = 0 endif if(j.le.0)then j1 = 1 else j1 = 0 endif if(k.le.0)then k1 = 1 else k1 = 0 endif ijk = i1*4+j1*2+k1 xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) call cross(xt,yt,ijk,cprd) if(cprd .gt. eps)then anticl = .true. else anticl = .false. endif return end deldir/src/triar.f0000644000176200001440000000034713615621456013611 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine triar(x0,y0,x1,y1,x2,y2,area) implicit double precision(a-h,o-z) half = 0.5d0 area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)) return end deldir/src/qtest.f0000644000176200001440000000327113615621456013627 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine qtest(h,i,j,k,shdswp,x,y,ntot,eps,nerror) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) integer h logical shdswp nerror = -1 if(i.le.0)then ii = 1 else ii = 0 endif if(j.le.0)then jj = 1 else jj = 0 endif if(k.le.0)then kk = 1 else kk = 0 endif ijk = ii*4+jj*2+kk if(ijk.eq.7)then shdswp = .true. return endif if(ijk.eq.6)then xh = x(h) yh = y(h) xk = x(k) yk = y(k) ss = 1 - 2*mod(-j,2) test = (xh*yk+xk*yh-xh*yh-xk*yk)*ss if(test.gt.0.d0)then shdswp = .true. else shdswp = .false. endif if(shdswp)then call acchk(j,k,h,shdswp,x,y,ntot,eps) endif return endif if(ijk.eq.5)then shdswp = .true. return endif if(ijk.eq.4)then call acchk(j,k,h,shdswp,x,y,ntot,eps) return endif if(ijk.eq.3)then xi = x(i) yi = y(i) xh = x(h) yh = y(h) ss = 1 - 2*mod(-j,2) test = (xh*yi+xi*yh-xh*yh-xi*yi)*ss if(test.gt.0.d0)then shdswp = .true. else shdswp = .false. endif if(shdswp)then call acchk(h,i,j,shdswp,x,y,ntot,eps) endif return endif if(ijk.eq.2)then shdswp = .false. return endif if(ijk.eq.1)then call acchk(h,i,j,shdswp,x,y,ntot,eps) return endif if(ijk.eq.0)then call qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) return endif nerror = 7 return end deldir/src/delseg.f0000644000176200001440000000151213615621456013726 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,nerror) 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) npd = ntot-4 kseg = 0 do23000 i = 2,npd do23002 j = 1,i-1 call adjchk(i,j,value,nadj,madj,ntot,nerror) if(nerror.gt.0)then return endif if(value)then kseg = kseg+1 if(kseg .gt. ndel)then nerror = 14 return endif delsgs(1,kseg) = x(i) delsgs(2,kseg) = y(i) delsgs(3,kseg) = x(j) delsgs(4,kseg) = y(j) delsgs(5,kseg) = i delsgs(6,kseg) = j endif 23002 continue 23003 continue 23000 continue 23001 continue ndel = kseg return end deldir/src/delet1.f0000644000176200001440000000067113615621456013646 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine delet1(i,j,nadj,madj,ntot) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) n = nadj(i,0) do23000 k = 1,n if(nadj(i,k).eq.j)then do23004 kk = k,n-1 nadj(i,kk) = nadj(i,kk+1) 23004 continue 23005 continue nadj(i,n) = -99 nadj(i,0) = n-1 return endif 23000 continue 23001 continue end deldir/src/dirout.f0000644000176200001440000000402413615621456013772 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsum(npd,3), rw(4) logical collin, intfnd, bptab, bptcd, rwu xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) do23000 i = 1,npd area = 0. nbpt = 0 npt = 0 np = nadj(i,0) do23002 j1 = 1,np j = nadj(i,j1) call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror.gt.0)then return endif if(collin)then nerror = 13 return endif call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror.gt.0)then return endif if(collin)then nerror = 13 return endif call stoke(a,b,c,d,rw,tmp,sn,eps,nerror) if(nerror .gt. 0)then return endif area = area+sn*tmp xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi.ne.yj)then slope = (xi - xj)/(yj - yi) rwu = .true. else slope = 0.d0 rwu = .false. endif call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedge) if(intfnd)then call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedge) if(.not.intfnd)then nerror = 17 return endif if(bptab .and. bptcd)then xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xmin.lt.xm.and.xm.lt.xmax.and.ymin.lt.ym.and.ym.lt.ymax)then nbpt = nbpt+2 npt = npt+1 endif else npt = npt + 1 if(bptab .or. bptcd)then nbpt = nbpt+1 endif endif endif 23002 continue 23003 continue dirsum(i,1) = npt dirsum(i,2) = nbpt dirsum(i,3) = area 23000 continue 23001 continue return end deldir/src/delout.f0000644000176200001440000000211213615621456013754 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine delout(delsum,nadj,madj,x,y,ntot,npd,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension delsum(npd,4) do23000 i = 1,npd area = 0. np = nadj(i,0) xi = x(i) yi = y(i) npt = np do23002 k = 1,np kp = k+1 if(kp.gt.np)then kp = 1 endif if(nadj(i,k).le.0.or.nadj(i,kp).le.0)then npt = npt-1 endif 23002 continue 23003 continue do23008 j1 = 1,np j = nadj(i,j1) if(j.le.0)then goto 23008 endif xj = x(j) yj = y(j) call succ(k,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(k.le.0)then goto 23008 endif xk = x(k) yk = y(k) call triar(xi,yi,xj,yj,xk,yk,tmp) area = area+tmp/3. 23008 continue 23009 continue delsum(i,1) = xi delsum(i,2) = yi delsum(i,3) = npt delsum(i,4) = area 23000 continue 23001 continue return end deldir/src/mnnd.f0000644000176200001440000000100613615621456013415 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine mnnd(x,y,n,dminbig,dminav) implicit double precision(a-h,o-z) dimension x(n), y(n) dminav = 0.d0 do23000 i = 1,n dmin = dminbig do23002 j = 1,n if(i.ne.j)then d = (x(i)-x(j))**2 + (y(i)-y(j))**2 if(d .lt. dmin)then dmin = d endif endif 23002 continue 23003 continue dminav = dminav + sqrt(dmin) 23000 continue 23001 continue dminav = dminav/n return end deldir/src/dldins.f0000644000176200001440000000277713615621456013756 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bpt,nedge) implicit double precision(a-h,o-z) dimension rw(4) logical intfnd, bpt, rwu intfnd = .true. bpt = .true. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) if(xmin.le.a.and.a.le.xmax.and.ymin.le.b.and.b.le.ymax)then ai = a bi = b bpt = .false. nedge = 0 return endif if(.not.rwu)then if(b .lt. ymin)then ai = a bi = ymin nedge = 1 if(xmin.le.ai.and.ai.le.xmax)then return endif endif if(b .gt. ymax)then ai = a bi = ymax nedge = 3 if(xmin.le.ai.and.ai.le.xmax)then return endif endif intfnd = .false. return endif if(a.lt.xmin)then ai = xmin bi = b + slope*(ai-a) nedge = 2 if(ymin.le.bi.and.bi.le.ymax)then return endif endif if(b.lt.ymin)then bi = ymin ai = a + (bi-b)/slope nedge = 1 if(xmin.le.ai.and.ai.le.xmax)then return endif endif if(a.gt.xmax)then ai = xmax bi = b + slope*(ai-a) nedge = 4 if(ymin.le.bi.and.bi.le.ymax)then return endif endif if(b.gt.ymax)then bi = ymax ai = a + (bi-b)/slope nedge = 3 if(xmin.le.ai.and.ai.le.xmax)then return endif endif intfnd = .false. return end deldir/src/init.c0000644000176200001440000000235013520170202013403 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/src/insrt1.f0000644000176200001440000000107013615621456013702 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine insrt1(i,j,kj,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) if(n.eq.0)then nadj(i,0) = 1 nadj(i,1) = j return endif kk = n+1 if(kk.gt.madj)then nerror = 4 return endif 23004 if(kk.gt.kj)then nadj(i,kk) = nadj(i,kk-1) kk = kk-1 goto 23004 endif 23005 continue nadj(i,kj) = j nadj(i,0) = n+1 return end deldir/src/stoke.f0000644000176200001440000000426513615621456013620 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine stoke(x1,y1,x2,y2,rw,area,s1,eps,nerror) implicit double precision(a-h,o-z) dimension rw(4) logical value zero = 0.d0 nerror = -1 call testeq(x1,x2,eps,value) if(value)then area = 0. s1 = 0. return endif if(x1.lt.x2)then xl = x1 yl = y1 xr = x2 yr = y2 s1 = -1. else xl = x2 yl = y2 xr = x1 yr = y1 s1 = 1. endif xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) slope = (yl-yr)/(xl-xr) x = max(xl,xmin) y = yl+slope*(x-xl) xl = x yl = y x = min(xr,xmax) y = yr+slope*(x-xr) xr = x yr = y if(xr.le.xmin.or.xl.ge.xmax)then area = 0. return endif ybot = min(yl,yr) ytop = max(yl,yr) if(ymax.le.ybot)then area = (xr-xl)*(ymax-ymin) return endif if(ymin.le.ybot.and.ymax.le.ytop)then call testeq(slope,zero,eps,value) if(value)then w1 = 0. w2 = xr-xl else xit = xl+(ymax-yl)/slope w1 = xit-xl w2 = xr-xit if(slope.lt.0.)then tmp = w1 w1 = w2 w2 = tmp endif endif area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin) return endif if(ybot.le.ymin.and.ymax.le.ytop)then xit = xl+(ymax-yl)/slope xib = xl+(ymin-yl)/slope if(slope.gt.0.)then w1 = xit-xib w2 = xr-xit else w1 = xib-xit w2 = xit-xl endif area = 0.5*w1*(ymax-ymin)+w2*(ymax-ymin) return endif if(ymin.le.ybot.and.ytop.le.ymax)then area = 0.5*(xr-xl)*((ytop-ymin)+(ybot-ymin)) return endif if(ybot.le.ymin.and.ymin.le.ytop)then call testeq(slope,zero,eps,value) if(value)then area = 0. return endif xib = xl+(ymin-yl)/slope if(slope.gt.0.)then w = xr-xib else w = xib-xl endif area = 0.5*w*(ytop-ymin) return endif if(ytop.le.ymin)then area = 0. return endif nerror = 8 return end deldir/src/crossutil.f0000644000176200001440000000115113615621456014511 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine crossutil(i,j,k,x,y,ntot,eps,collin) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) dimension xt(3), yt(3) logical collin xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) i1 = 0 if(j.le.0)then j1 = 1 else j1 = 0 endif if(k.le.0)then k1 = 1 else k1 = 0 endif ijk = i1*4+j1*2+k1 call cross(xt,yt,ijk,cprd) collin = (abs(cprd) .lt. eps) return end deldir/src/initad.f0000644000176200001440000000213713615621456013737 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) integer tau(3) call trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror .gt. 0)then return endif if(nedge.ne.0)then ip = nedge i = ip-1 if(i.eq.0)then i = 3 endif call pred(k,tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call succ(kk,tau(ip),tau(i),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call delet(tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(k.eq.kk)then call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) endif if(nerror .gt. 0)then return endif endif do23016 i = 1,3 call insrt(j,tau(i),nadj,madj,x,y,ntot,nerror,eps) if(nerror .gt. 0)then return endif 23016 continue 23017 continue return end deldir/src/addpt.f0000644000176200001440000000144413615621456013563 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical didswp call initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror .gt. 0)then return endif now = nadj(j,1) nxt = nadj(j,2) ngap = 0 23002 continue call swap(j,now,nxt,didswp,nadj,madj,x,y,ntot,eps,nerror) if(nerror .gt. 0)then return endif n = nadj(j,0) if(.not.didswp)then now = nxt ngap = ngap+1 endif call succ(nxt,j,now,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif 23003 if(.not.(ngap.eq.n))goto 23002 23004 continue return end deldir/src/locn.f0000644000176200001440000000144513615621456013423 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine locn(i,j,kj,nadj,madj,x,y,ntot,eps) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical before n = nadj(i,0) if(n.eq.0)then kj = 1 return endif do23002 ks = 1,n kj = ks k = nadj(i,kj) call acchk(i,j,k,before,x,y,ntot,eps) if(before)then km = kj-1 if(km.eq.0)then km = n endif k = nadj(i,km) call acchk(i,j,k,before,x,y,ntot,eps) if(before)then goto 23002 endif if(kj.eq.1)then kj = n+1 endif return endif 23002 continue 23003 continue if(before)then kj = 1 else kj = n+1 endif return end deldir/src/testeq.f0000644000176200001440000000107513615621456013774 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine testeq(a,b,eps,value) implicit double precision(a-h,o-z) logical value one = 1.d0 ten = 1.d10 if(abs(b).le.eps)then if(abs(a).le.eps)then value = .true. else value = .false. endif return endif if(abs(a).gt.ten*abs(b).or.abs(a).lt.one*abs(b))then value = .false. return endif c = a/b if(abs(c-1.d0).le.eps)then value = .true. else value = .false. endif return end deldir/src/intri.f0000644000176200001440000000156213615621456013615 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine intri(x,y,u,v,n,okay) implicit double precision(a-h,o-z) dimension x(3), y(3), u(n), v(n) integer okay logical inside zero = 0.d0 s = 1.d0 a = x(2) - x(1) b = y(2) - y(1) c = x(3) - x(1) d = y(3) - y(1) cp = a*d - b*c if(cp .lt. 0)then s = -s endif do23002 i = 1,n inside = .true. do23004 j = 1,3 jp = j+1 if(jp.eq.4)then jp = 1 endif a = x(jp) - x(j) b = y(jp) - y(j) c = u(i) - x(j) d = v(i) - y(j) cp = s*(a*d - b*c) if(cp .le. zero)then inside = .false. goto 23005 endif 23004 continue 23005 continue if(inside)then okay = 0 return endif 23002 continue 23003 continue okay = 1 return end deldir/src/qtest1.f0000644000176200001440000000315313615621456013707 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3), indv(3) dimension itmp(1) dimension xtmp(1) integer h logical shdswp, collin 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 call cross(xt,yt,nid,cprd) collin = (abs(cprd) .lt. eps) if(collin)then 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(alpha.gt.0)then itmp(1) = 1 call intpr("error detected in qtest1",-1,itmp,0) 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 rexit("Points are collinear but h not between i and k.") endif shdswp = .true. endif xh = x(h) yh = y(h) xj = x(j) yj = y(j) call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror) if(nerror.gt.0)then return endif if(shdswp)then return endif a = x0-xh b = y0-yh r2 = a*a+b*b a = x0-xj b = y0-yj ch = a*a + b*b if(ch.lt.r2)then shdswp = .true. else shdswp = .false. endif return end deldir/src/succ.f0000644000176200001440000000100213615621456013412 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine succ(ksc,i,j,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) if(n.eq.0)then nerror = 9 return endif do23002 k = 1,n if(j.eq.nadj(i,k))then kp = k+1 if(kp.gt.n)then kp = 1 endif ksc = nadj(i,kp) return endif 23002 continue 23003 continue nerror = 10 return end deldir/src/adjchk.f0000644000176200001440000000127413615621456013714 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine adjchk(i,j,adj,nadj,madj,ntot,nerror) dimension nadj(-3:ntot,0:madj) logical adj nerror = -1 adj = .false. ni = nadj(i,0) if(ni.gt.0)then do23002 k = 1,ni if(j.eq.nadj(i,k))then adj = .true. goto 23003 endif 23002 continue 23003 continue endif nj = nadj(j,0) if(nj.gt.0)then do23008 k = 1,nj if(i.eq.nadj(j,k))then if(adj)then return else nerror = 1 return endif endif 23008 continue 23009 continue endif if(adj)then nerror = 1 return endif return end deldir/src/dirseg.f0000644000176200001440000000624213615621456013745 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ntri,n *error) implicit double precision(a-h,o-z) logical collin, adjace, intfnd, bptab, bptcd, goferit, rwu dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsgs(10,ndir), rw(4) nerror = -1 xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) a = xmax-xmin b = ymax-ymin c = sqrt(a*a+b*b) npd = ntot-4 nstt = npd+1 i = nstt x(i) = xmin-c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymax+c i = i+1 x(i) = xmin-c y(i) = ymax+c do23000 j = nstt,ntot call addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) ntri = ntri + 3 if(nerror .gt. 0)then return endif 23000 continue 23001 continue kseg = 0 do23004 i = 2,npd do23006 j = 1,i-1 call adjchk(i,j,adjace,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(adjace)then call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror .gt. 0)then return endif if(collin)then nerror = 12 return endif call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror .gt. 0)then return endif if(collin)then nerror = 12 return endif xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi.ne.yj)then slope = (xi - xj)/(yj - yi) rwu = .true. else slope = 0.d0 rwu = .false. endif call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedgeab) if(.not.intfnd)then nerror = 16 return endif call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedgecd) if(.not.intfnd)then nerror = 16 return endif goferit = .false. if(bptab .and. bptcd)then xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xmin.lt.xm.and.xm.lt.xmax.and.ymin.lt.ym.and.ym.lt.ymax)then goferit = .true. endif endif if((.not.bptab).or.(.not.bptcd))then goferit = .true. endif if(goferit)then kseg = kseg + 1 if(kseg .gt. ndir)then nerror = 15 return endif dirsgs(1,kseg) = ai dirsgs(2,kseg) = bi dirsgs(3,kseg) = ci dirsgs(4,kseg) = di dirsgs(5,kseg) = 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 23006 continue 23007 continue 23004 continue 23005 continue ndir = kseg return end deldir/src/binsrt.f0000644000176200001440000000271213615621456013767 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine binsrt(x,y,rw,npd,ind,rind,tx,ty,ilst,nerror) implicit double precision(a-h,o-z) dimension x(npd), y(npd), tx(npd), ty(npd) integer rind(npd) dimension ind(npd), ilst(npd) dimension rw(4) nerror = -1 kdiv = int(1+dble(npd)**0.25) xkdiv = dble(kdiv) xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) w = xmax-xmin h = ymax-ymin dw = w/xkdiv dh = h/xkdiv kx = 1 ky = 1 ink = 1 k = 0 do23000 i = 1,npd ilst(i) = 0 23000 continue 23001 continue 23002 if(ky.le.kdiv)then do23004 i = 1,npd if(ilst(i).eq.1)then goto 23004 endif xt = x(i) yt = y(i) ix = int(1+(xt-xmin)/dw) if(ix.gt.kdiv)then ix = kdiv endif jy = int(1+(yt-ymin)/dh) if(jy.gt.kdiv)then jy = kdiv endif if(ix.eq.kx.and.jy.eq.ky)then k = k+1 ind(i) = k rind(k) = i tx(k) = xt ty(k) = yt ilst(i) = 1 endif 23004 continue 23005 continue kc = kx+ink if((1.le.kc).and.(kc.le.kdiv))then kx = kc else ky = ky+1 ink = -ink endif goto 23002 endif 23003 continue if(k.ne.npd)then nerror = 2 return endif do23018 i = 1,npd x(i) = tx(i) y(i) = ty(i) 23018 continue 23019 continue return end deldir/src/pred.f0000644000176200001440000000100113615621456013406 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine pred(kpr,i,j,nadj,madj,ntot,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) if(n.eq.0)then nerror = 5 return endif do23002 k = 1,n if(j.eq.nadj(i,k))then km = k-1 if(km.lt.1)then km = n endif kpr = nadj(i,km) return endif 23002 continue 23003 continue nerror = 6 return end deldir/src/swap.f0000644000176200001440000000202513615621456013435 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical shdswp, anticl call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(.not.shdswp)then return endif call pred(k,k1,k2,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call succ(kk,k2,k1,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(kk.ne.k)then shdswp = .false. return endif call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror) if(nerror .gt. 0)then return endif if(shdswp)then call delet(k1,k2,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror .gt. 0)then return endif endif return end deldir/src/insrt.f0000644000176200001440000000126113615621456013623 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine insrt(i,j,nadj,madj,x,y,ntot,nerror,eps) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical adj call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif if(adj)then return endif call locn(i,j,kj,nadj,madj,x,y,ntot,eps) call locn(j,i,ki,nadj,madj,x,y,ntot,eps) call insrt1(i,j,kj,nadj,madj,ntot,nerror) if(nerror .gt.0)then return endif call insrt1(j,i,ki,nadj,madj,ntot,nerror) if(nerror .gt.0)then return endif return end deldir/src/trifnd.f0000644000176200001440000000540113615621456013752 0ustar liggesusersC Output from Public domain Ratfor, version 1.03 subroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror) implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot), xt(3), yt( *3) dimension itmp(1) integer tau(3) logical adjace, anticl nerror = -1 if(j.eq.1)then nerror = 11 return endif j1 = j-1 tau(1) = j1 tau(3) = nadj(j1,1) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot,nerror) if(nerror.gt.0)then return endif if(.not.adjace)then tau(3) = tau(2) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif ktri = 0 1 continue 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 itmp(1) = j call intpr("Point number =",-1,itmp,1) call intpr("Previous triangle:",-1,tau,3) call rexit("Both vertex orderings are clockwise. See help for deld *ir.") else ivtmp = tau(3) tau(3) = tau(1) tau(1) = ivtmp endif endif ntau = 0 nedge = 0 do23014 i = 1,3 ip = i+1 if(ip.eq.4)then ip = 1 endif xt(1) = x(tau(i)) yt(1) = y(tau(i)) xt(2) = x(tau(ip)) yt(2) = y(tau(ip)) xt(3) = x(j) yt(3) = y(j) if(tau(i).le.0)then i1 = 1 else i1 = 0 endif if(tau(ip).le.0)then j1 = 1 else j1 = 0 endif k1 = 0 ijk = i1*4+j1*2+k1 call cross(xt,yt,ijk,cprd) if(cprd .ge. eps)then continue else if(cprd .gt. -eps)then nedge = ip else ntau = ip goto 23015 endif endif 23014 continue 23015 continue if(ntau.eq.0)then return endif if(ntau.eq.1)then tau(2) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif if(ntau.eq.2)then tau(3) = tau(2) call pred(tau(2),tau(1),tau(3),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif if(ntau.eq.3)then tau(1) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror .gt. 0)then return endif endif ktri = ktri + 1 if(ktri .gt. ntri)then itmp(1) = j call intpr("Point being added:",-1,itmp,1) call rexit("Cannot find an enclosing triangle. See help for deldi *r.") endif go to 1 end deldir/R/0000755000176200001440000000000013520172612011715 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.R0000644000176200001440000000154612666130612015101 0ustar liggesusersdivchain.deldir <- function (x,...) { # z <- x$summary$z if(!is.factor(z)) { xc <- deparse(substitute(x)) whinge <- paste("The class deldir object",xc,"was created without\n", "a factor-valued \"weights\" argument \"z\" being supplied.\n") stop(whinge) } 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/dumpts.R0000644000176200001440000000264213076600406013363 0ustar liggesusersdumpts <- function(x,y,dpl,rw) { # # Function dumpts to append a sequence of dummy points to the # data points. # ndm <- 0 xd <- NULL yd <- NULL xmin <- rw[1] xmax <- rw[2] ymin <- rw[3] ymax <- rw[4] # Points on radii of circles emanating from data points: if(!is.null(dpl$nrad)) { nrad <- dpl$nrad # Number of radii from each data point. nper <- dpl$nper # Number of dummy points per radius. fctr <- dpl$fctr # Length of each radius = fctr * mean # interpoint distance. lrad <- fctr*mnndR(x,y)/nper theta <- 2*pi*(1:nrad)/nrad cs <- cos(theta) sn <- sin(theta) xt <- c(lrad*(1:nper)%o%cs) yt <- c(lrad*(1:nper)%o%sn) xd <- c(outer(x,xt,'+')) yd <- c(outer(y,yt,'+')) } # Ad hoc points passed over as part of dpl: if(!is.null(dpl$x)) { xd <- c(xd,dpl$x) yd <- c(yd,dpl$y) } # Delete dummy points outside the rectangular window. ndm <- length(xd) if(ndm >0) { drop <- (1:ndm)[xdxmax|ydymax] if(length(drop)>0) { xd <- xd[-drop] yd <- yd[-drop] } } # Rectangular grid: ndx <- dpl$ndx okx <- !is.null(ndx) && ndx > 0 ndy <- dpl$ndy oky <- !is.null(ndy) && ndy > 0 if(okx & oky) { xt <- if(ndx>1) seq(xmin,xmax,length=ndx) else 0.5*(xmin+xmax) yt <- if(ndy>1) seq(ymin,ymax,length=ndy) else 0.5*(ymin+ymax) xy <- expand.grid(x=xt,y=yt) xd <- c(xd,xy$x) yd <- c(yd,xy$y) } ndm <- length(xd) list(x=c(x,xd),y=c(y,yd),ndm=ndm) } deldir/R/tilePerim.R0000644000176200001440000000044012222404341013763 0ustar liggesuserstilePerim <- function(object,inclbdry=TRUE) { if(!inherits(object,"tile.list")) stop("Argument \"object\" must be of class \"tile.list\".\n") perims <- sapply(object,tilePerim0,inclbdry=inclbdry) list(perimeters=perims,totalPerim=sum(perims),meanPerim=mean(perims)) } deldir/R/print.tileInfo.R0000644000176200001440000000156613064050733014756 0ustar liggesusersprint.tileInfo <- function(x,digits=4,...) { # # Matrix of edge lengths: lel <- lapply(x$indivTiles,function(u){u$edgeLengths}) nel <- sapply(lel,length) pNs <- sapply(x$indivTiles,function(u){u$ptNum}) m <- length(nel) n <- max(nel) M <- matrix("",nrow=m,ncol=n) ld <- ceiling(log10(max(unlist(lel)))) + digits + 1 fmt <- paste0("%",ld,".",digits,"f") for(i in 1:m) { M[i,1:nel[i]] <- sprintf(fmt,lel[[i]]) } rownames(M) <- paste0("tile ",pNs,": ") colnames(M) <- rep("",n) cat("\nEdge lengths:\n") cat("=============\n") print(M,quote=FALSE) # 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") invisible() } deldir/R/tilePerim0.R0000644000176200001440000000061112222443522014047 0ustar liggesuserstilePerim0 <- function (object,inclbdry=TRUE) { x <- object[["x"]] y <- object[["y"]] xx <- c(x,x[1]) yy <- c(y,y[1]) if(inclbdry) { ok <- rep(TRUE,length(x)) } else { bp1 <- object[["bp"]] bp2 <- c(bp1,bp1[1]) bpm <- cbind(bp1,bp2[-1]) ok <- !apply(bpm,1,all) } sum(sqrt(((xx[-1] - x)[ok])^2 + ((yy[-1] - y)[ok])^2)) } deldir/R/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.R0000644000176200001440000000074512222425535013266 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) warn(paste("Cannot interpret the z-components of", "argument \"x\" as colours.\n")) return(NA) } ccc } deldir/R/plot.deldir.R0000644000176200001440000000426413077010516014267 0ustar liggesusersplot.deldir <- function(x,add=FALSE,wlines=c('both','triang','tess'), wpoints=c('both','real','dummy','none'), number=FALSE,cex=1,nex=1,col=NULL,lty=NULL, pch=NULL,xlim=NULL,ylim=NULL,axes=FALSE, xlab=if(axes) 'x' else '',ylab=if(axes) 'y' else'', showrect=FALSE,...) { # # Function plot.deldir to produce a plot of the Delaunay triangulation # and Dirichlet tesselation of a point set, as produced by the # function deldir(). # # Check that x is of the appropriate class. if(!inherits(x, "deldir")) stop("Argument \"x\" is not of class deldir.\n") wlines <- match.arg(wlines) wpoints <- match.arg(wpoints) col <- if(is.null(col)) c(1,1,1,1,1) else rep(col,length.out=5) lty <- if(is.null(lty)) 1:2 else rep(lty,length.out=2) pch <- if(is.null(pch)) 1:2 else rep(pch,length.out=2) plot.del <- switch(wlines,both=TRUE,triang=TRUE,tess=FALSE) plot.dir <- switch(wlines,both=TRUE,triang=FALSE,tess=TRUE) plot.rl <- switch(wpoints,both=TRUE,real=TRUE,dummy=FALSE,none=FALSE) plot.dum <- switch(wpoints,both=TRUE,real=FALSE,dummy=TRUE,none=FALSE) delsgs <- x$delsgs dirsgs <- x$dirsgs n <- x$n.data rw <- x$rw if(plot.del) { x1<-delsgs[,1] y1<-delsgs[,2] x2<-delsgs[,3] y2<-delsgs[,4] } if(plot.dir) { u1<-dirsgs[,1] v1<-dirsgs[,2] u2<-dirsgs[,3] v2<-dirsgs[,4] } X<-x$summary[,"x"] Y<-x$summary[,"y"] if(!add) { pty.save <- par()$pty on.exit(par(pty=pty.save)) par(pty='s') if(is.null(xlim)) xlim <- rw[1:2] if(is.null(ylim)) ylim <- rw[3:4] plot(0,0,type='n',xlim=xlim,ylim=ylim, xlab=xlab,ylab=ylab,axes=axes,...) } if(plot.del) segments(x1,y1,x2,y2,col=col[1],lty=lty[1],...) if(plot.dir) segments(u1,v1,u2,v2,col=col[2],lty=lty[2],...) if(plot.rl) { x.real <- X[1:n] y.real <- Y[1:n] points(x.real,y.real,pch=pch[1],col=col[3],cex=cex,...) } if(plot.dum) { x.dumm <- X[-(1:n)] y.dumm <- Y[-(1:n)] points(x.dumm,y.dumm,pch=pch[2],col=col[4],cex=cex,...) } if(number) { xoff <- 0.02*diff(range(X)) yoff <- 0.02*diff(range(Y)) text(X+xoff,Y+yoff,1:length(X),cex=nex,col=col[5],...) } if(showrect) do.call(rect,as.list(x$rw)[c(1,3,2,4)]) invisible() } deldir/R/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.R0000644000176200001440000000525413477633065014226 0ustar liggesuserslawSummary <- function(object) { # # Function to produce a summary of a Direchlet (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) <- rownames(smry.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, 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/binsrt.R0000644000176200001440000000131013076572763013355 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), nerror=as.integer(0), PACKAGE="deldir" ) if(rslt$nerror > 0) stop("Mismatch between number of points and number of sorted points.\n") list(x=rslt$tx,y=rslt$ty,ind=rslt$ind,rind=rslt$rind) } deldir/R/tile.centroids.R0000644000176200001440000000061111621163455014771 0ustar liggesuserstile.centroids <- function(xxx){ foo <- function (x,y) { x <- c(x,x[1]) y <- c(y,y[1]) n <- length(x) u <- x[-n]*y[-1] v <- x[-1]*y[-n] w <- x[-n]+x[-1] z <- y[-n]+y[-1] A <- 3*(sum(u)-sum(v)) Cx <- sum(w*(u-v))/A Cy <- sum(z*(u-v))/A c(Cx,Cy) } ccc <- lapply(xxx,function(x){foo(x$x,x$y)}) ccc <- as.data.frame(matrix(unlist(ccc),ncol=2,byrow=TRUE)) names(ccc) <- c("x","y") ccc } deldir/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.R0000644000176200001440000000162113076537730014424 0ustar liggesusersprelimtlist <- function(object) { # # prelimtlist <--> "preliminary triangle list" # The ("prelimiary") 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(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/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/tile.list.R0000644000176200001440000000335213503557554013767 0ustar liggesuserstile.list <- function (object) { if (!inherits(object, "deldir")) stop("Argument \"object\" is not of class \"deldir\".\n") ptp <- object$summary$pt.type rw <- object$rw x.crnrs <- rw[c(1, 2, 2, 1)] y.crnrs <- rw[c(3, 3, 4, 4)] ddd <- object$dirsgs sss <- object$summary npts <- nrow(sss) x <- sss[["x"]] y <- sss[["y"]] z <- sss[["z"]] haveZ <- !is.null(z) i.crnr <- get.cnrind(x, y, rw) rslt <- list() ind.orig <- object$ind.orig for (i in 1:npts) { filter1 <- ddd$ind1 == i filter2 <- ddd$ind2 == 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]) if(length(ptp)) { tmp <- append(tmp,values=ptp[i],after=2) names(tmp)[3] <- "ptType" } rslt[[i]] <- acw(tmp) if(haveZ) rslt[[i]]["z"] <- z[i] } class(rslt) <- "tile.list" attr(rslt, "rw") <- object$rw 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.R0000644000176200001440000000033112133366475013137 0ustar liggesusers.onLoad <- function(lib, pkg) { library.dynam("deldir", pkg, lib) } .onAttach <- function(lib, pkg) { ver <- read.dcf(file.path(lib, pkg, "DESCRIPTION"), "Version") packageStartupMessage(paste(pkg, ver)) } deldir/R/plot.tile.list.R0000644000176200001440000000771513064045154014741 0ustar liggesusersplot.tile.list <- function (x, verbose = FALSE, close = FALSE, pch = 1, fillcol = getCol(x,warn=warn), col.pts=NULL, col.num=NULL,border=NULL, showpoints = !number, add = FALSE, asp = 1, clipp=NULL, xlab = "x", ylab = "y", main = "", warn=FALSE, number=FALSE,adj=NULL,...) { object <- x if (!inherits(object, "tile.list")) stop("Argument \"object\" is not of class tile.list.\n") clip <- !is.null(clipp) n <- length(object) rw <- attr(object, "rw") rx <- rw[1:2] ry <- rw[3:4] x.pts <- unlist(lapply(object, function(w) { w$pt[1] })) y.pts <- unlist(lapply(object, function(w) { w$pt[2] })) if (!add) plot(0, 0, type = "n", asp = asp, xlim = rx, ylim = ry, xlab = xlab, ylab = ylab, main = main) fillcol <- apply(col2rgb(fillcol, TRUE), 2, function(x) { do.call(rgb, as.list(x/255)) }) fillcol <- rep(fillcol, length = length(object)) hexbla <- do.call(rgb, as.list(col2rgb("black", TRUE)/255)) hexwhi <- do.call(rgb, as.list(col2rgb("white", TRUE)/255)) if(is.null(col.pts)){ col.pts <- ifelse(fillcol == hexbla, hexwhi, hexbla) } else { col.pts <- apply(col2rgb(col.pts, TRUE), 2, function(x) { do.call(rgb, as.list(x/255)) }) col.pts <- rep(col.pts, length = length(object)) } if(is.null(col.num)){ col.num <- ifelse(fillcol == hexbla, hexwhi, hexbla) } else { col.num <- apply(col2rgb(col.num, TRUE), 2, function(x) { do.call(rgb, as.list(x/255)) }) col.num <- rep(col.num, length = length(object)) } if(is.null(border)) border <- if(all(fillcol == hexbla)) hexwhi else hexbla else if(length(border) > 1) stop("Argument \"border\" must be a scalar or NULL.\n") lnwid <- if(all(fillcol == hexbla)) 2 else 1 ptNums <- sapply(x,function(u){u$ptNum}) Adj <- adj if(is.null(Adj)) Adj <- if(showpoints) -1 else 0 pch <- rep(pch,n) okn <- logical(n) for(i in 1:n) { if(clip) { if(requireNamespace("polyclip",quietly=TRUE)) { pgon <- polyclip::polyclip(object[[i]],clipp) ok <- length(pgon) > 0 } else { stop("Cannot clip the tiles; package \"polyclip\" not available.\n") } } else { pgon <- list(object[[i]]) ok <- TRUE } okn[i] <- ok inner <- !any(object[[i]]$bp) for(ii in seq(along=pgon)){ ptmp <- pgon[[ii]] polygon(ptmp,col=fillcol[i],border=NA) if (close | inner) { polygon(ptmp,col = NA, border = border, lwd = lnwid) } else { x <- ptmp$x y <- ptmp$y ni <- length(x) for (j in 1:ni) { jnext <- if (j < ni) j + 1 else 1 do.it <- mid.in(x[c(j, jnext)], y[c(j, jnext)], rx, ry) if (do.it) segments(x[j], y[j], x[jnext], y[jnext], col = border, lwd = lnwid) } } } if(ok & verbose) { if(showpoints) points(object[[i]]$pt[1], object[[i]]$pt[2], pch = pch[i], col = col.pts[i],...) if(number) text(object[[i]]$pt[1], object[[i]]$pt[2], labels=ptNums[i], col = col.num[i],adj=Adj,...) if(i < n) readline(paste("i = ",i,"; Go? ",sep="")) if(i == n) cat("i = ",i,"\n",sep="") } } if (showpoints & !verbose) points(x.pts[okn], y.pts[okn], pch = pch[okn], col = col.pts[okn],...) if (number & !verbose) text(x.pts[okn], y.pts[okn], labels = ptNums[okn], col = col.num[okn], adj=Adj,...) invisible() } 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.R0000644000176200001440000000057212666124231015260 0ustar liggesusersdivchain.default <- function (x,y,z,...) { # if(missing(z)) { if(inherits(x,"ppp") && is.factor(x$marks)) { z <- x$marks } else { stop("Either argument \"z\" was not supplied or it was not a factor.\n") } } else if(!is.factor(z)) stop("Argument \"z\" must be a factor.\n") dd <- deldir(x,y,z=z,...) divchain(dd) } deldir/R/tileInfo.R0000644000176200001440000000410013066026477013620 0ustar liggesuserstileInfo <- function(object,bndry=FALSE) { # # 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 tiles in the tessellation. tl <- tile.list(object) # Required info: # * for each tile, the number of edges # * for each tile, a vector of the lengths of the edges # * 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 # * adjust plot.tile.list() so that the number of the point/tile # is plotted. foo <- function(tile){ x <- tile$x y <- tile$y x1 <- c(x,x[1]) y1 <- c(y,y[1]) ledge <- sqrt(((x1[-1] - x))^2 + ((y1[-1] - y))^2) nedge <- length(ledge) list(edgeLengths=ledge,numEdges=nedge,area=tile$area,ptNum=tile$ptNum) } ok <- if(bndry) rep(TRUE,length(tl)) else sapply(tl,function(x){!any(x$bp)}) xxx <- lapply(tl[ok],foo) ptNums <- sapply(xxx,function(x){x$ptNum}) nms <- paste("tile",ptNums,sep=".") names(xxx) <- nms # Extract and tabulate the edge counts. allnedge <- sapply(xxx,function(x){x$numEdges}) 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 <- unlist(lapply(xxx,function(x){x$edgeLengths})) # Extract the tile areas into a single vector. areas <- sapply(xxx,function(x){x$area}) # Now go back to the deldir object to get the unique edge lengths. d <- object$dirsgs ok <- if(bndry) rep(TRUE,nrow(d)) else !(d$bp1 | d$bp2) ue <- with(d,sqrt((x1-x2)^2 + (y1-y2)^2)) # Pack up and go home. rslt <- list(indivTiles=xxx,allEdgeCounts=allnedge,tabEdgeCounts=tabnedge, allEdgeLengths=all.lengths,Areas=areas,uniqueEdgeLengths=ue) class(rslt) <- "tileInfo" rslt } deldir/R/triang.list.R0000644000176200001440000000367713077240606014321 0ustar liggesuserstriang.list <- function (object) { stopifnot(inherits(object,"deldir")) io <- object$ind.orig pt <- object$summary$pt.type tlist <- prelimtlist(object) x <- object$summary[,"x"] y <- object$summary[,"y"] if("z" %in% colnames(object$summary)) { z <- object$summary[,"z"] haveZ <- TRUE } else haveZ <- FALSE xtri <- matrix(x[tlist], nrow(tlist), 3) ytri <- matrix(y[tlist], nrow(tlist), 3) if(haveZ) ztri <- matrix(z[tlist], nrow(tlist), 3) ctri <- ytri - min(y) dx <- cbind(xtri[, 2] - xtri[, 1], xtri[, 3] - xtri[, 2], xtri[, 1] - xtri[, 3]) zm <- cbind(ctri[, 1] + ctri[, 2], ctri[, 2] + ctri[, 3], ctri[, 3] + ctri[, 1]) negareas <- apply(dx * zm, 1, sum) clockwise <- (negareas > 0) if (any(clockwise)) { xc <- xtri[clockwise,,drop=FALSE] yc <- ytri[clockwise,,drop=FALSE] tc <- tlist[clockwise,,drop=FALSE] if(haveZ) zc <- ztri[clockwise,,drop=FALSE] xtri[clockwise, ] <- xc[, c(1, 3, 2)] ytri[clockwise, ] <- yc[, c(1, 3, 2)] tlist[clockwise,] <- tc[, c(1, 3, 2)] if(haveZ) ztri[clockwise, ] <- zc[, c(1, 3, 2)] } rslt <- list() K <- 0 for(i in 1:nrow(xtri)) { tmp <- .Fortran( "intri", x=as.double(xtri[i,]), y=as.double(ytri[i,]), u=as.double(x), v=as.double(y), n=as.integer(length(x)), okay=integer(1), PACKAGE="deldir" ) if(as.logical(tmp$okay)) { tmp <- data.frame(ptNum=io[tlist[i,]],x=xtri[i,],y=ytri[i,]) if(length(pt)) tmp <- cbind(tmp[,1,drop=FALSE], ptType=pt[tlist[i,]],tmp[,2:3]) 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.R0000644000176200001440000000062212477270507015267 0ustar liggesusersplot.triang.list <- function(x,showrect=FALSE,add=FALSE,xlab="x",ylab="y", main="",asp=1,...) { stopifnot(inherits(x,"triang.list")) rw <- attr(x,"rw") if(!add) { plot(0,0,type="n",xlim=rw[1:2],ylim=rw[3:4], xlab=xlab,ylab=ylab,main=main,asp=asp) } for(tri in x) { polygon(as.list(tri),...) } if(showrect) do.call(rect,as.list(rw)[c(1,3,2,4)]) invisible() } deldir/R/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.R0000644000176200001440000003221313520164627013313 0ustar liggesusersdeldir <- local({ EnvSupp <- new.env() function(x,y,dpl=NULL,rw=NULL,eps=1e-9,sort=TRUE, plotit=FALSE,digits=6,z=NULL, zdum=NULL, suppressMsge=FALSE,...) { # Function deldir # # Copyright (C) 1996 by T. Rolf Turner # # Permission to use, copy, modify, and distribute this software and # its documentation for any purpose and without fee is hereby # granted, provided that the above copyright notice appear in all # copies and that both that copyright notice and this permission # notice appear in supporting documentation. # # ORIGINALLY PROGRAMMED BY: Rolf Turner in 1987/88, while with the # Division of Mathematics and Statistics, CSIRO, Sydney, Australia. # Re-programmed by Rolf Turner to adapt the implementation from a # stand-alone Fortran program to an S function, while visiting the # University of Western Australia, May 1995. Further revised # December 1996. # # Function to compute the Delaunay Triangulation (and hence the # Dirichlet Tesselation) of a planar point set according to the # second (iterative) algorithm of Lee and Schacter, International # Journal of Computer and Information Sciences, Vol. 9, No. 3, 1980, # pages 219 to 242. # The triangulation is made to be with respect to the whole plane by # `suspending' it from `ideal' points # (-R,-R), (R,-R) (R,R), and (-R,R), where R --> infinity. # It is also enclosed in a finite rectangle (whose boundaries truncate any # infinite Dirichlet tiles) with corners (xmin,ymin) etc. This rectangle # is referred to elsewhere as `the' rectangular window. if(exists("deldirMsgeDone",envir=EnvSupp)) suppressMsge <- TRUE if(!suppressMsge){ mess <- paste("\n PLEASE NOTE: The components \"delsgs\"", "and \"summary\" of the\n object returned by deldir()", "are now DATA FRAMES rather than\n matrices (as they", "were prior to release 0.0-18).\n See help(\"deldir\").\n", "\n PLEASE NOTE: The process that deldir() uses for", "determining\n duplicated points has changed from that", "used in version\n 0.0-9 of this package (and previously).", "See help(\"deldir\").\n\n") message(mess) assign("deldirMsgeDone","xxx",envir=EnvSupp) } # If the first argument is a data frame, extract the column # named "z", if there is one, to be the "z weights". Remove # this column from the first argument. Extract the column named # "x", if there is one, to be the "x" coordinates, otherwise take # the "x" coordinates to be the first column which is isn't named # "y". Extract the column named "y", if there is one, to be the # "y" coordinates, otherwise take the "y" coordinates to be the # first column which is isn't named "x". if(is.data.frame(x)) { if(ncol(x) < 2) stop(paste("If \"x\" is a data frame it must have\n", "at least two columns.\n")) j <- match("z",names(x)) if(!is.na(j)) { if(is.null(z)) z <- x[,j] x <- x[,-j] } j <- match(c("x","y"),names(x)) if(all(is.na(j))){ j <- 1:2 } else { if(is.na(j[2])) j[2] <- if(j[1]==1) 2 else 1 if(is.na(j[1])) j[1] <- if(j[2]==1) 2 else 1 } y <- x[,j[2]] x <- x[,j[1]] } else 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 a vector or a factor and if z is NULL, then set # z equal to the marks. if(is.null(z)) { marx <- x$marks ok <- !is.null(marx) && (is.vector(marx) | is.factor(marx)) if(ok) z <- x$marks } y <- x$y x <- x$x } else if(is.list(x)) { # If the first argument is a list (but not a data frame) extract # components x and y (and possibly z). if(all(!is.na(match(c('x','y'),names(x))))) { y <- x$y z <- if(is.null(z) && !inherits(x,"ppp")) x$z else z x <- x$x } else { stop("Argument \"x\" is a list but lacks x and/or y components.\n") } } haveZ <- !is.null(z) # Check that lengths match. n <- length(x) if(n!=length(y)) stop("Lengths \"x\" and \"y\" do not match.\n") if(haveZ) { if(n!=length(z)) stop("Length of \"z\" does not match lengths of \"x\" and \"y\".\n") } # If a data window is specified, turn it into a 4-tuple (if necessary). # Otherwise, if x is of class "ppp", form the data window as the bounding # box of the window of that if(!is.null(rw)) { if(inherits(rw,"owin")) { xr <- rw$window$xrange yr <- rw$window$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. if(is.matrix(rw)) rw <- as.vector(t(rw)) } else if(inherits(x,"ppp")) { rw <- c(x$window$xrange, x$window$yrange) } # 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] drop <- (1:n)[xxmax|yymax] if(length(drop)>0) { x <- x[-drop] y <- y[-drop] if(haveZ) z <- z[-drop] } } # 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 and no rectangular window specified.\n") xmin <- min(x) xmax <- max(x) ymin <- min(y) ymax <- max(y) xdff <- xmax-xmin ydff <- ymax-ymin xmin <- xmin-0.1*xdff xmax <- xmax+0.1*xdff ymin <- ymin-0.1*ydff ymax <- ymax+0.1*ydff rw <- c(xmin,xmax,ymin,ymax) } # Add the dummy points: if(!is.null(dpl)) { dpts <- dumpts(x,y,dpl,rw) x <- dpts$x y <- dpts$y ndm <- length(x) - n if(haveZ) { if(!is.null(zdum)) { if(length(zdum) != ndm) stop("The z dummy points are of the wrong length.\n") } else { zdum <- rep(NA,ndm) } z <- c(z,zdum) } } else ndm <- 0 # Eliminate duplicate points: iii <- duplicatedxy(x,y) if(any(iii)) { kkk <- !iii ndm <- sum(kkk[-(1:n)]) n <- sum(kkk[1:n]) if(haveZ) { jjj <- duplicated(data.frame(x=x,y=y,z=z)) if(sum(jjj) < sum(iii)) { whinge <- paste("There were different z \"weights\" corresponding to\n", "duplicated points.\n",sep="") warning(whinge) } z <- z[kkk] } x <- x[kkk] y <- y[kkk] ind.orig <- which(!iii) } else ind.orig <- seq_along(iii) # Toadal length of coordinate vectors ("n plus dummy"). npd <- n + ndm # Check there are sufficiently many points to triangulate/tessellate. if(npd <= 1) { whinge <- paste("There is at most one point, data or dummy, inside\n", " the given rectangular window. Thus there are\n", " insufficiently many points to triangulate/tessellate.\n") stop(whinge) } # Sort the coordinates into "bins". There are approximately # sqrt(npd) 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, ..., npd. Thus rind[ind] = ind[rind] = 1, 2, ..., npd. # 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:npd rind <- 1:npd } # Make space for the total number of points (real and dummy) as # well as 4 ideal points and 4 extra corner points which get used # (only) by subroutines dirseg and dirout in the ``output'' process # (returning a description of the triangulation after it has been # calculated): ntot <- npd + 4 # ntot includes the 4 ideal points but # but NOT the 4 extra corners x <- c(rep(0,4),x,rep(0,4)) y <- c(rep(0,4),y,rep(0,4)) # Set up fixed dimensioning constants: ntdel <- 4*npd ntdir <- 3*npd # Set up dimensioning constants which might need to be increased: madj <- max(20,ceiling(3*sqrt(ntot))) tadj <- (madj+1)*(ntot+4) ndel <- madj*(madj+1)/2 tdel <- 6*ndel ndir <- ndel tdir <- 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), npd=as.integer(npd), 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), nerror=integer(1), PACKAGE='deldir' ) # Check for errors: nerror <- tmp$nerror if(nerror < 0) break else { if(nerror==4) { cat('nerror =',nerror,'\n') nmadj <- ceiling(1.2*madj) cat('Increasing madj from',madj,'to',nmadj,'and trying again.\n') madj <- nmadj tadj <- (madj+1)*(ntot+4) ndel <- max(ndel,madj*(madj+1)/2) tdel <- 6*ndel ndir <- ndel tdir <- 10*ndir } else if(nerror==14|nerror==15) { cat('nerror =',nerror,'\n') nndel <- ceiling(1.2*ndel) wrds <-paste('Increasing ndel and ndir from',ndel, 'to',nndel,'and trying again.\n') ndel <- nndel tdel <- 6*ndel ndir <- ndel tdir <- 10*ndir } else { cat('nerror =',nerror,'\n') return(invisible()) } } } # Collect up the results for return: ndel <- tmp$ndel delsgs <- round(t(as.matrix(matrix(tmp$delsgs,nrow=6)[,1:ndel])),digits) delsgs <- as.data.frame(delsgs) names(delsgs) <- c('x1','y1','x2','y2','ind1','ind2') delsum <- matrix(tmp$delsum,ncol=4) del.area <- sum(delsum[,4]) delsum <- round(cbind(delsum,delsum[,4]/del.area),digits) del.area <- round(del.area,digits) ndir <- tmp$ndir dirsgs <- round(t(as.matrix(matrix(tmp$dirsgs,nrow=10)[,1:ndir])),digits) dirsgs <- as.data.frame(dirsgs) dirsum <- matrix(tmp$dirsum,ncol=3) dir.area <- sum(dirsum[,3]) dirsum <- round(cbind(dirsum,dirsum[,3]/dir.area),digits) dir.area <- round(dir.area,digits) names(dirsgs) <- c('x1','y1','x2','y2','ind1','ind2','bp1','bp2', '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)])) # 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 # Put in an indicator of point type if there were any # dummy points added. i1 <- if(ndm > 0) { data.frame(pt.type=c(rep("data",n),rep("dummy",ndm))) } else { as.data.frame(matrix(nrow=n,ncol=0)) } i2 <- if(haveZ) { data.frame(z=z) } else { as.data.frame(matrix(nrow=n+ndm,ncol=0)) } allsum <- cbind(allsum[,1:2],i1,i2,allsum[,3:9]) rw <- round(rw,digits) # Aw' done!!! rslt <- list(delsgs=delsgs,dirsgs=dirsgs,summary=allsum,n.data=n, n.dum=ndm,del.area=del.area,dir.area=dir.area,rw=rw, ind.orig=ind.orig) class(rslt) <- 'deldir' if(plotit) { plot(rslt,...) return(invisible(rslt)) } else return(rslt) } } ) deldir/MD50000644000176200001440000002106313615764032012036 0ustar liggesusersdd851fa250989b896ce37a91c3b637d8 *ChangeLog 122b9488a046c343466ef4fd6e468170 *DESCRIPTION 1a6ae0134a7d7f79ea976999c1faee9f *NAMESPACE 276c474998f3b1b2af301365f41b4171 *R/First.R 73e1fe7de214e92456cd97ad52a32f44 *R/acw.R 6a846af3d0ab4ab78512bee974ec6162 *R/binsrt.R 5935b62dc3be0f036c0b3f29ab827f85 *R/deldir.R e93cf566c9d47595ee8fd48fd53c49ff *R/divchain.R b6bc4dcf957c3deea31c6f8784b4257e *R/divchain.default.R b9c43e43a0f28730313ee9a4c9b6e96d *R/divchain.deldir.R a85dfaf3a04856f232991908a4e285a2 *R/dumpts.R 993ce9e5a7e061fba1847c6f029def08 *R/duplicatedxy.R 3e37aaac8530922a03f0cc05eee1a13e *R/get.cnrind.R fb4fd373dd2a698f4b5db76ad9bd4a48 *R/getCol.R 1c8ff720c4eb4ce2c2285fcadfbe9e7a *R/lawSummary.R e55af1ae6eb1861a0e7e2ea8a68c8444 *R/mid.in.R 38cab98679b46834c875f24aa585652d *R/mnnd.R 1e5012489a9c348a7b2791cb9fdda731 *R/plot.deldir.R d6eab673058844acdc5ec31ba74cac63 *R/plot.divchain.R 1d66c3d631a8c9376fc042b3680dc4e1 *R/plot.tile.list.R d2c672a1e243a6ee9446433850234456 *R/plot.triang.list.R c38f2e687eac60ef5e9d8d3026f7e325 *R/prelimtlist.R d9aada184c9d53295acb039d9ae1365c *R/print.tileInfo.R 3d4ae286693d20b4f89a5f408d6d76fb *R/tile.centroids.R 4686972f74d7d7cac48272a3264e53ca *R/tile.list.R 1bcd4f3274aefa373f4f7dcc513e3e0c *R/tileInfo.R 63589e2638a0b8a89eabb0b58e64bc0a *R/tilePerim.R 99a2662f5f54f53bee9917472c32d960 *R/tilePerim0.R 0877e76d2988a0e49b6751dcb40953b5 *R/triMat.R 5960a388ca8e9322538eabf6378bfe64 *R/triang.list.R d7d6dfe03916e59bef1323472197b6a2 *R/which.tile.R 6786c448abb17c3802afd0c917a4927e *data/niProperties.rda bb757b218a6ff52f7d2cbc730f605d90 *data/seaweed.rda 35ba8c19c87b1fe11803fff4326a88fc *inst/READ_ME 238b147302480cbe754a6222b01a37b1 *inst/SavedRatfor/acchk.r f8b7a4456cf2255dfe791f45c43c754e *inst/SavedRatfor/addpt.r 93ed44f787438449a98e24be66775d8b *inst/SavedRatfor/adjchk.r 325cded2f116b8584005937dabcedc19 *inst/SavedRatfor/binsrt.r be684d6aff22bd00ada3d19fc9fd6e6b *inst/SavedRatfor/circen.r 095eff7113f9df4353b9ce028fd521ed *inst/SavedRatfor/collincheck.r bfeaf199b574efa120d1a1573db190f2 *inst/SavedRatfor/cross.r c0912df4c2d04f977bbc04a3621295a2 *inst/SavedRatfor/crossutil.r 1c9a2dd463728754fc088b5da7e88348 *inst/SavedRatfor/delet.r 2aa853d7aaac39e955f2c8d7f44bee60 *inst/SavedRatfor/delet1.r eaa96f58e0df78d1fd1b12102c74037c *inst/SavedRatfor/delout.r 816b8baabfad840865006d6d3faa40f0 *inst/SavedRatfor/delseg.r 47353d13841379422f3cbf884caacf66 *inst/SavedRatfor/dirout.r e0f1d57d985c2089bbceeec874bd8622 *inst/SavedRatfor/dirseg.r c813395c2782b6e7ccc2bd5ea8d75dad *inst/SavedRatfor/dldins.r aa90712ccd692519e85d279192a5093f *inst/SavedRatfor/initad.r 7619a1d2f32f246670662e4f309e64b1 *inst/SavedRatfor/insrt.r 8d92aa51712ce4e98089b46daa29614f *inst/SavedRatfor/insrt1.r ee8f0a67f9a2064d87039cbec1adaf1b *inst/SavedRatfor/intri.r 5bad4291a0b880522b1fd6d62e7d7429 *inst/SavedRatfor/locn.r fb48046c41704d92c156fd11de706b2e *inst/SavedRatfor/master.r d03a4191bd92932b2738cf296f349033 *inst/SavedRatfor/mnnd.r 62f8ee83f2883425442a31b7492c3fa1 *inst/SavedRatfor/pred.r b2f36d395d489589d5bb834705f70f90 *inst/SavedRatfor/qtest.r ec28b6da05b12b6911b1ba1e27f65a83 *inst/SavedRatfor/qtest1.r a8636bf7b643eca192877bc38a6f2c87 *inst/SavedRatfor/stoke.r 6d1ed8f4862aea3c6cd9a28179c51ddf *inst/SavedRatfor/succ.r 9ef3474e6b93b694e903ef58a4ce43bc *inst/SavedRatfor/swap.r 24d5480cf4bdadf3689600d63d8de5e6 *inst/SavedRatfor/testeq.r 728e4e2b3d69a1ea05c3373ce5c378f5 *inst/SavedRatfor/triar.r fa5bfbfe72e8e42ba8db89dfb07b7ef6 *inst/SavedRatfor/trifnd.r 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 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 6b9d8dec2bc172cb280aa76cf285b67b *inst/err.list b1e64b5aed9484584095ac4e02baea84 *inst/ex.out 32332f6b7cc4f78b3307c77566bb5a89 *inst/ratfor/acchk.r f8b7a4456cf2255dfe791f45c43c754e *inst/ratfor/addpt.r 93ed44f787438449a98e24be66775d8b *inst/ratfor/adjchk.r 325cded2f116b8584005937dabcedc19 *inst/ratfor/binsrt.r 566e19a7629fe7a4c5ef2f86328c76ab *inst/ratfor/circen.r bfeaf199b574efa120d1a1573db190f2 *inst/ratfor/cross.r 4dc3c88910b10561f928f840e3c8e0d8 *inst/ratfor/crossutil.r 1c9a2dd463728754fc088b5da7e88348 *inst/ratfor/delet.r 2aa853d7aaac39e955f2c8d7f44bee60 *inst/ratfor/delet1.r eaa96f58e0df78d1fd1b12102c74037c *inst/ratfor/delout.r 816b8baabfad840865006d6d3faa40f0 *inst/ratfor/delseg.r 47353d13841379422f3cbf884caacf66 *inst/ratfor/dirout.r e0f1d57d985c2089bbceeec874bd8622 *inst/ratfor/dirseg.r c813395c2782b6e7ccc2bd5ea8d75dad *inst/ratfor/dldins.r 203564e21f3704e0feca7082121bcaaa *inst/ratfor/initad.r 7619a1d2f32f246670662e4f309e64b1 *inst/ratfor/insrt.r 8d92aa51712ce4e98089b46daa29614f *inst/ratfor/insrt1.r ee8f0a67f9a2064d87039cbec1adaf1b *inst/ratfor/intri.r 5bad4291a0b880522b1fd6d62e7d7429 *inst/ratfor/locn.r b0b4711c3a3980c39a7251dde6d5dff4 *inst/ratfor/makefor 4c57ba1c7941e9f7bf346b0c21437926 *inst/ratfor/master.r d03a4191bd92932b2738cf296f349033 *inst/ratfor/mnnd.r 62f8ee83f2883425442a31b7492c3fa1 *inst/ratfor/pred.r b2f36d395d489589d5bb834705f70f90 *inst/ratfor/qtest.r 6e033e3c1b8dbdde1dab35f247429dc5 *inst/ratfor/qtest1.r a8636bf7b643eca192877bc38a6f2c87 *inst/ratfor/stoke.r 6d1ed8f4862aea3c6cd9a28179c51ddf *inst/ratfor/succ.r ae763fdef4e32189add54be38868d492 *inst/ratfor/swap.r 24d5480cf4bdadf3689600d63d8de5e6 *inst/ratfor/testeq.r 728e4e2b3d69a1ea05c3373ce5c378f5 *inst/ratfor/triar.r 2b83d525c7bd91e73d0e4107b6eccf2b *inst/ratfor/trifnd.r 016e78adc896fe444119258f827f9be1 *man/deldir-internal.Rd 945bb2f8a485803a24bdf969e066dd25 *man/deldir.Rd d8d136a9c89729dc77d9b001608dbe39 *man/divchain.Rd 9a864d08542901f46155c75482e027c3 *man/divchain.default.Rd 5b2eedfe0ad5ff390b83e77b86fe6e38 *man/divchain.deldir.Rd 4d3115865ece296df66e7899d53f3be6 *man/duplicatedxy.Rd 6321c7706fc6345bcacefae5f2c48173 *man/lawSummary.Rd 2ce7fbea93478b4645c8061eb4966093 *man/niProperties.Rd b3a5b85d2e6dcd005f7fda86abc2751d *man/plot.deldir.Rd 6e913c92d1e1b06484d9e128d68051f2 *man/plot.divchain.Rd e2e14d87ebcba8c95b55195e7ecf69bf *man/plot.tile.list.Rd bb74ebbd0b644b2ef29de2ce4378f9ac *man/plot.triang.list.Rd 4fb482672931a9e47edea03539e6ea8c *man/print.tileInfo.Rd 1bc0a40a839fd81771f508b4b39fd16b *man/seaweed.Rd 6792aca36d22c4311f076a398ce8b2d7 *man/tile.centroids.Rd 4c8c4a0eacbde3a6e43b2959bf90a914 *man/tile.list.Rd d76db01a93f1c250b738839459443425 *man/tileInfo.Rd 1a445f24882bdb832d115514897389bf *man/tilePerim.Rd 4cd6cb5dfeead58a474f7d5aeb93ec5a *man/triMat.Rd 7693498598a1fa296c15a429a44bc43f *man/triang.list.Rd b19b7f645ad78070a72b9e3b4f04adbf *man/which.tile.Rd 76a558eb6db0bdbeef0087d1f3c35b92 *src/acchk.f 24ab0baab8c8eda80c2ac4859fe8118c *src/addpt.f baf7a91021182fadffa7c365a3d07cd9 *src/adjchk.f 5efad71f8a1a4f86a8728a7602502d73 *src/binsrt.f 924bd170fa22af5200c83fc16a8f66ba *src/circen.f 5db09a2919e8de068cb510d559b1aa7b *src/cross.f 54417788fe806ff9997252bdeb34ff08 *src/crossutil.f 15faa338e3376f3a007528c5102a8287 *src/delet.f 95495d604758eb931a4c3749877f8def *src/delet1.f 844a7887e5fca62254789d1c6c18708f *src/delout.f 5b2872af9c448f23a295fb0946767631 *src/delseg.f 8fb196044a3f1fb51d2ebad083db45cc *src/dirout.f f87bf25e205306d4451c40411fee4819 *src/dirseg.f f48c9c8fa1c57a814ad5b2666e501fc1 *src/dldins.f 6490ad9d3b6a5f9b44b79966ed8c7aeb *src/init.c c8f146dc75e0c4150fb97e730cc149cc *src/initad.f d47d2da0ad71e2a3bbcae67062ae6a0d *src/insrt.f 7cf37275d8490c9988de60c584d614f0 *src/insrt1.f a77d6dc9e203596292e68242e9bb8b13 *src/intri.f 5b9375d7cc7eb47f18ac425ceeb0f04c *src/locn.f f134729de2914ff35b96414153d3d761 *src/master.f e8eaff0b0bfcfb4e8c8424b113c88775 *src/mnnd.f d84ae34ba990238a131a061eb22c2e43 *src/pred.f e276aa36ccb0ac0ddc32b1130dad28ed *src/qtest.f 728379a46cf7ba82e18410ed55e98bf5 *src/qtest1.f df7c0c900c054241100d4d388ddd39d8 *src/stoke.f 2968a6ad0d31463efccd26b1020e3941 *src/succ.f a6192e3409065f88ab33fca97924642d *src/swap.f dd0d239dae76f72a42e6cb3a23ce7899 *src/testeq.f 1e9b80939787f9aec36624d9fdb5b845 *src/triar.f 7d837ff5d39a330f586f5d605d263320 *src/trifnd.f deldir/inst/0000755000176200001440000000000013520465701012475 5ustar liggesusersdeldir/inst/code.discarded/0000755000176200001440000000000013615622065015333 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/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/ratfor/0000755000176200001440000000000013615621456014000 5ustar liggesusersdeldir/inst/ratfor/initad.r0000644000176200001440000000226413520002325015416 0ustar liggesuserssubroutine initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror) # Initial adding-in of a new point j. # Called by addpt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) integer tau(3) # Find the triangle containing vertex j. call trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror > 0) return # If the new point is on the edge of a triangle, detach the two # vertices of that edge from each other. Also join j to the vertex # of the triangle on the reverse side of that edge from the `found' # triangle (defined by tau) -- given that there ***is*** such a triangle. if(nedge!=0) { ip = nedge i = ip-1 if(i==0) i = 3 # Arithmetic modulo 3. call pred(k,tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror > 0) return call succ(kk,tau(ip),tau(i),nadj,madj,ntot,nerror) if(nerror > 0) return call delet(tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror > 0) return if(k==kk) call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } # Join the new point to each of the three vertices. do i = 1,3 { call insrt(j,tau(i),nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } return end deldir/inst/ratfor/succ.r0000644000176200001440000000157311621163455015121 0ustar liggesuserssubroutine succ(ksc,i,j,nadj,madj,ntot,nerror) # Find the successor of j in the adjacency list of i. # Called by addpt, initad, trifnd, swap, delout, dirseg, dirout. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) # If the adjacency list of i is empty, then clearly j has no successor # in this adjacency list. Something's wrong; stop. if(n==0) { nerror = 9 return } # The adjacency list of i is non-empty; search through it until j is found; # add 1 to the location of j, and find the contents of this new location. do k = 1,n { if(j==nadj(i,k)) { kp = k+1 if(kp>n) kp = 1 # Take kp modulo n. (The adjacency list ksc = nadj(i,kp) # is circular.) return } } # The adjacency list doesn't contain j. Something's wrong. nerror = 10 return end deldir/inst/ratfor/locn.r0000644000176200001440000000264111621163455015114 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) { kj = 1 return } # Run through i's list, checking if j should come before each element # of that list. (I.e. if i, j, and k are in anti-clockwise order.) # If j comes before the kj-th item, but not before the (kj-1)-st, then # j should have place kj. do ks = 1,n { kj = ks k = nadj(i,kj) call acchk(i,j,k,before,x,y,ntot,eps) if(before) { km = kj-1 if(km==0) km = n k = nadj(i,km) call acchk(i,j,k,before,x,y,ntot,eps) if(before) next # If j is before 1 and after n, then it should # have place n+1. if(kj==1) kj = n+1 return } } # We've gone right through the list and haven't been before # the kj-th item ***and*** after the (kj-1)-st on any occasion. # Therefore j is before everything (==> place 1) or after # everything (==> place n+1). if(before) kj = 1 else kj = n+1 return end deldir/inst/ratfor/crossutil.r0000644000176200001440000000075413520003405016177 0ustar liggesuserssubroutine crossutil(i,j,k,x,y,ntot,eps,collin) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) dimension xt(3), yt(3) logical collin xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) # Create indicator telling which of i, j, and k are ideal points. # The point being added, i, is never ideal. i1 = 0 if(j<=0) j1 = 1 else j1 = 0 if(k<=0) k1 = 1 else k1 = 0 ijk = i1*4+j1*2+k1 call cross(xt,yt,ijk,cprd) collin = (abs(cprd) < eps) return end deldir/inst/ratfor/dirseg.r0000644000176200001440000001016313507530616015436 0ustar liggesuserssubroutine dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ntri,nerror) # Output the endpoints of the segments of boundaries of Dirichlet # tiles. (Do it economically; each such segment once and only once.) # Called by master. implicit double precision(a-h,o-z) logical collin, adjace, intfnd, bptab, bptcd, goferit, rwu dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsgs(10,ndir), rw(4) nerror = -1 # Add in some dummy corner points, outside the actual window. # Far enough out so that no resulting tile boundaries intersect the # window. # Note that these dummy corners are needed by the routine `dirout' # but will screw things up for `delseg' and `delout'. Therefore # this routine (`dirseg') must be called ***before*** dirout, and # ***after*** delseg and delout. # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) a = xmax-xmin b = ymax-ymin c = sqrt(a*a+b*b) npd = ntot-4 nstt = npd+1 i = nstt x(i) = xmin-c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymax+c i = i+1 x(i) = xmin-c y(i) = ymax+c do j = nstt,ntot { call addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) ntri = ntri + 3 if(nerror > 0) { return } } # Put the segments into the array dirsgs. # For each distinct pair of (genuine) data points, find out if they are # adjacent. If so, find the circumcentres of the triangles lying on each # side of the segment joining them. kseg = 0 do i = 2,npd { do j = 1,i-1 { call adjchk(i,j,adjace,nadj,madj,ntot,nerror) if(nerror > 0) { return } if(adjace) { call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror > 0) return if(collin) { nerror = 12 return } call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror > 0) return if(collin) { nerror = 12 return } # If a circumcentre is outside the rectangular window # of interest, draw a line joining it to the other # circumcentre. Find the intersection of this line with # the boundary of the window; for (a,b) and call the point # of intersection (ai,bi). For (c,d), call it (ci,di). # Note: rwu = "right way up". xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi!=yj) { slope = (xi - xj)/(yj - yi) rwu = .true. } else { slope = 0.d0 rwu = .false. } call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedgeab) if(!intfnd) { nerror = 16 return } call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedgecd) if(!intfnd) { nerror = 16 return } goferit = .false. if(bptab & bptcd) { xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xmin ndir) { nerror = 15 return } dirsgs(1,kseg) = ai dirsgs(2,kseg) = bi dirsgs(3,kseg) = ci dirsgs(4,kseg) = di dirsgs(5,kseg) = i dirsgs(6,kseg) = j if(bptab) dirsgs(7,kseg) = 1.d0 else dirsgs(7,kseg) = 0.d0 if(bptcd) dirsgs(8,kseg) = 1.d0 else dirsgs(8,kseg) = 0.d0 if(bptab) dirsgs(9,kseg) = -nedgeab else dirsgs(9,kseg) = k if(bptcd) dirsgs(10,kseg) = -nedgecd else dirsgs(10,kseg) = l } } } } ndir = kseg return end deldir/inst/ratfor/triar.r0000644000176200001440000000040011621163455015271 0ustar liggesuserssubroutine triar(x0,y0,x1,y1,x2,y2,area) # Calculate the area of a triangle with given # vertices, in anti clockwise direction. # Called by delout. implicit double precision(a-h,o-z) half = 0.5d0 area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)) return end deldir/inst/ratfor/insrt1.r0000644000176200001440000000144311621163455015400 0ustar liggesuserssubroutine insrt1(i,j,kj,nadj,madj,ntot,nerror) # Insert j into the adjacency list of i. # Called by insrt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 # 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) { nadj(i,0) = 1 nadj(i,1) = j return } # 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) { # Watch out for over-writing!!! nerror = 4 return } while(kk>kj) { nadj(i,kk) = nadj(i,kk-1) kk = kk-1 } nadj(i,kj) = j nadj(i,0) = n+1 return end deldir/inst/ratfor/dldins.r0000644000176200001440000000504212665746367015456 0ustar liggesuserssubroutine dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bpt,nedge) # Get a point ***inside*** the rectangular window on the ray from # one circumcentre to the next one. I.e. if the `next one' is # inside, then that's it; else find the intersection of this ray with # the boundary of the rectangle. # Called by dirseg, dirout. implicit double precision(a-h,o-z) dimension rw(4) logical intfnd, bpt, rwu # Note that (a,b) is the circumcentre of a Delaunay triangle, # and that slope is the slope of the ray joining (a,b) to the # corresponding circumcentre on the opposite side of an edge of that # triangle. When `dldins' is called by `dirout' it is possible # for the ray not to intersect the window at all. (The Delaunay # edge between the two circumcentres might be connected to a `fake # outer corner', added to facilitate constructing a tiling that # completely covers the actual window.) The variable `intfnd' acts # as an indicator as to whether such an intersection has been found. # The variable `bpt' acts as an indicator as to whether the returned # point (ai,bi) is a true circumcentre, inside the window (bpt == .false.), # or is the intersection of a ray with the boundary of the window # (bpt = .true.). intfnd = .true. bpt = .true. # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) # Check if (a,b) is inside the rectangle. if(xmin<=a&a<=xmax&ymin<=b&b<=ymax) { ai = a bi = b bpt = .false. nedge = 0 return } # Look for appropriate intersections with the four lines forming # the sides of the rectangular window. # If not "the right way up" then the line joining the two # circumcentres is vertical. if(!rwu) { if(b < ymin) { ai = a bi = ymin nedge = 1 if(xmin<=ai&ai<=xmax) return } if(b > ymax) { ai = a bi = ymax nedge = 3 if(xmin<=ai&ai<=xmax) return } intfnd = .false. return } # Line 1: x = xmin. if(axmax) { ai = xmax bi = b + slope*(ai-a) nedge = 4 if(ymin<=bi&bi<=ymax) return } # Line 4: y = ymax. if(b>ymax) { bi = ymax ai = a + (bi-b)/slope nedge = 3 if(xmin<=ai&ai<=xmax) return } intfnd = .false. return end deldir/inst/ratfor/adjchk.r0000644000176200001440000000156613507530506015412 0ustar liggesuserssubroutine adjchk(i,j,adj,nadj,madj,ntot,nerror) # Check if vertices i and j are adjacent. # Called by insrt, delet, trifnd, swap, delseg, dirseg. dimension nadj(-3:ntot,0:madj) logical adj nerror = -1 # Check if j is in the adjacency list of i. adj = .false. ni = nadj(i,0) if(ni>0) { do k = 1,ni { if(j==nadj(i,k)) { adj = .true. break } } } # Check if i is in the adjacency list of j. nj = nadj(j,0) if(nj>0) { do k = 1,nj { if(i==nadj(j,k)) { if(adj) return # Have j in i's list and i in j's. else { nerror = 1 return } } } } # If we get to here i is not in j's list. if(adj) { # If adj is true, then j IS in i's list. nerror = 1 return } return end deldir/inst/ratfor/stoke.r0000644000176200001440000000756611621163455015321 0ustar liggesuserssubroutine stoke(x1,y1,x2,y2,rw,area,s1,eps,nerror) # Apply Stokes' theorem to find the area of a polygon; # we are looking at the boundary segment from (x1,y1) # to (x2,y2), travelling anti-clockwise. We find the # area between this segment and the horizontal base-line # y = ymin, and attach a sign s1. (Positive if the # segment is right-to-left, negative if left to right.) # The area of the polygon is found by summing the result # over all boundary segments. # Just in case you thought this wasn't complicated enough, # what we really want is the area of the intersection of # the polygon with the rectangular window that we're using. # Called by dirout. implicit double precision(a-h,o-z) dimension rw(4) logical value zero = 0.d0 nerror = -1 # If the segment is vertical, the area is zero. call testeq(x1,x2,eps,value) if(value) { area = 0. s1 = 0. return } # Find which is the right-hand end, and which is the left. if(x1=xmax) { area = 0. return } # We're now looking at a trapezoidal region which may or may # not protrude above or below the horizontal strip bounded by # y = ymax and y = ymin. ybot = min(yl,yr) ytop = max(yl,yr) # Case 1; ymax <= ybot: # The `roof' of the trapezoid is entirely above the # horizontal strip. if(ymax<=ybot) { area = (xr-xl)*(ymax-ymin) return } # Case 2; ymin <= ybot <= ymax <= ytop: # The `roof' of the trapezoid intersects the top of the # horizontal strip (y = ymax) but not the bottom (y = ymin). if(ymin<=ybot&ymax<=ytop) { call testeq(slope,zero,eps,value) if(value) { w1 = 0. w2 = xr-xl } else { xit = xl+(ymax-yl)/slope w1 = xit-xl w2 = xr-xit if(slope<0.) { tmp = w1 w1 = w2 w2 = tmp } } area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin) return } # Case 3; ybot <= ymin <= ymax <= ytop: # The `roof' intersects both the top (y = ymax) and # the bottom (y = ymin) of the horizontal strip. if(ybot<=ymin&ymax<=ytop) { xit = xl+(ymax-yl)/slope xib = xl+(ymin-yl)/slope if(slope>0.) { w1 = xit-xib w2 = xr-xit } else { w1 = xib-xit w2 = xit-xl } area = 0.5*w1*(ymax-ymin)+w2*(ymax-ymin) return } # Case 4; ymin <= ybot <= ytop <= ymax: # The `roof' is ***between*** the bottom (y = ymin) and # the top (y = ymax) of the horizontal strip. if(ymin<=ybot&ytop<=ymax) { area = 0.5*(xr-xl)*((ytop-ymin)+(ybot-ymin)) return } # Case 5; ybot <= ymin <= ytop <= ymax: # The `roof' intersects the bottom (y = ymin) but not # the top (y = ymax) of the horizontal strip. if(ybot<=ymin&ymin<=ytop) { call testeq(slope,zero,eps,value) if(value) { area = 0. return } xib = xl+(ymin-yl)/slope if(slope>0.) w = xr-xib else w = xib-xl area = 0.5*w*(ytop-ymin) return } # Case 6; ytop <= ymin: # The `roof' is entirely below the bottom (y = ymin), so # there is no area contribution at all. if(ytop<=ymin) { area = 0. return } # Default; all stuffed up: nerror = 8 return end deldir/inst/ratfor/intri.r0000644000176200001440000000143713077240004015301 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) { inside = .false. break } } if(inside) { okay = 0 return } } okay = 1 return end deldir/inst/ratfor/testeq.r0000644000176200001440000000145311621163455015466 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) { if(abs(a)<=eps) value = .true. else value = .false. return } # Test if a is a `lot different' from b. (If it is # they're obviously not equal.) This avoids under/overflow # problems in dividing a by b. if(abs(a)>ten*abs(b)|abs(a) eps) anticl = .true. else anticl = .false. return end deldir/inst/ratfor/insrt.r0000644000176200001440000000134113507530647015322 0ustar liggesuserssubroutine insrt(i,j,nadj,madj,x,y,ntot,nerror,eps) # Insert i and j into each other's adjacency list. # Called by master, initad, swap. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical adj # Check whether i and j are in each other's adjacency lists. call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror > 0) { return } if(adj) return # If not, find where in each list they should respectively be. call locn(i,j,kj,nadj,madj,x,y,ntot,eps) call locn(j,i,ki,nadj,madj,x,y,ntot,eps) # Put them in each other's lists in the appropriate position. call insrt1(i,j,kj,nadj,madj,ntot,nerror) if(nerror >0) return call insrt1(j,i,ki,nadj,madj,ntot,nerror) if(nerror >0) return return end deldir/inst/ratfor/circen.r0000644000176200001440000000340613615621225015423 0ustar liggesuserssubroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin,nerror) # Find the circumcentre (x0,y0) of the triangle with # vertices (x(i),y(i)), (x(j),y(j)), (x(k),y(k)). # Called by qtest1, dirseg, dirout. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) dimension indv(3) # To facillitate a lucid error message. dimension xtmp(1) logical collin nerror = -1 # Get the coordinates. xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) # Check for collinearity ijk = 0 call cross(xt,yt,ijk,cprd) if(abs(cprd) < eps) collin = .true. else collin = .false. # Form the vector u from i to j, and the vector v from i to k, # and normalize them. a = x(j) - x(i) b = y(j) - y(i) c = x(k) - x(i) d = y(k) - y(i) c1 = sqrt(a*a+b*b) c2 = sqrt(c*c+d*d) a = a/c1 b = b/c1 c = c/c2 d = d/c2 # If the points are collinear, make sure that they're in the right # order --- i between j and k. if(collin) { alpha = a*c+b*d # If they're not in the right order, bring things to # a shuddering halt. if(alpha>0) { 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 rexit("Points are collinear but in the wrong order.") } # Collinear, but in the right order; think of this as meaning # that the circumcircle in question has infinite radius. return } # Not collinear; go ahead, make my circumcentre. (First, form # the cross product of the ***unit*** vectors, instead of the # ``normalized'' cross product produced by ``cross''.) crss = a*d - b*c x0 = x(i) + 0.5*(c1*d - c2*b)/crss y0 = y(i) + 0.5*(c2*a - c1*c)/crss return end deldir/inst/ratfor/qtest1.r0000644000176200001440000000633413615621164015406 0ustar liggesuserssubroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) # The Lee-Schacter test for the LOP (all points are real, # i.e. non-ideal). If the LOP is ***not*** satisfied (i.e. if # vertex j is inside the circumcircle of vertices h, i, and k) then the # diagonals should be swapped, i.e. shdswp ("should-swap") is true. # Called by qtest. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3), indv(3) dimension itmp(1) dimension xtmp(1) integer h logical shdswp, collin # 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) { # 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) { itmp(1) = 1 call intpr("error detected in qtest1",-1,itmp,0) 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 rexit("Points are collinear but h not between i and k.") } # Collinear, and in the right order; think of this as meaning # that the circumcircle in question has infinite radius. shdswp = .true. } # Get the coordinates of vertices h and j. xh = x(h) yh = y(h) xj = x(j) yj = y(j) # Find the centre of the circumcircle of vertices h, i, k. call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror) if(nerror>0) return if(shdswp) return # The points h, i, and k are colinear, so # the circumcircle has `infinite radius', so # (xj,yj) is definitely inside. # Check whether (xj,yj) is inside the circle of centre # (x0,y0) and radius r = dist[(x0,y0),(xh,yh)] a = x0-xh b = y0-yh r2 = a*a+b*b a = x0-xj b = y0-yj ch = a*a + b*b if(ch0){ return } if(value) { kseg = kseg+1 if(kseg > ndel) { nerror = 14 return } delsgs(1,kseg) = x(i) delsgs(2,kseg) = y(i) delsgs(3,kseg) = x(j) delsgs(4,kseg) = y(j) delsgs(5,kseg) = i delsgs(6,kseg) = j } } } ndel = kseg return end deldir/inst/ratfor/dirout.r0000644000176200001440000000752712665747073015514 0ustar liggesuserssubroutine dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror) # Output the description of the Dirichlet tile centred at point # i for i = 1, ..., npd. Do this in the original order of the # points, not in the order into which they have been bin-sorted. # Called by master. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsum(npd,3), rw(4) logical collin, intfnd, bptab, bptcd, rwu # Note that at this point some Delaunay neighbours may be # `spurious'; they are the corners of a `large' rectangle in which # the rectangular window of interest has been suspended. This # large window was brought in simply to facilitate output concerning # the Dirichlet tesselation. They were added to the triangulation # in the routine `dirseg' which ***must*** therefore be called before # this routine (`dirout') is called. (Likewise `dirseg' must be called # ***after*** `delseg' and `delout' have been called.) # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) do i = 1,npd { area = 0. # Initialize the area of the ith tile to zero. nbpt = 0 # Initialize the number of boundary points of # the ith tile to zero. npt = 0 # Initialize the number of tile boundaries to zero. np = nadj(i,0) # Output the point number, its coordinates, and the number of # its Delaunay neighbours == the number of boundary segments in # its Dirichlet tile. # For each Delaunay neighbour, find the circumcentres of the # triangles on each side of the segment joining point i to that # neighbour. do j1 = 1,np { j = nadj(i,j1) call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror>0) return if(collin) { nerror = 13 return } call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror>0) return if(collin) { nerror = 13 return } # Increment the area of the current Dirichlet # tile (intersected with the rectangular window) by applying # Stokes' Theorem to the segment of tile boundary joining # (a,b) to (c,d). (Note that the direction is anti-clockwise.) call stoke(a,b,c,d,rw,tmp,sn,eps,nerror) if(nerror > 0) return area = area+sn*tmp # If a circumcentre is outside the rectangular window, replace # it with the intersection of the rectangle boundary with the # line joining the two circumcentres. Then output # the number of the current Delaunay neighbour and # the two circumcentres (or the points with which # they have been replaced). # Note: rwu = "right way up". xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi!=yj) { slope = (xi - xj)/(yj - yi) rwu = .true. } else { slope = 0.d0 rwu = .false. } call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedge) if(intfnd) { call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedge) if(!intfnd) { nerror = 17 return } if(bptab & bptcd) { xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xminnp) kp = 1 if(nadj(i,k)<=0|nadj(i,kp)<=0) npt = npt-1 } # For each point in the adjacency list of point i, find its # successor, and the area of the triangle determined by these # three points. do j1 = 1,np { j = nadj(i,j1) if(j<=0) next xj = x(j) yj = y(j) call succ(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return if(k<=0) next xk = x(k) yk = y(k) call triar(xi,yi,xj,yj,xk,yk,tmp) # Downweight the area by 1/3, since each # triangle eventually appears 3 times over. area = area+tmp/3. } delsum(i,1) = xi delsum(i,2) = yi delsum(i,3) = npt delsum(i,4) = area } return end deldir/inst/ratfor/makefor0000744000176200001440000000016411621163455015344 0ustar liggesusers#! /bin/csh foreach file (*.r) set stem = `basename $file .r` ratfor $file > $stem.f /bin/mv $stem.f ../../src end deldir/inst/ratfor/master.r0000644000176200001440000000352613520167762015464 0ustar liggesuserssubroutine master(x,y,rw,npd,ntot,nadj,madj,eps,delsgs,ndel,delsum, dirsgs,ndir,dirsum,nerror) # Master subroutine: # One subroutine to rule them all, # One subroutine to find them. # One subroutine to bring them all in, # And in the darkness bind them. implicit double precision(a-h,o-z) 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(npd,4), dirsum(npd,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 } } # Put the four ideal points into x and y and the adjacency list. # The ideal points are given pseudo-coordinates # (-1,-1), (1,-1), (1,1), and (-1,1). They are numbered as # 0 -1 -2 -3 # i.e. the numbers decrease anticlockwise from the # `bottom left corner'. x(-3) = -one y(-3) = one x(-2) = one y(-2) = one x(-1) = one y(-1) = -one x(0) = -one y(0) = -one do i = 1,4 { j = i-4 k = j+1 if(k>0) k = -3 call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror>0) return } # Put in the first of the point set into the adjacency list. do i = 1,4 { j = i-4 call insrt(1,j,nadj,madj,x,y,ntot,nerror,eps) if(nerror>0) return } ntri = 4 # Now add the rest of the point set do j = 2,npd { call addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror>0) { return } ntri = ntri + 3 } # Obtain the description of the triangulation. call delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,nerror) if(nerror>0) return call delout(delsum,nadj,madj,x,y,ntot,npd,nerror) if(nerror>0) return call dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ntri,nerror) if(nerror>0) return call dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror) return end deldir/inst/ratfor/trifnd.r0000644000176200001440000000767113615621374015463 0ustar liggesuserssubroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror) # Find the triangle of the extant triangulation in which # lies the point currently being added. # Called by initad. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot), xt(3), yt(3) dimension itmp(1) integer tau(3) logical adjace, anticl nerror = -1 # The first point must be added to the triangulation before # calling trifnd. if(j==1) { nerror = 11 return } # Get the previous triangle: j1 = j-1 tau(1) = j1 tau(3) = nadj(j1,1) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot,nerror) if(nerror>0) { return } if(!adjace) { tau(3) = tau(2) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return } # Move to the adjacent triangle in the direction of the new # point, until the new point lies in this triangle. ktri = 0 1 continue # 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(!anticl) { call acchk(tau(3),tau(2),tau(1),anticl,x,y,ntot,eps) if(!anticl) { itmp(1) = j call intpr("Point number =",-1,itmp,1) call intpr("Previous triangle:",-1,tau,3) call rexit("Both vertex orderings are clockwise. See help for deldir.") } else { ivtmp = tau(3) tau(3) = tau(1) tau(1) = ivtmp } } ntau = 0 # This number will identify the triangle to be moved to. nedge = 0 # If the point lies on an edge, this number will identify that edge. do i = 1,3 { ip = i+1 if(ip==4) ip = 1 # Take addition modulo 3. # Get the coordinates of the vertices of the current side, # and of the point j which is being added: xt(1) = x(tau(i)) yt(1) = y(tau(i)) xt(2) = x(tau(ip)) yt(2) = y(tau(ip)) xt(3) = x(j) yt(3) = y(j) # Create indicator telling which of tau(i), tau(ip), and j # are ideal points. (The point being added, j, is ***never*** ideal.) if(tau(i)<=0) i1 = 1 else i1 = 0 if(tau(ip)<=0) j1 = 1 else j1 = 0 k1 = 0 ijk = i1*4+j1*2+k1 # Calculate the ``normalized'' cross product; if this is positive # then the point being added is to the left (as we move along the # edge in an anti-clockwise direction). If the test value is positive # for all three edges, then the point is inside the triangle. Note # that if the test value is very close to zero, we might get negative # values for it on both sides of an edge, and hence go into an # infinite loop. call cross(xt,yt,ijk,cprd) if(cprd >= eps) continue else if(cprd > -eps) nedge = ip else { ntau = ip break } } # We've played ring-around-the-triangle; now figure out the # next move: # case 0: All tests >= 0.; the point is inside; return. if(ntau==0) return # The point is not inside; work out the vertices of the triangle to which # to move. Notation: Number the vertices of the current triangle from 1 to 3, # anti-clockwise. Then "triangle i+1" is adjacent to the side from vertex i to # vertex i+1, where i+1 is taken modulo 3 (i.e. "3+1 = 1"). # case 1: Move to "triangle 1" if(ntau==1) { #tau(1) = tau(1) tau(2) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror > 0) return } # case 2: Move to "triangle 2" if(ntau==2) { #tau(1) = tau(1) tau(3) = tau(2) call pred(tau(2),tau(1),tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return } # case 3: Move to "triangle 3" if(ntau==3) { tau(1) = tau(3) #tau(2) = tau(2) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror > 0) return } # We've moved to a new triangle; check if the point being added lies # inside this one. ktri = ktri + 1 if(ktri > ntri) { itmp(1) = j call intpr("Point being added:",-1,itmp,1) call rexit("Cannot find an enclosing triangle. See help for deldir.") } go to 1 end deldir/inst/ratfor/qtest.r0000644000176200001440000000721211621163455015320 0ustar liggesuserssubroutine qtest(h,i,j,k,shdswp,x,y,ntot,eps,nerror) # Test whether the LOP is satisified; i.e. whether vertex j # is outside the circumcircle of vertices h, i, and k of the # quadrilateral. Vertex h is the vertex being added; i and k are # the vertices of the quadrilateral which are currently joined; # j is the vertex which is ``opposite'' the vertex being added. # If the LOP is not satisfied, then shdswp ("should-swap") is true, # i.e. h and j should be joined, rather than i and k. I.e. if j # is outside the circumcircle of h, i, and k then all is well as-is; # *don't* swap ik for hj. If j is inside the circumcircle of h, # i, and k then change is needed so swap ik for hj. # Called by swap. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) integer h logical shdswp nerror = -1 # Look for ideal points. if(i<=0) ii = 1 else ii = 0 if(j<=0) jj = 1 else jj = 0 if(k<=0) kk = 1 else kk = 0 ijk = ii*4+jj*2+kk # All three corners other than h (the point currently being # added) are ideal --- so h, i, and k are co-linear; so # i and k shouldn't be joined, and h should be joined to j. # So swap. (But this can't happen, anyway!!!) # case 7: if(ijk==7) { shdswp = .true. return } # If i and j are ideal, find out which of h and k is closer to the # intersection point of the two diagonals, and choose the diagonal # emanating from that vertex. (I.e. if h is closer, swap.) # Unless swapping yields a non-convex quadrilateral!!! # case 6: if(ijk==6) { xh = x(h) yh = y(h) xk = x(k) yk = y(k) ss = 1 - 2*mod(-j,2) test = (xh*yk+xk*yh-xh*yh-xk*yk)*ss if(test>0.d0) shdswp = .true. else shdswp = .false. # Check for convexity: if(shdswp) call acchk(j,k,h,shdswp,x,y,ntot,eps) return } # Vertices i and k are ideal --- can't happen, but if it did, we'd # increase the minimum angle ``from 0 to more than 2*0'' by swapping ... # # 24/7/2011 --- I now think that the forgoing comment is misleading, # although it doesn't matter since it can't happen anyway. The # ``2*0'' is wrong. The ``new minimum angle would be min{alpha,beta} # where alpha and beta are the angles made by the line joining h # to j with (any) line with slope = -1. This will be greater than # 0 unless the line from h to j has slope = - 1. In this case h, # i, j, and k are all co-linear, so i and k should not be joined # (and h and j should be) so swapping is called for. If h, i, # j and j are not co-linear then the quadrilateral is definitely # convex whence swapping is OK. So let's say swap. # case 5: if(ijk==5) { shdswp = .true. return } # If i is ideal we'd increase the minimum angle ``from 0 to more than # 2*0'' by swapping, so just check for convexity: # case 4: if(ijk==4) { call acchk(j,k,h,shdswp,x,y,ntot,eps) return } # If j and k are ideal, this is like unto case 6. # case 3: if(ijk==3) { xi = x(i) yi = y(i) xh = x(h) yh = y(h) ss = 1 - 2*mod(-j,2) test = (xh*yi+xi*yh-xh*yh-xi*yi)*ss if(test>0.d0) shdswp = .true. else shdswp = .false. # Check for convexity: if(shdswp) call acchk(h,i,j,shdswp,x,y,ntot,eps) return } # If j is ideal we'd decrease the minimum angle ``from more than 2*0 # to 0'', by swapping; so don't swap. # case 2: if(ijk==2) { shdswp = .false. return } # If k is ideal, this is like unto case 4. # case 1: if(ijk==1) { call acchk(h,i,j,shdswp,x,y,ntot,eps) # This checks # for convexity. # (Was i,j,h,...) return } # If none of the `other' three corners are ideal, do the Lee-Schacter # test for the LOP. # case 0: if(ijk==0) { call qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) return } # default: # This CAN'T happen. nerror = 7 return end deldir/inst/ratfor/binsrt.r0000644000176200001440000000460613500027201015447 0ustar liggesuserssubroutine binsrt(x,y,rw,npd,ind,rind,tx,ty,ilst,nerror) # Sort the data points into bins. # Called by master. implicit double precision(a-h,o-z) dimension x(npd), y(npd), tx(npd), ty(npd) integer rind(npd) dimension ind(npd), ilst(npd) dimension rw(4) nerror = -1 kdiv = int(1+dble(npd)**0.25) # Round high. xkdiv = dble(kdiv) # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) w = xmax-xmin h = ymax-ymin # Number of bins is to be approx. sqrt(npd); thus number of subdivisions # on each side of rectangle is approx. npd**(1/4). dw = w/xkdiv dh = h/xkdiv # The width of each bin is dw; the height is dh. We shall move across # the rectangle from left to right, then up, then back from right to # left, then up, .... Note that kx counts the divisions from the left, # ky counts the divisions from the bottom; kx is incremented by ink, which # is +/- 1 and switches sign when ky is incremented; ky is always # incremented by 1. kx = 1 ky = 1 ink = 1 k = 0 do i = 1,npd { ilst(i) = 0 } # Keeps a list of those points already added while(ky<=kdiv) { # to the new list. do i = 1,npd { if(ilst(i)==1) next # The i-th point has already been added # to the new list. # If the i-th point is in the current bin, add it to the list. xt = x(i) yt = y(i) ix = int(1+(xt-xmin)/dw) if(ix>kdiv) ix = kdiv jy = int(1+(yt-ymin)/dh) if(jy>kdiv) jy = kdiv if(ix==kx&jy==ky) { k = k+1 ind(i) = k # Index i is the pos'n. of (x,y) in the 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. } } # Move to the next bin. kc = kx+ink if((1<=kc)&(kc<=kdiv)) kx = kc else { ky = ky+1 ink = -ink } } # Check that all points from old list have been added to the new, # with no spurious additions. if(k!=npd) { nerror = 2 return } # Copy the new sorted vector back on top of the old ones. do i = 1,npd { x(i) = tx(i) y(i) = ty(i) } return end deldir/inst/ratfor/swap.r0000644000176200001440000000242513520002165015121 0ustar liggesuserssubroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror) # The segment k1->k2 is a diagonal of a quadrilateral # with a vertex at j (the point being added to the # triangulation). If the LOP is not satisfied, swap # it for the other diagonal. # Called by addpt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical shdswp, anticl # If vertices k1 and k2 are not connected there is no diagonal to swap. # This could happen if vertices j, k1, and k2 were colinear, but shouldn't. call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror) if(nerror > 0) { return } if(!shdswp) return # Get the other vertex of the quadrilateral. call pred(k,k1,k2,nadj,madj,ntot,nerror) # If these aren't the same, then if(nerror > 0) return call succ(kk,k2,k1,nadj,madj,ntot,nerror) # there is no other vertex. if(nerror > 0) return if(kk!=k) { shdswp = .false. return } # Check whether the LOP is satisified; i.e. whether # vertex k is outside the circumcircle of vertices j, k1, and k2 call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror) if(nerror > 0) return # Do the actual swapping. if(shdswp) { call delet(k1,k2,nadj,madj,ntot,nerror) if(nerror > 0) return call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } return end deldir/inst/ratfor/delet1.r0000644000176200001440000000101311621163455015327 0ustar liggesuserssubroutine delet1(i,j,nadj,madj,ntot) # Delete j from the adjacency list of i. # Called by delet. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) n = nadj(i,0) do k = 1,n { if(nadj(i,k)==j) { # Find j in the list; # then move everything back one notch. do kk = k,n-1 { nadj(i,kk) = nadj(i,kk+1) } nadj(i,n) = -99 # Changed from the confusing 0 value 25/7/2011. nadj(i,0) = n-1 return } } end deldir/inst/ratfor/pred.r0000644000176200001440000000157711621163455015122 0ustar liggesuserssubroutine pred(kpr,i,j,nadj,madj,ntot,nerror) # Find the predecessor of j in the adjacency list of i. # Called by initad, trifnd, swap, dirseg, dirout. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) # If the adjacency list of i is empty, then clearly j has no predecessor # in this adjacency list. Something's wrong; stop. if(n==0) { nerror = 5 return } # The adjacency list of i is non-empty; search through it until j is found; # subtract 1 from the location of j, and find the contents of this new location do k = 1,n { if(j==nadj(i,k)) { km = k-1 if(km<1) km = n # Take km modulo n. (The adjacency list kpr = nadj(i,km) # is circular.) return } } # The adjacency list for i doesn't contain j. Something's wrong; stop. nerror = 6 return end deldir/inst/ratfor/mnnd.r0000644000176200001440000000056711621163455015122 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!=j) { d = (x(i)-x(j))**2 + (y(i)-y(j))**2 if(d < dmin) dmin = d } } dminav = dminav + sqrt(dmin) } dminav = dminav/n return end deldir/inst/ratfor/addpt.r0000644000176200001440000000204313517447514015260 0ustar liggesuserssubroutine addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) # Add point j to the triangulation. # Called by master, dirseg. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical didswp # Put the new point in, joined to the vertices of its # enclosing triangle. call initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror > 0) return # Look at each `gap', i.e. pair of adjacent segments # emanating from the new point; they form two sides of a # quadrilateral; see whether the extant diagonal of this # quadrilateral should be swapped with its alternative # (according to the LOP: local optimality principle). now = nadj(j,1) nxt = nadj(j,2) ngap = 0 repeat { call swap(j,now,nxt,didswp,nadj,madj,x,y,ntot,eps,nerror) if(nerror > 0) return n = nadj(j,0) if(!didswp) { # If no swap of diagonals now = nxt # move to the next gap. ngap = ngap+1 } call succ(nxt,j,now,nadj,madj,ntot,nerror) if(nerror > 0) return } until(ngap==n) return end deldir/inst/ratfor/delet.r0000644000176200001440000000073013507530543015254 0ustar liggesuserssubroutine delet(i,j,nadj,madj,ntot,nerror) # Delete i and j from each other's adjacency lists. # Called by initad, swap. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) logical adj # First check that they're IN each other's lists. call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror > 0) { return } # Then do the actual deletion if they are. if(adj) { call delet1(i,j,nadj,madj,ntot) call delet1(j,i,nadj,madj,ntot) } return end deldir/inst/SavedRatfor/0000755000176200001440000000000013520000775014711 5ustar liggesusersdeldir/inst/SavedRatfor/initad.r0000644000176200001440000000254213520000775016347 0ustar liggesuserssubroutine initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror) # Initial adding-in of a new point j. # Called by addpt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) integer tau(3) integer tadj(1000) # Find the triangle containing vertex j. call trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror > 0) return # If the new point is on the edge of a triangle, detach the two # vertices of that edge from each other. Also join j to the vertex # of the triangle on the reverse side of that edge from the `found' # triangle (defined by tau) -- given that there ***is*** such a triangle. if(nedge!=0) { ip = nedge i = ip-1 if(i==0) i = 3 # Arithmetic modulo 3. call pred(k,tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror > 0) return call succ(kk,tau(ip),tau(i),nadj,madj,ntot,nerror) if(nerror > 0) return call delet(tau(i),tau(ip),nadj,madj,ntot,nerror) if(nerror > 0) return if(k==kk) call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } # Join the new point to each of the three vertices. do i = 1,3 { call insrt(j,tau(i),nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } if(j==580) { nj = nadj(j,0) do jc = 1,nj { tadj(jc) = nadj(j,jc) } call intpr("Initial adjacency list of point 580:",-1,tadj,nj) } return end deldir/inst/SavedRatfor/succ.r0000644000176200001440000000157313520000775016037 0ustar liggesuserssubroutine succ(ksc,i,j,nadj,madj,ntot,nerror) # Find the successor of j in the adjacency list of i. # Called by addpt, initad, trifnd, swap, delout, dirseg, dirout. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) # If the adjacency list of i is empty, then clearly j has no successor # in this adjacency list. Something's wrong; stop. if(n==0) { nerror = 9 return } # The adjacency list of i is non-empty; search through it until j is found; # add 1 to the location of j, and find the contents of this new location. do k = 1,n { if(j==nadj(i,k)) { kp = k+1 if(kp>n) kp = 1 # Take kp modulo n. (The adjacency list ksc = nadj(i,kp) # is circular.) return } } # The adjacency list doesn't contain j. Something's wrong. nerror = 10 return end deldir/inst/SavedRatfor/locn.r0000644000176200001440000000264113520000775016032 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) { kj = 1 return } # Run through i's list, checking if j should come before each element # of that list. (I.e. if i, j, and k are in anti-clockwise order.) # If j comes before the kj-th item, but not before the (kj-1)-st, then # j should have place kj. do ks = 1,n { kj = ks k = nadj(i,kj) call acchk(i,j,k,before,x,y,ntot,eps) if(before) { km = kj-1 if(km==0) km = n k = nadj(i,km) call acchk(i,j,k,before,x,y,ntot,eps) if(before) next # If j is before 1 and after n, then it should # have place n+1. if(kj==1) kj = n+1 return } } # We've gone right through the list and haven't been before # the kj-th item ***and*** after the (kj-1)-st on any occasion. # Therefore j is before everything (==> place 1) or after # everything (==> place n+1). if(before) kj = 1 else kj = n+1 return end deldir/inst/SavedRatfor/crossutil.r0000644000176200001440000000075613520000775017133 0ustar liggesuserssubrountine crossutil(i,j,k,x,y,ntot,eps,collin) implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) dimension xt(3), yt(3) logical collin xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) # Create indicator telling which of i, j, and k are ideal points. # The point being added, i, is never ideal. i1 = 0 if(j<=0) j1 = 1 else j1 = 0 if(k<=0) k1 = 1 else k1 = 0 ijk = i1*4+j1*2+k1 call cross(xt,yt,ijk,cprd) collin = (abs(cprd) < eps) return end deldir/inst/SavedRatfor/dirseg.r0000644000176200001440000001016313520000775016352 0ustar liggesuserssubroutine dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ntri,nerror) # Output the endpoints of the segments of boundaries of Dirichlet # tiles. (Do it economically; each such segment once and only once.) # Called by master. implicit double precision(a-h,o-z) logical collin, adjace, intfnd, bptab, bptcd, goferit, rwu dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsgs(10,ndir), rw(4) nerror = -1 # Add in some dummy corner points, outside the actual window. # Far enough out so that no resulting tile boundaries intersect the # window. # Note that these dummy corners are needed by the routine `dirout' # but will screw things up for `delseg' and `delout'. Therefore # this routine (`dirseg') must be called ***before*** dirout, and # ***after*** delseg and delout. # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) a = xmax-xmin b = ymax-ymin c = sqrt(a*a+b*b) npd = ntot-4 nstt = npd+1 i = nstt x(i) = xmin-c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymin-c i = i+1 x(i) = xmax+c y(i) = ymax+c i = i+1 x(i) = xmin-c y(i) = ymax+c do j = nstt,ntot { call addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) ntri = ntri + 3 if(nerror > 0) { return } } # Put the segments into the array dirsgs. # For each distinct pair of (genuine) data points, find out if they are # adjacent. If so, find the circumcentres of the triangles lying on each # side of the segment joining them. kseg = 0 do i = 2,npd { do j = 1,i-1 { call adjchk(i,j,adjace,nadj,madj,ntot,nerror) if(nerror > 0) { return } if(adjace) { call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror > 0) return if(collin) { nerror = 12 return } call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror > 0) return if(collin) { nerror = 12 return } # If a circumcentre is outside the rectangular window # of interest, draw a line joining it to the other # circumcentre. Find the intersection of this line with # the boundary of the window; for (a,b) and call the point # of intersection (ai,bi). For (c,d), call it (ci,di). # Note: rwu = "right way up". xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi!=yj) { slope = (xi - xj)/(yj - yi) rwu = .true. } else { slope = 0.d0 rwu = .false. } call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedgeab) if(!intfnd) { nerror = 16 return } call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedgecd) if(!intfnd) { nerror = 16 return } goferit = .false. if(bptab & bptcd) { xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xmin ndir) { nerror = 15 return } dirsgs(1,kseg) = ai dirsgs(2,kseg) = bi dirsgs(3,kseg) = ci dirsgs(4,kseg) = di dirsgs(5,kseg) = i dirsgs(6,kseg) = j if(bptab) dirsgs(7,kseg) = 1.d0 else dirsgs(7,kseg) = 0.d0 if(bptcd) dirsgs(8,kseg) = 1.d0 else dirsgs(8,kseg) = 0.d0 if(bptab) dirsgs(9,kseg) = -nedgeab else dirsgs(9,kseg) = k if(bptcd) dirsgs(10,kseg) = -nedgecd else dirsgs(10,kseg) = l } } } } ndir = kseg return end deldir/inst/SavedRatfor/triar.r0000644000176200001440000000040013520000775016207 0ustar liggesuserssubroutine triar(x0,y0,x1,y1,x2,y2,area) # Calculate the area of a triangle with given # vertices, in anti clockwise direction. # Called by delout. implicit double precision(a-h,o-z) half = 0.5d0 area = half*((x1-x0)*(y2-y0)-(x2-x0)*(y1-y0)) return end deldir/inst/SavedRatfor/insrt1.r0000644000176200001440000000144313520000775016316 0ustar liggesuserssubroutine insrt1(i,j,kj,nadj,madj,ntot,nerror) # Insert j into the adjacency list of i. # Called by insrt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 # 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) { nadj(i,0) = 1 nadj(i,1) = j return } # 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) { # Watch out for over-writing!!! nerror = 4 return } while(kk>kj) { nadj(i,kk) = nadj(i,kk-1) kk = kk-1 } nadj(i,kj) = j nadj(i,0) = n+1 return end deldir/inst/SavedRatfor/dldins.r0000644000176200001440000000504213520000775016352 0ustar liggesuserssubroutine dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bpt,nedge) # Get a point ***inside*** the rectangular window on the ray from # one circumcentre to the next one. I.e. if the `next one' is # inside, then that's it; else find the intersection of this ray with # the boundary of the rectangle. # Called by dirseg, dirout. implicit double precision(a-h,o-z) dimension rw(4) logical intfnd, bpt, rwu # Note that (a,b) is the circumcentre of a Delaunay triangle, # and that slope is the slope of the ray joining (a,b) to the # corresponding circumcentre on the opposite side of an edge of that # triangle. When `dldins' is called by `dirout' it is possible # for the ray not to intersect the window at all. (The Delaunay # edge between the two circumcentres might be connected to a `fake # outer corner', added to facilitate constructing a tiling that # completely covers the actual window.) The variable `intfnd' acts # as an indicator as to whether such an intersection has been found. # The variable `bpt' acts as an indicator as to whether the returned # point (ai,bi) is a true circumcentre, inside the window (bpt == .false.), # or is the intersection of a ray with the boundary of the window # (bpt = .true.). intfnd = .true. bpt = .true. # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) # Check if (a,b) is inside the rectangle. if(xmin<=a&a<=xmax&ymin<=b&b<=ymax) { ai = a bi = b bpt = .false. nedge = 0 return } # Look for appropriate intersections with the four lines forming # the sides of the rectangular window. # If not "the right way up" then the line joining the two # circumcentres is vertical. if(!rwu) { if(b < ymin) { ai = a bi = ymin nedge = 1 if(xmin<=ai&ai<=xmax) return } if(b > ymax) { ai = a bi = ymax nedge = 3 if(xmin<=ai&ai<=xmax) return } intfnd = .false. return } # Line 1: x = xmin. if(axmax) { ai = xmax bi = b + slope*(ai-a) nedge = 4 if(ymin<=bi&bi<=ymax) return } # Line 4: y = ymax. if(b>ymax) { bi = ymax ai = a + (bi-b)/slope nedge = 3 if(xmin<=ai&ai<=xmax) return } intfnd = .false. return end deldir/inst/SavedRatfor/adjchk.r0000644000176200001440000000156613520000775016330 0ustar liggesuserssubroutine adjchk(i,j,adj,nadj,madj,ntot,nerror) # Check if vertices i and j are adjacent. # Called by insrt, delet, trifnd, swap, delseg, dirseg. dimension nadj(-3:ntot,0:madj) logical adj nerror = -1 # Check if j is in the adjacency list of i. adj = .false. ni = nadj(i,0) if(ni>0) { do k = 1,ni { if(j==nadj(i,k)) { adj = .true. break } } } # Check if i is in the adjacency list of j. nj = nadj(j,0) if(nj>0) { do k = 1,nj { if(i==nadj(j,k)) { if(adj) return # Have j in i's list and i in j's. else { nerror = 1 return } } } } # If we get to here i is not in j's list. if(adj) { # If adj is true, then j IS in i's list. nerror = 1 return } return end deldir/inst/SavedRatfor/stoke.r0000644000176200001440000000756613520000775016237 0ustar liggesuserssubroutine stoke(x1,y1,x2,y2,rw,area,s1,eps,nerror) # Apply Stokes' theorem to find the area of a polygon; # we are looking at the boundary segment from (x1,y1) # to (x2,y2), travelling anti-clockwise. We find the # area between this segment and the horizontal base-line # y = ymin, and attach a sign s1. (Positive if the # segment is right-to-left, negative if left to right.) # The area of the polygon is found by summing the result # over all boundary segments. # Just in case you thought this wasn't complicated enough, # what we really want is the area of the intersection of # the polygon with the rectangular window that we're using. # Called by dirout. implicit double precision(a-h,o-z) dimension rw(4) logical value zero = 0.d0 nerror = -1 # If the segment is vertical, the area is zero. call testeq(x1,x2,eps,value) if(value) { area = 0. s1 = 0. return } # Find which is the right-hand end, and which is the left. if(x1=xmax) { area = 0. return } # We're now looking at a trapezoidal region which may or may # not protrude above or below the horizontal strip bounded by # y = ymax and y = ymin. ybot = min(yl,yr) ytop = max(yl,yr) # Case 1; ymax <= ybot: # The `roof' of the trapezoid is entirely above the # horizontal strip. if(ymax<=ybot) { area = (xr-xl)*(ymax-ymin) return } # Case 2; ymin <= ybot <= ymax <= ytop: # The `roof' of the trapezoid intersects the top of the # horizontal strip (y = ymax) but not the bottom (y = ymin). if(ymin<=ybot&ymax<=ytop) { call testeq(slope,zero,eps,value) if(value) { w1 = 0. w2 = xr-xl } else { xit = xl+(ymax-yl)/slope w1 = xit-xl w2 = xr-xit if(slope<0.) { tmp = w1 w1 = w2 w2 = tmp } } area = 0.5*w1*((ybot-ymin)+(ymax-ymin))+w2*(ymax-ymin) return } # Case 3; ybot <= ymin <= ymax <= ytop: # The `roof' intersects both the top (y = ymax) and # the bottom (y = ymin) of the horizontal strip. if(ybot<=ymin&ymax<=ytop) { xit = xl+(ymax-yl)/slope xib = xl+(ymin-yl)/slope if(slope>0.) { w1 = xit-xib w2 = xr-xit } else { w1 = xib-xit w2 = xit-xl } area = 0.5*w1*(ymax-ymin)+w2*(ymax-ymin) return } # Case 4; ymin <= ybot <= ytop <= ymax: # The `roof' is ***between*** the bottom (y = ymin) and # the top (y = ymax) of the horizontal strip. if(ymin<=ybot&ytop<=ymax) { area = 0.5*(xr-xl)*((ytop-ymin)+(ybot-ymin)) return } # Case 5; ybot <= ymin <= ytop <= ymax: # The `roof' intersects the bottom (y = ymin) but not # the top (y = ymax) of the horizontal strip. if(ybot<=ymin&ymin<=ytop) { call testeq(slope,zero,eps,value) if(value) { area = 0. return } xib = xl+(ymin-yl)/slope if(slope>0.) w = xr-xib else w = xib-xl area = 0.5*w*(ytop-ymin) return } # Case 6; ytop <= ymin: # The `roof' is entirely below the bottom (y = ymin), so # there is no area contribution at all. if(ytop<=ymin) { area = 0. return } # Default; all stuffed up: nerror = 8 return end deldir/inst/SavedRatfor/intri.r0000644000176200001440000000143713520000775016226 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) { inside = .false. break } } if(inside) { okay = 0 return } } okay = 1 return end deldir/inst/SavedRatfor/testeq.r0000644000176200001440000000145313520000775016404 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) { if(abs(a)<=eps) value = .true. else value = .false. return } # Test if a is a `lot different' from b. (If it is # they're obviously not equal.) This avoids under/overflow # problems in dividing a by b. if(abs(a)>ten*abs(b)|abs(a) eps) anticl = .true. else anticl = .false. if(i==580 & j==579 & k==578) { call dblepr("crossproduct",-1,cprd,1) } return end deldir/inst/SavedRatfor/insrt.r0000644000176200001440000000134113520000775016232 0ustar liggesuserssubroutine insrt(i,j,nadj,madj,x,y,ntot,nerror,eps) # Insert i and j into each other's adjacency list. # Called by master, initad, swap. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical adj # Check whether i and j are in each other's adjacency lists. call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror > 0) { return } if(adj) return # If not, find where in each list they should respectively be. call locn(i,j,kj,nadj,madj,x,y,ntot,eps) call locn(j,i,ki,nadj,madj,x,y,ntot,eps) # Put them in each other's lists in the appropriate position. call insrt1(i,j,kj,nadj,madj,ntot,nerror) if(nerror >0) return call insrt1(j,i,ki,nadj,madj,ntot,nerror) if(nerror >0) return return end deldir/inst/SavedRatfor/circen.r0000644000176200001440000000333113520000775016337 0ustar liggesuserssubroutine circen(i,j,k,x0,y0,x,y,ntot,eps,collin,nerror) # Find the circumcentre (x0,y0) of the triangle with # vertices (x(i),y(i)), (x(j),y(j)), (x(k),y(k)). # Called by qtest1, dirseg, dirout. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3) dimension indv(3) # To facillitate a lucid error message. logical collin nerror = -1 # Get the coordinates. xt(1) = x(i) yt(1) = y(i) xt(2) = x(j) yt(2) = y(j) xt(3) = x(k) yt(3) = y(k) # Check for collinearity ijk = 0 call cross(xt,yt,ijk,cprd) if(abs(cprd) < eps) collin = .true. else collin = .false. # Form the vector u from i to j, and the vector v from i to k, # and normalize them. a = x(j) - x(i) b = y(j) - y(i) c = x(k) - x(i) d = y(k) - y(i) c1 = sqrt(a*a+b*b) c2 = sqrt(c*c+d*d) a = a/c1 b = b/c1 c = c/c2 d = d/c2 # If the points are collinear, make sure that they're in the right # order --- i between j and k. if(collin) { alpha = a*c+b*d # If they're not in the right order, bring things to # a shuddering halt. if(alpha>0) { indv(1) = i indv(2) = j indv(3) = k call intpr("Point numbers:",-1,indv,3) call dblepr("Test value:",-1,alpha,1) call rexit("Points are collinear but in the wrong order.") } # Collinear, but in the right order; think of this as meaning # that the circumcircle in question has infinite radius. return } # Not collinear; go ahead, make my circumcentre. (First, form # the cross product of the ***unit*** vectors, instead of the # ``normalized'' cross product produced by ``cross''.) crss = a*d - b*c x0 = x(i) + 0.5*(c1*d - c2*b)/crss y0 = y(i) + 0.5*(c2*a - c1*c)/crss return end deldir/inst/SavedRatfor/qtest1.r0000644000176200001440000000616313520000775016323 0ustar liggesuserssubroutine qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) # The Lee-Schacter test for the LOP (all points are real, # i.e. non-ideal). If the LOP is ***not*** satisfied (i.e. if # vertex j is inside the circumcircle of vertices h, i, and k) then the # diagonals should be swapped, i.e. shdswp ("should-swap") is true. # Called by qtest. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot), xt(3), yt(3), indv(3) integer h logical shdswp, collin # 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) { # 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) { call intpr("error detected in qtest1",-1,1,0) indv(1) = i indv(2) = j indv(3) = k call intpr("Point being added, h:",-1,h,1) call intpr("now, other vertex, nxt:",-1,indv,3) call dblepr("Test value:",-1,alpha,1) call rexit("Points are collinear but h not between i and k.") } # Collinear, and in the right order; think of this as meaning # that the circumcircle in question has infinite radius. shdswp = .true. } # Get the coordinates of vertices h and j. xh = x(h) yh = y(h) xj = x(j) yj = y(j) # Find the centre of the circumcircle of vertices h, i, k. call circen(h,i,k,x0,y0,x,y,ntot,eps,shdswp,nerror) if(nerror>0) return if(shdswp) return # The points h, i, and k are colinear, so # the circumcircle has `infinite radius', so # (xj,yj) is definitely inside. # Check whether (xj,yj) is inside the circle of centre # (x0,y0) and radius r = dist[(x0,y0),(xh,yh)] a = x0-xh b = y0-yh r2 = a*a+b*b a = x0-xj b = y0-yj ch = a*a + b*b if(ch0){ return } if(value) { kseg = kseg+1 if(kseg > ndel) { nerror = 14 return } delsgs(1,kseg) = x(i) delsgs(2,kseg) = y(i) delsgs(3,kseg) = x(j) delsgs(4,kseg) = y(j) delsgs(5,kseg) = i delsgs(6,kseg) = j } } } ndel = kseg return end deldir/inst/SavedRatfor/dirout.r0000644000176200001440000000752713520000775016415 0ustar liggesuserssubroutine dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror) # Output the description of the Dirichlet tile centred at point # i for i = 1, ..., npd. Do this in the original order of the # points, not in the order into which they have been bin-sorted. # Called by master. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension dirsum(npd,3), rw(4) logical collin, intfnd, bptab, bptcd, rwu # Note that at this point some Delaunay neighbours may be # `spurious'; they are the corners of a `large' rectangle in which # the rectangular window of interest has been suspended. This # large window was brought in simply to facilitate output concerning # the Dirichlet tesselation. They were added to the triangulation # in the routine `dirseg' which ***must*** therefore be called before # this routine (`dirout') is called. (Likewise `dirseg' must be called # ***after*** `delseg' and `delout' have been called.) # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) do i = 1,npd { area = 0. # Initialize the area of the ith tile to zero. nbpt = 0 # Initialize the number of boundary points of # the ith tile to zero. npt = 0 # Initialize the number of tile boundaries to zero. np = nadj(i,0) # Output the point number, its coordinates, and the number of # its Delaunay neighbours == the number of boundary segments in # its Dirichlet tile. # For each Delaunay neighbour, find the circumcentres of the # triangles on each side of the segment joining point i to that # neighbour. do j1 = 1,np { j = nadj(i,j1) call pred(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call succ(l,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return call circen(i,k,j,a,b,x,y,ntot,eps,collin,nerror) if(nerror>0) return if(collin) { nerror = 13 return } call circen(i,j,l,c,d,x,y,ntot,eps,collin,nerror) if(nerror>0) return if(collin) { nerror = 13 return } # Increment the area of the current Dirichlet # tile (intersected with the rectangular window) by applying # Stokes' Theorem to the segment of tile boundary joining # (a,b) to (c,d). (Note that the direction is anti-clockwise.) call stoke(a,b,c,d,rw,tmp,sn,eps,nerror) if(nerror > 0) return area = area+sn*tmp # If a circumcentre is outside the rectangular window, replace # it with the intersection of the rectangle boundary with the # line joining the two circumcentres. Then output # the number of the current Delaunay neighbour and # the two circumcentres (or the points with which # they have been replaced). # Note: rwu = "right way up". xi = x(i) xj = x(j) yi = y(i) yj = y(j) if(yi!=yj) { slope = (xi - xj)/(yj - yi) rwu = .true. } else { slope = 0.d0 rwu = .false. } call dldins(a,b,slope,rwu,ai,bi,rw,intfnd,bptab,nedge) if(intfnd) { call dldins(c,d,slope,rwu,ci,di,rw,intfnd,bptcd,nedge) if(!intfnd) { nerror = 17 return } if(bptab & bptcd) { xm = 0.5*(ai+ci) ym = 0.5*(bi+di) if(xminnp) kp = 1 if(nadj(i,k)<=0|nadj(i,kp)<=0) npt = npt-1 } # For each point in the adjacency list of point i, find its # successor, and the area of the triangle determined by these # three points. do j1 = 1,np { j = nadj(i,j1) if(j<=0) next xj = x(j) yj = y(j) call succ(k,i,j,nadj,madj,ntot,nerror) if(nerror > 0) return if(k<=0) next xk = x(k) yk = y(k) call triar(xi,yi,xj,yj,xk,yk,tmp) # Downweight the area by 1/3, since each # triangle eventually appears 3 times over. area = area+tmp/3. } delsum(i,1) = xi delsum(i,2) = yi delsum(i,3) = npt delsum(i,4) = area } return end deldir/inst/SavedRatfor/master.r0000644000176200001440000000366613520000775016402 0ustar liggesuserssubroutine master(x,y,rw,npd,ntot,nadj,madj,eps,delsgs,ndel,delsum, dirsgs,ndir,dirsum,collinchk,nerror) # Master subroutine: # One subroutine to rule them all, # One subroutine to find them. # One subroutine to bring them all in, # And in the darkness bind them. implicit double precision(a-h,o-z) 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(npd,4), dirsum(npd,3) integer collinchk # 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 } } # Put the four ideal points into x and y and the adjacency list. # The ideal points are given pseudo-coordinates # (-1,-1), (1,-1), (1,1), and (-1,1). They are numbered as # 0 -1 -2 -3 # i.e. the numbers decrease anticlockwise from the # `bottom left corner'. x(-3) = -one y(-3) = one x(-2) = one y(-2) = one x(-1) = one y(-1) = -one x(0) = -one y(0) = -one do i = 1,4 { j = i-4 k = j+1 if(k>0) k = -3 call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror>0) return } # Put in the first of the point set into the adjacency list. do i = 1,4 { j = i-4 call insrt(1,j,nadj,madj,x,y,ntot,nerror,eps) if(nerror>0) return } ntri = 4 # Now add the rest of the point set do j = 2,npd { call addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) if(collinchk==1) call collincheck(nadj,j,madj,x,y,ntot,eps) if(nerror>0) { return } ntri = ntri + 3 } # Obtain the description of the triangulation. call delseg(delsgs,ndel,nadj,madj,npd,x,y,ntot,nerror) if(nerror>0) return call delout(delsum,nadj,madj,x,y,ntot,npd,nerror) if(nerror>0) return call dirseg(dirsgs,ndir,nadj,madj,npd,x,y,ntot,rw,eps,ntri,nerror) if(nerror>0) return call dirout(dirsum,nadj,madj,x,y,ntot,npd,rw,eps,nerror) return end deldir/inst/SavedRatfor/trifnd.r0000644000176200001440000000765113520000775016373 0ustar liggesuserssubroutine trifnd(j,tau,nedge,nadj,madj,x,y,ntot,eps,ntri,nerror) # Find the triangle of the extant triangulation in which # lies the point currently being added. # Called by initad. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot), xt(3), yt(3) integer tau(3) logical adjace, anticl nerror = -1 # The first point must be added to the triangulation before # calling trifnd. if(j==1) { nerror = 11 return } # Get the previous triangle: j1 = j-1 tau(1) = j1 tau(3) = nadj(j1,1) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return call adjchk(tau(2),tau(3),adjace,nadj,madj,ntot,nerror) if(nerror>0) { return } if(!adjace) { tau(3) = tau(2) call pred(tau(2),j1,tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return } # Move to the adjacent triangle in the direction of the new # point, until the new point lies in this triangle. ktri = 0 1 continue # 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(!anticl) { call acchk(tau(3),tau(2),tau(1),anticl,x,y,ntot,eps) if(!anticl) { call intpr("Point number =",-1,j,1) call intpr("Previous triangle:",-1,tau,3) call rexit("Both vertex orderings are clockwise. See help for deldir.") } else { ivtmp = tau(3) tau(3) = tau(1) tau(1) = ivtmp } } ntau = 0 # This number will identify the triangle to be moved to. nedge = 0 # If the point lies on an edge, this number will identify that edge. do i = 1,3 { ip = i+1 if(ip==4) ip = 1 # Take addition modulo 3. # Get the coordinates of the vertices of the current side, # and of the point j which is being added: xt(1) = x(tau(i)) yt(1) = y(tau(i)) xt(2) = x(tau(ip)) yt(2) = y(tau(ip)) xt(3) = x(j) yt(3) = y(j) # Create indicator telling which of tau(i), tau(ip), and j # are ideal points. (The point being added, j, is ***never*** ideal.) if(tau(i)<=0) i1 = 1 else i1 = 0 if(tau(ip)<=0) j1 = 1 else j1 = 0 k1 = 0 ijk = i1*4+j1*2+k1 # Calculate the ``normalized'' cross product; if this is positive # then the point being added is to the left (as we move along the # edge in an anti-clockwise direction). If the test value is positive # for all three edges, then the point is inside the triangle. Note # that if the test value is very close to zero, we might get negative # values for it on both sides of an edge, and hence go into an # infinite loop. call cross(xt,yt,ijk,cprd) if(cprd >= eps) continue else if(cprd > -eps) nedge = ip else { ntau = ip break } } # We've played ring-around-the-triangle; now figure out the # next move: # case 0: All tests >= 0.; the point is inside; return. if(ntau==0) { if(j==580) { call intpr("Initial containing triangle for point 580:",-1,tau,3) } return } # The point is not inside; work out the vertices of the triangle to which # to move. Notation: Number the vertices of the current triangle from 1 to 3, # anti-clockwise. Then "triangle i+1" is adjacent to the side from vertex i to # vertex i+1, where i+1 is taken modulo 3 (i.e. "3+1 = 1"). # case 1: Move to "triangle 1" if(ntau==1) { #tau(1) = tau(1) tau(2) = tau(3) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror > 0) return } # case 2: Move to "triangle 2" if(ntau==2) { #tau(1) = tau(1) tau(3) = tau(2) call pred(tau(2),tau(1),tau(3),nadj,madj,ntot,nerror) if(nerror > 0) return } # case 3: Move to "triangle 3" if(ntau==3) { tau(1) = tau(3) #tau(2) = tau(2) call succ(tau(3),tau(1),tau(2),nadj,madj,ntot,nerror) if(nerror > 0) return } # We've moved to a new triangle; check if the point being added lies # inside this one. ktri = ktri + 1 if(ktri > ntri) { call rexit("Cannot find an enclosing triangle. See help for deldir.") } go to 1 end deldir/inst/SavedRatfor/qtest.r0000644000176200001440000000721213520000775016236 0ustar liggesuserssubroutine qtest(h,i,j,k,shdswp,x,y,ntot,eps,nerror) # Test whether the LOP is satisified; i.e. whether vertex j # is outside the circumcircle of vertices h, i, and k of the # quadrilateral. Vertex h is the vertex being added; i and k are # the vertices of the quadrilateral which are currently joined; # j is the vertex which is ``opposite'' the vertex being added. # If the LOP is not satisfied, then shdswp ("should-swap") is true, # i.e. h and j should be joined, rather than i and k. I.e. if j # is outside the circumcircle of h, i, and k then all is well as-is; # *don't* swap ik for hj. If j is inside the circumcircle of h, # i, and k then change is needed so swap ik for hj. # Called by swap. implicit double precision(a-h,o-z) dimension x(-3:ntot), y(-3:ntot) integer h logical shdswp nerror = -1 # Look for ideal points. if(i<=0) ii = 1 else ii = 0 if(j<=0) jj = 1 else jj = 0 if(k<=0) kk = 1 else kk = 0 ijk = ii*4+jj*2+kk # All three corners other than h (the point currently being # added) are ideal --- so h, i, and k are co-linear; so # i and k shouldn't be joined, and h should be joined to j. # So swap. (But this can't happen, anyway!!!) # case 7: if(ijk==7) { shdswp = .true. return } # If i and j are ideal, find out which of h and k is closer to the # intersection point of the two diagonals, and choose the diagonal # emanating from that vertex. (I.e. if h is closer, swap.) # Unless swapping yields a non-convex quadrilateral!!! # case 6: if(ijk==6) { xh = x(h) yh = y(h) xk = x(k) yk = y(k) ss = 1 - 2*mod(-j,2) test = (xh*yk+xk*yh-xh*yh-xk*yk)*ss if(test>0.d0) shdswp = .true. else shdswp = .false. # Check for convexity: if(shdswp) call acchk(j,k,h,shdswp,x,y,ntot,eps) return } # Vertices i and k are ideal --- can't happen, but if it did, we'd # increase the minimum angle ``from 0 to more than 2*0'' by swapping ... # # 24/7/2011 --- I now think that the forgoing comment is misleading, # although it doesn't matter since it can't happen anyway. The # ``2*0'' is wrong. The ``new minimum angle would be min{alpha,beta} # where alpha and beta are the angles made by the line joining h # to j with (any) line with slope = -1. This will be greater than # 0 unless the line from h to j has slope = - 1. In this case h, # i, j, and k are all co-linear, so i and k should not be joined # (and h and j should be) so swapping is called for. If h, i, # j and j are not co-linear then the quadrilateral is definitely # convex whence swapping is OK. So let's say swap. # case 5: if(ijk==5) { shdswp = .true. return } # If i is ideal we'd increase the minimum angle ``from 0 to more than # 2*0'' by swapping, so just check for convexity: # case 4: if(ijk==4) { call acchk(j,k,h,shdswp,x,y,ntot,eps) return } # If j and k are ideal, this is like unto case 6. # case 3: if(ijk==3) { xi = x(i) yi = y(i) xh = x(h) yh = y(h) ss = 1 - 2*mod(-j,2) test = (xh*yi+xi*yh-xh*yh-xi*yi)*ss if(test>0.d0) shdswp = .true. else shdswp = .false. # Check for convexity: if(shdswp) call acchk(h,i,j,shdswp,x,y,ntot,eps) return } # If j is ideal we'd decrease the minimum angle ``from more than 2*0 # to 0'', by swapping; so don't swap. # case 2: if(ijk==2) { shdswp = .false. return } # If k is ideal, this is like unto case 4. # case 1: if(ijk==1) { call acchk(h,i,j,shdswp,x,y,ntot,eps) # This checks # for convexity. # (Was i,j,h,...) return } # If none of the `other' three corners are ideal, do the Lee-Schacter # test for the LOP. # case 0: if(ijk==0) { call qtest1(h,i,j,k,x,y,ntot,eps,shdswp,nerror) return } # default: # This CAN'T happen. nerror = 7 return end deldir/inst/SavedRatfor/binsrt.r0000644000176200001440000000460613520000775016403 0ustar liggesuserssubroutine binsrt(x,y,rw,npd,ind,rind,tx,ty,ilst,nerror) # Sort the data points into bins. # Called by master. implicit double precision(a-h,o-z) dimension x(npd), y(npd), tx(npd), ty(npd) integer rind(npd) dimension ind(npd), ilst(npd) dimension rw(4) nerror = -1 kdiv = int(1+dble(npd)**0.25) # Round high. xkdiv = dble(kdiv) # Dig out the corners of the rectangular window. xmin = rw(1) xmax = rw(2) ymin = rw(3) ymax = rw(4) w = xmax-xmin h = ymax-ymin # Number of bins is to be approx. sqrt(npd); thus number of subdivisions # on each side of rectangle is approx. npd**(1/4). dw = w/xkdiv dh = h/xkdiv # The width of each bin is dw; the height is dh. We shall move across # the rectangle from left to right, then up, then back from right to # left, then up, .... Note that kx counts the divisions from the left, # ky counts the divisions from the bottom; kx is incremented by ink, which # is +/- 1 and switches sign when ky is incremented; ky is always # incremented by 1. kx = 1 ky = 1 ink = 1 k = 0 do i = 1,npd { ilst(i) = 0 } # Keeps a list of those points already added while(ky<=kdiv) { # to the new list. do i = 1,npd { if(ilst(i)==1) next # The i-th point has already been added # to the new list. # If the i-th point is in the current bin, add it to the list. xt = x(i) yt = y(i) ix = int(1+(xt-xmin)/dw) if(ix>kdiv) ix = kdiv jy = int(1+(yt-ymin)/dh) if(jy>kdiv) jy = kdiv if(ix==kx&jy==ky) { k = k+1 ind(i) = k # Index i is the pos'n. of (x,y) in the 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. } } # Move to the next bin. kc = kx+ink if((1<=kc)&(kc<=kdiv)) kx = kc else { ky = ky+1 ink = -ink } } # Check that all points from old list have been added to the new, # with no spurious additions. if(k!=npd) { nerror = 2 return } # Copy the new sorted vector back on top of the old ones. do i = 1,npd { x(i) = tx(i) y(i) = ty(i) } return end deldir/inst/SavedRatfor/swap.r0000644000176200001440000000444213520000775016052 0ustar liggesuserssubroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror) # The segment k1->k2 is a diagonal of a quadrilateral # with a vertex at j (the point being added to the # triangulation). If the LOP is not satisfied, swap # it for the other diagonal. # Called by addpt. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) dimension ntadj(1000) logical shdswp, anticl # If vertices k1 and k2 are not connected there is no diagonal to swap. # This could happen if vertices j, k1, and k2 were colinear, but shouldn't. call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror) if(nerror > 0) { return } if(!shdswp) return # Get the other vertex of the quadrilateral. call pred(k,k1,k2,nadj,madj,ntot,nerror) # If these aren't the same, then if(nerror > 0) return call succ(kk,k2,k1,nadj,madj,ntot,nerror) # there is no other vertex. if(nerror > 0) return if(kk!=k) { # if(j==580) call intpr("no other vertex",-1,1,0) shdswp = .false. return } # Check whether the LOP is satisified; i.e. whether # vertex k is outside the circumcircle of vertices j, k1, and k2 if(k==580) { call intpr("From swap; point being added =",-1,j,1) # Adj. list of k1 ("now"). nk1 = nadj(k1,0) do jc = 1,nk1 { ntadj(jc) = nadj(k1,jc) } call intpr("now =",-1,k1,1) call intpr("adjacency list of now:",-1,ntadj,nk1) # Adj. list of k1 ("now"). nk2 = nadj(k2,0) do jc = 1,nk2 { ntadj(jc) = nadj(k2,jc) } call intpr("nxt =",-1,k2,1) call intpr("adjacency list of nxt:",-1,ntadj,nk2) # Adj. list of j ("point being added"). nj = nadj(j,0) do jc = 1,nj { ntadj(jc) = nadj(j,jc) } call intpr("point being added =",-1,j,1) call intpr("adjacency list of point being added:",-1,ntadj,nj) # j, now, nxt should be in anticlockwise order. call acchk(j,k1,k2,anticl,x,y,ntot,eps) if(anticl) { call intpr("anticlockwise",-1,1,0) } else { call intpr("clockwise",-1,1,0) } # # i = now = k1, k = nxt = k2, and j = other vertex = k: } call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror) if(nerror > 0) return # Do the actual swapping. if(shdswp) { call delet(k1,k2,nadj,madj,ntot,nerror) if(nerror > 0) return call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps) if(nerror > 0) return } return end deldir/inst/SavedRatfor/collincheck.r0000644000176200001440000000333313520000775017354 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/SavedRatfor/delet1.r0000644000176200001440000000101313520000775016245 0ustar liggesuserssubroutine delet1(i,j,nadj,madj,ntot) # Delete j from the adjacency list of i. # Called by delet. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) n = nadj(i,0) do k = 1,n { if(nadj(i,k)==j) { # Find j in the list; # then move everything back one notch. do kk = k,n-1 { nadj(i,kk) = nadj(i,kk+1) } nadj(i,n) = -99 # Changed from the confusing 0 value 25/7/2011. nadj(i,0) = n-1 return } } end deldir/inst/SavedRatfor/pred.r0000644000176200001440000000157713520000775016040 0ustar liggesuserssubroutine pred(kpr,i,j,nadj,madj,ntot,nerror) # Find the predecessor of j in the adjacency list of i. # Called by initad, trifnd, swap, dirseg, dirout. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) nerror = -1 n = nadj(i,0) # If the adjacency list of i is empty, then clearly j has no predecessor # in this adjacency list. Something's wrong; stop. if(n==0) { nerror = 5 return } # The adjacency list of i is non-empty; search through it until j is found; # subtract 1 from the location of j, and find the contents of this new location do k = 1,n { if(j==nadj(i,k)) { km = k-1 if(km<1) km = n # Take km modulo n. (The adjacency list kpr = nadj(i,km) # is circular.) return } } # The adjacency list for i doesn't contain j. Something's wrong; stop. nerror = 6 return end deldir/inst/SavedRatfor/mnnd.r0000644000176200001440000000056713520000775016040 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!=j) { d = (x(i)-x(j))**2 + (y(i)-y(j))**2 if(d < dmin) dmin = d } } dminav = dminav + sqrt(dmin) } dminav = dminav/n return end deldir/inst/SavedRatfor/addpt.r0000644000176200001440000000204313520000775016167 0ustar liggesuserssubroutine addpt(j,nadj,madj,x,y,ntot,eps,ntri,nerror) # Add point j to the triangulation. # Called by master, dirseg. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot) logical didswp # Put the new point in, joined to the vertices of its # enclosing triangle. call initad(j,nadj,madj,x,y,ntot,eps,ntri,nerror) if(nerror > 0) return # Look at each `gap', i.e. pair of adjacent segments # emanating from the new point; they form two sides of a # quadrilateral; see whether the extant diagonal of this # quadrilateral should be swapped with its alternative # (according to the LOP: local optimality principle). now = nadj(j,1) nxt = nadj(j,2) ngap = 0 repeat { call swap(j,now,nxt,didswp,nadj,madj,x,y,ntot,eps,nerror) if(nerror > 0) return n = nadj(j,0) if(!didswp) { # If no swap of diagonals now = nxt # move to the next gap. ngap = ngap+1 } call succ(nxt,j,now,nadj,madj,ntot,nerror) if(nerror > 0) return } until(ngap==n) return end deldir/inst/SavedRatfor/delet.r0000644000176200001440000000073013520000775016171 0ustar liggesuserssubroutine delet(i,j,nadj,madj,ntot,nerror) # Delete i and j from each other's adjacency lists. # Called by initad, swap. implicit double precision(a-h,o-z) dimension nadj(-3:ntot,0:madj) logical adj # First check that they're IN each other's lists. call adjchk(i,j,adj,nadj,madj,ntot,nerror) if(nerror > 0) { return } # Then do the actual deletion if they are. if(adj) { call delet1(i,j,nadj,madj,ntot) call delet1(j,i,nadj,madj,ntot) } return end deldir/inst/err.list0000644000176200001440000000322411621163455014164 0ustar liggesusers Error list: =========== nerror = 1: Contradictory adjacency lists. Error in adjchk. nerror = 2: Number of points jumbled. Error in binsrt. nerror = 3: Vertices of 'triangle' are collinear and vertex 2 is not between 1 and 3. Error in circen. nerror = 4: Number of adjacencies too large. Error in insrt. (Automatically adjusted for in deldir().) nerror = 5: Adjacency list of i is empty, and so cannot contain j. Error in pred. nerror = 6: Adjacency list of i does not contain j. Error in pred. nerror = 7: Indicator ijk is out of range. (This CAN'T happen!) Error in qtest. nerror = 8: Fell through all six cases. Something must be totally stuffed up. Error in stoke. nerror = 9: Adjacency list of i is empty, and so cannot contain j. Error in succ. nerror = 10: Adjacency list of i does not contain j. Error in succ. nerror = 11: No triangles to find. Error in trifnd. nerror = 12: Vertices of triangle are collinear. Error in dirseg. nerror = 13: Vertices of triangle are collinear. Error in dirout. nerror = 14: Number of Delaunay segments exceeds alloted space. Error in delseg. (Automatically adjusted for in deldir().) nerror = 15: Number of Dirichlet segments exceeds alloted space. Error in dirseg. (Automatically adjusted for in deldir().) nerror = 16: Line from midpoint to circumcenter does not intersect rectangle boundary; but it HAS to!!! Error in dirseg. nerror = 17: Line from midpoint to circumcenter does not intersect rectangle boundary; but it HAS to!!! Error in dirout. deldir/inst/ex.out0000644000176200001440000000530311621163455013644 0ustar liggesusers$delsgs x1 y1 x2 y2 ind1 ind2 [1,] 3 3 2.3 2.3 2 1 [2,] 7 2 2.3 2.3 3 1 [3,] 7 2 3.0 3.0 3 2 [4,] 1 5 2.3 2.3 4 1 [5,] 1 5 3.0 3.0 4 2 [6,] 3 8 3.0 3.0 5 2 [7,] 3 8 7.0 2.0 5 3 [8,] 3 8 1.0 5.0 5 4 [9,] 8 9 7.0 2.0 6 3 [10,] 8 9 3.0 8.0 6 5 [11,] 0 0 2.3 2.3 7 1 [12,] 0 0 7.0 2.0 7 3 [13,] 0 0 1.0 5.0 7 4 [14,] 10 0 7.0 2.0 8 3 [15,] 10 0 8.0 9.0 8 6 [16,] 10 0 0.0 0.0 8 7 [17,] 0 10 1.0 5.0 9 4 [18,] 0 10 3.0 8.0 9 5 [19,] 0 10 8.0 9.0 9 6 [20,] 0 10 0.0 0.0 9 7 [21,] 10 10 8.0 9.0 10 6 [22,] 10 10 10.0 0.0 10 8 [23,] 10 10 0.0 10.0 10 9 $dirsgs x1 y1 x2 y2 ind1 ind2 bp1 bp2 1 1.650000 3.650000 4.560000 0.740000 2 1 FALSE FALSE 2 4.560000 0.740000 4.512766 0.000000 3 1 FALSE TRUE 3 5.750000 5.500000 4.560000 0.740000 3 2 FALSE FALSE 4 0.000000 2.855556 1.650000 3.650000 4 1 TRUE FALSE 5 1.650000 3.650000 3.500000 5.500000 4 2 FALSE FALSE 6 3.500000 5.500000 5.750000 5.500000 5 2 FALSE FALSE 7 5.750000 5.500000 6.058824 5.705882 5 3 FALSE FALSE 8 0.500000 7.500000 3.500000 5.500000 5 4 FALSE FALSE 9 6.058824 5.705882 10.000000 5.142857 6 3 FALSE TRUE 10 5.200000 10.000000 6.058824 5.705882 6 5 TRUE FALSE 11 2.300000 0.000000 0.000000 2.300000 7 1 TRUE TRUE 12 10.000000 3.250000 7.833333 0.000000 8 3 TRUE TRUE 13 0.000000 7.400000 0.500000 7.500000 9 4 TRUE FALSE 14 0.500000 7.500000 2.166667 10.000000 9 5 FALSE TRUE 15 8.750000 10.000000 10.000000 7.500000 10 6 TRUE TRUE $summary x y n.tri del.area del.wts n.tside nbpt dir.area dir.wts [1,] 2.3 2.3 4 4.500000 0.045000 4 4 9.092057 0.090921 [2,] 3.0 3.0 4 6.050000 0.060500 4 0 10.738500 0.107385 [3,] 7.0 2.0 6 18.666667 0.186667 5 4 23.318162 0.233182 [4,] 1.0 5.0 5 7.500000 0.075000 4 2 9.394167 0.093942 [5,] 3.0 8.0 5 15.000000 0.150000 5 2 18.055637 0.180556 [6,] 8.0 9.0 5 16.666667 0.166667 3 4 18.314811 0.183148 [7,] 0.0 0.0 4 8.450000 0.084500 1 2 2.645000 0.026450 [8,] 10.0 0.0 3 10.500000 0.105000 1 2 3.520833 0.035208 [9,] 0.0 10.0 4 7.666667 0.076667 2 2 3.358333 0.033583 [10,] 10.0 10.0 2 5.000000 0.050000 1 2 1.562500 0.015625 $n.data [1] 6 $n.dum [1] 4 $del.area [1] 100 $dir.area [1] 100 $rw [1] 0 10 0 10 attr(,"class") [1] "deldir" deldir/inst/READ_ME0000644000176200001440000002112011621163455013511 0ustar liggesusers Version 0.0-9 (??? 2 June 2009) Added a new function tile.centroids() --- which does the obvious. Motivated by an inquiry from Leandro Moreira. Version 0.0-8 (4 April 2009) Removed the labels from the x and y vectors in the tile descriptions produced by tile.list. These labels (which were the row numbers in the dirsgs data frame returned by deldir()) served no useful purpose and were potentially confusing. ***************************** Versions 0.0-2 through 0.0-7 were not tracked here. :-( Simply forgot about doing this. I thouroughly *intend* [ :-) ] to get the archives from CRAN and try to document the changes. Recent ones involved fixing bugs in and adding features to the tile.list() and plot.tile.list() functions. ***************************** Version 0.0-1 (21 February 2002) This version is simply an adaptation of the Splus version of the package to R. ***************************** Version date: 14 February 2002. This version supercedes the version dated 24 April 1999. ***************************** The changes from the version dated 24 April 1999 to the version dated 14 February 2002 were: A bug in the procedure for eliminating duplicated points was fixed. Thanks go to Dr. Berwin Turlach of the Department of Maths and Stats at the University of Western Australia, for spotting this bug. ***************************** The changes from the version dated 26 October 1998 to the version dated 24 April 1999 were: (1) The function mipd(), stored in mipd.sf, and the corresponding Fortran subroutine mipd, stored in mipd.r, have been replaced by mnnd() in mnnd.sf and mnnd in mnnd.r. The function mipd calculated the mean interpoint distance, to be used in constructing dummy point structures of a certain type. After some reflection it became apparent that the mean interpoint distance was much too large for the intended purpose, and that a more appropriate value was the ``mean nearest neighbour distance'' which is calculated by the new function. This new value is now used in constructing dummy point structures. Note that the operative result is that the resulting dummy point structures contain many more points than before. The old value caused large numbers of the dummy points to fall outside the data window and therefore to be clipped. ***************************** The changes from the version dated 6 December 1996 to the version dated 26 October 1998 were: (1) A ratfor/Fortran routine named ``inside'' has been renamed ``dldins'' to avoid conflict with a name built in to some versions of Splus. (2) Some minor corrections have been made to dangerous infelicities in a piece of the ratfor/Fortran code. (3) The dynamic loading procedure has been changed to use dyn.load.shared so that the package is easily usable on IRIX systems as well as under SunOS/Solaris. (4) The package has been adjusted slightly so that it can easily be installed as a section of a library. In particular, the dynamic loading is now done by the .First.lib() function rather than from within deldir() itself; reference to an environment variable DYN_LOAD_LIB is no longer needed. ***************************** This package computes and plots the Dirichlet (Voronoi) tesselation and the Delaunay triangulation of a set of of data points and possibly a superimposed ``grid'' of dummy points. The tesselation is constructed with respect to the whole plane by suspending it from ideal points at infinity. ORIGINALLY PROGRAMMED BY: Rolf Turner in 1987/88, while with the Division of Mathematics and Statistics, CSIRO, Sydney, Australia. Re-programmed by Rolf Turner to adapt the implementation from a stand-alone Fortran program to an S function, while visiting the University of Western Australia, May 1995. Further revised December 1996, October 1998, April 1999, and February 2002. Adapted to an R package 21 February 2002. Current address of the author: Department of Mathematics and Statistics, University of New Brunswick, P.O. Box 4400, Fredericton, New Brunswick, Canada E3B 5A3 Email: rolf@math.unb.ca The author gratefully acknowledges the contributions, assistance, and guidance of Mark Berman, of D.M.S., CSIRO, in collaboration with whom this project was originally undertaken. The author also acknowledges much useful advice from Adrian Baddeley, formerly of D.M.S. CSIRO (now Professor of Statistics at the University of Western Australia). Daryl Tingley of the Department of Mathematics and Statistics, University of New Brunswick provided some helpful insight. Special thanks are extended to Alan Johnson, of the Alaska Fisheries Science Centre, who supplied two data sets which were extremely valuable in tracking down some errors in the code. Don MacQueen, of Lawrence Livermore National Lab, wrote an Splus driver function for the old stand-alone version of this software. That driver, which was available on Statlib, is now deprecated in favour of this current package. Don also collaborated in the preparation of this current package. Bill Dunlap of MathSoft Inc. tracked down a bug which was making the deldir() function crash on some systems, and pointed out some other improvements to be made. Berwin Turlach of the Department of Maths and Stats at the University of Western Australia pointed out a bug in the procedure for eliminating duplicated points. ***************************** The man directory, contains, in addition to the R documentation files deldir.Rd and plot.deldir.Rd: (a) This READ_ME file. (b) A file err.list, containing a list of meanings of possible error numbers which could be returned. NONE of these errors should ever actually happen except for errors 4, 14, and 15. These relate to insufficient dimensioning, and if they occur, the driver increases the dimensions and tries again (informing you of this fact). (c) A file ex.out containing a printout of the object returned by running the example given in the help file for deldir. The src directory contains many, many *.f (Fortran) files, which get compiled and dynamically loaded. The Fortran code is ponderous --- it was automatically generated from Ratfor code, which was pretty ponderous to start with. It is quite possibly very kludgy aw well --- i.e. a good programmer could make it ***much*** more efficient I'm sure. It contains all sorts of checking for anomalous situations which probably can/will never occur. These checks basically reflect my pessimism and fervent belief in Murphy's Law. The program was also designed with a particular application in mind, in which we wished to superimpose a grid of dummy points onto the actual data points which we were triangulating. This fact adds slightly to the complication of the code. ***************************** Here follows a brief description of the package: (1) The function deldir computes the Delaunay Triangulation (and hence the Dirichlet Tesselation) of a planar point set according to the second (iterative) algorithm of Lee and Schacter, International Journal of Computer and Information Sciences, Vol. 9, No. 3, 1980, pages 219 to 242. The tesselation/triangulation is made to be **** with respect to the whole plane **** by `suspending' it from `ideal' points (-Inf,-Inf), (Inf,-Inf) (Inf,Inf), and (-Inf,Inf). (2) The tesselation/triangulation is also enclosed in a finite rectangle with corners (xmin,ymax) * ------------------------ * (xmax,ymax) | | | | | | | | | | (xmin,ymin) * ------------------------ * (xmax,ymin) The boundaries of this rectangle truncate some Dirichlet tiles, in particular any infinite ones. This rectangle is referred to elsewhere as `the' rectangular window. === (2) The function plot.deldir is a method for plot. I.e. it may be invoked simply by typing ``plot(x)'' provided that ``x'' is an object of class ``deldir'' (as produced by the function deldir). The plot (by default) consists of the edges of the Delaunay triangles (solid lines) and the edges of the Dirichlet tiles (dotted lines). By default the real data points are indicated by circles, and the dummy points are indicated by triangles.