spam/0000755000176000001440000000000012403575207011247 5ustar ripleyusersspam/inst/0000755000176000001440000000000012403543426012222 5ustar ripleyusersspam/inst/0LICENSE0000644000176000001440000000301312401700731013274 0ustar ripleyusersAll R code and documentation in this package is licensed under the terms of the GPL license. The Fortran functions in spammodified.f were written by Reinhard Furrer. The Fortran functions in bckslvmodified.f cholmod.f are modifications of Fortran functions provided by the SparseM package. The code in cholesky.f is a modified version of code originally written by Esmond Ng and Barry Peyton. The modified version is distributed as part of PCx by Czyzyk, Mehrotra, Wagner, and Wright and is copywrite by the University of Chicago. The PCx distribution makes the following stipulation: This software discloses material protectable under copyright laws of the United States. Permission is hereby granted to use, reproduce, prepare derivative works, and redistribute to others at no charge, provided that the original PCx copyright notice, Government license and disclaimer are retained and any changes are clearly documented; however, any entity desiring permission to use this software within a commercial organization or to incorporate this software or a work based on the software into a product for sale must contact Paul Betten at the Industrial Technology Development Center, Argonne National Laboratory. PAUL BETTEN betten@anl.gov Industrial Technology Development Center, Argonne National Laboratory, Argonne, IL 60439 (630) 252-4962 FAX: (630) 252-5230 All other Fortran functions are from http://www-users.cs.umn.edu/~saad/software/SPARSKIT/index.html (GNU Lesser General Public License) spam/inst/CITATION0000644000176000001440000000143012402021152013337 0ustar ripleyuserscitHeader("To cite `spam` in publications use:") citEntry(entry = "Article", title = "{spam}: A Sparse Matrix {R} Package with Emphasis on {MCMC} Methods for {G}aussian {M}arkov Random Fields", author = personList(as.person("Reinhard Furrer"), as.person("Stephan R. Sain")), journal = "Journal of Statistical Software", year = "2010", volume = "36", number = "10", pages = "1--25", url = "http://www.jstatsoft.org/v36/i10/", textVersion = paste("Reinhard Furrer, Stephan R. Sain (2010).", "spam: A Sparse Matrix R Package with Emphasis on MCMC Methods for Gaussian Markov Random Fields.", "Journal of Statistical Software, 36(10), 1-25.", "URL http://www.jstatsoft.org/v36/i10/."), ) spam/inst/0ChangeLog0000644000176000001440000000267112377554501014070 0ustar ripleyusers>spam_0.41: moved definitively to GIT. ChangeLog will consist of `git log` spam_0.41-0 2014-02-26 (RF) - addressed several Rdevel CMD check --as-cran Notes. - minor changes in tests/mle (improving speed) - minor code tiding - file header edits spam_0.40-1 2014-02-20 (Florian Gerber) - update grid_trace2() and grid_trace2.Rd - eliminate bug in cov.mat() and correct typo in cov.Rd add tests/covmat.R tests/covmat.Rout.save changeset: 4:66173a00f913 tag: tip user: Reinhard Furrer @ lappi date: Wed Aug 21 21:09:05 2013 +0200 summary: Adjusted DESCRIPTION, NEWS, ChangeLog for push to CRAN changeset: 3:412496cbb8b3 user: Florian Gerber date: Tue Aug 20 15:36:34 2013 +0200 summary: gridBase NOT in dependency. comment germany.Rd about 'fields' changeset: 2:2526f2c1d501 user: Florian Gerber date: Mon Aug 19 15:42:49 2013 +0200 summary: add plot grid_zoom() and grid_trace2() incl help files. changeset: 1:2929fe7a2799 user: Florian Gerber date: Tue Aug 06 14:31:11 2013 +0200 summary: Test hg, small changes in spam0.30-0/man/mcmczoomPlot.Rd changeset: 0:0029fc2741f4 user: Reinhard Furrer date: Mon Aug 05 13:53:20 2013 +0200 summary: First Version that runs... spam/inst/0NEWS0000644000176000001440000002722712346261543013016 0ustar ripleyusers Dear Emacs, please make this -*-Text-*- mode! ************************************************** * * * SPAM VERSION 0.21 * * * ************************************************** o New functions bandwidth, permutation, mle[.nomean][.spam], neg2loglikelihood[.spam]. o Renamed adiag.spam to bdiag.spam. o Cleaned up argument naming with the rmvnorm.* suite. o Varios Fortran code, R code and help file improvements. ************************************************** * * * SPAM VERSION 0.20 * * * ************************************************** CHANGES IN R VERSION 0.20-3 o Resolved dependency issues. CHANGES IN R VERSION 0.20-1,2 o Minor changes to pass the CRAN test. CHANGES IN R VERSION 0.20-0 o New demos, test functions, datasets. o Method t for spam.chol.NgPeyton. o Method Math2 now with signature digits="ANY". o Update in rmvnorm.canonical, can take a Cholesky structure as argument. o New functionality for a sparse times a full matrix multiplication. o Minor ajustment in memory allocation of chol. ************************************************** * * * SPAM VERSION 0.15 * * * ************************************************** CHANGES IN R VERSION 0.15-6 o Minor change in Fortran routines to accomodate some Intel compilers (pointed out by Tim Hoar). CHANGES IN R VERSION 0.15-5 o New function adiag.spam, creation of block diagonal sparse matrices. No method though. o New functions rmvnorm.spam, rmvnorm.canonical and rmvnorm.prec to draw multivariate normals. o New function apply.spam, similar functionality as apply. o drop is implemented now when subsetting a sparse matrix with a binary matrix. o Major overhaul to nearest.dist: zeros are not included. Old parameters are kept for backwards compatibility. o Orders/complexities of major algorithms are now described in the help 'complexity'. o Using packageStartupMessage in .onAttach. o Code clean up and help improvements. Changes reflecting the change to UZH. o Bugfix in assinging via a nx2 matrix. CHANGES IN R VERSION 0.15-4 o Changes in help files. Minor code improvements. o New function powerboost. o Changes to if(getRversion() >= "x.y"), required for R 2.10. CHANGES IN R VERSION 0.15-3 o Several bug fixes in the demos due to the changes in the previous versions. o Several minior changes in the help files to compile with the new help parser and to correct for typos. o Added the demos into the tests directory. Additionally, tests contains now the proper Rout.saves files. o In test files, library( spam, warn.conflict=FALSE) is used to avoid masking messages in R-2.8.0. Timing output in test files is suppressed. o Added trivial headers to most files. o Bug fix in spam.list(), negative values were not correctly handled. o Bug fix in subsetting (occured when subsetting very sparse matrices, memory allocation problem). CHANGES IN R VERSION 0.15-2 o Method all.equal for matrix-spam signature. o Bug fix in Fortran function of nearest.dist. Numerical instabilities could return NaN on diagonal. Additionally, overhaul of tests/dist.R. o Several minor improvements in the help files as well as in function nearest.dist and tests/*.R. CHANGES IN R VERSION 0.15-1 o Improvements in the nearest.dist function. The diagonals are now handled consistenly. o Symmetry check criterion for Cholesky decomposition has been relaxed from (2+eps)*eps to 100*eps for an easier handling when working with great circle distance induced covariance matrices. Same cutoff is used with eigen. Instead of using norm, we use essentially an isSymmetric.spam test. o Methods isSymmetric and all.equal for spam. o Methods image and display for spam.chol.NgPeyton. o Method as.spam for distance class implemented. o Complete rewrite of spam.list. Method as.spam for lists are implemented as well. o Method spam for spam objects (possibility to rearrange the dimension) has been eliminated. The approach was based on creating the full matrix and assigning it back to a spam object. o Binary subsetting and subassigning is implemented. o Bug fix: the Cholesky Fortran routine checks if diagonal elements are available (and positive). o Bug fix: in dim<-.spam o Minor improvements in the help files as well as the following R functions: norm, .spam.matmul. CHANGES IN R VERSION 0.15-0 o The devel versions of 14-x have been sitting around for a while and I was inconsistent with the devel/gold numbering. To avoid any confusion, I have decided to go to the next minor version. An additional reason supporting this is that the version number identification has changed over the 0.14-devel. ************************************************** * * * SPAM VERSION 0.14 * * * ************************************************** CHANGES IN R VERSION 0.14-x o A few rudimentary functions to change between the compressed sparse row formats of the packages SparseM and Matrix. Just the functions, no S3/S4 constructs available. o Functionality to read matrices stored in the Harwell-Boeing or MatrixMarket formats.Read MatrixMarket. o Rewritten cbind.spam and rbind.spam. Both can take now numeric and spam objects. cbind.spam calls now Fortran code and is now very fast. Rewrite of their help. o Implemented spam.list to go from a index based list to a spam matrix. The function triplets does the inverse. o forwardsolve and backsolve methods for spam objects. o Implemented the function 'dim<-' for spam objects. o Method diag and as.matrix for spam.chol.NgPeyton. o eps is now tested for being at least double precision. o as.spam.xxx and spam.yyy functions have been streamlined. o Initializing an empty spam matrix causes a warning but still coerces to a zero matrix, see new("spam",entries=rep(1,0)) o Eliminated bug in subsetting (occuring when subsetting for an empty matrix). Clean out subsetting and assigning. o Include a inst subdirectory containing this file, which is renamed to NEWS. Once we have reached a stable version I will maintain a proper CHANGELOG file in the root directory. o Proper method handling for kronecker and bug fixes in kronecker.spam. o Saved the datasets UScounties.storder/ndorder as spam objects as assumed by demo article-jss. o Implemented many 'identical' structures and homogenized zero matrix handling, throughout the R code. int0, ..., int2 are internally defined integers. o Similar changes as for 13-3. Additionally, considerable improvements in help, file structure, tests, timing, etc. CHANGES IN R VERSION 0.14-0 Major revision. Slight loss of backwards compatibility. o New demo article-jss. o New variable spam.version, similar to the R version variable. o Change and adding of a few option names, for example cholsymmetrycheck, cholpivotcheck, cholupdatesingular, dopivoting, safemode, ... See help files for details. o Complete rewrite of chol. The argument ordering is now called pivot, more consistent with the generic function. Two different orderings are implemented. Uses the new option cholsymmetrycheck. o Similar changes as in chol in determinant.spam. o New function update.spam.chol.NgPeyton. o Invisible/minor changes in method c for spam, in solve.spam, determinant.chol.NgPeyton o The class spam.chol.NgPeyton is defined differently. Accordingly, print and summary methods are updated. Notably, fill-in ratios are given with summary. Summary also hands back the length of the vectors holding the factor and the column indices. o New methods for spam.chol.NgPeyton, namely, dim, length, c, dim<-, and length<-. The latter two giving simply errors. o Along the redefinition of the class spam.chol.NgPeyton, forwardsolve.spam and backsolve.spam are updated. Use now the option dopivoting. o kronecker.r is implemented. o nearest.dist, a function to calculate close distances within one or two sets of locations is implemented. Roughly speaking, it is the union of dist in base and rdist/rdist.earth in fields. (comes with options nearestdistincreasefactor and nearestdistnnz). o print and show now emphasize that the non-zero elements are row-wise printed. o UScounties is a dataset containing the adjacency matrix of the first and second order neighbors of the counties of the lower 48 US states. o Some changes in help files, especially in the *-class files. o Eliminated warnings issued when compiling. o Minor R and Fortran code cleaning. o Along the new features, update of CHANGELOG, todo, NAMESPACE files, etc. ************************************************** * * * SPAM VERSION SERIES 0.13 * * * ************************************************** CHANGES IN R VERSION 0.13-3 o Minor changes in R and Fortran code to eliminate warnings. o In diag()'s argument list, drop the explicit default (' = n'). As is now in R-2.7. CHANGES IN R VERSION 0.13-2 o New spam.options and getOption functions. .Spam as a variable is not visible anymore. o Retrieving information from the DESCRIPTION file directly (thanks to Roger Bivand). CHANGES IN R VERSION 0.13-1 o Minor Fortran Changes for g77 compatibility. Thanks to Roger Bivand. o Updated DESCRIPTION file. CHANGES IN R VERSION 0.13 o Updated NAMESPACE (for versions > 2.5). o Some changes in help files. o Cleaned Fortran source files (eliminated unused subroutines and used the posted complier output to straighten details). o Implemented more efficient transpose Fortran code. This also eliminates a bug when transposing a 1 row matrix. o Eliminated bug when assigning with a 1 row matix. o Eliminated bug (Fortran code) that could potentially occur when assigning. o Eliminated bug when plotting a 1 row matix. o Minor R code cleaning. ************************************************** * * * SPAM VERSION 0.12 * * * ************************************************** o Updated NAMESPACE and DESCRIPTION file. o print and summary pass back NULL instead of the object. o Changed to prod(x@dimension) instead of nrow*ncol to overcome integer overflow for very large matrices. o Introduced a prototype in the definition of spam and spam.chol.*. o .Spam$safemode also determines if a spam object is tested for validity, as well as for NAOK. o In many functions sparse matrix construction is done manually using slots (and check=FALSE, if approprate). o Increased the value of symmetry criteria to (2+eps)*eps, as each element can be off by eps, subtraction leads to a 2*eps offset and yet we are symmetric. o Major restructuration of chol/det with elimination of auxiliarychol. o Methods chol/backsolve/forwarsolve now call the *.spam functions. o Many internal changes to favour speed and efficiency. o Bug fix in .spam.elemul. occuring when the result is the zero matrix. spam/inst/NEWS0000644000176000001440000002503712403543425012727 0ustar ripleyusers CHANGES IN VERSION 1.0 and 1.0-1 o This version is up to 'DESCRIPTION' and its implied changes identical to 0.90-1. With the upcoming JSS article "Pitfalls in the implementation of Bayesian hierarchical modeling of areal count data. An illustration using BYM and Leroux models." a "major" version jump is adequate. o Referencing to spam data through spam::... o Implemented `1.1.3.1 Suggested packages` approach. CHANGES IN VERSION 0.70/0.80/0.90/0.90-1 SIGNIFICANT USER-VISIBLE CHANGES o Introduction of many as('spam','...') functions. o Coercion function `as.vector` for spam objects. o Wrapper functions `spam_rdist` and 'spam_rdist.earth` for smooth use in `fields`. o The use of `update(A, B)` without assignment has been eliminated. This is one way to address the change in memory handling changes from R 3.0.2 to R 3.1.0. There is a slight overhead in memory. If this causes problems, let me know. o Adjustment of the license. NEW FEATURES o Arguments `diag` and `eps` in `nearest.dist` cause now an error. o Further augmented help pages. BUG FIXES o The demo now points to the new JSS article. INTERNAL CHANGES o Set 'structurebased=TRUE' for the demos. o Link to upcoming JSS article in one of the demos. o 'update.spam.chol.NgPeyton' preserves the structure (pointed out by Chris Paciorek), see above. o Using similar License approach as SparseM. New files `README`, `inst/0LICENSE`. o File renaming (OChangeLog -> 0ChangeLog) o Adjusted error messages for precmat.RW2 CHANGES IN VERSION 0.60-0 SIGNIFICANT USER-VISIBLE CHANGES o Using the flag 'structurebased', the behavior of spam is now more consistent. o "Arith", "Compare", "Logic" (getGroupMembers("Ops")) have now a consistent behavior. NEW FEATURES o Few new S3 functions for simplicity: 'var.spam', 'eigen.spam', ... o New constructor functions 'colindices<-' etc. Maybe additional tests may be required. o Operators from 'Arith' obey now the structure based calculation. BUG FIXES o 'inefficiencywarning' passes message correctly. INTERNAL CHANGES o many more spam/tests/*. o Consistent use of 'spam' and 'vector' siglist for 'Ops'. o Minor cleaning of Fortran code. o Renaming/restructuring/cleaning of files... o Fortran arguments are copied when updating the cholesky structure. CHANGES IN VERSION 0.50-0 SIGNIFICANT USER-VISIBLE CHANGES o Using the flag 'structurebased=FALSE', the behavior of spam is now much, much closer to regular matrix calculations. This is illustrated when calculating gamma of a sparse matrix. o Along the same lines, the flag 'NAOK=TRUE' allows the use of the "not finite numbers" (NA, NaN, Inf). We have tested many, many functions but full fledged use is not yet guaranteed. o Currently, we can still guarantee backwards compatibility... NEW FEATURES o New functions 'crossprod' and 'tcrossprod' as well as according method definitions. o New constructor functions 'rowpointers<-' etc. o Better option handling. The option 'safemode' is now 'safemodevalidity'. Additionally, new option 'NAOK'. o Help pages have been improved. o Operators from 'Summary' and 'Math' obey now the structure based calculation. ('Math2' inherently does). BUG FIXES o rmvnorm.[].const now work properly for any number of constraints and n. o Assignment handles properly recycling. o todo() now works properly. INTERNAL CHANGES o eliminated {d,i}check by equivalent coercion. o Consistent use of NAOK in Fortran calls. o Minor cleaning of Fortran code. o Renaming/restructuring of files... CHANGES IN VERSION 0.42-0 NEW FEATURES o More consistent handling of subsetting. Warning is issued if subsetting with NA BUG FIXES o Fixed several issues when rowsubsetting... INTERNAL CHANGES o Additional tests for positive definiteness in 'chol'. CHANGES IN VERSION 0.41-0 NEW FEATURES o Functions grid_trace2() received more functionality. BUG FIXES o Eliminated bug in cov.mat(). Pointed out by Joshua French INTERNAL CHANGES o Updated DESCRIPTION: added Florian Gerber [ctb] o Minor code and help cleanup. Additional testing files. File header edits. o Addressed Rdevel CMD check --as-cran Notes, especially workaround for DUP=FALSE CHANGES IN VERSION 0.40-0 BUG FIXES o A severe bug in subsetting a spam object with a nx2 matrix crept in spam in version 0.29-3. Thanks to Andrew Hong and Beat Briner for pointing out. To simplify communication, we have switched increased the tenth version number. All other changes are of cosmetic nature. CHANGES IN VERSION 0.30-x SIGNIFICANT USER-VISIBLE CHANGES o Added several plots to visualize several MCMC chains ('grid_trace2', 'grid_zoom', ...). NEW FEATURES o New function 'germany.plot' to draw the landkreise. ('map.landkreis' is now obsolete). o Switched from 'tim.colors' to 'colorRampPalette' in 'germany.plot'. o Metadata in 'germany.info', polygon definitions in 'germany.poly' ('germany' kept for backwards compatibility). INTERNAL CHANGES o Switched to mercurial for maintaining the package. o Updated ChangeLog file (hg log). o Increased dependency to >= R 2.15. o Minor code and help cleanup. CHANGES IN VERSION 0.29-0, 0.29-1, 0.29-2, 0.29-3 SIGNIFICANT USER-VISIBLE CHANGES o There is a generic conflict with 'backsolve' between spam and other packages (e.g., bdsmatrix). To avoid the issue, we use the standard generic implemented in 'methods' which requires an additional argument for version 0.29-0 (see also PR#14883). However to maintain backwards compatibility with packages that depend on spam, this was reverted in 0.29-1. Currently, this conflict is not properly solved. I propose to load 'spam' first then the other packages, followed by manually calling: setMethod("backsolve","spam.chol.NgPeyton",backsolve.spam) setMethod("backsolve","spam",backsolve.spam) Stay tuned... o Calls like: mat <- diag.spam(4) diag( mat[-1,]) <- 3 diag.spam( mat[,-1]) <-2 now work. They are, however, somewhat inefficient. 'toeplitz.spam' is to be prefered. Pointed out by Florian Gerber. o The Gibbs sampler in the demo article-jss-example2 contains several bugs, pointed out by Steve Geinitz and Andrea Riebler. I'll post an updated sampler in a future release. NEW FEATURES o New functions 'rmvnorm.const', 'rmvnorm.prec.const' and 'rmvnorm.canonical.const' to draw constrained multivariate normal variates. o New functions 'precmat' (wrapper to), 'precmat.RW1', 'precmat.RW2', 'precmat.season', 'precmat.IGMRFreglat' and 'precmat.IGMRFirreglat' to create precision matrices for IGMRF. o New methods 'rowSums', 'colSums' and 'rowMeans', 'colMeans' for 'spam' objects. o New methods 'head' and 'tail' for 'spam' and 'spam.chol.NgPeyton' objects. o New method 'chol2inv' for 'spam' object. o New option 'inefficiencywarning': handling of warnings issued in case of an inefficient calculation. o New option 'structurebased': should operations be performed on the nonzero entries or on including the zeros. Classical example: what should the cosine of a sparse matrix look like? In the near future, all operations from Math and Ops will include this option. Some loss of backwards compatibility might be lost in the future. INTERNAL CHANGES o New much faster approach to extract rows. For not too sparse large matrices improvements over two orders of magnitudes are achieved. o Elininated '.Internal()' calls that induce a 'Note' on CRAN checks. This also implied a minor rewrite of 'image.spam'. o Minor code improvements. o Eliminated non-API calls (29.1). o Rewritten .C("bincode",...) call as suggested by Brian Ripley (29.2). BUG FIXES o Bug fix that occures when multiplying elementwise matrices that have non-intersecting structures (pointed out by Corentin Barbu). o Bug fix in triangular backsolves involving 'spam' objects and rhs matrices. o Bug fix in triangular backsolve causing errors on some architectures. CHANGES IN VERSION 0.28 NEW FEATURES o New function 'cleanup' (suggested by Simon Barthelme). o Extending help files. o Improved functionality of 'isSymmetric'. INTERNAL CHANGES o Proper storage of data files. o Cleaning up argument names within spam functions. o Cleaning up old Fortran code, i.e., eliminating unnecessary subroutines and write calls. BUG FIXES o Bug fix that may occure when extracting zero elements (pointed out by Corentin Barbu). CHANGES IN VERSION 0.27 NEW FEATURES o Requires now R2.10 and higher. o Functions to create Toeplitz and circulant matrices. o Function to create precision matrices for gridded GMRF. o Improvements in the mle.* functions. o Method diff for sparse matrices (suggested by Paul Eilers). o Improvement of help pages. o Eliminated some help aliases to base functions (for which no 'usage' is given). INTERNAL CHANGES o Change to iL coding. o Start to using 'identical'. o Code cleaning due to requirement of R2.10 and higher. BUG FIXES o Bug fix in as.spam.list (thanks to Paul Eilers). o Bug fix in demo(spam) (thanks to Thomas Gsponer). CHANGES IN VERSION 0.24, 0.25 and 0.26 o Devel versions, not released. CHANGES IN VERSION 0.23 NEW FEATURES o Further improved versions of demos. o Some improvements to meet Rd standards. Adjustments for future R versions. CHANGES IN VERSION 0.22 NEW FEATURES o Improved versions of demos. Synchronized with the JSS article. o Additional changes and improvements in the help files (thanks to Steve Geinitz). CHANGES IN VERSION 0.21 NEW FEATURES o New NEWS file, to work better with news() command. The previous is available under ONEWS. o New functions bandwidth, permutation, mle[.nomean][.spam], neg2loglikelihood[.spam]. o Renamed adiag.spam to bdiag.spam. o Cleaned up argument naming with the rmvnorm.* suite. INTERNAL CHANGES o Various Fortran code, R code and help file improvements. BUG FIXES o Minor change in one of the demos (solves a 64bit issue). spam/inst/demodata/0000755000176000001440000000000012346261543014003 5ustar ripleyusersspam/inst/demodata/germany.adjacency0000644000176000001440000004127212346261543017316 0ustar ripleyusers544 0 1 11 1 2 9 10 2 4 5 7 14 386 3 3 9 10 12 4 4 6 10 11 13 5 7 2 14 15 37 39 384 389 6 2 4 11 22 8 16 18 19 26 490 491 493 494 23 6 20 21 24 31 32 141 24 5 20 21 23 529 542 25 5 16 17 19 30 31 26 6 16 17 21 22 31 490 27 1 30 28 8 33 45 46 58 59 60 63 105 29 5 30 31 32 34 104 7 4 2 9 12 14 8 4 12 13 15 43 9 5 1 3 7 10 12 10 7 1 3 4 9 11 12 13 11 4 0 4 6 10 12 8 3 7 8 9 10 13 14 15 13 5 4 8 10 12 43 14 5 2 5 7 12 15 15 6 5 8 12 14 37 43 16 5 17 19 22 25 26 17 5 16 21 25 26 31 18 2 19 22 19 9 16 18 22 25 30 35 44 493 497 20 7 23 24 138 141 144 520 542 21 8 17 23 24 26 31 490 502 529 30 9 19 25 27 29 31 33 34 35 42 31 8 17 21 23 25 26 29 30 32 32 5 23 29 31 103 104 33 6 28 30 34 42 45 105 34 5 29 30 33 104 105 69 3 77 78 88 70 4 66 67 71 76 71 5 66 67 70 79 92 72 4 73 74 89 90 73 4 72 74 76 90 74 5 72 73 76 89 112 75 3 78 79 95 76 11 65 66 67 70 73 74 77 82 83 90 112 77 10 65 66 68 69 76 78 82 85 86 88 78 6 68 69 75 77 79 88 79 8 66 68 71 75 78 92 95 97 80 1 84 81 2 91 146 82 6 76 77 83 86 90 91 83 3 76 82 90 84 4 80 85 87 88 85 5 77 84 86 87 88 86 5 77 82 85 87 91 87 6 84 85 86 91 146 159 88 5 69 77 78 84 85 89 8 72 74 90 91 112 114 115 147 90 7 72 73 76 82 83 89 91 91 9 81 82 86 87 89 90 146 147 152 92 4 67 71 79 97 93 4 67 97 107 111 94 3 96 98 99 95 6 56 75 79 96 97 98 96 7 94 95 97 98 99 110 118 97 10 67 79 92 93 95 96 107 108 111 118 98 8 49 54 56 59 94 95 96 99 99 7 59 94 96 98 101 110 117 100 3 101 102 104 101 7 59 99 100 102 104 106 117 102 5 59 100 101 104 105 103 6 32 104 106 113 141 143 104 9 29 32 34 100 101 102 103 105 106 105 6 28 33 34 59 102 104 106 5 101 103 104 113 117 107 6 67 93 97 108 111 112 108 5 97 107 109 112 118 109 4 108 112 114 118 110 4 96 99 117 118 111 3 93 97 107 112 8 67 74 76 89 107 108 109 114 113 7 103 106 114 115 116 117 143 114 7 89 109 112 113 115 117 118 115 5 89 113 114 116 147 35 4 19 30 42 44 36 5 40 41 43 61 64 37 6 5 15 39 41 42 43 38 7 39 44 361 389 390 495 497 39 6 5 37 38 42 44 389 40 5 36 41 45 61 63 41 6 36 37 40 42 43 45 42 8 30 33 35 37 39 41 44 45 43 6 8 13 15 36 37 41 44 6 19 35 38 39 42 497 45 6 28 33 40 41 42 63 46 4 28 58 61 63 47 2 52 57 48 3 51 58 61 49 2 59 98 50 1 55 51 6 48 53 55 57 58 61 52 3 47 57 62 53 6 51 54 57 58 59 60 54 5 53 56 57 59 98 55 5 50 51 57 61 62 56 3 54 95 98 57 7 47 51 52 53 54 55 62 58 7 28 46 48 51 53 60 61 59 10 28 49 53 54 60 98 99 101 102 105 60 4 28 53 58 59 61 9 36 40 46 48 51 55 58 63 64 62 3 52 55 57 63 5 28 40 45 46 61 64 2 36 61 65 3 66 76 77 66 7 65 68 70 71 76 77 79 67 8 70 71 76 92 93 97 107 112 68 4 66 77 78 79 116 7 113 115 134 136 143 147 155 117 7 99 101 106 110 113 114 118 118 7 96 97 108 109 110 114 117 119 2 124 130 120 7 121 125 126 127 128 130 132 121 3 120 127 130 122 5 125 128 131 165 179 123 7 124 125 129 169 178 199 201 124 6 119 123 125 129 130 298 125 9 120 122 123 124 128 130 165 171 179 126 6 120 128 131 132 134 135 127 9 120 121 130 132 137 139 298 299 304 128 5 120 122 125 126 131 129 5 123 124 200 201 303 130 7 119 120 121 124 125 127 298 131 6 122 126 128 135 154 179 132 6 120 126 127 133 134 137 133 4 132 134 136 137 134 7 116 126 132 133 135 136 155 135 5 126 131 134 154 155 136 6 116 133 134 137 142 143 137 7 127 132 133 136 139 140 142 138 2 20 141 139 7 127 137 140 299 300 513 526 140 6 137 139 142 144 513 514 141 7 20 23 103 138 142 143 144 142 6 136 137 140 141 143 144 143 6 103 113 116 136 141 142 144 7 20 140 141 142 514 520 527 145 3 151 154 155 146 6 81 87 91 151 152 159 147 6 89 91 115 116 152 155 148 6 149 153 171 173 176 179 149 6 148 153 157 160 176 326 150 4 151 153 157 159 151 8 145 146 150 152 153 154 155 159 152 5 91 146 147 151 155 153 7 148 149 150 151 154 157 179 154 7 131 135 145 151 153 155 179 155 8 116 134 135 145 147 151 152 154 156 1 160 157 6 149 150 153 158 159 160 158 3 157 159 160 159 6 87 146 150 151 157 158 160 6 149 156 157 158 322 326 161 3 164 178 199 162 2 175 180 163 3 172 177 180 164 3 161 178 199 165 3 122 125 179 166 2 172 177 167 1 180 168 3 178 196 201 169 4 123 171 172 178 170 2 180 325 171 6 125 148 169 172 173 179 172 9 163 166 169 171 173 175 177 178 180 173 5 148 171 172 175 176 174 5 177 178 195 196 197 175 5 162 172 173 176 180 176 7 148 149 173 175 323 325 326 177 6 163 166 172 174 178 180 178 11 123 161 164 168 169 172 174 177 196 199 201 179 8 122 125 131 148 153 154 165 171 180 8 162 163 167 170 172 175 177 325 181 4 182 183 185 186 182 6 181 183 185 203 204 217 183 5 181 182 184 186 216 184 5 183 186 192 193 220 185 5 181 182 186 188 204 186 7 181 183 184 185 188 190 193 187 1 188 188 9 185 186 187 189 190 196 200 201 204 189 4 188 190 191 200 190 6 186 188 189 191 193 288 191 8 189 190 200 288 292 303 304 306 192 6 184 193 220 313 314 319 193 6 184 186 190 192 288 319 194 1 197 195 2 174 196 196 9 168 174 178 188 195 197 201 203 204 197 6 174 194 196 203 205 209 198 2 199 201 199 6 123 161 164 178 198 201 200 6 129 188 189 191 201 303 201 9 123 129 168 178 188 196 198 199 200 202 2 203 204 203 7 182 196 197 202 204 205 217 204 6 182 185 188 196 202 203 205 6 197 203 209 210 217 218 206 2 207 208 207 5 206 208 211 214 215 208 4 206 207 209 211 209 5 197 205 208 210 211 210 5 205 209 211 212 218 211 7 207 208 209 210 212 213 215 212 5 210 211 213 218 224 213 4 211 212 222 224 214 2 207 215 215 3 207 211 214 216 6 183 217 218 220 221 224 217 5 182 203 205 216 218 218 6 205 210 212 216 217 224 219 2 220 315 220 7 184 192 216 219 221 314 315 221 7 216 220 223 224 310 315 318 222 4 213 223 224 316 223 7 221 222 224 310 316 318 320 224 7 212 213 216 218 221 222 223 225 3 233 242 243 226 3 231 236 241 227 1 244 228 3 240 246 257 229 1 246 230 5 237 239 241 245 247 231 6 226 235 236 241 243 311 232 4 234 240 241 244 233 8 225 242 243 253 265 293 294 319 234 5 232 235 240 241 254 235 6 231 234 241 243 253 254 236 6 226 231 238 241 245 311 237 3 230 247 317 238 6 236 245 247 311 312 317 239 3 230 241 244 240 7 228 232 234 244 246 254 257 241 10 226 230 231 232 234 235 236 239 244 245 242 5 225 233 243 311 319 243 6 225 231 233 235 242 253 244 6 227 232 239 240 241 246 245 5 230 236 238 241 247 246 4 228 229 240 244 247 5 230 237 238 245 317 248 1 254 249 1 255 250 1 258 251 6 252 255 256 257 258 259 252 3 251 255 256 253 6 233 235 243 254 265 267 254 9 234 235 240 248 253 257 258 259 267 255 4 249 251 252 257 256 4 251 252 258 264 257 6 228 240 251 254 255 259 258 7 250 251 254 256 259 264 267 259 4 251 254 257 258 260 1 263 261 1 267 262 1 266 263 6 260 265 266 268 275 291 264 4 256 258 267 268 265 7 233 253 263 267 268 291 293 266 5 262 263 268 269 275 267 7 253 254 258 261 264 265 268 268 5 263 264 265 266 267 269 3 266 275 282 270 1 274 271 1 275 272 1 276 273 1 278 274 10 270 275 276 277 281 289 292 301 302 305 275 10 263 266 269 271 274 277 278 280 282 291 276 7 272 274 279 281 301 521 538 277 4 274 275 289 291 278 9 273 275 279 280 282 447 450 525 533 279 8 276 278 280 281 525 528 532 538 280 4 275 278 279 281 281 4 274 276 279 280 282 3 269 275 278 283 1 288 284 3 285 286 289 285 3 284 286 290 286 7 284 285 287 289 290 291 293 287 2 286 293 288 9 190 191 193 283 290 292 293 294 319 289 7 274 277 284 286 290 291 292 290 6 285 286 288 289 292 293 291 7 263 265 275 277 286 289 293 292 7 191 274 288 289 290 302 306 293 8 233 265 286 287 288 290 291 294 294 4 233 288 293 319 295 2 298 303 296 1 305 297 1 306 298 6 124 127 130 295 303 304 299 5 127 139 300 304 305 300 6 139 299 301 305 521 526 301 5 274 276 300 305 521 302 4 274 292 305 306 303 6 129 191 200 295 298 304 304 7 127 191 298 299 303 305 306 305 8 274 296 299 300 301 302 304 306 306 6 191 292 297 302 304 305 307 2 311 312 308 1 317 309 1 320 310 3 221 223 318 311 7 231 236 238 242 307 312 319 312 8 238 307 311 313 314 317 318 319 313 4 192 312 314 319 314 6 192 220 312 313 315 318 315 5 219 220 221 314 318 316 3 222 223 320 317 7 237 238 247 308 312 318 320 318 8 221 223 310 312 314 315 317 320 319 9 192 193 233 242 288 294 311 312 313 320 5 223 309 316 317 318 321 3 323 324 325 322 3 160 324 326 323 5 176 321 324 325 326 324 4 321 322 323 326 325 5 170 176 180 321 323 326 6 149 160 176 322 323 324 327 7 328 333 353 358 360 362 372 328 6 327 340 348 353 360 369 329 2 341 365 330 1 343 331 1 345 332 3 345 348 366 333 2 327 362 334 1 335 335 5 334 344 363 370 396 336 4 340 344 366 369 337 7 346 351 367 436 448 452 457 338 6 343 345 348 350 353 355 339 7 341 352 357 362 470 471 472 340 7 328 336 344 349 360 369 370 341 8 329 339 358 362 365 472 487 489 342 6 343 346 355 356 367 368 343 7 330 338 342 347 350 355 368 344 4 335 336 340 370 345 5 331 332 338 348 350 346 5 337 342 351 356 367 347 3 343 350 368 348 7 328 332 338 345 353 366 369 349 5 340 359 360 370 394 350 4 338 343 345 347 351 6 337 346 352 356 457 468 352 6 339 351 356 357 468 471 353 6 327 328 338 348 355 372 354 7 358 359 361 364 365 371 492 355 6 338 342 343 353 356 372 356 7 342 346 351 352 355 357 372 357 5 339 352 356 362 372 358 7 327 341 354 359 360 362 365 359 6 349 354 358 360 371 394 360 6 327 328 340 349 358 359 361 7 38 354 364 390 395 492 495 362 7 327 333 339 341 357 358 372 363 5 335 370 394 396 404 364 5 354 361 371 391 395 365 6 329 341 354 358 489 492 366 4 332 336 348 369 367 7 337 342 346 368 436 439 440 368 6 342 343 347 367 439 458 369 5 328 336 340 348 366 370 6 335 340 344 349 363 394 371 6 354 359 364 391 394 398 372 6 327 353 355 356 357 362 373 1 385 374 3 393 394 407 375 2 381 399 376 1 401 377 3 387 400 403 378 1 408 379 5 380 383 392 393 407 380 6 379 383 385 393 406 409 381 4 375 382 399 408 382 5 381 388 399 402 408 383 5 379 380 385 387 392 384 4 5 386 389 401 385 5 373 380 383 387 409 386 4 2 384 401 408 387 7 377 383 385 392 397 403 405 388 6 382 391 399 402 405 407 389 6 5 38 39 384 390 401 390 5 38 361 389 395 401 391 7 364 371 388 395 398 402 407 392 5 379 383 387 405 407 393 7 374 379 380 394 404 406 407 394 10 349 359 363 370 371 374 393 398 404 407 395 6 361 364 390 391 401 402 396 4 335 363 404 406 397 4 387 399 403 405 398 4 371 391 394 407 399 6 375 381 382 388 397 405 400 1 377 401 8 376 384 386 389 390 395 402 408 402 6 382 388 391 395 401 408 403 3 377 387 397 404 5 363 393 394 396 406 405 6 387 388 392 397 399 407 406 4 380 393 396 404 407 9 374 379 388 391 392 393 394 398 405 408 6 378 381 382 386 401 402 409 2 380 385 410 2 423 429 411 3 427 431 449 412 1 434 413 1 442 414 2 447 450 415 2 459 463 416 4 417 444 454 462 417 6 416 418 441 454 456 463 418 6 417 441 447 450 451 463 419 7 420 434 439 440 443 446 455 420 4 419 427 440 455 421 6 432 435 442 477 485 509 422 4 425 429 430 444 423 8 410 429 433 437 438 453 456 462 424 4 428 442 466 482 425 4 422 430 431 449 426 6 435 437 445 448 452 453 427 8 411 420 431 436 440 445 449 455 428 6 424 442 457 460 467 471 429 7 410 422 423 430 437 444 462 430 6 422 425 429 431 437 445 431 6 411 425 427 430 445 449 432 4 421 435 453 509 433 7 423 438 453 459 463 509 535 434 5 412 419 443 446 461 435 7 421 426 432 442 448 453 460 436 6 337 367 427 440 445 452 437 6 423 426 429 430 445 453 438 4 423 433 456 463 439 6 367 368 419 440 446 458 440 6 367 419 420 427 436 439 441 3 417 418 447 442 10 413 421 424 428 435 460 477 478 482 484 443 3 419 434 461 444 4 416 422 429 462 445 7 426 427 430 431 436 437 452 446 4 419 434 439 458 447 5 278 414 418 441 450 448 6 337 426 435 452 457 460 449 5 411 425 427 431 455 450 8 278 414 418 447 451 519 533 543 451 5 418 450 459 463 519 452 5 337 426 436 445 448 453 6 423 426 432 433 435 437 454 2 416 417 455 4 419 420 427 449 456 5 417 423 438 462 463 457 7 337 351 428 448 460 468 471 458 3 368 439 446 459 7 415 433 451 463 517 519 535 460 5 428 435 442 448 457 461 2 434 443 462 5 416 423 429 444 456 463 8 415 417 418 433 438 451 456 459 464 4 466 467 469 470 465 6 469 474 476 482 498 499 466 5 424 464 467 469 482 467 5 428 464 466 470 471 468 4 351 352 457 471 469 7 464 465 466 470 472 482 498 470 6 339 464 467 469 471 472 471 7 339 352 428 457 467 468 470 472 6 339 341 469 470 487 498 473 2 478 482 474 6 465 476 490 494 496 499 475 4 476 481 482 483 476 6 465 474 475 482 483 496 477 5 421 442 479 484 485 478 6 442 473 480 481 482 484 479 8 477 480 484 485 510 515 523 536 480 6 478 479 481 484 512 536 481 6 475 478 480 482 483 512 482 10 424 442 465 466 469 473 475 476 478 481 483 8 475 476 481 496 502 512 529 537 484 5 442 477 478 479 480 485 7 421 477 479 509 515 517 535 486 4 487 498 501 503 487 7 341 472 486 489 498 500 503 488 6 491 493 495 497 500 503 489 5 341 365 487 492 500 490 7 21 22 26 474 494 496 502 491 6 22 488 493 494 501 503 492 6 354 361 365 489 495 500 493 5 19 22 488 491 497 494 6 22 474 490 491 499 501 495 6 38 361 488 492 497 500 496 5 474 476 483 490 502 497 6 19 38 44 488 493 495 498 7 465 469 472 486 487 499 501 499 5 465 474 494 498 501 500 6 487 488 489 492 495 503 501 6 486 491 494 498 499 503 502 5 21 483 490 496 529 503 6 486 487 488 491 500 501 504 2 511 516 505 1 517 506 2 523 541 507 2 522 540 508 1 541 509 5 421 432 433 485 535 510 4 479 523 536 541 511 7 504 516 518 522 531 540 541 512 5 480 481 483 536 537 513 6 139 140 514 518 526 534 514 6 140 144 513 518 524 527 515 5 479 485 517 523 539 516 6 504 511 518 524 536 541 517 9 459 485 505 515 519 530 535 539 543 518 7 511 513 514 516 524 534 540 519 5 450 451 459 517 543 520 4 20 144 527 542 521 8 276 300 301 522 526 528 538 540 522 6 507 511 521 528 531 540 523 8 479 506 510 515 530 531 539 541 524 6 514 516 518 527 536 537 525 5 278 279 530 532 533 526 6 139 300 513 521 534 540 527 6 144 514 520 524 537 542 528 6 279 521 522 531 532 538 529 6 21 24 483 502 537 542 530 8 517 523 525 531 532 533 539 543 531 7 511 522 523 528 530 532 541 532 5 279 525 528 530 531 533 5 278 450 525 530 543 534 4 513 518 526 540 535 5 433 459 485 509 517 536 8 479 480 510 512 516 524 537 541 537 7 483 512 524 527 529 536 542 538 4 276 279 521 528 539 4 515 517 523 530 540 7 507 511 518 521 522 526 534 541 8 506 508 510 511 516 523 531 536 542 6 20 24 520 527 529 537 543 5 450 517 519 530 533 spam/tests/0000755000176000001440000000000012403543611012403 5ustar ripleyusersspam/tests/math.Rout.save0000644000176000001440000001723712403543611015156 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/R/definitions.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > library( spam, warn.conflict=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > > > test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, + tag=NULL){ + # slightly different test function! + if( !is.null(tag)){ + cat( "testing: ", tag, fill=TRUE)} + + denom <- ifelse( relative, mean( abs(c(xtrue))),1.0) + + if (any(dim(xtest)!=dim(xtrue))) + return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), + fill=TRUE)) + test.value <- sum( abs(c(as.matrix(xtest)) - c( xtrue) ),na.rm=T ) /denom + if( test.value < tol ){ + cat("** PASSED test at tolerance ", tol, fill=TRUE)} + else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, + fill=TRUE)} + + } > > > > > > # construct matrices: > n <- 10 > m <- 5 > > set.seed(14) > tt <- matrix(rnorm(m*n),n,m) > tt[tt<0] <- 0 > > ss <- as.spam(tt) > spam.options( structurebased=FALSE) # test for equivalence! > > # ‘Math’ ‘"abs"’, ‘"sign"’, ‘"sqrt"’, ‘"ceiling"’, ‘"floor"’, > # ‘"trunc"’, ‘"cummax"’, ‘"cummin"’, ‘"cumprod"’, ‘"cumsum"’, > # ‘"log"’, ‘"log10"’, ‘"log2"’, ‘"log1p"’, ‘"acos"’, ‘"acosh"’, > # ‘"asin"’, ‘"asinh"’, ‘"atan"’, ‘"atanh"’, ‘"exp"’, ‘"expm1"’, > # ‘"cos"’, ‘"cosh"’, ‘"cospi"’, ‘"sin"’, ‘"sinh"’, ‘"sinpi"’, > # ‘"tan"’, ‘"tanh"’, ‘"tanpi"’, ‘"gamma"’, ‘"lgamma"’, > # ‘"digamma"’, ‘"trigamma"’ > > # ‘Math2’ ‘"round"’, ‘"signif"’ > > # ‘Summary’ ‘"max"’, ‘"min"’, ‘"range"’, ‘"prod"’, ‘"sum"’, ‘"any"’, ‘"all"’ > > # > # ! > A <- diag.spam(4) ; B <- diag(4) > test.for.zero(A, B) ** PASSED test at tolerance 1e-06 > test.for.zero(!A, !B) ** PASSED test at tolerance 1e-06 > diag(A)=0 ; diag(B) <- 0 > test.for.zero(!A, !B) ** PASSED test at tolerance 1e-06 > # str(A) # is what needs to be expected..., > # different to spam:::complement.spam(A) > > > > > > > > > > > > > # ‘Summary’ > test.for.zero(max(ss), max(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(min(ss), min(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(range(ss), range(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(prod(ss), prod(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(sum(ss), sum(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(any(ss), any(tt)) ** PASSED test at tolerance 1e-06 Warning message: In any(tt) : coercing argument of type 'double' to logical > test.for.zero(all(ss), all(tt)) ** PASSED test at tolerance 1e-06 Warning message: In all(tt) : coercing argument of type 'double' to logical > > # ‘Math2’ > test.for.zero(round(ss), round(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(signif(ss), signif(tt)) ** PASSED test at tolerance 1e-06 > > # ‘Math’ ‘"abs"’, ‘"sign"’, ‘"sqrt"’, ‘"ceiling"’, ‘"floor"’, > # ‘"trunc"’, ‘"log1p"’ > # ‘"asin"’, ‘"asinh"’, ‘"atan"’, ‘"atanh"’, ‘"expm1"’, > # ‘"sin"’, ‘"sinh"’, ‘"sinpi"’, > # ‘"tan"’, ‘"tanh"’, ‘"tanpi"’, > > # ‘"cummax"’, ‘"cummin"’, ‘"cumprod"’, ‘"cumsum"’, > # ‘"log"’, ‘"log10"’, ‘"log2"’, ‘"acos"’, ‘"acosh"’, > # , ‘"exp"’, ‘"cos"’, ‘"cosh"’, ‘"cospi"’ > # ‘"gamma"’, ‘"lgamma"’, ‘"digamma"’, ‘"trigamma"’ > > > test.for.zero(abs(ss), abs(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(cos(ss), cos(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(cosh(ss), cosh(tt)) ** PASSED test at tolerance 1e-06 > > spam.options( NAOK=TRUE) # test for equivalence! > > > test.for.zero(gamma(ss), gamma(tt)) # ** PASSED test at tolerance 1e-06 Warning messages: 1: In .Primitive("gamma")(as.matrix(x)) : NaNs produced 2: In gamma(tt) : NaNs produced > test.for.zero(digamma(ss), digamma(tt)) # ** PASSED test at tolerance 1e-06 Warning messages: 1: In .Primitive("digamma")(as.matrix(x)) : NaNs produced 2: In digamma(tt) : NaNs produced > test.for.zero(trigamma(ss), trigamma(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(exp(ss), exp(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(expm1(ss), expm1(tt)) ** PASSED test at tolerance 1e-06 > > > test.for.zero(log(ss), log(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(cummax(ss), cummax(tt)) ** PASSED test at tolerance 1e-06 > > for (f in getGroupMembers("Math")) + test.for.zero( do.call(f, list(ss)), + do.call(f, list(tt)), tag=f) testing: abs ** PASSED test at tolerance 1e-06 testing: sign ** PASSED test at tolerance 1e-06 testing: sqrt ** PASSED test at tolerance 1e-06 testing: ceiling ** PASSED test at tolerance 1e-06 testing: floor ** PASSED test at tolerance 1e-06 testing: trunc ** PASSED test at tolerance 1e-06 testing: cummax ** PASSED test at tolerance 1e-06 testing: cummin ** PASSED test at tolerance 1e-06 testing: cumprod ** PASSED test at tolerance 1e-06 testing: cumsum ** PASSED test at tolerance 1e-06 testing: exp ** PASSED test at tolerance 1e-06 testing: expm1 ** PASSED test at tolerance 1e-06 testing: log ** PASSED test at tolerance 1e-06 testing: log10 ** PASSED test at tolerance 1e-06 testing: log2 ** PASSED test at tolerance 1e-06 testing: log1p ** PASSED test at tolerance 1e-06 testing: cos ** PASSED test at tolerance 1e-06 testing: cosh ** PASSED test at tolerance 1e-06 testing: sin ** PASSED test at tolerance 1e-06 testing: sinh ** PASSED test at tolerance 1e-06 testing: tan ** PASSED test at tolerance 1e-06 testing: tanh ** PASSED test at tolerance 1e-06 testing: acos ** PASSED test at tolerance 1e-06 testing: acosh ** PASSED test at tolerance 1e-06 testing: asin ** PASSED test at tolerance 1e-06 testing: asinh ** PASSED test at tolerance 1e-06 testing: atan ** PASSED test at tolerance 1e-06 testing: atanh ** PASSED test at tolerance 1e-06 testing: cospi ## FAILED test value = 22 at tolerance 1e-06 testing: sinpi ** PASSED test at tolerance 1e-06 testing: tanpi ** PASSED test at tolerance 1e-06 testing: gamma ** PASSED test at tolerance 1e-06 testing: lgamma ** PASSED test at tolerance 1e-06 testing: digamma ** PASSED test at tolerance 1e-06 testing: trigamma ** PASSED test at tolerance 1e-06 There were 50 or more warnings (use warnings() to see the first 50) > > > proc.time() user system elapsed 0.880 0.021 0.883 spam/tests/demo_article-jss.R0000644000176000001440000002600612346261543015765 0ustar ripleyusers# This is file ../spam/tests/demo_article-jss.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # This demo contains the R code to construct the figures and the table of the # article: # "spam: A Sparse Matrix R Package with Emphasis on # MCMC Methods for Gaussian Markov Random Fields" # submitted to JSS. # The code presented here differs in the following points form the actually used # one: # - Very large grid sizes or very high order neighbor structures are not included # here; # - Instead of (100+1) factorizations only (10+1) are performed here; # - No figure fine-tuning is done here. # - We had a few additional gc(), just to be sure. # The following are tests specific. Not all computers run with profiling. Instead # of commenting, we define dummies. options( echo=FALSE) library( spam, warn.conflict=FALSE) Rprof <- function(memory.profiling=TRUE, interval=0.1) return() summaryRprof <- function(memory="both") return(list(by.total=rbind(1:4))) # Figure 1: i <- c( 2,4,4,5,5) j <- c( 1,1,2,1,3) A <- spam(0,5,5) A[cbind(i,j)] <- rep(.5, length(i)) A <- t( A)+A+diag.spam(5) U <- chol( A) pivot <- U@pivot B <- A[pivot,pivot] R <- chol( B) U@pivot U@snmember U@supernodes U@entries U@colindices U@colpointers U@rowpointers if (F){ display( A) display( as.spam( chol(as.matrix( A)))) display( B) display( as.spam(R)) abline( h=-U@supernodes+.5,col=3,lty=2) } # Figure 2: theta1 <- .1 theta2 <- .01 n <- dim( UScounties.storder)[1] USmat <- diag.spam(n) + theta1 * UScounties.storder + theta2 * UScounties.ndorder U <- chol( USmat,memory=list(nnzR=146735)) if (F) { display( as.spam(U)) text(400,-2200,"MMD\nz=146735\nw=30182\ns=1262",adj=0) } U <- chol( USmat, pivot="RCM",memory=list(nnzR=256198,nnzcolindices=140960)) if (F) { display( as.spam(U)) text(400,-2200,"RCM\nz=256198\nw=140960\ns=1706",adj=0) } U <- chol( USmat, pivot=FALSE,memory=list(nnzR=689615,nnzcolindices=96463)) if (F) { display( as.spam(U)) text(400,-2200,"no permutation\nz=689615\nw=96463\ns=711",adj=0) } # general parameters for the following N <- 10 # would be 100 in the article stsel <- 1 # user.self rPsx <- 1 # for function "system.time" rPsy <- 3 # memory usage rPint <- .0001 # small interval # Figure 3: theta1 <- .1 theta2 <- .05 xseq <- ceiling(4 + exp(seq(0,to=4,by=1))/2) # would be seq(0.5,to=6,by=.5) in the article xseql <- length(xseq) table <- array(NA,c(xseql,4)) for (ix in 1:xseql) { egdx <- expand.grid(1:xseq[ix],1:xseq[ix]) Cspam <- nearest.dist( egdx, delta=1., upper=NULL) Dspam <- nearest.dist( egdx, delta=1.5,upper=NULL) mat <- diag.spam(xseq[ix]^2) + theta1 * Cspam + theta2 * Dspam Rprof( memory.profiling=TRUE, interval = rPint) table[ix,1] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch1 <- chol(mat)} )[stsel] Rprof( NULL) table[ix,2] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[ix,3] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch2 <- update(ch1,mat) } )[stsel] Rprof( NULL) table[ix,4] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] } if (F) { # Since we have a small N, elements in table might be zero. table <- pmax(table, 0.0001) par(mfcol=c(1,2)) plot(xseq, table[,1], type='l', log='xy', ylim=range(table[,c(1,3)]), xlab="L (log scale)", ylab="seconds (log scale)") lines(xseq, table[,3], lty=2) plot(xseq, table[,2], type='l', log='xy', ylim=range(table[,c(2,4)]+0.01), xlab="L (log scale)", ylab="Mbytes (log scale)") lines(xseq, table[,4], lty=2) } # Figure 4: x <- 20 # was 50 in article maxnn <- 3 # was 6 in article egdx <- expand.grid( 1:(maxnn+1), 1:(maxnn+1)) dval <- sort(unique(nearest.dist( egdx, delta=maxnn)@entries)) dvall <- length( dval) egdx <- expand.grid( 1:x, 1:x) table <- array(NA, c(dvall,5)) for (id in 1:dvall) { mat <- nearest.dist( egdx, delta=dval[id],upper=NULL) mat@entries <- exp(-2*mat@entries) # arbitrary values to get a spd precision matrix table[id,5] <- length(Cspam) Rprof( memory.profiling=TRUE, interval = rPint) table[id,1] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch1 <- chol(mat)} )[stsel] Rprof( NULL) table[id,2] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[id,3] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch2 <- update(ch1,mat) } )[stsel] Rprof( NULL) table[id,4] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] } if (F) { # Since we have a small N, elements in table might be zero. table <- pmax(table, 0.0001) par(mfcol=c(1,2)) plot( dval, table[,1], type='l', log='xy',ylim=range(table[,c(1,3)]), xlab="distance (log scale)", ylab="seconds (log scale)") lines( dval, table[,3],lty=2) plot( dval, table[,2], type='l', log='xy',ylim=range(table[,c(2,4)]), xlab="distance (log scale)", ylab="Mbytes (log scale)") lines( dval, table[,4],lty=2) } # Table 1: table <- array(NA,c(9,4)) x <- 10 # was 50 in article egdx <- expand.grid(1:x,1:x) # As above hence shortend gridmat <- diag.spam(x^2) + .2 * nearest.dist( egdx, delta=1.,upper=NULL) + .1 * nearest.dist( egdx, delta=1.5,upper=NULL) # USmat was constructed above. # Generic call first: Rprof( memory.profiling=TRUE, interval = rPint) table[1,1] <- system.time( for (i in 1:N) ch1 <- chol(gridmat) )[stsel] Rprof( NULL) table[1,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[1,3] <- system.time( for (i in 1:N) ch2 <- chol(USmat) )[stsel] Rprof( NULL) table[1,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Call a chol.spam directly Rprof( memory.profiling=TRUE, interval = rPint) table[2,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat))[stsel] Rprof( NULL) table[2,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[2,3] <- system.time( for (i in 1:N) ch2 <- chol.spam(USmat) )[stsel] Rprof( NULL) table[2,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Less checking: spam.options( safemode=c(FALSE, FALSE, FALSE)) Rprof( memory.profiling=TRUE, interval = rPint) table[3,1] <- system.time( for (i in 1:N) ch1 <- chol( gridmat) )[stsel] Rprof( NULL) table[3,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[3,3] <- system.time( for (i in 1:N) ch2 <- chol( USmat) )[stsel] Rprof( NULL) table[3,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] spam.options( safemode=c(TRUE, TRUE, TRUE)) # lesser checking spam.options( cholsymmetrycheck=FALSE) Rprof( memory.profiling=TRUE, interval = rPint) table[4,1] <- system.time( for (i in 1:N) ch1 <- chol( gridmat) )[stsel] Rprof( NULL) table[4,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[4,3] <- system.time( for (i in 1:N) ch2 <- chol( USmat) )[stsel] Rprof( NULL) table[4,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] spam.options( cholsymmetrycheck=TRUE) # Pass optimal memory parameters (from above memory1 = summary(ch1)[1:2] memory2 = summary(ch2)[1:2] Rprof( memory.profiling=TRUE, interval = rPint) table[5,1] <- system.time( for (i in 1:N) ch1 <- chol( gridmat,memory=memory1) )[stsel] Rprof( NULL) table[5,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[5,3] <- system.time( for (i in 1:N) ch2 <- chol( USmat,memory=memory2) )[stsel] Rprof( NULL) table[5,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # All of the above spam.options( cholsymmetrycheck=FALSE, safemode=c(FALSE,FALSE,FALSE)) Rprof( memory.profiling=TRUE, interval = rPint) table[6,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat,memory=memory1) )[stsel] Rprof( NULL) table[6,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[6,3] <- system.time( for (i in 1:N) ch2 <- chol.spam(USmat,memory=memory2) )[stsel] Rprof( NULL) table[6,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # supply the permutation pivot1 <- ch1@pivot pivot2 <- ch2@pivot Rprof( memory.profiling=TRUE, interval = rPint) table[7,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat,pivot=pivot1, memory=memory1) )[stsel] Rprof( NULL) table[7,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[7,3] <- system.time( for (i in 1:N) ch1 <- chol.spam(USmat,pivot=pivot2, memory=memory2) )[stsel] Rprof( NULL) table[7,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Do not check the permutation spam.options( cholpivotcheck=FALSE) Rprof( memory.profiling=TRUE, interval = rPint) table[8,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat,pivot=pivot1, memory=memory1) )[stsel] Rprof( NULL) table[8,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[8,3] <- system.time( for (i in 1:N) ch2 <- chol.spam(USmat,pivot=pivot2, memory=memory2) )[stsel] Rprof( NULL) table[8,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Update only Rprof( memory.profiling=TRUE, interval = rPint) table[9,1] <- system.time( for (i in 1:N) ch1 <- update(ch1,gridmat) )[stsel] Rprof( NULL) table[9,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[9,3] <- system.time( for (i in 1:N) ch2 <- update(ch2,USmat) )[stsel] Rprof( NULL) table[9,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # assemble the table colnames(table) <- c("grid_time","grid_mem","US_time","US_mem") rownames(table) <- c("Generic chol","chol.spam","safemode", "symmetrycheck","memory","all","reusing pivot","best cast","update only") normed.table <- t( round( t(table[-1,])/table[1,],3)) if (F) { print( t( round( t(table[-1,])/table[1,],3))) } # Figure 5 In <- diag.spam(nrow(UScounties.storder)) struct <- chol(In + .2 * UScounties.storder + .1 * UScounties.ndorder) len.1 <- 10 # in the article, is set to 180 len.2 <- 5 # in the article, is set to 100 theta.1 <- seq(-.225, to=.515, len=len.1) theta.2 <- seq(-.09, to=.235, len=len.2) grid <- array(NA, c(len.1, len.2)) spam.options('cholupdatesingular'='null') for (i in 1:len.1) for(j in 1:len.2) grid[i,j] <- !is.null(update(struct, In + theta.1[i]*UScounties.storder + theta.2[j]* UScounties.ndorder)) options( echo=TRUE) spam/tests/diff.R0000644000176000001440000000105712375333757013461 0ustar ripleyusers# This is file ../spam/tests/diff.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) spam.options( structurebased=FALSE) # test for equivalence! n <- 10 x <- array(rnorm(n^2),c(n,n)) norm(diff(x)-diff(as.spam(x))) norm(diff(x,d=2)-diff(as.spam(x), d=2)) norm(diff(x,d=4)-diff(as.spam(x), d=4)) norm(diff(x,2, d=2)-diff(as.spam(x),2, d=2)) identical(diff(x,4, d=4), diff(as.spam(x),4, d=4)) spam/tests/subsetting.R0000644000176000001440000000565712346261543014741 0ustar ripleyusers# This is file ../spam/tests/subsetting.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] #options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, tag=NULL){ # slightly different test function! if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) if (any(dim(xtest)!=dim(xtrue))) return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), fill=TRUE)) test.value <- sum( abs(c(xtest) - c( xtrue) ),na.rm=T ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } # subsetting: ######################################################################## # construct matrices (should be at least 3x5, with n # This is file ../spam/tests/overall.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing transpose ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing add/subtracting ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing assigning ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing 'rbind' and 'cbind' ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing 'diag' and derivatives: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing 'as.spam' and derivatives: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing 'as.spam.list' and 'triplet': ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > > proc.time() user system elapsed 1.021 0.021 1.024 spam/tests/foreign.Rout.save0000644000176000001440000000632512403543611015652 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/foreign.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > # A few rudimentary tests to check transformations. > # This is for illustration and will not be run. > > if (FALSE) { + + options( echo=FALSE) + library( spam, warn.conflict=FALSE) + + test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, tag=NULL){ + + if( !is.null(tag)){ + cat( "testing: ", tag, fill=TRUE)} + + + test.value <- sum( abs(c(xtest) - c( xtrue) ) ) + if( test.value < tol ){ + cat("** PASSED test at tolerance ", tol, fill=TRUE)} + else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, + fill=TRUE)} + + } + + + xn <- 3 + xm <- 2 + set.seed(14) + + X <- array(runif(xn*xm), c( xn,xm)) + + S <- as.spam(X) + + R <- as.matrix.csr.spam(S) + test.for.zero(as.matrix(R),X) + + Q <- as.spam.matrix.csr(R) + test.for.zero(Q,X) + + + U <- as.dgRMatrix.spam(S) + test.for.zero(as.matrix(U),S) + + + V <- as.spam.dgRMatrix(U) + test.for.zero(V,X) + + W <- as.dgCMatrix.spam(S) + test.for.zero(as.matrix(W),S) + + Z <- as.spam.dgCMatrix(W) + test.for.zero(Z,X) + + + + + lundAs <- read.HB(system.file("external/lund_a.rsa",package = "Matrix")) + lundAm <- readHB(system.file("external/lund_a.rsa",package = "Matrix")) + test.for.zero(lundAs, as.matrix(lundAm)) + + + + + + lundAs <- read.MM(system.file("external/lund_a.mtx",package = "Matrix")) + lundAm <- readMM(system.file("external/lund_a.mtx",package = "Matrix")) + test.for.zero(lundAs, as.matrix(lundAm)) + + tmp <- read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/bcspwr/bcspwr01.mtx.gz"))) + + image(tmp <- read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/acoust/young1c.mtx.gz")))) + + tmp <- read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/bcspwr/bcspwr01.mtx.gz"))) + + + tmp <-read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/platz/plskz362.mtx.gz"))) + + test.for.zero(sum(upper.tri.spam(tmp) - t( lower.tri.spam(tmp))),0) + test.for.zero(norm(tmp,'F'),8.152348) + test.for.zero(dim(tmp),rep(362,2)) + + + + # use + # file=gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/platz/plskz362.mtx.gz")) + #open(file) + + + + + } > > > proc.time() user system elapsed 0.124 0.020 0.124 spam/tests/dim.Rout.save0000644000176000001440000000544612403543611014775 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/R/definitions.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > library( spam, warn.conflict=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > > > test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, + tag=NULL){ + # slightly different test function! + if( !is.null(tag)){ + cat( "testing: ", tag, fill=TRUE)} + + denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) + + if (any(dim(xtest)!=dim(xtrue))) + return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), + fill=TRUE)) + test.value <- sum( abs(c(as.matrix(xtest)) - c( xtrue) ),na.rm=T ) /denom + if( test.value < tol ){ + cat("** PASSED test at tolerance ", tol, fill=TRUE)} + else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, + fill=TRUE)} + + } > > > > # simple tests: > ######################################################################## > > > # construct matrices: > n <- 10 > m <- 15 > > set.seed(14) > tt <- matrix(rnorm(m*n),n,m) > tt[tt<0] <- 0 > > ss <- as.spam(tt) > > > > > test.for.zero(ss,tt) ** PASSED test at tolerance 1e-06 > > dim(ss) <- c(m,n) > dim(tt) <- c(m,n) > test.for.zero(ss,tt) ** PASSED test at tolerance 1e-06 > > dim(ss) <- c(m*n,1) > dim(tt) <- c(m*n,1) > test.for.zero(ss,tt) ** PASSED test at tolerance 1e-06 > > dim(ss) <- c(1, m*n) > dim(tt) <- c(1, m*n) > test.for.zero(ss,tt) ** PASSED test at tolerance 1e-06 > > try( dim(ss) <- c(-1, -m*n)) Error in spam.list(slist, nrow = value[1], ncol = value[2], eps = .Machine$double.eps) : Indices need to be positive > try( dim(ss) <- c(1, m, n)) Error in `dim<-`(`*tmp*`, value = c(1, 15, 10)) : dims should be of length 1 or 2 > > > > proc.time() user system elapsed 0.836 0.025 0.844 spam/tests/dim.R0000644000176000001440000000251412374456354013317 0ustar ripleyusers# This is file ../spam/R/definitions.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, tag=NULL){ # slightly different test function! if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) if (any(dim(xtest)!=dim(xtrue))) return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), fill=TRUE)) test.value <- sum( abs(c(as.matrix(xtest)) - c( xtrue) ),na.rm=T ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } # simple tests: ######################################################################## # construct matrices: n <- 10 m <- 15 set.seed(14) tt <- matrix(rnorm(m*n),n,m) tt[tt<0] <- 0 ss <- as.spam(tt) test.for.zero(ss,tt) dim(ss) <- c(m,n) dim(tt) <- c(m,n) test.for.zero(ss,tt) dim(ss) <- c(m*n,1) dim(tt) <- c(m*n,1) test.for.zero(ss,tt) dim(ss) <- c(1, m*n) dim(tt) <- c(1, m*n) test.for.zero(ss,tt) try( dim(ss) <- c(-1, -m*n)) try( dim(ss) <- c(1, m, n)) spam/tests/jss_areal_counts.Rout.save0000644000176000001440000001222212403543611017550 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > > > > > # JSS article: > # "Pitfalls in the implementation of Bayesian > # hierarchical modeling of areal count data. > # An illustration using BYM and Leroux models." > # > # test the MCMC sampler from the paper with 30 iterations. > > > # SETUP: > library("spam") Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Attaching package: 'spam' The following objects are masked from 'package:base': backsolve, forwardsolve > spam.options(structurebased=TRUE) > > # BYM --------------------------------------------- > data(Oral); attach(Oral) > path <- system.file("demodata/germany.adjacency", package = "spam") > A <- adjacency.landkreis(path); n <- dim(A)[1] > > set.seed(2) > hyperA <- c(1, 1); hyperB <- c(0.5, .01) > totalg <- 30 > > upost <- vpost <- array(0, c(totalg, n)) > kpost <- array(NA, c(totalg, 2)); accept <- rep(NA, totalg) > upost[1,] <- vpost[1,] <- rep(.001, 544); kpost[1,] <- c(10, 100) > > eta <- upost[1,] + vpost[1,] > C <- exp(eta) * E; diagC <- diag.spam(c(rep(0, n), C)) > b <- c( rep(0, n), Y + (eta - 1) * C) > Qu <- R <- precmat.IGMRFirreglat(A); pad(Qu) <- c(2 * n, 2 * n) > Qv <- as.spam(rbind(cbind( diag(n), -diag(n)), + cbind(-diag(n), diag(n)))) > Q <- kpost[1,1] * Qu + kpost[1,2] * Qv + diagC > struct <- chol(Q, memory = list(nnzcolindices = 6467)) > uRuHalf <- t(upost[1,]) %*% (R %*% upost[1,]) / 2 > vvHalf <- t(vpost[1,]) %*% vpost[1,] / 2 > postshape <- hyperA + c(n - 1, n) / 2 > > for (i in 2:totalg) { + kpost[i,] <- rgamma(2, postshape, hyperB + c(uRuHalf, vvHalf)) + + etaTilde <- eta + for(index in 1:2){ + C <- E * exp(etaTilde) + diagC <- diag.spam(c(rep(0, n), C)) + b <- c(rep(0, 544), Y + (etaTilde - 1) * C) + Q <- kpost[i,1] * Qu + kpost[i,2] * Qv + diagC + etaTilde <- c(solve.spam(Q, b, + Rstruct = struct))[1:n + n] + } + + C <- exp(etaTilde) * E; diagC <- diag.spam(c(rep(0, n), C)) + b <- c( rep(0, n), Y + (etaTilde - 1) * C) + Q <- kpost[i,1] * Qu + kpost[i,2] * Qv + diagC + + x_ <- c(rmvnorm.canonical(1, b, Q, Rstruct = struct)) + upost[i,] <- x_[1:n]; eta_ <- x_[1:n + n]; vpost[i,] <- eta_ - upost[i,] + uRuHalf_ <- t(upost[i,]) %*% (R %*% upost[i,]) / 2 + vvHalf_ <- t(vpost[i,]) %*% vpost[i,] / 2 + + etaTilde_ <- eta_ + for(index in 1:2){ + C_ <- E * exp(etaTilde_) + diagC_ <- diag.spam(c(rep(0, n), C_)) + b_ <- c(rep(0, 544), Y + (etaTilde_ - 1) * C_) + Q_<- kpost[i,1] * Qu + kpost[i,2] * Qv + diagC_ + etaTilde_ <- c(solve.spam(Q_, b_, + Rstruct = struct))[1:n + n] + } + + C_ <- exp(etaTilde_) * E; diagC_ <- diag.spam(c(rep(0, n), C_)) + b_ <- c( rep(0, n), Y + (etaTilde_ - 1) * C_) + Q_ <- kpost[i,1] * Qu + kpost[i,2] * Qv + diagC_ + + logPost_ <- sum(Y * eta_ - E * exp(eta_)) - + kpost[i,1] * uRuHalf_ - kpost[i, 2] * vvHalf_ + logPost <- sum(Y * eta - E * exp(eta)) - kpost[i,1] * uRuHalf - + kpost[i,2] * vvHalf + logApproxX_ <- - kpost[i,1] * uRuHalf_ - kpost[i,2] * vvHalf_ - + sum(.5 * eta_^2 * C) + sum(b * eta_) + logApproxX <- - kpost[i,1] * uRuHalf - kpost[i,2] * vvHalf - + sum(.5 * eta^2 * C_) + sum(b_ * eta) + logAlpha <- min(0, logPost_ - logPost + logApproxX - logApproxX_) + + if (log(runif(1)) < logAlpha) { + uRuHalf <- uRuHalf_; vvHalf <- vvHalf_ + eta <- eta_; b <- b_; C <- C_; accept[i] <- 1 + } else{ + accept[i] <- 0; upost[i,] <- upost[i-1,]; vpost[i,] <- vpost[i-1,]} + } > > # values of 30th iteration > head(eta) [1] -0.45371922 0.17297575 0.02605778 -0.44984751 -0.36053283 0.01309363 > tail(b) [1] -1.341895 -3.756725 -2.514229 -4.411210 -6.486653 -5.101487 > head(C) [1] 15.05715 53.22751 41.15492 13.16245 19.87138 30.27948 > tail(accept) [1] 0 1 1 1 1 0 > tail(upost[30,]) [1] 0.255439209 -0.299099415 -0.004660022 -0.392147580 -0.318792450 [6] -0.344095560 > tail(vpost[30,]) [1] -0.0152950744 0.0008418105 0.0400659014 -0.0160847172 0.0064331753 [6] -0.0154282422 > sum(accept[-1]) [1] 21 > sum(upost) [1] -780.3814 > > > proc.time() user system elapsed 1.606 0.030 1.619 spam/tests/demo_timing.Rout.save0000644000176000001440000000431612403543611016512 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/demo_timing.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > # We construct a few large matrices and we compare how much faster (slower) > # we are compared to the full matrix analysis. > # Since all the calculation are also done with full matrices, we do not > # exagerate with the sizes. > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Comparing: Transpose Comparing: multiplication Comparing: solving Comparing: Transpose Comparing: multiplication Comparing: add identity Comparing: add identity quicker Comparing: solving Matrix object of class 'spam' of dimension 10x10, with 10 (row-wise) nonzero elements. Density of the matrix is 10%. Class 'spam' > > > > > > # illustrate the new spam x matrix multiply: > if (F){ + n <- 1000 + + A <- spam(0,n,n) + A[cbind(1:(n-1),2:n)] <- -c(2,rep(4,n-3),2) + A[cbind(1:(n-2),3:n)] <- rep(1,n-2) + A <- A + t( A) + diag(A) <- c(1,5,rep(6,n-4),5,1) + + + B <- array(rnorm(n*n),c(n,n)) + + system.time(C1 <- .spam.matmul.mat(A,B)) + system.time(C2 <- .spam.matmul(A,B)) + norm(C1-C2) + + + } > > proc.time() user system elapsed 1.477 0.029 1.489 spam/tests/xybind.Rout.save0000644000176000001440000000535112403543611015514 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/xybind.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > ###################################################################### > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Testing rbind: Testing with two matrices: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing with vectors and scalars: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing with NULL: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing cbind: Testing with two matrices: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing with vectors and scalars: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing with NULL: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > > proc.time() user system elapsed 0.884 0.026 0.902 spam/tests/math.R0000644000176000001440000000677012375026470013500 0ustar ripleyusers# This is file ../spam/R/definitions.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, tag=NULL){ # slightly different test function! if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom <- ifelse( relative, mean( abs(c(xtrue))),1.0) if (any(dim(xtest)!=dim(xtrue))) return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), fill=TRUE)) test.value <- sum( abs(c(as.matrix(xtest)) - c( xtrue) ),na.rm=T ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } # construct matrices: n <- 10 m <- 5 set.seed(14) tt <- matrix(rnorm(m*n),n,m) tt[tt<0] <- 0 ss <- as.spam(tt) spam.options( structurebased=FALSE) # test for equivalence! # ‘Math’ ‘"abs"’, ‘"sign"’, ‘"sqrt"’, ‘"ceiling"’, ‘"floor"’, # ‘"trunc"’, ‘"cummax"’, ‘"cummin"’, ‘"cumprod"’, ‘"cumsum"’, # ‘"log"’, ‘"log10"’, ‘"log2"’, ‘"log1p"’, ‘"acos"’, ‘"acosh"’, # ‘"asin"’, ‘"asinh"’, ‘"atan"’, ‘"atanh"’, ‘"exp"’, ‘"expm1"’, # ‘"cos"’, ‘"cosh"’, ‘"cospi"’, ‘"sin"’, ‘"sinh"’, ‘"sinpi"’, # ‘"tan"’, ‘"tanh"’, ‘"tanpi"’, ‘"gamma"’, ‘"lgamma"’, # ‘"digamma"’, ‘"trigamma"’ # ‘Math2’ ‘"round"’, ‘"signif"’ # ‘Summary’ ‘"max"’, ‘"min"’, ‘"range"’, ‘"prod"’, ‘"sum"’, ‘"any"’, ‘"all"’ # # ! A <- diag.spam(4) ; B <- diag(4) test.for.zero(A, B) test.for.zero(!A, !B) diag(A)=0 ; diag(B) <- 0 test.for.zero(!A, !B) # str(A) # is what needs to be expected..., # different to spam:::complement.spam(A) # ‘Summary’ test.for.zero(max(ss), max(tt)) test.for.zero(min(ss), min(tt)) test.for.zero(range(ss), range(tt)) test.for.zero(prod(ss), prod(tt)) test.for.zero(sum(ss), sum(tt)) test.for.zero(any(ss), any(tt)) test.for.zero(all(ss), all(tt)) # ‘Math2’ test.for.zero(round(ss), round(tt)) test.for.zero(signif(ss), signif(tt)) # ‘Math’ ‘"abs"’, ‘"sign"’, ‘"sqrt"’, ‘"ceiling"’, ‘"floor"’, # ‘"trunc"’, ‘"log1p"’ # ‘"asin"’, ‘"asinh"’, ‘"atan"’, ‘"atanh"’, ‘"expm1"’, # ‘"sin"’, ‘"sinh"’, ‘"sinpi"’, # ‘"tan"’, ‘"tanh"’, ‘"tanpi"’, # ‘"cummax"’, ‘"cummin"’, ‘"cumprod"’, ‘"cumsum"’, # ‘"log"’, ‘"log10"’, ‘"log2"’, ‘"acos"’, ‘"acosh"’, # , ‘"exp"’, ‘"cos"’, ‘"cosh"’, ‘"cospi"’ # ‘"gamma"’, ‘"lgamma"’, ‘"digamma"’, ‘"trigamma"’ test.for.zero(abs(ss), abs(tt)) test.for.zero(cos(ss), cos(tt)) test.for.zero(cosh(ss), cosh(tt)) spam.options( NAOK=TRUE) # test for equivalence! test.for.zero(gamma(ss), gamma(tt)) # test.for.zero(digamma(ss), digamma(tt)) # test.for.zero(trigamma(ss), trigamma(tt)) test.for.zero(exp(ss), exp(tt)) test.for.zero(expm1(ss), expm1(tt)) test.for.zero(log(ss), log(tt)) test.for.zero(cummax(ss), cummax(tt)) for (f in getGroupMembers("Math")) test.for.zero( do.call(f, list(ss)), do.call(f, list(tt)), tag=f) spam/tests/mle.Rout.save0000644000176000001440000000346612403543611015001 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/mle.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 testing: Expect a warning ** PASSED test at tolerance 1e-06 Warning message: In neg2loglikelihood.spam(y, X, distmat, cov.sph.mat, truebeta, : 'Covariance' should return a spam object. Forced to spam. ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > > proc.time() user system elapsed 6.974 0.038 6.995 spam/tests/demo_cholesky.R0000644000176000001440000001043212346261543015362 0ustar ripleyusers# This is file ../spam/tests/demo_cholesky.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # We illustrate the Cholesky decompostion approaches options( echo=FALSE) library( spam, warn.conflict=FALSE) set.seed(14) # first start with a full matrix. xn <- 50 fmat1 <- matrix(rnorm(xn*xn),xn,xn) fmat1 <- t( fmat1) %*% fmat1 smat1 <- as.spam(fmat1) smat2 <- smat1 + diag.spam(xn) # Generic Cholesky # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( fmat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, direct call # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, without symmetry check spam.options(cholsymmetrycheck=FALSE) # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, reusing pivoting # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1,pivot=ch1@pivot) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, updating # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- update.spam.chol.NgPeyton( ch1, smat2) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # reset to default spam.options(cholsymmetrycheck=TRUE) # now create a sparse matrix. fmat1[fmat1<3] <- 0 smat1 <- as.spam(fmat1) smat2 <- smat1 + diag.spam(xn) # Generic Cholesky # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( fmat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, direct call # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, without symmetry check spam.options(cholsymmetrycheck=FALSE) # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, reusing pivoting # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1,pivot=ch1@pivot) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, updating # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- update.spam.chol.NgPeyton( ch1, smat2) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # reset to default spam.options(cholsymmetrycheck=TRUE) # now create an even sparser matrix. fmat1 <- fmat1+20*diag(xn) fmat1[fmat1<32] <- 0 smat1 <- as.spam(fmat1) smat2 <- smat1 + 1* diag.spam(xn) # Generic Cholesky # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( fmat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, direct call # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, without symmetry check spam.options(cholsymmetrycheck=FALSE) # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, reusing pivoting spam.options(cholsymmetrycheck=FALSE) # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1,pivot=ch1@pivot) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, updating spam.options(cholsymmetrycheck=FALSE) # tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- update.spam.chol.NgPeyton( ch1, smat2) # Rprof(NULL);print( summaryRprof(memory="both")$by.total) # reset to default spam.options(cholsymmetrycheck=TRUE) options( echo=TRUE) spam/tests/foreign.R0000644000176000001440000000445312346261543014174 0ustar ripleyusers# This is file ../spam/tests/foreign.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # A few rudimentary tests to check transformations. # This is for illustration and will not be run. if (FALSE) { options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, tag=NULL){ if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} test.value <- sum( abs(c(xtest) - c( xtrue) ) ) if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } xn <- 3 xm <- 2 set.seed(14) X <- array(runif(xn*xm), c( xn,xm)) S <- as.spam(X) R <- as.matrix.csr.spam(S) test.for.zero(as.matrix(R),X) Q <- as.spam.matrix.csr(R) test.for.zero(Q,X) U <- as.dgRMatrix.spam(S) test.for.zero(as.matrix(U),S) V <- as.spam.dgRMatrix(U) test.for.zero(V,X) W <- as.dgCMatrix.spam(S) test.for.zero(as.matrix(W),S) Z <- as.spam.dgCMatrix(W) test.for.zero(Z,X) lundAs <- read.HB(system.file("external/lund_a.rsa",package = "Matrix")) lundAm <- readHB(system.file("external/lund_a.rsa",package = "Matrix")) test.for.zero(lundAs, as.matrix(lundAm)) lundAs <- read.MM(system.file("external/lund_a.mtx",package = "Matrix")) lundAm <- readMM(system.file("external/lund_a.mtx",package = "Matrix")) test.for.zero(lundAs, as.matrix(lundAm)) tmp <- read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/bcspwr/bcspwr01.mtx.gz"))) image(tmp <- read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/acoust/young1c.mtx.gz")))) tmp <- read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/bcspwr/bcspwr01.mtx.gz"))) tmp <-read.MM(gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/platz/plskz362.mtx.gz"))) test.for.zero(sum(upper.tri.spam(tmp) - t( lower.tri.spam(tmp))),0) test.for.zero(norm(tmp,'F'),8.152348) test.for.zero(dim(tmp),rep(362,2)) # use # file=gzcon(url("ftp://math.nist.gov/pub/MatrixMarket2/Harwell-Boeing/platz/plskz362.mtx.gz")) #open(file) } spam/tests/kronecker.R0000644000176000001440000000413212346261543014520 0ustar ripleyusers# This is file ../spam/tests/kronecker.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=TRUE, tag=NULL){ if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) test.value <- sum( abs(c(xtest) - c( xtrue) ) ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } ######## spam.options(printsize=6) xn <- 3 xm <- 2 yn <- 4 ym <- 2 set.seed(14) X <- array(runif(xn*xm), c( xn,xm)) Y <- array(runif(yn*ym), c( yn,ym)) R <- as.spam(X) S <- as.spam(Y) b <- rnorm(5) # with matrices cat("Testing with two matrices:\n") test.for.zero( kronecker( X, Y), kronecker.spam( X, Y) ) test.for.zero( kronecker( X, Y), kronecker.spam( R, S) ) test.for.zero( kronecker( X, Y), kronecker( R, S) ) test.for.zero( kronecker( X, Y), kronecker( R, Y) ) test.for.zero( kronecker( X, Y), kronecker( X, S) ) cat("Testing with a matrix and a vector:\n") test.for.zero( kronecker( X, b), kronecker.spam( X, b) ) test.for.zero( kronecker( b, Y), kronecker.spam( b, S) ) test.for.zero( kronecker( X, b), kronecker( R, b) ) test.for.zero( kronecker( b, Y), kronecker( b, S) ) cat("Testing degenerate cases\n") test.for.zero( kronecker( X, 0), kronecker.spam( X, 0),rel=FALSE ) test.for.zero( kronecker( 0, 0), kronecker.spam( 0, 0),rel=FALSE ) test.for.zero( kronecker( 0, Y), kronecker( spam(0), Y),rel=FALSE ) cat("Testing for different operators:\n") test.for.zero( kronecker(X,Y,FUN="+"),kronecker(R,S,FUN="+")) test.for.zero( kronecker(X,b,FUN="+"),kronecker(R,b,FUN="+")) test.for.zero( kronecker(c(0,1,0),Y,FUN="+"),kronecker(c(0,1,0),S,FUN="+")) cat(" expect a warning from testing and from 'kronecker':\n") test.for.zero( kronecker(diag(2),Y,FUN="+"),kronecker(diag.spam(2),S,FUN="+")) spam/tests/kronecker.Rout.save0000644000176000001440000000410112403543611016172 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/kronecker.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Testing with two matrices: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing with a matrix and a vector: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing degenerate cases ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing for different operators: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 expect a warning from testing and from 'kronecker': ## FAILED test value = 11.69646 at tolerance 1e-06 Warning message: Sparseness structure of 'kronecker(X,Y)' preseved when applying 'FUN'. > proc.time() user system elapsed 0.853 0.020 0.853 spam/tests/mle.R0000644000176000001440000001166512375433727013332 0ustar ripleyusers# This is file ../spam/tests/mle.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=TRUE, tag=NULL){ if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) test.value <- sum( abs(c(xtest) - c( xtrue) ) ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } ################## _DO NOT CHANGE THE PARAMETERS_ ################# # Optimization uses these values for a quick run through!!! truebeta <- c(1,2,.2) truetheta <- c(.5,2,.02) spherical <- function(distmat, theta, eps = 1e-06) { Sigma <- distmat d <- Sigma@entries/theta[1] Sigma@entries <- ifelse(d < eps, theta[3]+ theta[2], ifelse(d < 1, theta[2]*(1 - 1.5*d + 0.5*d^3), 0)) return( Sigma) } sphericalmat <- function(distmat, theta, eps = 1e-06) { Sigma <- distmat d <- Sigma@entries/theta[1] Sigma@entries <- ifelse(d < eps, theta[3]+ theta[2], ifelse(d < 1, theta[2]*(1 - 1.5*d + 0.5*d^3), 0)) return( as.matrix(Sigma)) } xl <- 10 x <- seq(0,1,l=xl) locs <- expand.grid(x,x) X <- as.matrix(cbind(1,locs)) # design matrix cov.sph.mat <- function(...) as.matrix(cov.sph(...)) # covariance function distmat <- nearest.dist(locs,upper=NULL) # distance matrix Sigma <- cov.sph(distmat,truetheta) # true covariance matrix set.seed(15) y <- c(rmvnorm.spam(1,X%*%truebeta,Sigma)) # construct samples test.for.zero(round(neg2loglikelihood.spam( y, X, distmat, cov.sph, truebeta, truetheta),2), 262.98) test.for.zero(round(neg2loglikelihood( y, X, distmat, cov.sph, truebeta, truetheta),2), 262.98) test.for.zero(round(neg2loglikelihood( y, X, distmat, cov.sph.mat, truebeta, truetheta),2), 262.98) test.for.zero(round(neg2loglikelihood.spam( y, X, distmat, cov.sph.mat, truebeta, truetheta),2), 262.98, tag="Expect a warning") # we pass now to the mle: # not that we should set: # ,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf) # for quicker testing we use res1 <- mle.spam(y, X, distmat, cov.sph, truebeta, truetheta,thetalower=c(0.4,1.5,0.02),thetaupper=c(.6,2.5,.1)) # truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) betahat <- res1$par[1:3] test.for.zero(round(res1$par,2), c(2.35, 1.45, -0.58, 0.50, 1.70, 0.08)) test.for.zero(round(res1$val,2), 259.03) if (F){ # takes too long... res2 <- mle(y, X, distmat, cov.sph, truebeta, truetheta,thetalower=c(0.4,1.5,0.02),thetaupper=c(.6,2.5,.1)) # truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) res3 <- mle(y, X, distmat, cov.sph.mat, truebeta, truetheta,thetalower=c(0.4,1.5,0.02),thetaupper=c(.6,2.5,.1)) # truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) test.for.zero(round(res2$par,2), c(2.35, 1.45, -0.58, 0.50, 1.70, 0.08)) test.for.zero(round(res2$val,2), 259.03) test.for.zero(round(res3$par,2), c(2.35, 1.45, -0.58, 0.50, 1.70, 0.08)) test.for.zero(round(res3$val,2), 259.03) } res1 <- mle.nomean.spam(y-X%*%betahat, distmat, cov.sph, # truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) truetheta,thetalower=c(0.4,1,0.02),thetaupper=c(.6,2.5,.1)) res2 <- mle.nomean(y-X%*%betahat, distmat, cov.sph, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) res3 <- mle.nomean(y-X%*%betahat, distmat, cov.sph.mat, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) test.for.zero(round(res1$par,2), c( 0.50, 1.70, 0.08)) test.for.zero(round(res1$val,2), 259.03) test.for.zero(round(res2$par,2), c( 0.50, 1.70, 0.08)) test.for.zero(round(res2$val,2), 259.03) test.for.zero(round(res3$par,2), c( 0.50, 1.70, 0.08)) test.for.zero(round(res3$val,2), 259.03) ##########################33 if (F){ system.time({ res1 <- mle.spam(y, X, distmat, cov.sph, truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) }) system.time({ res2 <- mle(y, X, distmat, cov.sph, truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) }) system.time({ res3 <- mle(y, X, distmat, cov.sph.mat, truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) }) } # note that if (F) { forwardsolve(cholSmat, resid,transpose=T,upper.tri=T)-forwardsolve(t(cholSmat), resid) backsolve(cholS,forwardsolve(cholS, resid,transpose=T,upper.tri=T))- backsolve(cholSmat,forwardsolve(t(cholSmat), resid)) backsolve(cholS,forwardsolve(t(cholS), resid))- backsolve(cholSmat,forwardsolve(t(cholSmat), resid)) } options( echo=TRUE) spam/tests/displays.Rout.save0000644000176000001440000000236512403543611016051 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/displays.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > proc.time() user system elapsed 1.059 0.023 1.073 spam/tests/permutation.Rout.save0000644000176000001440000000327712403543611016573 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/permutation.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > proc.time() user system elapsed 1.017 0.031 1.031 spam/tests/demo_timing.R0000644000176000001440000000437612346261543015042 0ustar ripleyusers# This is file ../spam/tests/demo_timing.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # We construct a few large matrices and we compare how much faster (slower) # we are compared to the full matrix analysis. # Since all the calculation are also done with full matrices, we do not # exagerate with the sizes. options( echo=FALSE) library( spam, warn.conflict=FALSE) set.seed(14) # In the test function, we do not print out the actual times # We would get too many differences pointed out! compare <- function(expr1,expr2,tag=NULL) { if( !is.null(tag)) cat( "Comparing: ", tag, fill=TRUE) invisible(data.frame(full=system.time( expr1, TRUE)[1:3], sparse=system.time( expr2, TRUE)[1:3], row.names=c("user","system","elapsed"))) } xn <- 10 xm <- 12 # first start with a full matrix. fmat1 <- matrix(rnorm(xn*xm),xn,xm) smat1 <- as.spam(fmat1) compare(fmat2 <- t(fmat1), smat2 <- t(smat1), "Transpose") compare(ffmat <- fmat1 %*% fmat2, ssmat <- smat1 %*% smat2, "multiplication") compare( solve(ffmat), solve(ssmat), "solving") compare(rbind(fmat1,fmat1),rbind(smat1,smat1)) compare(cbind(fmat1,fmat1),cbind(smat1,smat1)) # now create a sparse matrix. fmat1[fmat1<3] <- 0 smat1 <- as.spam(fmat1) compare(fmat2 <- t(fmat1), smat2 <- t(smat1), "Transpose") compare(ffmat <- fmat1 %*% fmat2, ssmat <- smat1 %*% smat2, "multiplication") compare(ffmat <- ffmat + diag(xn), ssmat <- ssmat + diag.spam(xn), "add identity") compare(ffmat <- 1:xn %d+% ffmat, ssmat <- 1:xn %d+% ssmat, "add identity quicker") compare( solve(ffmat), solve(ssmat), "solving") summary(ssmat) # compare a few cbind/rbinds compare(rbind(fmat1,fmat1),rbind(smat1,smat1)) compare(cbind(fmat1,fmat1),cbind(smat1,smat1)) options( echo=TRUE) # illustrate the new spam x matrix multiply: if (F){ n <- 1000 A <- spam(0,n,n) A[cbind(1:(n-1),2:n)] <- -c(2,rep(4,n-3),2) A[cbind(1:(n-2),3:n)] <- rep(1,n-2) A <- A + t( A) diag(A) <- c(1,5,rep(6,n-4),5,1) B <- array(rnorm(n*n),c(n,n)) system.time(C1 <- .spam.matmul.mat(A,B)) system.time(C2 <- .spam.matmul(A,B)) norm(C1-C2) } spam/tests/rowcolstats.R0000644000176000001440000000364212346261543015126 0ustar ripleyusers# This is file ../spam/tests/rowcolstats.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] #options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, tag=NULL){ # slightly different test function! if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) if (any(dim(xtest)!=dim(xtrue))) return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), fill=TRUE)) test.value <- sum( abs(c(xtest) - c( xtrue) ),na.rm=T ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } # simple tests: ######################################################################## # construct matrices: n <- 10 m <- 15 set.seed(14) tt <- matrix(rnorm(m*n),n,m) tt[tt<0] <- 0 ss <- as.spam(tt) test.for.zero(rowSums(ss),rowSums(tt)) test.for.zero(colSums(ss),colSums(tt)) spam.options(structurebased=FALSE) test.for.zero(rowMeans(ss),rowMeans(tt)) # ok test.for.zero(colMeans(ss),colMeans(tt)) # ok spam.options(structurebased=TRUE) test.for.zero(rowMeans(ss),rowSums(tt)/apply(tt>0,1,sum)) # ok test.for.zero(colMeans(ss),colSums(tt)/apply(tt>0,2,sum)) # ok test.for.zero(rowMeans(ss),apply.spam(ss,1,mean)) # ok test.for.zero(colMeans(ss),apply.spam(ss,2,mean)) # ok test.for.zero(rowMeans(spam(0,n,m)),rowMeans(tt*0)) # ok test.for.zero(colMeans(spam(0,n,m)),colMeans(tt*0)) # ok test.for.zero(rowMeans(as.spam(diag(0,n))),rowMeans(diag(0,n))) # ok test.for.zero(colMeans(as.spam(diag(0,n))),colMeans(diag(0,n))) # ok spam.options(structurebased=TRUE) options( echo=TRUE) spam/tests/spamlist.Rout.save0000644000176000001440000000304112403543611016045 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/spamlist.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > > proc.time() user system elapsed 0.855 0.007 0.847 spam/tests/overall.R0000644000176000001440000002010012375333642014174 0ustar ripleyusers# This is file ../spam/tests/overall.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) spam.options(structurebased=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=TRUE, tag=NULL){ if( !is.null(tag)) cat( "testing: ", tag, fill=TRUE) denom <- ifelse( relative, mean( abs(c(xtrue))),1.0) test.value <- sum( abs(c(xtest) - c( xtrue) ) ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE) }else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } # construct matrices (should be at least 3x5, with n0] <- 1:length(ss2) # Nonzero values are identic but subsetting does not return same structure ss[ss2[1:3,1:3]] ss[tt2[1:3,1:3]>0] # latter two identic tt[tt2[1:3,1:3]>0] # The following commands do not work ss[ss2] <- 1:length(ss2) # error, wrong format ss[as.spam(tmp <- array(1:15,c(5,3)))] # error, wrong format ss[ array(sample(1:15,24,rep=T),c(12,2))] # works not because out of bounds ss[numeric(0),] # error, at least one element is needed... } ss[cbind(1,1)] <- 4;tt[cbind(1,1)] <- 4 test.for.zero(ss,tt) ss[rbind(dim(ss))] <- 4;tt[rbind(dim(tt))] <- 4 test.for.zero(ss,tt) ss[rbind(c(1,1),dim(ss))] <- c(0.1,0.1);tt[rbind(c(1,1),dim(tt))] <- c(0.1,0.1) test.for.zero(ss,tt) rw <- c(1,3);cl <- 1:3; ss[rw,cl] <- 1:3;tt[rw,cl] <- 1:3 test.for.zero(ss,tt) rw <- c(3,1);cl <- 1:3; ss[rw,cl] <- 1:3;tt[rw,cl] <- 1:3 test.for.zero(ss,tt) nn <- length(tt[-rw,-cl]) test.for.zero(ss[-rw,-cl] <- 1:nn,tt[-rw,-cl] <- 1:nn) nn <- length(tt[-rw,cl]) test.for.zero(ss[-rw,cl] <- 1:nn,tt[-rw,cl] <- 1:nn) nn <- length(tt[rw,-cl]) test.for.zero(ss[rw,-cl] <- 1:nn,tt[rw,-cl] <- 1:nn) # mathstuff test.for.zero(sqrt(ss),sqrt(tt)) test.for.zero(lower.tri(ss),lower.tri(tt)&tt!=0) test.for.zero(lower.tri(ss,F),lower.tri(tt,F)&tt!=0) test.for.zero(upper.tri(ss),upper.tri(tt)&tt!=0) test.for.zero(upper.tri(ss,F),upper.tri(tt,F)&tt!=0) if (F) {# only works for full matrices test.for.zero(ss/tt,tt/tt) test.for.zero(ss/ss,tt/tt) kk <- tt/tt kk[is.na(kk)] <- 0 test.for.zero(ss/tt,kk) test.for.zero(ss/ss,kk) test.for.zero(ss^tt,tt^tt) test.for.zero(ss^ss,tt^tt) } # maybe not all of them make sense if (F) { # this need to be discussed ss/ss test.for.zero(ss2/tt2,tt2/tt2) test.for.zero(ss2^tt2,tt2^tt2) test.for.zero(ss2/ss2,tt2/tt2) test.for.zero(ss2^ss2,tt2^tt2) } # testing rbind/cbind cat("Testing 'rbind' and 'cbind'\n") test.for.zero(rbind(tt,t(tt2)), rbind(ss,t(ss2))) test.for.zero(rbind(tt,tt,t(tt2),1:ncol(tt)), rbind(ss,ss,t(ss2),t(spam(1:ncol(tt))))) test.for.zero(cbind(tt,t(tt2)), cbind(ss,t(ss2))) test.for.zero(cbind(tt,tt,t(tt2),1:nrow(tt)), cbind(ss,ss,t(ss2),spam(1:nrow(tt)))) if (F) { # dummy testing rbind.spam() cbind.spam() rbind.spam(deparse.level=0) cbind.spam(deparse.level=0) # the following should produce warnings: rbind(a=ss) cbind(b=ss) rbind.spam(deparse.level=1) cbind.spam(deparse.level=1) # the following should produces errors: rbind(ss,tt) cbind(ss,tt) rbind(ss,ss2) cbind(ss,ss2) } # testing diag: cat("Testing 'diag' and derivatives:\n") test.for.zero(diag(tt),diag(ss)) test.for.zero(diag.spam(ss),diag(ss)) test.for.zero(diag.spam(1:4),diag(1:4)) test.for.zero(diag.spam(1,2,3),diag(1,2,3)) test.for.zero(diag.spam(1:4,4,6),diag(1:4,4,6)) test.for.zero(diag.spam(1:4,12),diag(1:4,12)) diag(tt) <- diag(ss) <- 1:n test.for.zero(tt, ss) diag(tt) <- diag(ss) <- 2 test.for.zero(tt, ss) diag(tt) <- diag(ss) <- 0 diag(tt) <- diag(ss) <- 1:n test.for.zero(tt, ss) test.for.zero(diag(tt[,5]),diag(ss[,5])) test.for.zero(diag(tt[,5,drop=T]),diag(ss[,5,drop=T])) test.for.zero(diag(tt[,5,drop=F]),diag(ss[,5,drop=F]),rel=F) # testing as.spam cat("Testing 'as.spam' and derivatives:\n") test.for.zero(as.spam(0), as.matrix(0),rel=FALSE) b <- rnorm(n) test.for.zero(as.spam(b), b ) test.for.zero(as.spam(-abs(b)), -abs(b) ) test.for.zero(-as.spam(abs(b)), -abs(b) ) test.for.zero(as.spam(tt), tt) # testing spam test.for.zero(spam(0,1000,1000), matrix(0,1000,1000),rel=FALSE) test.for.zero(spam(1,12,12),matrix(1,12,12)) # no NA, NaN, Inf handling if (F) { #not implemented ss[2,] <- NA tt[4,] <- NA tt[,4] <- NaN tt[5,] <- Inf as.spam(tt) } # transformation from list and else cat("Testing 'as.spam.list' and 'triplet':\n") test.for.zero( spam(triplet(ss)), ss) test.for.zero( spam(triplet(ss, tri=TRUE)), ss) test.for.zero( spam(triplet(tt)), ss) test.for.zero( spam(triplet(tt, tri=TRUE)), ss) if (F) { # the following should cause errors: spam.list( list(i=1, 2)) spam.list( list(ind=1, 2)) spam.list( list(ind=1, 1, 2)) spam.list( list(ind=1, j=0, 2)) spam.list( list(ind=numeric(0), j=numeric(0), numeric(0))) } options( echo=TRUE) spam/tests/ops.Rout.save0000644000176000001440000001571412403543611015024 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/ops.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > library( spam, warn.conflict=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > > > test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, + tag=NULL){ + # slightly different test function! + if( !is.null(tag)){ + cat( "testing: ", tag, fill=TRUE)} + + denom <- ifelse( relative, mean( abs(c(xtrue))),1.0) + + if (any(dim(xtest)!=dim(xtrue))) + return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), + fill=TRUE)) + test.value <- sum( abs(c(as.matrix(xtest)) - c( xtrue) ),na.rm=T ) /denom + if( test.value < tol ){ + cat("** PASSED test at tolerance ", tol, fill=TRUE)} + else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, + fill=TRUE)} + + } > > > > > > # construct matrices: > n <- 10 > m <- 5 > > set.seed(14) > tt <- matrix(rnorm(m*n),n,m) > rr <- matrix(rnorm(m*n),n,m) > tt[tt<0] <- 0 > rr[rr>0] <- 0 > > ss <- as.spam(tt) > qq <- as.spam(rr) > spam.options( structurebased=FALSE) # test for equivalence! > > spam.options( NAOK=TRUE) # test for equivalence! > > > for (f in rev(getGroupMembers("Arith"))) + test.for.zero( do.call(f, list(ss,qq)), do.call(f, list(tt,rr)), tag=f) testing: / ** PASSED test at tolerance 1e-06 testing: %/% ** PASSED test at tolerance 1e-06 testing: %% ** PASSED test at tolerance 1e-06 testing: ^ ** PASSED test at tolerance 1e-06 testing: * ** PASSED test at tolerance 1e-06 testing: - ** PASSED test at tolerance 1e-06 testing: + ** PASSED test at tolerance 1e-06 > > for (f in getGroupMembers("Compare")) + test.for.zero( do.call(f, list(ss,qq)), do.call(f, list(tt,rr)), tag=f) testing: == ** PASSED test at tolerance 1e-06 testing: > ** PASSED test at tolerance 1e-06 testing: < ** PASSED test at tolerance 1e-06 testing: != ** PASSED test at tolerance 1e-06 testing: <= ** PASSED test at tolerance 1e-06 testing: >= ** PASSED test at tolerance 1e-06 > > for (f in getGroupMembers("Logic")) + test.for.zero( do.call(f, list(ss,qq)), do.call(f, list(tt,rr)), tag=f) testing: & ** PASSED test at tolerance 1e-06 testing: | ** PASSED test at tolerance 1e-06 > > > tv <- sv <- ss@entries > qv <- qq@entries > spam.options( structurebased=TRUE) > > > test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, tag=NULL){ + # slightly different test function! + if( !is.null(tag)){ + cat( "testing: ", tag, fill=TRUE)} + + denom <- ifelse( relative, mean( abs(c(xtrue))),1.0) + + test.value <- sum( abs(xtest@entries - c( xtrue) ),na.rm=T ) /denom + if( test.value < tol ){ + cat("** PASSED test at tolerance ", tol, fill=TRUE)} + else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, + fill=TRUE)} + + } > > for (g in getGroupMembers("Ops")) { + for (f in getGroupMembers(g)) { + test.for.zero( do.call(f, list(ss,sv)), do.call(f, list(tv,sv)), tag=f) + test.for.zero( do.call(f, list(sv,ss)), do.call(f, list(sv,tv)), tag=f) + test.for.zero( do.call(f, list(ss,4)), do.call(f, list(tv,4)), tag=f) + } + } testing: + ** PASSED test at tolerance 1e-06 testing: + ** PASSED test at tolerance 1e-06 testing: + ** PASSED test at tolerance 1e-06 testing: - ** PASSED test at tolerance 1e-06 testing: - ** PASSED test at tolerance 1e-06 testing: - ** PASSED test at tolerance 1e-06 testing: * ** PASSED test at tolerance 1e-06 testing: * ** PASSED test at tolerance 1e-06 testing: * ** PASSED test at tolerance 1e-06 testing: ^ ** PASSED test at tolerance 1e-06 testing: ^ ** PASSED test at tolerance 1e-06 testing: ^ ** PASSED test at tolerance 1e-06 testing: %% ** PASSED test at tolerance 1e-06 testing: %% ** PASSED test at tolerance 1e-06 testing: %% ** PASSED test at tolerance 1e-06 testing: %/% ** PASSED test at tolerance 1e-06 testing: %/% ** PASSED test at tolerance 1e-06 testing: %/% ** PASSED test at tolerance 1e-06 testing: / ** PASSED test at tolerance 1e-06 testing: / ** PASSED test at tolerance 1e-06 testing: / ** PASSED test at tolerance 1e-06 testing: == ** PASSED test at tolerance 1e-06 testing: == ** PASSED test at tolerance 1e-06 testing: == ** PASSED test at tolerance 1e-06 testing: > ** PASSED test at tolerance 1e-06 testing: > ** PASSED test at tolerance 1e-06 testing: > ** PASSED test at tolerance 1e-06 testing: < ** PASSED test at tolerance 1e-06 testing: < ** PASSED test at tolerance 1e-06 testing: < ** PASSED test at tolerance 1e-06 testing: != ** PASSED test at tolerance 1e-06 testing: != ** PASSED test at tolerance 1e-06 testing: != ** PASSED test at tolerance 1e-06 testing: <= ** PASSED test at tolerance 1e-06 testing: <= ** PASSED test at tolerance 1e-06 testing: <= ** PASSED test at tolerance 1e-06 testing: >= ** PASSED test at tolerance 1e-06 testing: >= ** PASSED test at tolerance 1e-06 testing: >= ** PASSED test at tolerance 1e-06 testing: & ** PASSED test at tolerance 1e-06 testing: & ** PASSED test at tolerance 1e-06 testing: & ** PASSED test at tolerance 1e-06 testing: | ** PASSED test at tolerance 1e-06 testing: | ** PASSED test at tolerance 1e-06 testing: | ** PASSED test at tolerance 1e-06 > try(do.call(f, list(ss,1:2))) Error in | 1:2 : incompatible lengths for '|' operation. > > #################################################################################################################################### > > { + spam.options(inefficiencywarning=TRUE) + spam.options(structurebased=FALSE) + + diag(2)+diag.spam(2) + } [,1] [,2] [1,] 2 0 [2,] 0 2 Class 'spam' > > > #################################################################################################################################### > > options( echo=TRUE) > > proc.time() user system elapsed 0.848 0.025 0.857 spam/tests/rowcolstats.Rout.save0000644000176000001440000000674312403543611016611 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/rowcolstats.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > #options( echo=FALSE) > library( spam, warn.conflict=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > > > test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, + tag=NULL){ + # slightly different test function! + if( !is.null(tag)){ + cat( "testing: ", tag, fill=TRUE)} + + denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) + + if (any(dim(xtest)!=dim(xtrue))) + return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), + fill=TRUE)) + test.value <- sum( abs(c(xtest) - c( xtrue) ),na.rm=T ) /denom + if( test.value < tol ){ + cat("** PASSED test at tolerance ", tol, fill=TRUE)} + else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, + fill=TRUE)} + + } > > > > # simple tests: > ######################################################################## > > > # construct matrices: > n <- 10 > m <- 15 > > set.seed(14) > tt <- matrix(rnorm(m*n),n,m) > tt[tt<0] <- 0 > > ss <- as.spam(tt) > > test.for.zero(rowSums(ss),rowSums(tt)) ** PASSED test at tolerance 1e-06 > test.for.zero(colSums(ss),colSums(tt)) ** PASSED test at tolerance 1e-06 > > > spam.options(structurebased=FALSE) > > test.for.zero(rowMeans(ss),rowMeans(tt)) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(colMeans(ss),colMeans(tt)) # ok ** PASSED test at tolerance 1e-06 > > > > spam.options(structurebased=TRUE) > test.for.zero(rowMeans(ss),rowSums(tt)/apply(tt>0,1,sum)) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(colMeans(ss),colSums(tt)/apply(tt>0,2,sum)) # ok ** PASSED test at tolerance 1e-06 > > test.for.zero(rowMeans(ss),apply.spam(ss,1,mean)) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(colMeans(ss),apply.spam(ss,2,mean)) # ok ** PASSED test at tolerance 1e-06 > > > test.for.zero(rowMeans(spam(0,n,m)),rowMeans(tt*0)) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(colMeans(spam(0,n,m)),colMeans(tt*0)) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(rowMeans(as.spam(diag(0,n))),rowMeans(diag(0,n))) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(colMeans(as.spam(diag(0,n))),colMeans(diag(0,n))) # ok ** PASSED test at tolerance 1e-06 > > spam.options(structurebased=TRUE) > > > options( echo=TRUE) > > proc.time() user system elapsed 0.849 0.015 0.845 spam/tests/crossprod.Rout.save0000644000176000001440000000272012403543611016232 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/crossprod.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > ###################################################################### > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Testing crossprod n=1: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > proc.time() user system elapsed 0.825 0.028 0.838 spam/tests/demo_spam.Rout.save0000644000176000001440000000376712403543611016174 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/demo_spam.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > # This is a simple demo, wrapping up the functionality of spam. > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. [,1] [,2] [,3] [,4] [,5] [,6] [,7] [1,] -0.6618498 1.231945 -0.3828219 0.8828018 -1.266815 -0.7666105 -1.421992 Class 'spam' [,1] [,2] [,3] [,4] [,5] [,6] [,7] [1,] 0 1.23194518 -0.3828219 0.8828018 -1.2668148 -0.7666105 -1.4219925 [2,] 0 -0.06488077 0.2994216 1.8627490 -0.1985833 1.4433629 -0.3282283 [3,] 0 1.06899373 0.6742398 1.6117253 0.1388658 0.8448793 0.2845701 [4,] 0 -0.37696531 -0.2928163 0.1354795 -0.2793360 -0.3993704 0.7193359 [5,] 0 1.04318309 0.4880534 1.0880860 0.7089194 -1.4277676 0.4324160 Class 'spam' [1] -0.36181804 0.07322929 -0.13634352 0.59605327 0.52252315 > > proc.time() user system elapsed 0.838 0.019 0.838 spam/tests/norm.Rout.save0000644000176000001440000000236112403543611015170 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/norm.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > proc.time() user system elapsed 0.853 0.016 0.852 spam/tests/demo_article-jss-example1.R0000644000176000001440000001240412375334717017502 0ustar ripleyusers# This is file ../spam/tests/demo_article-jss-example1.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # JSS article: # "spam: A Sparse Matrix R Package with Emphasis on # MCMC Methods for Gaussian Markov Random Fields" # # Compared to the R code given in the article, here we give: # - improved formatting # - more comments # - the R code to construct the figures # SETUP: library("spam") spam.options(structurebased=TRUE) data("UKDriverDeaths") y <- sqrt(c(UKDriverDeaths)) # square root counts n <- length(y) # n=192 m <- 12 # We want to predict for one season. nm <- n+m # Total length of s and t priorshape <- c(4, 1, 1) # alpha's, as in Rue & Held (2005) priorinvscale <- c(4, 0.1, 0.0005) # beta's # Construct the individual block precisions # (based on unit precision parameters kappa, denoted with k): # Qsy, Qty are trivial: Qsy <- diag.spam(n) pad(Qsy) <- c(n+m, n) # previously: dim(Qsy) <- c(n+m, n) Qty <- Qsy Qst <- spam(0, nm, nm) Qst[cbind(1:n, 1:n)] <- rep(1, n) # The form of Qss is given by (Rue and Held equation 3.59). # Qss can be constructed with a loop: Qss <- spam(0, nm, nm) for (i in 0:(nm-m)) { Qss[i+1:m,i+1:m] <- Qss[i+1:m, i+1:m] + matrix(1,m,m) # Qss[i+1:m,i+1:m] <- Qss[i+1:m, i+1:m]+1 # previously... } # Note that for the final version we need: # Qss <- k_s * Qss + k_y * diag.spam(nm) # The form of Qtt is given by (Rue and Held equation 3.40). # Similar approaches to construct Qtt: Qtt <- spam(0,nm,nm) Qtt[cbind(1:(nm-1),2:nm)] <- -c(2,rep(4,nm-3),2) Qtt[cbind(1:(nm-2),3:nm)] <- rep(1,nm-2) Qtt <- Qtt + t( Qtt) diag(Qtt) <- c(1,5,rep(6,nm-4),5,1) # Create temporary kappa and precision matrix to illustrate # adjacency matrix and ordering. k <- c(1,1,1) Qst_yk <- rbind(cbind(k[2]*Qss + k[1]*diag.spam(nm), k[1]*Qst), cbind(k[1]*Qst, k[3]*Qtt + k[1]*diag.spam(nm))) struct <- chol(Qst_yk) # Note that we do not provide the exactly the same ordering # algorithms. Hence, the following is sightly different than # Figure RH4.2. cholQst_yk <- chol(Qst_yk,pivot="RCM") P <- ordering(cholQst_yk) display(Qst_yk) display(Qst_yk[P,P]) # Recall: # k=( kappa_y, kappa_s, kappa_t)' # Gibbs sampler ngibbs <- 100 # In the original version is 500! burnin <- 10 # > 0 totalg <- ngibbs+burnin set.seed(14) # Initialize parameters: spost <- tpost <- array(0, c(totalg, nm)) kpost <- array(0, c(totalg, 3)) # Starting values: kpost[1,] <- c(.5,28,500) tpost[1,] <- 40 # calculation of a few variables: postshape <- priorshape + c( n/2, (n+1)/2, (n+m-2)/2) for (ig in 2:totalg) { Q <- rbind(cbind(kpost[ig-1,2]*Qss + kpost[ig-1,1]*Qst, kpost[ig-1,1]*Qst), cbind(kpost[ig-1,1]*Qst, kpost[ig-1,3]*Qtt + kpost[ig-1,1]*Qst)) b <- c(kpost[ig-1,1]*Qsy %*% y, kpost[ig-1,1]*Qsy %*% y) tmp <- rmvnorm.canonical(1, b, Q, Lstruct=struct) spost[ig,] <- tmp[1:nm] tpost[ig,] <- tmp[1:nm+nm] tmp <- y-spost[ig,1:n]-tpost[ig,1:n] postinvscale <- priorinvscale + # prior contribution c( sum( tmp^2)/2, # Qyy_st is the identity t(spost[ig,]) %*% (Qss %*% spost[ig,])/2, t(tpost[ig,]) %*% (Qtt %*% tpost[ig,])/2) kpost[ig,] <- rgamma(3, postshape, postinvscale) if( (ig%%10)==0) cat('.') } # Eliminate burn-in: kpost <- kpost[-c(1:burnin),] spost <- spost[-c(1:burnin),] tpost <- tpost[-c(1:burnin),] postquant <- apply(spost+tpost, 2, quantile,c(.025,.975)) postmean <- apply(spost+tpost, 2, mean) postmedi <- apply(spost+tpost, 2, median) if (F){ par(mfcol=c(1,1),mai=c(.6,.8,.01,.01)) plot( y^2, ylim=c(800,2900),xlim=c(0,nm),ylab="Counts") #lines( postmean^2, col=2) lines( postmedi^2, col=2) matlines( t(postquant)^2, col=4,lty=1) legend("topright",legend=c("Posterior median", "Quantiles of posterior sample", "Quantiles of predictive distribution"), bty="n",col=c(2,4,3),lty=1) # Constructing a predictive distribution: ypred <- rnorm( ngibbs*nm, c(spost+tpost),sd=rep( 1/sqrt(kpost[,1]), nm)) dim(ypred) <- c(ngibbs,nm) postpredquant <- apply(ypred, 2, quantile,c(.025,.975)) matlines( t(postpredquant)^2, col=3,lty=1) points(y^2) dev.off() kpostmedian <- apply(kpost,2,median) par(mfcol=c(1,3),mai=c(.65,.65,.01,.01),cex=.85,mgp=c(2.6,1,0)) matplot( log( kpost), lty=1, type="l",xlab="Index") abline(h=log(kpostmedian),col=3) acf( kpost[,3],ylab=expression(kappa[t])) plot(kpost[,2:3],ylab=expression(kappa[t]),xlab=expression(kappa[s]),cex=.8) abline(h=kpostmedian[3],v=kpostmedian[2],col=3) dev.off() allkappas <- rbind(apply(kpost,2,mean), apply(kpost,2,median), apply(1/kpost,2,mean), apply(1/kpost,2,median)) colnames(allkappas) <- c("kappa_y", "kappa_s", "kappa_t") rownames(allkappas) <- c("Prec (mean)", "Prec (median)", "Var (mean)", "Var (median) ") print(allkappas,4) png("example1_m1.png",width=300,height=300) par(mai=c(.5,.5,.05,.05)) display(Qst_yk) dev.off() png("example1_m2.png",width=300,height=300) par(mai=c(.5,.5,.05,.05)) display(struct) dev.off() summary(kpost) } spam/tests/ops.R0000644000176000001440000000546412375434673013357 0ustar ripleyusers# This is file ../spam/tests/ops.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, tag=NULL){ # slightly different test function! if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom <- ifelse( relative, mean( abs(c(xtrue))),1.0) if (any(dim(xtest)!=dim(xtrue))) return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), fill=TRUE)) test.value <- sum( abs(c(as.matrix(xtest)) - c( xtrue) ),na.rm=T ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } # construct matrices: n <- 10 m <- 5 set.seed(14) tt <- matrix(rnorm(m*n),n,m) rr <- matrix(rnorm(m*n),n,m) tt[tt<0] <- 0 rr[rr>0] <- 0 ss <- as.spam(tt) qq <- as.spam(rr) spam.options( structurebased=FALSE) # test for equivalence! spam.options( NAOK=TRUE) # test for equivalence! for (f in rev(getGroupMembers("Arith"))) test.for.zero( do.call(f, list(ss,qq)), do.call(f, list(tt,rr)), tag=f) for (f in getGroupMembers("Compare")) test.for.zero( do.call(f, list(ss,qq)), do.call(f, list(tt,rr)), tag=f) for (f in getGroupMembers("Logic")) test.for.zero( do.call(f, list(ss,qq)), do.call(f, list(tt,rr)), tag=f) tv <- sv <- ss@entries qv <- qq@entries spam.options( structurebased=TRUE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, tag=NULL){ # slightly different test function! if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom <- ifelse( relative, mean( abs(c(xtrue))),1.0) test.value <- sum( abs(xtest@entries - c( xtrue) ),na.rm=T ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } for (g in getGroupMembers("Ops")) { for (f in getGroupMembers(g)) { test.for.zero( do.call(f, list(ss,sv)), do.call(f, list(tv,sv)), tag=f) test.for.zero( do.call(f, list(sv,ss)), do.call(f, list(sv,tv)), tag=f) test.for.zero( do.call(f, list(ss,4)), do.call(f, list(tv,4)), tag=f) } } try(do.call(f, list(ss,1:2))) #################################################################################################################################### { spam.options(inefficiencywarning=TRUE) spam.options(structurebased=FALSE) diag(2)+diag.spam(2) } #################################################################################################################################### options( echo=TRUE) spam/tests/dist.R0000644000176000001440000001356712346261543013514 0ustar ripleyusers# This is file ../spam/tests/dist.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) distmatrix <- function(x1,x2=NULL,upper=NULL,...) { if (is.null(x2)) { tmp <- as.matrix(dist(x1,...)) if (is.null(upper)) return(tmp) if (upper) tmp[row(tmp)col(tmp)] <- -1 return( tmp[tmp>-0.5]) } else return( as.matrix( dist(rbind(x1,x2),...))[1:dim(x1)[1],1:dim(x2)[1]+dim(x1)[1]]) } test.for.zero <- function( vec, tol = 1.0e-6) { test.value <- sum( (vec^2)) if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } ######## ## as an aside, comparing nearest.dist with dist, use diag=true, upper=TRUE cat("Results of the form '[1] TRUE' are from 'all.equal'\n\n") spam.options(printsize=6) n1 <- as.integer( 4) n2 <- n1 nd <- as.integer(2) set.seed(14) x2 <- x1 <- array(runif(n1*nd), c( n1,nd)) if (F){ # testing the structure distmatrix(x1) nearest.dist( x1, x1, upper=NULL) # and all other possibilities (3[upper]) # with x1,x1 and x1, NULL: par(mfcol=c(3,2)) display( nearest.dist( x1, x1, upper=NULL)) # default display( nearest.dist( x1, x1, upper=FALSE)) display( nearest.dist( x1, x1, upper=TRUE)) display( nearest.dist( x1, upper=NULL)) display( nearest.dist( x1, upper=FALSE)) display( nearest.dist( x1, upper=TRUE)) } # nearest.dist( x1) and nearest.dist( x1,x1) should be identical... all.equal( nearest.dist( x1, x1, upper=NULL) ,nearest.dist( x1, upper=NULL) ) all.equal( nearest.dist( x1, x1, upper=FALSE),nearest.dist( x1, upper=FALSE)) all.equal( nearest.dist( x1, x1, upper=TRUE) ,nearest.dist( x1, upper=TRUE) ) # testing Euclidian eta <- 1 o1 <- nearest.dist( x1, upper=NULL) o2 <- distmatrix(x1) test.for.zero(o2[o2< eta]- o1@entries) o1 <- nearest.dist( x1, upper=!FALSE) # is default... o3 <- distmatrix(x1, upper=!FALSE) test.for.zero(o1@entries-o3) x2 <- x1 <- array(runif(n1*nd), c( n1,nd)) o1 <- nearest.dist( x1,x2,upper=NULL) o2 <- distmatrix(x1,x2) test.for.zero(o2[o2< eta]- o1@entries) o1 <- nearest.dist( x1, upper=!FALSE) test.for.zero(o2[2< eta & lower.tri(o2)]- o1@entries) # Should cause error: # nearest.dist(cbind(1,1)) # this is ok: test.for.zero( nearest.dist(rbind(1,0)) - c(0,1,0,0)) test.for.zero( nearest.dist(cbind(1,1),cbind(1,0)) -1) # testing with dist only test.for.zero( c(as.spam( dist(x1)) - nearest.dist(x1,delta=2))) # testing some other norms method <- "max" p <- 1.0001 o1 <- nearest.dist( x1,method=method,p=p, upper=TRUE ) o3 <- distmatrix(x1,method=method,p=p, upper=TRUE) test.for.zero(o1@entries-o3) if (F){ # system.time is not always available... n1 <- as.integer( 400) set.seed(14) x1 <- array(runif(n1*nd), c( n1,nd)) system.time( o1 <- nearest.dist( x1,method="max",p=p) ) system.time( o1 <- nearest.dist( x1,method="min",p=1) ) system.time( o1 <- nearest.dist( x1,method="min",p=1.5) ) system.time( o1 <- nearest.dist( x1,method="min",p=2) ) system.time( o1 <- nearest.dist( x1,method="euc",p=1) ) system.time( o1 <- dist( x1) ) } # testing GC n1 <- as.integer( 4) n2 <- as.integer(6) set.seed(14) x1 <- array(runif(n1*2,-90,90), c( n1,2)) x2 <- array(runif(n2*2,-90,90), c( n2,2)) if (F){ # structure delta <- 180 par(mfcol=c(3,2)) display( nearest.dist( x1, delta=delta,method="gr", upper=FALSE)) display( nearest.dist( x1, delta=delta,method="gr", upper=TRUE)) display( nearest.dist( x1, delta=delta,method="gr", upper=NULL)) display( nearest.dist( x1,x1, delta=delta,method="gr", upper=FALSE)) display( nearest.dist( x1,x1, delta=delta,method="gr", upper=TRUE)) display( nearest.dist( x1,x1, delta=delta,method="gr", upper=NULL)) } # if (F){ # if fields would be available, the following can be used as well. delta <- 180 o2 <- rdist.earth(x1) o1 <- nearest.dist( x1, method="gr",upper=NULL,delta=delta) test.for.zero(o2- o1@entries) o2 <- rdist.earth(x1, R=1) o1 <- nearest.dist( x1, method="gr",upper=NULL,delta=delta,R=1) test.for.zero(o2- o1@entries) delta <- 90 o2 <- rdist.earth(x2,x1,R=1) o1 <- nearest.dist( x1,x2, method="gr",upper=NULL,delta=delta,R=1) test.for.zero(o2[o2 # This is file ../spam/tests/demo_article-jss-example1.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > # JSS article: > # "spam: A Sparse Matrix R Package with Emphasis on > # MCMC Methods for Gaussian Markov Random Fields" > # > # Compared to the R code given in the article, here we give: > # - improved formatting > # - more comments > # - the R code to construct the figures > > > > # SETUP: > library("spam") Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Attaching package: 'spam' The following objects are masked from 'package:base': backsolve, forwardsolve > spam.options(structurebased=TRUE) > data("UKDriverDeaths") > > y <- sqrt(c(UKDriverDeaths)) # square root counts > > n <- length(y) # n=192 > m <- 12 # We want to predict for one season. > nm <- n+m # Total length of s and t > > > priorshape <- c(4, 1, 1) # alpha's, as in Rue & Held (2005) > priorinvscale <- c(4, 0.1, 0.0005) # beta's > > # Construct the individual block precisions > # (based on unit precision parameters kappa, denoted with k): > > # Qsy, Qty are trivial: > Qsy <- diag.spam(n) > pad(Qsy) <- c(n+m, n) # previously: dim(Qsy) <- c(n+m, n) > > Qty <- Qsy > > Qst <- spam(0, nm, nm) > Qst[cbind(1:n, 1:n)] <- rep(1, n) > > > # The form of Qss is given by (Rue and Held equation 3.59). > # Qss can be constructed with a loop: > Qss <- spam(0, nm, nm) > for (i in 0:(nm-m)) { + Qss[i+1:m,i+1:m] <- Qss[i+1:m, i+1:m] + matrix(1,m,m) + # Qss[i+1:m,i+1:m] <- Qss[i+1:m, i+1:m]+1 # previously... + } > > # Note that for the final version we need: > # Qss <- k_s * Qss + k_y * diag.spam(nm) > > > > > # The form of Qtt is given by (Rue and Held equation 3.40). > # Similar approaches to construct Qtt: > > Qtt <- spam(0,nm,nm) > Qtt[cbind(1:(nm-1),2:nm)] <- -c(2,rep(4,nm-3),2) > Qtt[cbind(1:(nm-2),3:nm)] <- rep(1,nm-2) > Qtt <- Qtt + t( Qtt) > diag(Qtt) <- c(1,5,rep(6,nm-4),5,1) > > > > # Create temporary kappa and precision matrix to illustrate > # adjacency matrix and ordering. > k <- c(1,1,1) > Qst_yk <- rbind(cbind(k[2]*Qss + k[1]*diag.spam(nm), k[1]*Qst), + cbind(k[1]*Qst, k[3]*Qtt + k[1]*diag.spam(nm))) > > struct <- chol(Qst_yk) > > > > # Note that we do not provide the exactly the same ordering > # algorithms. Hence, the following is sightly different than > # Figure RH4.2. > cholQst_yk <- chol(Qst_yk,pivot="RCM") > P <- ordering(cholQst_yk) > display(Qst_yk) Warning message: default value for 'cex' in 'display' might not be the optimal choice > display(Qst_yk[P,P]) Warning message: default value for 'cex' in 'display' might not be the optimal choice > > > > # Recall: > # k=( kappa_y, kappa_s, kappa_t)' > > # Gibbs sampler > ngibbs <- 100 # In the original version is 500! > burnin <- 10 # > 0 > totalg <- ngibbs+burnin > set.seed(14) > > # Initialize parameters: > spost <- tpost <- array(0, c(totalg, nm)) > kpost <- array(0, c(totalg, 3)) > > # Starting values: > kpost[1,] <- c(.5,28,500) > tpost[1,] <- 40 > > # calculation of a few variables: > postshape <- priorshape + c( n/2, (n+1)/2, (n+m-2)/2) > > > for (ig in 2:totalg) { + + Q <- rbind(cbind(kpost[ig-1,2]*Qss + kpost[ig-1,1]*Qst, + kpost[ig-1,1]*Qst), + cbind(kpost[ig-1,1]*Qst, + kpost[ig-1,3]*Qtt + kpost[ig-1,1]*Qst)) + + b <- c(kpost[ig-1,1]*Qsy %*% y, kpost[ig-1,1]*Qsy %*% y) + + tmp <- rmvnorm.canonical(1, b, Q, Lstruct=struct) + + + spost[ig,] <- tmp[1:nm] + + tpost[ig,] <- tmp[1:nm+nm] + + + tmp <- y-spost[ig,1:n]-tpost[ig,1:n] + + postinvscale <- priorinvscale + # prior contribution + c( sum( tmp^2)/2, # Qyy_st is the identity + t(spost[ig,]) %*% (Qss %*% spost[ig,])/2, + t(tpost[ig,]) %*% (Qtt %*% tpost[ig,])/2) + + + kpost[ig,] <- rgamma(3, postshape, postinvscale) + + if( (ig%%10)==0) cat('.') + + } ...........> > > > # Eliminate burn-in: > kpost <- kpost[-c(1:burnin),] > spost <- spost[-c(1:burnin),] > tpost <- tpost[-c(1:burnin),] > > postquant <- apply(spost+tpost, 2, quantile,c(.025,.975)) > postmean <- apply(spost+tpost, 2, mean) > postmedi <- apply(spost+tpost, 2, median) > > if (F){ + + par(mfcol=c(1,1),mai=c(.6,.8,.01,.01)) + + plot( y^2, ylim=c(800,2900),xlim=c(0,nm),ylab="Counts") + #lines( postmean^2, col=2) + lines( postmedi^2, col=2) + matlines( t(postquant)^2, col=4,lty=1) + + legend("topright",legend=c("Posterior median", "Quantiles of posterior sample", + "Quantiles of predictive distribution"), + bty="n",col=c(2,4,3),lty=1) + + + + + # Constructing a predictive distribution: + ypred <- rnorm( ngibbs*nm, c(spost+tpost),sd=rep( 1/sqrt(kpost[,1]), nm)) + dim(ypred) <- c(ngibbs,nm) + postpredquant <- apply(ypred, 2, quantile,c(.025,.975)) + matlines( t(postpredquant)^2, col=3,lty=1) + points(y^2) + dev.off() + + kpostmedian <- apply(kpost,2,median) + + par(mfcol=c(1,3),mai=c(.65,.65,.01,.01),cex=.85,mgp=c(2.6,1,0)) + + matplot( log( kpost), lty=1, type="l",xlab="Index") + abline(h=log(kpostmedian),col=3) + acf( kpost[,3],ylab=expression(kappa[t])) + plot(kpost[,2:3],ylab=expression(kappa[t]),xlab=expression(kappa[s]),cex=.8) + abline(h=kpostmedian[3],v=kpostmedian[2],col=3) + dev.off() + + + allkappas <- rbind(apply(kpost,2,mean), + apply(kpost,2,median), + apply(1/kpost,2,mean), + apply(1/kpost,2,median)) + colnames(allkappas) <- c("kappa_y", "kappa_s", "kappa_t") + rownames(allkappas) <- c("Prec (mean)", "Prec (median)", + "Var (mean)", "Var (median) ") + print(allkappas,4) + + png("example1_m1.png",width=300,height=300) + par(mai=c(.5,.5,.05,.05)) + display(Qst_yk) + dev.off() + + png("example1_m2.png",width=300,height=300) + par(mai=c(.5,.5,.05,.05)) + display(struct) + dev.off() + + + summary(kpost) + + + } > > proc.time() user system elapsed 1.926 0.033 1.942 spam/tests/displays.R0000644000176000001440000000511212346261543014364 0ustar ripleyusers# This is file ../spam/tests/displays.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) # This script illustrates the plotting capacities # the following function is form fields (and should be made default) tim.colors <- function (n = 64) { orig <- c("#00008F", "#00009F", "#0000AF", "#0000BF", "#0000CF", "#0000DF", "#0000EF", "#0000FF", "#0010FF", "#0020FF", "#0030FF", "#0040FF", "#0050FF", "#0060FF", "#0070FF", "#0080FF", "#008FFF", "#009FFF", "#00AFFF", "#00BFFF", "#00CFFF", "#00DFFF", "#00EFFF", "#00FFFF", "#10FFEF", "#20FFDF", "#30FFCF", "#40FFBF", "#50FFAF", "#60FF9F", "#70FF8F", "#80FF80", "#8FFF70", "#9FFF60", "#AFFF50", "#BFFF40", "#CFFF30", "#DFFF20", "#EFFF10", "#FFFF00", "#FFEF00", "#FFDF00", "#FFCF00", "#FFBF00", "#FFAF00", "#FF9F00", "#FF8F00", "#FF8000", "#FF7000", "#FF6000", "#FF5000", "#FF4000", "#FF3000", "#FF2000", "#FF1000", "#FF0000", "#EF0000", "#DF0000", "#CF0000", "#BF0000", "#AF0000", "#9F0000", "#8F0000", "#800000") if (n == 64) return(orig) rgb.tim <- t(col2rgb(orig)) temp <- matrix(NA, ncol = 3, nrow = n) x <- seq(0, 1, , 64) for (k in 1:3) { # the original function uses splint here. hold <- spline(x, rgb.tim[, k], n)$y hold[hold < 0] <- 0 hold[hold > 255] <- 255 temp[, k] <- round(hold) } rgb(temp[, 1], temp[, 2], temp[, 3], maxColorValue = 255) } m <- 10 n <- 7 set.seed(124) tt <- matrix(rnorm(m*n),n,m) tt[tt<0] <- 0 ss <- as.spam(tt) par(mfcol=c(1,2)) spam.options(imagesize=10) display(ss,cex=1) spam.options(imagesize=n*m+1) display(ss) par(mfcol=c(1,2)) plot(tt) plot(ss) plot( tt[,1]) plot(as.spam( tt[,1])) plot( t( tt[,2])) plot(as.spam( t( tt[,2]))) nl <- length(ss) #ok ss@entries <- 1:nl z <- ss br <- c(seq(0.1,max(z),l=nl),max(z)) par(mfcol=c(1,2)) spam.options( imagesize=1000) image(z, breaks=br,col=tim.colors(nl)) spam.options( imagesize=10) image(z, breaks=br,col=tim.colors(nl),cex=1) nl <- length(ss) ss@entries <- 1:nl par(mfcol=c(1,2)) spam.options( imagesize=1000) image(ss, col=tim.colors(nl)) spam.options( imagesize=10) image(ss, col=tim.colors(nl),cex=1) # very large sample nz <- 128 ln <- nz^2 ss <- spam(0,ln,ln) for (i in 1:nz) ss[sample(ln,1),sample(ln,1)] <- i par( mfcol=c(1,1)) image(ss, col=tim.colors(nl),cex=100) spam/tests/permutation.R0000644000176000001440000000340112346261543015102 0ustar ripleyusers# This is file ../spam/tests/permutation.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=TRUE, tag=NULL){ if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) test.value <- sum( abs(c(xtest) - c( xtrue) ) ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } ######## set.seed(14) res <- 12.5 grid <- expand.grid(lat=seq(-90+3*res/2,to=90-res,by=res),lon=seq(res/2,to=360,by=res)) dist <- nearest.dist(grid[,2:1],method='gr',upper=NULL, delta=30,R=1) distm <- as.matrix(dist) n <- dim(dist)[1] perm <- sample.int(n,n) test.for.zero(permutation.spam(dist,P=perm),distm[order(perm),]) test.for.zero(permutation.spam(dist,Q=perm),distm[,order(perm)]) test.for.zero(permutation.spam(dist,P=perm,ind=T),distm[perm,]) test.for.zero(permutation.spam(dist,Q=perm,ind=T),distm[,perm]) test.for.zero(permutation(dist,P=perm),distm[order(perm),]) test.for.zero(permutation(dist,Q=perm),distm[,order(perm)]) test.for.zero(permutation(dist,P=perm,ind=T),distm[perm,]) test.for.zero(permutation(dist,Q=perm,ind=T),distm[,perm]) test.for.zero(permutation(distm,P=perm),distm[order(perm),]) test.for.zero(permutation(distm,Q=perm),distm[,order(perm)]) test.for.zero(permutation(distm,P=perm,ind=T),distm[perm,]) test.for.zero(permutation(distm,Q=perm,ind=T),distm[,perm]) test.for.zero(t(permutation(t(dist),P=perm)),distm[,order(perm)]) spam/tests/demo_spam.R0000644000176000001440000000224712346261543014506 0ustar ripleyusers# This is file ../spam/tests/demo_spam.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # This is a simple demo, wrapping up the functionality of spam. options( echo=FALSE) library( spam, warn.conflict=FALSE) set.seed(14) nrow <- 5 ncol <- 7 fmat <- matrix(rnorm(nrow*ncol),nrow) smat <- as.spam(fmat) smat[1,] smat[,1] <- 0 as.spam(smat) ssmat <- smat %*% t(smat) b <- c(-2:2) solve(ssmat,b) cholssmat <- chol(ssmat) # works also for large matrices: set.seed(14) nz <- 100 nrow <- 100 ncol <- 100 smat <- diag.spam(1,nrow,ncol) smat[cbind(sample(1:(nrow*ncol),size=nz))] <- runif(nz) smat <- smat %*% t(smat) b <- rnorm(nz) smatinvb <- solve(smat,b) cholssmat <- chol(smat) # displaying matrices if (F) { opar <- par(no.readonly = TRUE) par(ask=interactive() && (.Device %in% c("X11","GTK","gnome","windows","quartz"))) display(smat, main="'scatterplot'-type display, very efficient") spam.options("imagesize"=prod(smat@dimension)+1) display(smat, main="'image'-type display, may be slow and heavy") par(opar) } options( echo=TRUE) spam/tests/constructors.Rout.save0000644000176000001440000000352712403543611016772 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/constructors.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Error : row pointers are not monotone increasing in `rowpointers<-`. Error : first element of row pointers is < 1 in `rowpointers<-`. Error : row pointers are not monotone increasing in `rowpointers<-`. Error : last element of row pointers does not conform in `rowpointers<-`. Error : last element of row pointers does not conform in `rowpointers<-`. Error : column indices exceed dimension `colindices<-`. Error : column indices exceed dimension `colindices<-`. Error : numerical required in `entries<-`. Error : wrong length in `entries<-`. Error : wrong length in `entries<-`. Error : modification through `dim' or `pad` > proc.time() user system elapsed 0.834 0.023 0.839 spam/tests/demo_article-jss-example2.R0000644000176000001440000001332312377116361017477 0ustar ripleyusers# This is file ../spam/tests/demo_article-jss-example2.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # INITALIZE AND FUNCTIONS: # JSS article: # "spam: A Sparse Matrix R Package with Emphasis on # MCMC Methods for Gaussian Markov Random Fields" # Compared to the R code in the article, here we give: # - improved formatting # - more comments, e.g. how to run the code using regular matrices # - the code to construct the figures # - minor modifcations due to evolvement of spam cat("\nThis demo contains the R code of the second example\nin the JSS article. As pointed out by Steve Geinitz\nand Andrea Riebler, the Gibbs sampler is not correct\nand contains several bugs. \n\nI'll post an updated sampler in a future release.\n\n") # INITALIZE AND FUNCTIONS: require("fields", warn.conflict=FALSE) spam.options(structurebased=TRUE) # READ DATA: attach(Oral) # CONSTRUCT ADJACENCY MATRIX: loc <- system.file("demodata/germany.adjacency", package="spam") A <- adjacency.landkreis(loc) n <- dim(A)[1] # Verification that we have a symmetric matrix: # norm(A-t(A)); display(A) # GIBBS SETUP: set.seed(14) # Construct the individual block precisions # (based on unit precision parameters kappa, denoted with k): Q1 <- R <- diag.spam( diff(A@rowpointers)) - A # this is R in (2) pad(Q1) <- c(2*n,2*n) # previously: dim(Q1) <- c(2*n,2*n) Q2 <- rbind(cbind( diag.spam(n), -diag.spam(n)), cbind(-diag.spam(n), diag.spam(n))) # Hence the precision Q in (2) is: # Q <- kappau*Q1 + kappav*Q2 # pre-define diagC <- as.spam( diag.spam(c(rep(0,n),rep(1,n)))) # Recall: # k=( kappa_u, kappa_y)' # hyperparameters ahyper <- c( 1, 1) bhyper <- c( .5, .01) # Gibbs sampler burnin <- 50 ngibbs <- 150 totalg <- burnin+ngibbs # Initialize parameters: upost <- array(0, c(totalg, n)) npost <- array(0, c(totalg, n)) kpost <- array(0, c(totalg, 2)) # Starting values: kpost[1,] <- c(40,500) upost[1,] <- u <- rnorm(n,sd=.2) *1 npost[1,] <- eta <- u + rnorm(n,sd=.05)*1 uRu <- t(u) %*% (R %*% u)/2 etauetau <- t(eta-u) %*% (eta-u)/2 postshape <- ahyper + c(n-1,n)/2 accept <- numeric(totalg) struct <- chol(Q1 + Q2 + diag.spam(2*n), memory=list(nnzcolindices=5500)) # struct <- NULL # If no update steps are wanted # R <- as.matrix(R) # If no spam analysis is wanted. # Q1 <- as.matrix(Q1) # Q2 <- as.matrix(Q2) for (ig in 2:totalg) { kstar <- rgamma(2,postshape, bhyper + c(uRu, etauetau)) expeta0E <- exp(eta)*E expeta0Eeta01 <- expeta0E *(eta-1) diagC@entries <- expeta0E Q <- kstar[1]*Q1 + kstar[2]*Q2 + diagC b <- c( rep(0,n), Y + expeta0Eeta01) xstar <- rmvnorm.canonical(1, # vector b: b, # Precision matrix Q, Rstruct=struct) ustar <- xstar[1:n] nstar <- xstar[1:n+n] uRustar <- t(ustar) %*% (R %*% ustar)/2 etauetaustar <- t(nstar-ustar) %*% (nstar-ustar)/2 # we work on the log scale: # logalpha <- min(0, log(ratios))=min(0, expterm+(...)log(kappa)- exptmp <- sum(expeta0Eeta01*(eta-nstar) - E*(exp(eta)-exp(nstar))) - sum( nstar^2*expeta0E)/2 + sum(eta^2*expeta0E)/2 - kstar[1] * uRu + kpost[ig-1,1] * uRustar - kstar[2] * etauetau + kpost[ig-1,2] * etauetaustar factmp <- (postshape-1)*(log(kstar)-log(kpost[ig-1,1])) logalpha <- min(0, exptmp + sum(factmp)) logU <- log(runif(1)) if (logU < logalpha) { # ACCEPT draw upost[ig,] <- u <- ustar npost[ig,] <- eta <- nstar kpost[ig,] <- kstar uRu <- uRustar etauetau <- etauetaustar accept[ig] <- 1 } else { upost[ig,] <- upost[ig-1,] npost[ig,] <- npost[ig-1,] kpost[ig,] <- kpost[ig-1,] } if( (ig%%10)==0) cat('.') } if (FALSE) { # POSTPROCESSING: accept <- accept[-c(1:burnin)] cat("\nAcceptance rate:",mean(accept),"\n") kpost <- kpost[-c(1:burnin),] upost <- upost[-c(1:burnin),] npost <- npost[-c(1:burnin),] kpostmean <- apply(kpost,2,mean) upostmean <- apply(upost,2,mean) npostmean <- apply(npost,2,mean) kpostmedian <- apply(kpost,2,median) upostmedian <- apply(upost,2,median) npostmedian <- apply(npost,2,median) vpost <- npost-upost vpostmedian <- apply(vpost,2,median) # ###################################################################### # Figures par(mfcol=c(1,3),mai=rep(0,4)) map.landkreis(log(Y)) map.landkreis(Y/E,zlim=c(.1,2.4)) map.landkreis(exp(upostmedian),zlim=c(.1,2.4)) par(mfcol=c(2,4),mai=c(.5,.5,.05,.1),mgp=c(2.3,.8,0)) hist(kpost[,1],main="",xlab=expression(kappa[u]),prob=TRUE) lines(density(kpost[,1]),col=2) tmp <- seq(0,to=max(kpost[,1]),l=500) lines(tmp,dgamma(tmp,ahyper[1],bhyper[1]),col=4) abline(v=kpostmedian[1],col=3) hist(kpost[,2],main="",xlab=expression(kappa[y]),prob=TRUE) lines(density(kpost[,2]),col=2) tmp <- seq(0,to=max(kpost[,2]),l=500) lines(tmp,dgamma(tmp,ahyper[2],bhyper[2]),col=4) abline(v=kpostmedian[2],col=3) # Trace plots: plot(kpost[,1],ylab=expression(kappa[u]),type="l") abline(h=kpostmedian[1],col=3) plot(kpost[,2],ylab=expression(kappa[y]),type="l") abline(h=kpostmedian[2],col=3) # ACF: acf(kpost[,1],ylab=expression(kappa[u])) acf(kpost[,2],ylab=expression(kappa[y])) # scatter plots plot(kpost[,1],kpost[,2],xlab=expression(kappa[u]),ylab=expression(kappa[y])) abline(v=kpostmedian[1],h=kpostmedian[2],col=3) plot(accept+rnorm(ngibbs,sd=.05),pch=".",ylim=c(-1,2),yaxt="n",ylab="") text(ngibbs/2,1/2,paste("Acceptance rate:",round(mean(accept),3))) axis(2,at=c(0,1),label=c("Reject","Accept")) } detach(Oral) ###################################################################### spam/tests/covmat.R0000644000176000001440000000161712346261543014033 0ustar ripleyusers# This is file ../spam/tests/covmat.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) cat("Results of the form '[1] TRUE' are from 'all.equal'\n\n") h <- nearest.dist(100*1:10, 100*1:10+1:10, delta=10) identical(cov.exp(1:10, 10), cov.exp(h, 10)@entries) identical(cov.sph(1:10, 10), cov.exp(h, 10)@entries) identical(cov.nug(1:10, 10), cov.exp(h, 10)@entries) identical(cov.wu1(1:10, 10), cov.exp(h, 10)@entries) identical(cov.wu1(1:10, 10), cov.exp(h, 10)@entries) identical(cov.wu2(1:10, 10), cov.exp(h, 10)@entries) identical(cov.wu3(1:10, 10), cov.exp(h, 10)@entries) identical(cov.wend1(1:10, 10), cov.exp(h, 10)@entries) identical(cov.wend2(1:10, 10), cov.exp(h, 10)@entries) identical(cov.mat(1:10, 10), cov.exp(h, 10)@entries) spam/tests/demo_article-jss.Rout.save0000644000176000001440000000556212403543611017447 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/demo_article-jss.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > # This demo contains the R code to construct the figures and the table of the > # article: > # "spam: A Sparse Matrix R Package with Emphasis on > # MCMC Methods for Gaussian Markov Random Fields" > # submitted to JSS. > > > # The code presented here differs in the following points form the actually used > # one: > # - Very large grid sizes or very high order neighbor structures are not included > # here; > # - Instead of (100+1) factorizations only (10+1) are performed here; > # - No figure fine-tuning is done here. > # - We had a few additional gc(), just to be sure. > > > > # The following are tests specific. Not all computers run with profiling. Instead > # of commenting, we define dummies. > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. [1] 3 5 1 2 4 [1] 1 2 3 3 3 [1] 1 2 3 6 [1] 1.0000000 0.5000000 0.8660254 0.5773503 0.8164966 0.6123724 0.6123724 [8] 0.7905694 0.1581139 0.7745967 [1] 1 2 2 3 3 4 5 [1] 1 3 5 8 [1] 1 3 5 8 10 11 NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL (Upper) Cholesky factor of class 'spam.chol.NgPeyton' of dimension 100x100 with 917 (row-wise) nonzero elements. Density of the factor is 9.17%. Fill-in ratio is 2.07 (Optimal argument for 'chol' is 'memory=list(nnzR=917)'.) Class 'spam.chol.NgPeyton' (Upper) Cholesky factor of class 'spam.chol.NgPeyton' of dimension 3082x3082 with 146735 (row-wise) nonzero elements. Density of the factor is 1.54%. Fill-in ratio is 4.65 (Optimal argument for 'chol' is 'memory=list(nnzR=146735)'.) Class 'spam.chol.NgPeyton' NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL NULL > > proc.time() user system elapsed 4.196 0.029 4.212 spam/tests/solve.Rout.save0000644000176000001440000000643412403543611015352 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/solve.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Testing 'solve' and derivatives: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing option 'chol.update' (expect two passes then one fail): ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ## FAILED test value = 11.60986 at tolerance 1e-06 Testing methods for 'spam.chol.NgPeyton': ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing option 'cholupdatesingular' (expect a pass, a warning then 2 errors): ** PASSED test at tolerance 1e-06 Warning in update.spam.chol.NgPeyton(ch3, ss3) : Singularity problem when updating a Cholesky Factor. 'object' not updated. Error in update.spam.chol.NgPeyton(ch3, ss3) : Singularity problem when updating a Cholesky Factor. Error in update.spam.chol.NgPeyton(ch3, ss3) : 'cholupdatesingular' should be 'error', 'null' or 'warning'. Testing 'det' and derivatives: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing 'ordering' and derivatives: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing triangular solves for spam objects: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > > proc.time() user system elapsed 0.885 0.017 0.887 spam/tests/solve.R0000644000176000001440000001200112346261543013657 0ustar ripleyusers# This is file ../spam/tests/solve.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=TRUE, tag=NULL){ if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) test.value <- sum( abs(c(xtest) - c( xtrue) ) ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } # construct spd matrices (should be at least 3x3): n <- 10 set.seed(11) tt <- matrix(rnorm(n*n),n,n) tt <- t(tt) %*% tt tt[tt<0] <- 0 # I have seen that with R version 2.4.0 Patched (2006-11-25 r39997) # on i486-pc-linux-gnu, tt is not symmetric... tt <- tt-(tt-t(tt))/2 ss <- as.spam(tt) # solving system cat("Testing 'solve' and derivatives:\n") b <- rnorm(n) test.for.zero(solve(ss),solve(tt)) test.for.zero(solve(ss,b),solve(tt,b)) css <- chol(ss) ctt <- chol(tt[ordering(css),ordering(css)]) test.for.zero(t(as.spam(css))%*%as.spam(css), t(ctt)%*%ctt) test.for.zero(t(as.spam(css))%*%as.spam(css), tt[ordering(css),ordering(css)]) test.for.zero((t(as.spam(css))%*%as.spam(css))[ordering(css,inv=T),ordering(css,inv=T)], tt) test.for.zero(backsolve(css,forwardsolve(css,b[ordering(css,inv=T)]))[ordering(css)], backsolve(ctt,forwardsolve(t(ctt),b),n)) #### ,n as patch test.for.zero(backsolve(css,b[ordering(css,inv=T)])[ordering(css)], backsolve(ctt,b,n)) #### ,n as patch test.for.zero(forwardsolve(css,b[ordering(css,inv=T)])[ordering(css)], forwardsolve(t(ctt),b)) test.for.zero(forwardsolve(css,b)[ordering(css)], forwardsolve(t(ctt),b[ordering(css)])) test.for.zero(forwardsolve(css,tt[ordering(css,inv=T),])[ordering(css),], forwardsolve(t(ctt),tt)) cat("Testing option 'chol.update' (expect two passes then one fail):\n") ss1 <- ss+diag.spam(dim(ss)[1]) test.for.zero( chol(ss), update.spam.chol.NgPeyton(css, ss)) sel <- which(ss[1,,drop=TRUE]!=0) ss1[1,sel[-1]] <- 0 ss2 <- ss ss2[n,1] <- .1 spam.options(cholsymmetrycheck=FALSE) test.for.zero(as.spam(update.spam.chol.NgPeyton(css,ss1)), as.spam( chol(ss1))) test.for.zero(as.spam(update.spam.chol.NgPeyton(css,ss1)), as.spam( chol(ss2))) css <- chol(ss) # spam.options(trivalues=TRUE) # spam.options(trivalues=FALSE) spam.options(cholsymmetrycheck=TRUE) # methods for spam.chol.NgPeyton cat("Testing methods for 'spam.chol.NgPeyton':\n") test.for.zero(as.spam(css), ctt) test.for.zero(as.matrix(css), as.matrix(ctt)) test.for.zero(diag(css), diag(ctt)) test.for.zero(length(css), length(ctt[ctt!=0])) test.for.zero(dim(css), dim(ctt)) test.for.zero(c(css), c(ctt)) # update singular matrices cat("Testing option 'cholupdatesingular' (expect a pass, a warning then 2 errors):\n") ss3 <- spam(rep(1,4),2) ch3 <- chol( ss3+diag.spam(2)) spam.options(cholupdatesingular="null") test.for.zero(is.null(update(ch3, ss3)),TRUE) spam.options(cholupdatesingular="warning") options(warn=1) update(ch3, ss3) spam.options(cholupdatesingular="error") try(update(ch3, ss3)) spam.options(cholupdatesingular="NULL") try(update(ch3, ss3)) # determinants cat("Testing 'det' and derivatives:\n") test.for.zero(det(ss),det(tt)) test.for.zero(det(ss,log=T),det(tt,log=T)) test.for.zero(determinant(ss)$mod,determinant(tt)$mod) test.for.zero(determinant(ss,log=F)$mod,determinant(tt,log=F)$mod) test.for.zero(det(chol(ss)),det(chol(tt))) test.for.zero(2*sum(log(diag(css))), determinant(tt)$modulus) # orderings and derivatives cat("Testing 'ordering' and derivatives:\n") tt5 <- matrix(c( 2,0,2,0,4,0,2,0,3),3) ss5 <- spam( c( 2,0,2,0,4,0,2,0,3),3) test.for.zero(ordering(tt5),1:3) test.for.zero(ordering(ss5),1:3) test.for.zero(ordering(tt5,inv=T),3:1) test.for.zero(ordering(ss5,inv=T),3:1) test.for.zero(ordering(chol(ss5)),c(2,3,1)) test.for.zero(ordering(chol(ss5),inv=T),c(3,1,2)) # spam triangular solves cat("Testing triangular solves for spam objects:\n") # We need to generate a upper triangular matrix first. ctt <- chol(tt) css <- as.spam(ctt) b <- rnorm(nrow(tt)) # Recall: test.for.zero(backsolve(ctt,forwardsolve(t(ctt),b),n), solve(tt,b)) # Now do testing: test.for.zero(forwardsolve(t(css),b), forwardsolve(t(ctt),b)) test.for.zero(forwardsolve(ss,b), forwardsolve(tt,b)) cs <- ss cs[upper.tri(cs)] <- 0 test.for.zero(forwardsolve(cs,b), forwardsolve(ss,b)) #### ,n as patch test.for.zero(backsolve(css,b), backsolve(ctt,b, n)) test.for.zero(backsolve(ss,b), backsolve(tt,b, n)) test.for.zero(backsolve(t(cs),b), backsolve(tt,b, n)) test.for.zero(backsolve(css,forwardsolve(t(css),b)), backsolve(ctt,forwardsolve(t(ctt),b), n)) if (F){ # a few specific tests leading mostly to errors/warnings... cs <- css cs[3,3] <- 0 forwardsolve(cs,b) backsolve(cs,b) } options( echo=TRUE) spam/tests/diff.Rout.save0000644000176000001440000000240312403543611015122 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/diff.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. [1] 0 [1] 0 [1] 0 [1] 0 [1] TRUE > proc.time() user system elapsed 0.858 0.016 0.856 spam/tests/demo_article-jss-example2.Rout.save0000644000176000001440000001716312403543611021162 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/demo_article-jss-example2.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > # INITALIZE AND FUNCTIONS: > # JSS article: > # "spam: A Sparse Matrix R Package with Emphasis on > # MCMC Methods for Gaussian Markov Random Fields" > > > # Compared to the R code in the article, here we give: > # - improved formatting > # - more comments, e.g. how to run the code using regular matrices > # - the code to construct the figures > # - minor modifcations due to evolvement of spam > > > cat("\nThis demo contains the R code of the second example\nin the JSS article. As pointed out by Steve Geinitz\nand Andrea Riebler, the Gibbs sampler is not correct\nand contains several bugs. \n\nI'll post an updated sampler in a future release.\n\n") This demo contains the R code of the second example in the JSS article. As pointed out by Steve Geinitz and Andrea Riebler, the Gibbs sampler is not correct and contains several bugs. I'll post an updated sampler in a future release. > > > # INITALIZE AND FUNCTIONS: > require("fields", warn.conflict=FALSE) Loading required package: fields Loading required package: spam Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Attaching package: 'spam' The following objects are masked from 'package:base': backsolve, forwardsolve Loading required package: maps > spam.options(structurebased=TRUE) > > > # READ DATA: > attach(Oral) > > > > # CONSTRUCT ADJACENCY MATRIX: > loc <- system.file("demodata/germany.adjacency", package="spam") > A <- adjacency.landkreis(loc) > n <- dim(A)[1] > # Verification that we have a symmetric matrix: > # norm(A-t(A)); display(A) > > > # GIBBS SETUP: > set.seed(14) > > # Construct the individual block precisions > # (based on unit precision parameters kappa, denoted with k): > > Q1 <- R <- diag.spam( diff(A@rowpointers)) - A # this is R in (2) > pad(Q1) <- c(2*n,2*n) # previously: dim(Q1) <- c(2*n,2*n) > > Q2 <- rbind(cbind( diag.spam(n), -diag.spam(n)), + cbind(-diag.spam(n), diag.spam(n))) > > # Hence the precision Q in (2) is: > # Q <- kappau*Q1 + kappav*Q2 > > # pre-define > diagC <- as.spam( diag.spam(c(rep(0,n),rep(1,n)))) > > > # Recall: > # k=( kappa_u, kappa_y)' > > # hyperparameters > ahyper <- c( 1, 1) > bhyper <- c( .5, .01) > > > # Gibbs sampler > burnin <- 50 > ngibbs <- 150 > totalg <- burnin+ngibbs > > # Initialize parameters: > upost <- array(0, c(totalg, n)) > npost <- array(0, c(totalg, n)) > kpost <- array(0, c(totalg, 2)) > > # Starting values: > kpost[1,] <- c(40,500) > upost[1,] <- u <- rnorm(n,sd=.2) *1 > npost[1,] <- eta <- u + rnorm(n,sd=.05)*1 > > uRu <- t(u) %*% (R %*% u)/2 > etauetau <- t(eta-u) %*% (eta-u)/2 > > postshape <- ahyper + c(n-1,n)/2 > > accept <- numeric(totalg) > > struct <- chol(Q1 + Q2 + diag.spam(2*n), + memory=list(nnzcolindices=5500)) > > # struct <- NULL # If no update steps are wanted > > # R <- as.matrix(R) # If no spam analysis is wanted. > # Q1 <- as.matrix(Q1) > # Q2 <- as.matrix(Q2) > > > for (ig in 2:totalg) { + + + kstar <- rgamma(2,postshape, bhyper + c(uRu, etauetau)) + + + expeta0E <- exp(eta)*E + expeta0Eeta01 <- expeta0E *(eta-1) + diagC@entries <- expeta0E + Q <- kstar[1]*Q1 + kstar[2]*Q2 + diagC + b <- c( rep(0,n), Y + expeta0Eeta01) + + xstar <- rmvnorm.canonical(1, + # vector b: + b, + # Precision matrix + Q, + Rstruct=struct) + + + ustar <- xstar[1:n] + nstar <- xstar[1:n+n] + + uRustar <- t(ustar) %*% (R %*% ustar)/2 + etauetaustar <- t(nstar-ustar) %*% (nstar-ustar)/2 + + + # we work on the log scale: + # logalpha <- min(0, log(ratios))=min(0, expterm+(...)log(kappa)- + + exptmp <- sum(expeta0Eeta01*(eta-nstar) - E*(exp(eta)-exp(nstar))) - + sum( nstar^2*expeta0E)/2 + sum(eta^2*expeta0E)/2 - + kstar[1] * uRu + kpost[ig-1,1] * uRustar - + kstar[2] * etauetau + kpost[ig-1,2] * etauetaustar + factmp <- (postshape-1)*(log(kstar)-log(kpost[ig-1,1])) + + logalpha <- min(0, exptmp + sum(factmp)) + logU <- log(runif(1)) + + if (logU < logalpha) { # ACCEPT draw + upost[ig,] <- u <- ustar + npost[ig,] <- eta <- nstar + kpost[ig,] <- kstar + uRu <- uRustar + etauetau <- etauetaustar + accept[ig] <- 1 + } else { + upost[ig,] <- upost[ig-1,] + npost[ig,] <- npost[ig-1,] + kpost[ig,] <- kpost[ig-1,] + } + + if( (ig%%10)==0) cat('.') + + } ....................> > > if (FALSE) { + + # POSTPROCESSING: + + accept <- accept[-c(1:burnin)] + cat("\nAcceptance rate:",mean(accept),"\n") + + kpost <- kpost[-c(1:burnin),] + upost <- upost[-c(1:burnin),] + npost <- npost[-c(1:burnin),] + + kpostmean <- apply(kpost,2,mean) + upostmean <- apply(upost,2,mean) + npostmean <- apply(npost,2,mean) + + kpostmedian <- apply(kpost,2,median) + upostmedian <- apply(upost,2,median) + npostmedian <- apply(npost,2,median) + + vpost <- npost-upost + vpostmedian <- apply(vpost,2,median) + + + # + + + + + + ###################################################################### + # Figures + par(mfcol=c(1,3),mai=rep(0,4)) + map.landkreis(log(Y)) + map.landkreis(Y/E,zlim=c(.1,2.4)) + map.landkreis(exp(upostmedian),zlim=c(.1,2.4)) + + + par(mfcol=c(2,4),mai=c(.5,.5,.05,.1),mgp=c(2.3,.8,0)) + hist(kpost[,1],main="",xlab=expression(kappa[u]),prob=TRUE) + lines(density(kpost[,1]),col=2) + tmp <- seq(0,to=max(kpost[,1]),l=500) + lines(tmp,dgamma(tmp,ahyper[1],bhyper[1]),col=4) + abline(v=kpostmedian[1],col=3) + + hist(kpost[,2],main="",xlab=expression(kappa[y]),prob=TRUE) + lines(density(kpost[,2]),col=2) + tmp <- seq(0,to=max(kpost[,2]),l=500) + lines(tmp,dgamma(tmp,ahyper[2],bhyper[2]),col=4) + abline(v=kpostmedian[2],col=3) + + # Trace plots: + plot(kpost[,1],ylab=expression(kappa[u]),type="l") + abline(h=kpostmedian[1],col=3) + plot(kpost[,2],ylab=expression(kappa[y]),type="l") + abline(h=kpostmedian[2],col=3) + + # ACF: + acf(kpost[,1],ylab=expression(kappa[u])) + acf(kpost[,2],ylab=expression(kappa[y])) + + + + # scatter plots + plot(kpost[,1],kpost[,2],xlab=expression(kappa[u]),ylab=expression(kappa[y])) + abline(v=kpostmedian[1],h=kpostmedian[2],col=3) + + + plot(accept+rnorm(ngibbs,sd=.05),pch=".",ylim=c(-1,2),yaxt="n",ylab="") + text(ngibbs/2,1/2,paste("Acceptance rate:",round(mean(accept),3))) + axis(2,at=c(0,1),label=c("Reject","Accept")) + + } > > detach(Oral) > ###################################################################### > > > proc.time() user system elapsed 1.533 0.029 1.546 spam/tests/norm.R0000644000176000001440000000133712346261543013514 0ustar ripleyusers# This is file ../spam/tests/norm.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=TRUE, tag=NULL){ if( !is.null(tag)){ cat( "testing: ", tag, fill=TRUE)} denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) test.value <- sum( abs(c(xtest) - c( xtrue) ) ) /denom if( test.value < tol ){ cat("** PASSED test at tolerance ", tol, fill=TRUE)} else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, fill=TRUE)} } ######## set.seed(14) spam/tests/subsetting.Rout.save0000644000176000001440000001321712403543611016406 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/subsetting.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > #options( echo=FALSE) > library( spam, warn.conflict=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > > > test.for.zero <- function( xtest, xtrue, tol= 1.0e-6, relative=FALSE, + tag=NULL){ + # slightly different test function! + if( !is.null(tag)){ + cat( "testing: ", tag, fill=TRUE)} + + denom<- ifelse( relative, mean( abs(c(xtrue))),1.0) + + if (any(dim(xtest)!=dim(xtrue))) + return( cat("## FAILED dimensions ", dim(xtest), " and ", dim(xtrue), + fill=TRUE)) + test.value <- sum( abs(c(xtest) - c( xtrue) ),na.rm=T ) /denom + if( test.value < tol ){ + cat("** PASSED test at tolerance ", tol, fill=TRUE)} + else{ cat( "## FAILED test value = ", test.value, " at tolerance ", tol, + fill=TRUE)} + + } > > > > # subsetting: > ######################################################################## > > > # construct matrices (should be at least 3x5, with n n <- 10 > m <- 15 > > set.seed(14) > tt <- matrix(rnorm(m*n),n,m) > tt[tt<0] <- 0 > > ss <- as.spam(tt) > > cat("Testing subsetting\n") Testing subsetting > test.for.zero(ss[],tt[]) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(ss[,],tt[,]) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(ss[1,],tt[1,]) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(ss[,2],tt[,2]) # ok ** PASSED test at tolerance 1e-06 > test.for.zero(ss[1,3],tt[1,3])# ok ** PASSED test at tolerance 1e-06 > test.for.zero(ss[3:1,],tt[3:1,])# ok ** PASSED test at tolerance 1e-06 > > > rw <- sample(c(T,F),nrow(tt),rep=T) > cl <- sample(c(T,F),ncol(tt),rep=T) > test.for.zero(ss[rw,cl],tt[rw,cl]) ** PASSED test at tolerance 1e-06 > test.for.zero(ss[rw],tt[rw]) ** PASSED test at tolerance 1e-06 > > > > > rw <- c(1,3);cl <- 1:3; > test.for.zero(ss[rw,cl],tt[rw,cl]) ** PASSED test at tolerance 1e-06 > test.for.zero(ss[-rw,cl],tt[-rw,cl]) ** PASSED test at tolerance 1e-06 > test.for.zero(ss[-rw,-cl],tt[-rw,-cl]) ** PASSED test at tolerance 1e-06 > rw <- c(3,1);cl <- 1:3; test.for.zero(ss[rw,cl],tt[rw,cl]) ** PASSED test at tolerance 1e-06 > rw <- c(3,1,2,1);cl <- 1:3; test.for.zero(ss[rw,cl],tt[rw,cl]) ** PASSED test at tolerance 1e-06 > > tmp <- cbind(sample(1:3,24,rep=T),sample(1:5,24,rep=T)) > test.for.zero(ss[tmp],tt[tmp]) ** PASSED test at tolerance 1e-06 > > > test.for.zero(diag(10)[1:2,9:10],diag.spam(10)[1:2,9:10],rel=F) ** PASSED test at tolerance 1e-06 > > rs <- sample(c(0,1:(2*n)),2*m,replace=T) > test.for.zero(ss[rs],tt[rs]) ** PASSED test at tolerance 1e-06 > # NAs simply work! > rs <- sample(c(0,1:(2*n),NA),2*m,replace=T) > test.for.zero(ss[rs],tt[rs]) ** PASSED test at tolerance 1e-06 > > rs <- sample(c(T,F,NA),2*m,replace=T) > test.for.zero(ss[rs],tt[rs]) ** PASSED test at tolerance 1e-06 > > # stuff from 0.31: > > tt <- array(1:36,c(6,6)) > ss <- as.spam( tt) > > for (i in 1:4) { + rs <- cbind(rep(1:i,each=i),rep(1:i,i)) + test.for.zero(ss[rs],tt[rs]) + test.for.zero(ss[rs+1],tt[rs+1]) + test.for.zero(ss[rs+2],tt[rs+2]) + + ti <- array(1:(i^2),c(i,i)) + si <- as.spam( ti) + test.for.zero(si[rs],ti[rs]) + + si <- spam(0,i,i) + ti <- as.matrix(si) + test.for.zero(si[rs],ti[rs]) + + si <- diag.spam(i) + ti <- diag(i) + test.for.zero(si[rs],ti[rs]) + } ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 > > > if (F) { + # large timing example + + n <- 100 + m <- 15000 + + set.seed(14) + tt <- matrix(rnorm(m*n,mean=-1),n,m) + tt[tt<0] <- 0 + + ss <- as.spam(tt) + + set.seed(14) + system.time(for (i in 1:100) { + spam:::subset.rows.spam(ss,sample(1:n,10)) }) + set.seed(14) + system.time(for (i in 1:100) { + spam:::subset.spam(ss,sample(1:n,10),1:m) }) + + } > options( echo=TRUE) > > proc.time() user system elapsed 0.879 0.026 0.884 spam/tests/dist.Rout.save0000644000176000001440000000355112403543611015162 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/dist.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Results of the form '[1] TRUE' are from 'all.equal' [1] TRUE [1] TRUE [1] TRUE ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 storage conversion: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 [1] TRUE [1] TRUE Expect warning: ** PASSED test at tolerance 1e-06 Warning message: In as.spam(dist(c(0, NA, 1))) : 'NA/NaN/Inf' coerced to zero > proc.time() user system elapsed 0.859 0.016 0.858 spam/tests/covmat.Rout.save0000644000176000001440000000261312403543611015506 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/covmat.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Results of the form '[1] TRUE' are from 'all.equal' [1] TRUE [1] FALSE [1] FALSE [1] FALSE [1] FALSE [1] FALSE [1] FALSE [1] FALSE [1] FALSE [1] FALSE > proc.time() user system elapsed 0.837 0.018 0.836 spam/tests/helper.Rout.save0000644000176000001440000000616412403543611015501 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/helper.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. Testing bdiag.spam: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 Testing rmvnorm.*: ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 ** PASSED test at tolerance 1e-06 For rmvnorm.canonical: - comparing sample mean with truth: sample size n= 10 yields Frobenius-norm: 1.126081 sample size n= 100 yields Frobenius-norm: 0.3437831 sample size n= 1000 yields Frobenius-norm: 0.05796269 sample size n= 10000 yields Frobenius-norm: 0.0142912 - comparing sample variance with truth: sample size n= 10 yields Frobenius-norm: 1.391891 sample size n= 100 yields Frobenius-norm: 0.3126783 sample size n= 1000 yields Frobenius-norm: 0.1516094 sample size n= 10000 yields Frobenius-norm: 0.05381879 For rmvnorm.prec: - comparing sample mean with truth: sample size n= 10 yields Frobenius-norm: 1.126081 sample size n= 100 yields Frobenius-norm: 0.3437831 sample size n= 1000 yields Frobenius-norm: 0.05796269 sample size n= 10000 yields Frobenius-norm: 0.0142912 - comparing sample variance with truth: sample size n= 10 yields Frobenius-norm: 1.391891 sample size n= 100 yields Frobenius-norm: 0.3126783 sample size n= 1000 yields Frobenius-norm: 0.1516094 sample size n= 10000 yields Frobenius-norm: 0.05381879 For rmvnorm.spam: - comparing sample mean with truth: sample size n= 10 yields Frobenius-norm: 1.002695 sample size n= 100 yields Frobenius-norm: 0.2902257 sample size n= 1000 yields Frobenius-norm: 0.02515534 sample size n= 10000 yields Frobenius-norm: 0.01146114 - comparing sample variance with truth: sample size n= 10 yields Frobenius-norm: 1.677971 sample size n= 100 yields Frobenius-norm: 0.5462893 sample size n= 1000 yields Frobenius-norm: 0.2071184 sample size n= 10000 yields Frobenius-norm: 0.06459744 > > proc.time() user system elapsed 0.993 0.027 1.004 spam/tests/constructors.R0000644000176000001440000000221412375442511015302 0ustar ripleyusers# This is file ../spam/tests/constructors.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] options( echo=FALSE) library( spam, warn.conflict=FALSE) set.seed(14) n <- 7 ln <- 20 A <- spam(0,n,n) is <- sample(n,ln, replace=TRUE) js <- sample(n,ln, replace=TRUE) A[ unique( cbind(is,js)) ] <- 1:8 re <- A@rowpointers rowpointers(A) <- re # following will case error, thus the `try` r <- re; r[1:2] <- rev(r[1:2]); try( rowpointers(A) <- r ) r <- re; r[1] <- 0; try( rowpointers(A) <- r ) r <- re; r[n+1] <- 2; try( rowpointers(A) <- r ) r <- re; r[n+1] <- 20; try( rowpointers(A) <- r ) r <- c(rep(1,n),n+1); try( rowpointers(A) <- r ) ce <- A@colindices colindices(A) <- ce r <- ce; r[1:4] <- rev(r[1:4]); try( colindices(A) <- r ) r <- ce; r[1] <- 0; try( colindices(A) <- r ) r <- ce; r[1] <- 20; try( colindices(A) <- r ) entries(A) <- A@entries try( entries(A) <- as.logical(A@entries)) try( entries(A) <- c(r,1)) try( entries(A) <- r[-1]) try( dimension(A) <- c(1,2)) spam/tests/demo_cholesky.Rout.save0000644000176000001440000000246412403543611017046 0ustar ripleyusers R Under development (unstable) (2014-09-08 r66545) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # This is file ../spam/tests/demo_cholesky.R > # This file is part of the spam package, > # http://www.math.uzh.ch/furrer/software/spam/ > # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] > > > > > > > > > > # We illustrate the Cholesky decompostion approaches > options( echo=FALSE) Loading required package: grid Spam version 1.0-1 (2014-09-09) is loaded. Type 'help( Spam)' or 'demo( spam)' for a short introduction and overview of this package. Help for individual functions is also obtained by adding the suffix '.spam' to the function name, e.g. 'help( chol.spam)'. > > proc.time() user system elapsed 0.849 0.024 0.856 spam/src/0000755000176000001440000000000012403556057012040 5ustar ripleyusersspam/src/spamown2.f0000644000176000001440000002327612403556057013767 0ustar ripleyusers subroutine triplet3csr(nrow,ncol,nnz,a,ir,jc,ao,jao,iao,eps) implicit none double precision a(*),ao(*),eps integer nrow,ncol,nnz,ir(*),jc(*),jao(*),iao(*) integer kk,k,i,j,tmpi, cr(nrow), ig(nrow+1), g(nnz),st(nrow+1) double precision tmpa(ncol) C We assume that we have the correct dimensions. c in case we need to determine the max and min c also clean up the vectors containing the elements c provide empty arrays: do kk = 1,nnz g(kk) = 0 enddo do kk = 1,nrow cr(kk) = 0 enddo c row need to be determined k=0 do kk=1, nnz if ((jc(kk).le.ncol).and.(ir(kk).le.nrow)) then k=k+1 if (k.lt.kk) then jc(k)=jc(kk) ir(k)=ir(kk) a(k)=a(kk) endif endif enddo nnz=k do kk = 1,nnz cr(ir(kk)) = cr(ir(kk)) + 1 c jao(ir(kk)) = cr(ir(kk)) enddo c return st(1) = 1 do kk = 1, nrow st(kk+1) = st(kk) + cr(kk) enddo do kk = 1, nrow ig(kk) = st(kk) enddo do k=1,nnz kk = ir(k) g(ig(kk)) = k ig(kk) = ig(kk) +1 enddo c return kk = 0 iao(1)=1 do i = 1,nrow do j=1,ncol tmpa(j)=0.0 enddo do j=1,cr(i) tmpi = g(st(i) + j - 1) tmpa(jc(tmpi)) = tmpa(jc(tmpi)) + a(tmpi) enddo do j=1,ncol if( abs(tmpa(j)).gt.eps) then kk = kk + 1 ao(kk) = tmpa(j) jao(kk) = j endif enddo iao(i+1)= kk+1 enddo nnz = kk return end c----------------------------------------------------------------------- subroutine triplet2csr(nrow,ncol,nnz,a,ir,jc,ao,jao,iao,eps) implicit none double precision a(*),ao(*),eps integer nrow,ncol,nnz,ir(*),jc(*),jao(*),iao(*) integer newnnz, ipos, k, i, j, tmp1, tmp2 double precision tmp c----------------------------------------------------------------------- c Triplet representation to Compressed Sparse Row c Similar to coocsr from sparsekit c----------------------------------------------------------------------- c converts a matrix that is stored in coordinate format c a, ir, jc into a row general sparse ao, jao, iao format. c c on entry: c--------- c nrow = row dimension of matrix c nrow = col dimension of matrix c nnz = number of nonzero elements in matrix c a, c ir, c jc = matrix in coordinate format. a(k), ir(k), jc(k) store the nnz c nonzero elements of the matrix with a(k) = actual real value of c the elements, ir(k) = its row number and jc(k) = its column c number. The order of the elements is arbitrary. c c on return: c----------- c nnz = number of nonzero elements in matrix c ao, jao, iao = matrix in general sparse matrix format with ao c continung the real values, jao containing the column indices, c and iao being the pointer to the beginning of the row, c in arrays ao, jao. c c------------------------------------------------------------------------ c cycle over all entries and count the number of elements in each row c skip if larger than nrow and ncol. newnnz is actual number within c matrix(nrow,ncol). newnnz = 0 do k=1, nnz tmp1 = ir(k) if (tmp1 .le. nrow) then tmp2 = jc(k) if (tmp2 .le. ncol) then if (abs(a(k)) .gt. eps) then iao(tmp1) = iao(tmp1)+1 newnnz = newnnz + 1 if (newnnz.lt.k) then jc(newnnz) = tmp2 ir(newnnz) = tmp1 a(newnnz) = a(k) endif endif endif endif enddo c Starting position of each row, essentially a cumsum of iao k = 1 do j=1,nrow+1 tmp1 = iao(j) iao(j) = k k = k + tmp1 enddo c Go through the structure once more. Fill in output matrix. c iao is miss used. do k=1, newnnz i = ir(k) tmp1 = iao(i) ao(tmp1) = a(k) jao(tmp1) = jc(k) iao(i) = tmp1+1 enddo c Shift back iao do j=nrow,1,-1 iao(j+1) = iao(j) enddo iao(1) = 1 c Sort the individual rows do i = 1, nrow do ipos = iao(i), iao(i+1)-1 do j = iao(i+1)-1, ipos+1, -1 k = j - 1 if (jao(k).eq.jao(j)) then ao(k) = ao(k)+ao(j) ao(j) = 0.0 else if (jao(k).gt.jao(j)) then tmp1 = jao(k) jao(k) = jao(j) jao(j) = tmp1 tmp = ao(k) ao(k) = ao(j) ao(j) = tmp endif endif enddo enddo enddo call cleanspam(nrow,ao,jao,iao,eps) nnz = iao(nrow+1)-1 return c----------------------------------------------------------------------- end subroutine cleanspam(nrow,a,ja,ia,eps) implicit none integer nrow, ia(nrow+1), ja(*) double precision a(*), eps c c this routine removes zero entries. for more complicated cleaning c use the sparsekit2 subroutine clncsr. c c On entry: c---------- c nrow -- row dimension of the matrix c a,ja,ia -- input matrix in CSR format c c On return: c----------- c a,ja,ia -- cleaned matrix c c Notes: c------- c Reinhard Furrer 2006-09-13 c----------------------------------------------------------------------- c c Local integer i,j,k, oldia(nrow+1) do i = 1, nrow+1 oldia(i) = ia(i) enddo k = 1 do i = 1, nrow ia(i) = k do j=oldia(i),oldia(i+1)-1 if (.not.(dabs(a(j)) .le. eps)) then ja(k) = ja(j) a(k) = a(j) k = k + 1 endif enddo enddo ia(nrow+1) = k return c---- end of cleanspam ------------------------------------------------- c----------------------------------------------------------------------- end subroutine circulant(nrow,len, x,j, a,ja,ia) implicit none integer nrow, len, ia(nrow+1), ja(*), j(len) double precision a(*), x(len) c c c c On entry: c---------- c nrow -- row dimension of the matrix c len -- #nnz per line c x,j -- input values and indicies c c On return: c----------- c a,ja,ia -- cleaned circulant matrix c c Notes: c------- c Reinhard Furrer 2011-08-03 c----------------------------------------------------------------------- c c Local integer i,k, kk kk = 1 ia(1) = 1 do i = 1, nrow ia(i+1) = ia(i)+len do k = 1, len ja(kk) = mod( j(k) +i-2, nrow)+1 a(kk) = x(k) kk = kk+1 enddo enddo call sortrows(nrow,a, ja, ia) return c---- end of circulant ------------------------------------------------- c----------------------------------------------------------------------- end subroutine toeplitz(nrow,len, x,j, a,ja,ia,kk) implicit none integer nrow, len, ia(nrow+1), ja(*), j(len), kk double precision a(*), x(len) c c c c On entry: c---------- c nrow -- row dimension of the matrix c len -- total #nnz per line and column c x,j -- input values and indicies (indices are shifted!) c c On return: c----------- c a,ja,ia -- toeplitz matrix c kk -- nonzero elements c c Notes: c------- c Reinhard Furrer 2011-08-03 c----------------------------------------------------------------------- c c Local integer i,k, newj kk = 1 ia(1) = 1 do i = 1, nrow do k = 1, len newj = j(k) + i - nrow if ((newj.ge.1).and.(newj.le.nrow)) then ja(kk) = newj a(kk) = x(k) kk = kk+1 endif enddo ia(i+1) = kk enddo kk = kk - 1 return c---- end of toeplitz ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine sortrows(nrow,a,ja,ia) implicit none integer nrow integer ia(nrow+1),ja(*) double precision a(*) c c sorts the rows according to column entries c c On entry: c---------- c nrow -- row dimension of the matrix c a,ja,ia -- input matrix in sparse format c c On return: c----------- c a,ja,ia -- cleaned matrix c c Notes: c------- c Reinhard Furrer 2006-09-13 c----------------------------------------------------------------------- c Local variables integer i,j,k,ko,ipos double precision tmp c c c .. order the entries according to column indices c burble-sort is used c do 190 i = 1, nrow do 160 ipos = ia(i), ia(i+1)-1 do 150 j = ia(i+1)-1, ipos+1, -1 k = j - 1 if (ja(k).gt.ja(j)) then ko = ja(k) ja(k) = ja(j) ja(j) = ko tmp = a(k) a(k) = a(j) a(j) = tmp endif 150 continue 160 continue 190 continue return c---- end of sortrows -------------------------------------------------- c----------------------------------------------------------------------- end spam/src/dist.f0000644000176000001440000002017512403556057013157 0ustar ripleyusersC closestdistXY, distance between x and x or between x and y C C C We have four distances implemented: C c("euclidean", "maximum", "minkowski", "greatcircle") C c In case we need the distance matrix between x and x, then the c following parameters are used as well: c if part=-1, lower tri, part=0 the entire matrix c part= 1, upper tri only. c only values smaller than eta are considered. c p power for minkowski double precision function euclid(x,y,p) implicit none double precision x,y,p euclid=(x-y)**2 return end double precision function minkowski(x,y,p) implicit none double precision x,y,p minkowski=abs(x-y)**p return end subroutine closestdist( ncol, x,nrowx, y, nrowy, & part, p, method, & eta, colindices, rowpointers, entries, nnz, iflag) implicit none double precision euclid, minkowski external euclid, minkowski integer ncol,nrowx, nrowy, nnz, method, part, iflag integer colindices(nnz), rowpointers(nrowx+1) double precision p, x(nrowx,ncol),y(nrowy,ncol) double precision eta, entries(nnz) if (method.eq.1) then p=2.0 call closestEdistXY( ncol, x,nrowx, y, nrowy, & part, p, euclid, & eta, colindices, rowpointers, entries, nnz, iflag) endif if (method.eq.2) then p=1.0 call closestMAXdistXY( ncol, x,nrowx, y, nrowy, & part, & eta, colindices, rowpointers, entries, nnz, iflag) endif if (method.eq.3) then call closestEdistXY( ncol, x,nrowx, y, nrowy, & part, p, minkowski, & eta, colindices, rowpointers, entries, nnz, iflag) endif if (method.eq.4) then call closestGCdistXY( x,nrowx, y, nrowy, & part, p, & eta, colindices, rowpointers, entries, nnz, iflag) endif return end subroutine closestEdistXY( ncol, x,xnrow, y, ynrow, & part, p, distfcn, & eta, colindices, rowpointers, entries, nnz, iflag) implicit none double precision distfcn external distfcn integer ncol,xnrow, ynrow, nnz, part,iflag integer colindices(nnz),rowpointers(xnrow+1) double precision p,x(xnrow,ncol), y(ynrow,ncol) double precision eta, entries(nnz) c local variables integer jja, i,j,k, ifrom,ito, jfrom, jto double precision etap, tmp,pinv etap=eta**p pinv=1/p jja=1 rowpointers(1)=1 jfrom = 1 jto = ynrow c cycle over all rows of x (independent of part) do i= 1,xnrow if (part .lt. 0) then jto = i endif if (part .gt. 0) then jfrom = i endif do 10 j = jfrom,jto c Start calculating the distance (until delta is exceeded) tmp = 0.0 do k = 1, ncol tmp = tmp + distfcn(x(i,k),y(j,k),p) if( tmp.gt.etap) goto 10 enddo c Delta is not exceeded. c in case nnz was too small, recall line to get a better estimate if( jja .gt. nnz) then iflag = i goto 20 endif colindices(jja) = j if (p.eq.2) then entries(jja) = sqrt(tmp) else if (p.eq.1) then entries(jja) = tmp else entries(jja) = tmp**pinv endif endif jja = jja + 1 10 continue rowpointers(i+1)=jja enddo if (part.gt.0) then rowpointers(xnrow+1)=jja endif nnz=jja-1 20 continue return end subroutine closestMAXdistXY( ncol, x,xnrow, y, ynrow, & part, & eta, colindices, rowpointers, entries, nnz, iflag) implicit none integer ncol,xnrow, ynrow, nnz, part,iflag integer colindices(nnz),rowpointers(xnrow+1) double precision x(xnrow,ncol), y(ynrow,ncol) double precision eta, entries(nnz) c local variables integer jja, i,j,k, ifrom,ito, jfrom, jto double precision tmp jja=1 rowpointers(1)=1 jfrom = 1 jto = ynrow do i= 1,xnrow if (part .lt. 0) then jto = i endif if (part .gt. 0) then jfrom = i endif do 10 j = jfrom,jto c Start calculating the distance tmp = 0.0 do k = 1, ncol tmp = max(tmp, abs(x(i,k)-y(j,k))) if( tmp.gt.eta) goto 10 enddo c Delta is not exceeded. c (i,j) has a distance smaller than eta. c in case nnz was too small, recall line to get a better estimate if( jja .gt. nnz) then iflag = i goto 20 endif colindices(jja) = j entries(jja) = tmp jja = jja + 1 10 continue rowpointers(i+1)=jja enddo if (part.gt.0) then rowpointers(xnrow+1)=jja endif nnz=jja-1 20 continue return end subroutine closestGCdistXY( x,nx, y, ny, & part,p, & eta, colindices, rowpointers, entries, nnz, iflag) implicit none integer nx, ny, nnz, colindices(nnz),rowpointers(nx+1) integer part, iflag double precision x(nx,2), y(ny,2), p, eta, entries(nnz) c local variables logical equi integer jja, i,j,k, ifrom,ito, jfrom, jto double precision etap, tmp, rad, tmp1, tmp2 double precision scy12(ny), ccy12(ny), sy2(ny) double precision scx12, ccx12, sx2 parameter (rad = 0.01745329251994329) c Great savings if we know that x=y. This can be done by c multiplying diag by two. if (p .lt. 0) then equi=.TRUE. p=-p else equi= .FALSE. endif jja=1 etap=cos(eta*rad) rowpointers(1)=1 jfrom = 1 jto = ny DO j=1,ny tmp1=y(j,1)*rad tmp2=y(j,2)*rad ccy12(j)=dcos(tmp1)*dcos(tmp2) scy12(j)=dsin(tmp1)*dcos(tmp2) sy2(j)=dsin(tmp2) ENDDO do i= 1,nx c x2 is missing if equi=.TRUE. and we reuse the y stuff if (equi .eqv. .TRUE.) then ccx12=ccy12(i) scx12=scy12(i) sx2=sy2(i) else tmp1=x(i,1)*rad tmp2=x(i,2)*rad ccx12=dcos(tmp1)*dcos(tmp2) scx12=dsin(tmp1)*dcos(tmp2) sx2=dsin(tmp2) endif if (part .lt. 0) then jto = i endif if (part .gt. 0) then jfrom = i endif do 10 j = jfrom,jto c Start calculating the distance tmp = ccx12 * ccy12(j) + scx12 * scy12(j) + sx2*sy2(j) if (tmp .lt. etap) goto 10 c Delta is not exceeded. c Due to numerical instabilities, we need the following... 0.15-2: if (tmp .ge. 1) then tmp = 0.0 else tmp = dacos( tmp) endif c (i,j) has a distance smaller than eta. c In case nnz was too small, recall line to get a better estimate if( jja .gt. nnz) then iflag = i goto 20 endif colindices(jja) = j entries(jja) = tmp*p jja = jja + 1 10 continue rowpointers(i+1)=jja enddo if (part.gt.0) then rowpointers(nx+1)=jja endif nnz=jja-1 20 continue return end spam/src/xybind.f0000644000176000001440000000162612403556057013511 0ustar ripleyusersc system("R CMD SHLIB ../src/xybind.f") subroutine cbind(xncol,nrow,yncol, clen, a,ia,ja, b,ib,jb, & c,ic,jc) implicit none integer xncol, yncol, nrow, clen integer ia(*), ja(*), ib(*), jb(*), ic(*), jc(*) double precision a(*), b(*), c(*) integer j,j1,i,k k=1 do j = 1,nrow jc(j)=ja(j)+jb(j)-1 j1=j+1 if (ja(j) .lt. ja(j1)) then do i=ja(j),ja(j1)-1 c(k)=a(i) ic(k)=ia(i) k=k+1 c if (k.gt.clen) return enddo endif if (jb(j) .lt. jb(j1)) then do i=jb(j),jb(j1)-1 c(k)=b(i) ic(k)=ib(i)+xncol k=k+1 c if (k.gt.clen) return enddo endif enddo j=nrow+1 jc(j)=ja(j)+jb(j)-1 return end spam/src/fromsparsekit.f0000644000176000001440000006364512403556057015116 0ustar ripleyusersc----------------------------------------------------------------------- subroutine amask (nrow,ncol,a,ja,ia,jmask,imask, * c,jc,ic,iw,nzmax,ierr) c--------------------------------------------------------------------- real*8 a(*),c(*) integer ia(nrow+1),ja(*),jc(*),ic(nrow+1),jmask(*),imask(nrow+1) logical iw(ncol) c----------------------------------------------------------------------- c This subroutine builds a sparse matrix from an input matrix by c extracting only elements in positions defined by the mask jmask, imask c----------------------------------------------------------------------- c On entry: c--------- c nrow = integer. row dimension of input matrix c ncol = integer. Column dimension of input matrix. c c a, c ja, c ia = matrix in Compressed Sparse Row format c c jmask, c imask = matrix defining mask (pattern only) stored in compressed c sparse row format. c c nzmax = length of arrays c and jc. see ierr. c c On return: c----------- c c a, ja, ia and jmask, imask are unchanged. c c c c jc, c ic = the output matrix in Compressed Sparse Row format. c c ierr = integer. serving as error message.c c ierr = 1 means normal return c ierr .gt. 1 means that amask stopped when processing c row number ierr, because there was not enough space in c c, jc according to the value of nzmax. c c work arrays: c------------- c iw = logical work array of length ncol. c c note: c------ the algorithm is in place: c, jc, ic can be the same as c a, ja, ia in which cas the code will overwrite the matrix c c on a, ja, ia c c----------------------------------------------------------------------- ierr = 0 len = 0 do 1 j=1, ncol iw(j) = .false. 1 continue c unpack the mask for row ii in iw do 100 ii=1, nrow c save pointer in order to be able to do things in place do 2 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .true. 2 continue c add umasked elemnts of row ii k1 = ia(ii) k2 = ia(ii+1)-1 ic(ii) = len+1 do 200 k=k1,k2 j = ja(k) if (iw(j)) then len = len+1 if (len .gt. nzmax) then ierr = ii return endif jc(len) = j c(len) = a(k) endif 200 continue c do 3 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .false. 3 continue 100 continue ic(nrow+1)=len+1 c return c-----end-of-amask ----------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aplsb1 (nrow,ncol,a,ja,ia,s,b,jb,ib,c,jc,ic, * nzmax,ierr) real*8 a(*), b(*), c(*), s integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1) c----------------------------------------------------------------------- c performs the operation C = A+s B for matrices in sorted CSR format. c the difference with aplsb is that the resulting matrix is such that c the elements of each row are sorted with increasing column indices in c each row, provided the original matrices are sorted in the same way. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a, c ja, c ia = Matrix A in compressed sparse row format with entries sorted c c s = real. scalar factor for B. c c b, c jb, c ib = Matrix B in compressed sparse row format with entries sorted c ascendly in each row c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c Notes: c------- c this will not work if any of the two input matrices is not sorted c----------------------------------------------------------------------- ierr = 0 kc = 1 ic(1) = kc c c the following loop does a merge of two sparse rows + adds them. c do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue c c this is a while -- do loop -- c if (ka .le. kamax .or. kb .le. kbmax) then c if (ka .le. kamax) then j1 = ja(ka) else c take j1 large enough that always j2 .lt. j1 j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else c similarly take j2 large enough that always j1 .lt. j2 j2 = ncol+1 endif c c three cases c if (j1 .eq. j2) then c(kc) = a(ka)+s*b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then jc(kc) = j1 c(kc) = a(ka) ka = ka+1 kc = kc+1 else if (j1 .gt. j2) then jc(kc) = j2 c(kc) = s*b(kb) kb = kb+1 kc = kc+1 endif if (kc .gt. nzmax) goto 999 goto 5 c c end while loop c endif ic(i+1) = kc 6 continue return 999 ierr = i return c------------end-of-aplsb1 --------------------------------------------- c----------------------------------------------------------------------- end c subroutine submat (n,job,i1,i2,j1,j2,a,ja,ia,nr,nc,ao,jao,iao) integer n,job,i1,i2,j1,j2,nr,nc,ia(*),ja(*),jao(*),iao(*) real*8 a(*),ao(*) c----------------------------------------------------------------------- c extracts the submatrix A(i1:i2,j1:j2) and puts the result in c matrix ao,iao,jao c---- In place: ao,jao,iao may be the same as a,ja,ia. c-------------- c on input c--------- c n = row dimension of the matrix c i1,i2 = two integers with i2 .ge. i1 indicating the range of rows to be c extracted. c j1,j2 = two integers with j2 .ge. j1 indicating the range of columns c to be extracted. c * There is no checking whether the input values for i1, i2, j1, c j2 are between 1 and n. c a, c ja, c ia = matrix in compressed sparse row format. c c job = job indicator: if job .ne. 1 then the real values in a are NOT c extracted, only the column indices (i.e. data structure) are. c otherwise values as well as column indices are extracted... c c on output c-------------- c nr = number of rows of submatrix c nc = number of columns of submatrix c * if either of nr or nc is nonpositive the code will quit. c c ao, c jao,iao = extracted matrix in general sparse format with jao containing c the column indices,and iao being the pointer to the beginning c of the row,in arrays a,ja. c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c nr = i2-i1+1 nc = j2-j1+1 c if ( nr .le. 0 .or. nc .le. 0) return c klen = 0 c c simple procedure. proceeds row-wise... c do 100 i = 1,nr ii = i1+i-1 k1 = ia(ii) k2 = ia(ii+1)-1 iao(i) = klen+1 c----------------------------------------------------------------------- do 60 k=k1,k2 j = ja(k) if (j .ge. j1 .and. j .le. j2) then klen = klen+1 if (job .eq. 1) ao(klen) = a(k) jao(klen) = j - j1+1 endif 60 continue 100 continue iao(nr+1) = klen+1 return c------------end-of submat---------------------------------------------- c----------------------------------------------------------------------- end c subroutine amux (n, x, y, a,ja,ia) real*8 x(*), y(*), a(*) integer n, ja(*), ia(*) c----------------------------------------------------------------------- c A times a vector c----------------------------------------------------------------------- c multiplies a matrix by a vector using the dot product form c Matrix A is stored in compressed sparse row storage. c c on entry: c---------- c n = row dimension of A c x = real array of length equal to the column dimension of c the A matrix. c a, ja, c ia = input matrix in compressed sparse row format. c c on return: c----------- c y = real array of length n, containing the product y=Ax c c----------------------------------------------------------------------- c local variables c real*8 t integer i, k c----------------------------------------------------------------------- do 100 i = 1,n c c compute the inner product of row i with vector x c t = 0.0d0 do 99 k=ia(i), ia(i+1)-1 t = t + a(k)*x(ja(k)) 99 continue c c store result in y(i) c y(i) = t 100 continue c return c---------end-of-amux--------------------------------------------------- c----------------------------------------------------------------------- end c subroutine amubdg (nrow,ncol,ncolb,ja,ia,jb,ib,ndegr,nnz,iw) integer ja(*),jb(*),ia(nrow+1),ib(ncol+1),ndegr(nrow),iw(ncolb) c----------------------------------------------------------------------- c gets the number of nonzero elements in each row of A*B and the total c number of nonzero elements in A*B. c----------------------------------------------------------------------- c on entry: c -------- c c nrow = integer. row dimension of matrix A c ncol = integer. column dimension of matrix A = row dimension of c matrix B. c ncolb = integer. the colum dimension of the matrix B. c c ja, ia= row structure of input matrix A: ja = column indices of c the nonzero elements of A stored by rows. c ia = pointer to beginning of each row in ja. c c jb, ib= row structure of input matrix B: jb = column indices of c the nonzero elements of A stored by rows. c ib = pointer to beginning of each row in jb. c c on return: c --------- c ndegr = integer array of length nrow containing the degrees (i.e., c the number of nonzeros in each row of the matrix A * B c c nnz = total number of nonzero elements found in A * B c c work arrays: c------------- c iw = integer work array of length ncolb. c----------------------------------------------------------------------- do 1 k=1, ncolb iw(k) = 0 1 continue do 2 k=1, nrow ndegr(k) = 0 2 continue c c method used: Transp(A) * A = sum [over i=1, nrow] a(i)^T a(i) c where a(i) = i-th row of A. We must be careful not to add the c elements already accounted for. c c do 7 ii=1,nrow c c for each row of A c ldg = 0 c c end-of-linked list c last = -1 do 6 j = ia(ii),ia(ii+1)-1 c c row number to be added: c jr = ja(j) do 5 k=ib(jr),ib(jr+1)-1 jc = jb(k) if (iw(jc) .eq. 0) then c c add one element to the linked list c ldg = ldg + 1 iw(jc) = last last = jc endif 5 continue 6 continue ndegr(ii) = ldg c c reset iw to zero c do 61 k=1,ldg j = iw(last) iw(last) = 0 last = j 61 continue c----------------------------------------------------------------------- 7 continue c nnz = 0 do 8 ii=1, nrow nnz = nnz+ndegr(ii) 8 continue c return c---------------end-of-amubdg ------------------------------------------ c----------------------------------------------------------------------- end c subroutine amub (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,ierr) real*8 a(*), b(*), c(*) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(*),ic(*),iw(ncol) c----------------------------------------------------------------------- c performs the matrix by matrix product C = A B c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A = row dimension of C c ncol = integer. The column dimension of B = column dimension of C c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length equal to the number of c columns in A. c Note: c------- c The row dimension of B is not needed. However there is no checking c on the condition that ncol(A) = nrow(B). c c----------------------------------------------------------------------- real*8 scal logical values values = (job .ne. 0) len = 0 ic(1) = 1 ierr = 0 c initialize array iw. do 1 j=1, ncol iw(j) = 0 1 continue c do 500 ii=1, nrow c row i do 200 ka=ia(ii), ia(ii+1)-1 if (values) scal = a(ka) jj = ja(ka) do 100 kb=ib(jj),ib(jj+1)-1 jcol = jb(kb) jpos = iw(jcol) if (jpos .eq. 0) then len = len+1 if (len .gt. nzmax) then ierr = ii return endif jc(len) = jcol iw(jcol)= len if (values) c(len) = scal*b(kb) else if (values) c(jpos) = c(jpos) + scal*b(kb) endif 100 continue 200 continue do 201 k=ic(ii), len iw(jc(k)) = 0 201 continue ic(ii+1) = len+1 500 continue return c-------------end-of-amub----------------------------------------------- c----------------------------------------------------------------------- end c c------------------------------------------------------------------------ subroutine getl (n,a,ja,ia,ao,jao,iao) integer n, ia(*), ja(*), iao(*), jao(*) real*8 a(*), ao(*) c------------------------------------------------------------------------ c this subroutine extracts the lower triangular part of a matrix c and writes the result ao, jao, iao. The routine is in place in c that ao, jao, iao can be the same as a, ja, ia if desired. c----------- c on input: c c n = dimension of the matrix a. c a, ja, c ia = matrix stored in compressed sparse row format. c On return: c ao, jao, c iao = lower triangular matrix (lower part of a) c stored in a, ja, ia, format c note: the diagonal element is the last element in each row. c i.e. in a(ia(i+1)-1 ) c ao, jao, iao may be the same as a, ja, ia on entry -- in which case c getl will overwrite the result on a, ja, ia. c c------------------------------------------------------------------------ c local variables real*8 t integer ko, kold, kdiag, k, i c c inititialize ko (pointer for output matrix) c ko = 0 do 7 i=1, n kold = ko kdiag = 0 do 71 k = ia(i), ia(i+1) -1 if (ja(k) .gt. i) goto 71 ko = ko+1 ao(ko) = a(k) jao(ko) = ja(k) if (ja(k) .eq. i) kdiag = ko 71 continue if (kdiag .eq. 0 .or. kdiag .eq. ko) goto 72 c c exchange c t = ao(kdiag) ao(kdiag) = ao(ko) ao(ko) = t c k = jao(kdiag) jao(kdiag) = jao(ko) jao(ko) = k 72 iao(i) = kold+1 7 continue c redefine iao(n+1) iao(n+1) = ko+1 return c----------end-of-getl ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getu (n,a,ja,ia,ao,jao,iao) integer n, ia(*), ja(*), iao(*), jao(*) real*8 a(*), ao(*) c------------------------------------------------------------------------ c this subroutine extracts the upper triangular part of a matrix c and writes the result ao, jao, iao. The routine is in place in c that ao, jao, iao can be the same as a, ja, ia if desired. c----------- c on input: c c n = dimension of the matrix a. c a, ja, c ia = matrix stored in a, ja, ia, format c On return: c ao, jao, c iao = upper triangular matrix (upper part of a) c stored in compressed sparse row format c note: the diagonal element is the last element in each row. c i.e. in a(ia(i+1)-1 ) c ao, jao, iao may be the same as a, ja, ia on entry -- in which case c getu will overwrite the result on a, ja, ia. c c------------------------------------------------------------------------ c local variables real*8 t integer ko, k, i, kdiag, kfirst ko = 0 do 7 i=1, n kfirst = ko+1 kdiag = 0 do 71 k = ia(i), ia(i+1) -1 if (ja(k) .lt. i) goto 71 ko = ko+1 ao(ko) = a(k) jao(ko) = ja(k) if (ja(k) .eq. i) kdiag = ko 71 continue if (kdiag .eq. 0 .or. kdiag .eq. kfirst) goto 72 c exchange t = ao(kdiag) ao(kdiag) = ao(kfirst) ao(kfirst) = t c k = jao(kdiag) jao(kdiag) = jao(kfirst) jao(kfirst) = k 72 iao(i) = kfirst 7 continue c redefine iao(n+1) iao(n+1) = ko+1 return c----------end-of-getu ------------------------------------------------- c----------------------------------------------------------------------- end c- subroutine csrmsr (n,a,ja,ia,ao,jao,wk,iwk) real*8 a(*),ao(*),wk(n) integer ia(n+1),ja(*),jao(*),iwk(n+1) c----------------------------------------------------------------------- c Compressed Sparse Row to Modified - Sparse Row c Sparse row with separate main diagonal c----------------------------------------------------------------------- c converts a general sparse matrix a, ja, ia into c a compressed matrix using a separated diagonal (referred to as c the bell-labs format as it is used by bell labs semi conductor c group. We refer to it here as the modified sparse row format. c Note: this has been coded in such a way that one can overwrite c the output matrix onto the input matrix if desired by a call of c the form c c call csrmsr (n, a, ja, ia, a, ja, wk,iwk) c c In case ao, jao, are different from a, ja, then one can c use ao, jao as the work arrays in the calling sequence: c c call csrmsr (n, a, ja, ia, ao, jao, ao,jao) c c----------------------------------------------------------------------- c c on entry : c--------- c a, ja, ia = matrix in csr format. note that the c algorithm is in place: ao, jao can be the same c as a, ja, in which case it will be overwritten on it c upon return. c c on return : c----------- c c ao, jao = sparse matrix in modified sparse row storage format: c + ao(1:n) contains the diagonal of the matrix. c + ao(n+2:nnz) contains the nondiagonal elements of the c matrix, stored rowwise. c + jao(n+2:nnz) : their column indices c + jao(1:n+1) contains the pointer array for the nondiagonal c elements in ao(n+1:nnz) and jao(n+2:nnz). c i.e., for i .le. n+1 jao(i) points to beginning of row i c in arrays ao, jao. c here nnz = number of nonzero elements+1 c work arrays: c------------ c wk = real work array of length n c iwk = integer work array of length n+1 c c notes: c------- c Algorithm is in place. i.e. both: c c call csrmsr (n, a, ja, ia, ao, jao, ao,jao) c (in which ao, jao, are different from a, ja) c and c call csrmsr (n, a, ja, ia, a, ja, wk,iwk) c (in which wk, jwk, are different from a, ja) c are OK. c-------- c coded by Y. Saad Sep. 1989. Rechecked Feb 27, 1990. c----------------------------------------------------------------------- icount = 0 c c store away diagonal elements and count nonzero diagonal elements. c do 1 i=1,n wk(i) = 0.0d0 iwk(i+1) = ia(i+1)-ia(i) do 2 k=ia(i),ia(i+1)-1 if (ja(k) .eq. i) then wk(i) = a(k) icount = icount + 1 iwk(i+1) = iwk(i+1)-1 endif 2 continue 1 continue c c compute total length c iptr = n + ia(n+1) - icount c c copy backwards (to avoid collisions) c do 500 ii=n,1,-1 do 100 k=ia(ii+1)-1,ia(ii),-1 j = ja(k) if (j .ne. ii) then ao(iptr) = a(k) jao(iptr) = j iptr = iptr-1 endif 100 continue 500 continue c c compute pointer values and copy wk(*) c jao(1) = n+2 do 600 i=1,n ao(i) = wk(i) jao(i+1) = jao(i)+iwk(i+1) 600 continue return c------------ end of subroutine csrmsr --------------------------------- c----------------------------------------------------------------------- end c subroutine getdia (nrow,ncol,job,a,ja,ia,len,diag,idiag,ioff) real*8 diag(*),a(*) integer nrow, ncol, job, len, ioff, ia(*), ja(*), idiag(*) c----------------------------------------------------------------------- c this subroutine extracts a given diagonal from a matrix stored in csr c format. the output matrix may be transformed with the diagonal removed c from it if desired (as indicated by job.) c----------------------------------------------------------------------- c our definition of a diagonal of matrix is a vector of length nrow c (always) which contains the elements in rows 1 to nrow of c the matrix that are contained in the diagonal offset by ioff c with respect to the main diagonal. if the diagonal element c falls outside the matrix then it is defined as a zero entry. c thus the proper definition of diag(*) with offset ioff is c c diag(i) = a(i,ioff+i) i=1,2,...,nrow c with elements falling outside the matrix being defined as zero. c c----------------------------------------------------------------------- c c on entry: c---------- c c nrow = integer. the row dimension of the matrix a. c ncol = integer. the column dimension of the matrix a. c job = integer. job indicator. if job = 0 then c the matrix a, ja, ia, is not altered on return. c if job.ne.0 then getdia will remove the entries c collected in diag from the original matrix. c this is done in place. c c a,ja, c ia = matrix stored in compressed sparse row a,ja,ia,format c ioff = integer,containing the offset of the wanted diagonal c the diagonal extracted is the one corresponding to the c entries a(i,j) with j-i = ioff. c thus ioff = 0 means the main diagonal c c on return: c----------- c len = number of nonzero elements found in diag. c (len .le. min(nrow,ncol-ioff)-max(1,1-ioff) + 1 ) c c diag = real*8 array of length nrow containing the wanted diagonal. c diag contains the diagonal (a(i,j),j-i = ioff ) as defined c above. c c idiag = integer array of length len, containing the poisitions c in the original arrays a and ja of the diagonal elements c collected in diag. a zero entry in idiag(i) means that c there was no entry found in row i belonging to the diagonal. c c a, ja, c ia = if job .ne. 0 the matrix is unchanged. otherwise the nonzero c diagonal entries collected in diag are removed from the c matrix and therefore the arrays a, ja, ia will change. c (the matrix a, ja, ia will contain len fewer elements) c c----------------------------------------------------------------------c c Y. Saad, sep. 21 1989 - modified and retested Feb 17, 1996. c c----------------------------------------------------------------------c c local variables integer istart, max, iend, i, kold, k, kdiag, ko c istart = max(0,-ioff) iend = min(nrow,ncol-ioff) len = 0 do 1 i=1,nrow idiag(i) = 0 diag(i) = 0.0d0 1 continue c c extract diagonal elements c do 6 i=istart+1, iend do 51 k= ia(i),ia(i+1) -1 if (ja(k)-i .eq. ioff) then diag(i)= a(k) idiag(i) = k len = len+1 goto 6 endif 51 continue 6 continue if (job .eq. 0 .or. len .eq.0) return c c remove diagonal elements and rewind structure c ko = 0 do 7 i=1, nrow kold = ko kdiag = idiag(i) do 71 k= ia(i), ia(i+1)-1 if (k .ne. kdiag) then ko = ko+1 a(ko) = a(k) ja(ko) = ja(k) endif 71 continue ia(i) = kold+1 7 continue c c redefine ia(nrow+1) c ia(nrow+1) = ko+1 return c------------end-of-getdia---------------------------------------------- c----------------------------------------------------------------------- end spam/src/rowcolstats.f0000644000176000001440000001005212403556057014571 0ustar ripleyusers c----------------------------------------------------------------------- subroutine rowsums(a,ja,ia, nrw, rs) c----------------------------------------------------------------------- c purpose: c -------- c c c Reinhard Furrer 2012-04-04 c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c a,ja,ia = the matrix a in compressed sparse row format (input). c nrw = number of rows c c on return: c----------- c rs = rowsums of a c c note: c------ c no error testing is done. It is assumed that b has enough space c allocated. c----------------------------------------------------------------------- implicit none integer ia(*),ja(*), nrw double precision a(*), rs(*) c c local variables. c integer irw, jja c do irw = 1,nrw do jja = ia(irw),ia(irw+1)-1 rs(irw) = rs(irw)+a(jja) enddo c end irw, we've cycled over all lines enddo return c--------end-of-rowsums------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine rowmeans(a,ja,ia, nrw, ncl, flag, rs) c----------------------------------------------------------------------- c purpose: c -------- c see above c c Reinhard Furrer 2012-04-04 c----------------------------------------------------------------------- implicit none integer ia(*),ja(*), nrw, ncl, flag double precision a(*), rs(*) c c local variables. c integer irw, jja c do irw = 1,nrw do jja = ia(irw),ia(irw+1)-1 rs(irw) = rs(irw)+a(jja) enddo if (flag.eq.1) then if ((ia(irw+1)-ia(irw)).gt.0) then rs(irw) = rs(irw)/(ia(irw+1)-ia(irw)) endif else rs(irw) = rs(irw)/ncl endif c end irw, we've cycled over all lines enddo return c--------end-of-rowmeans------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine colsums(a,ja,ia, nrw, cs) c----------------------------------------------------------------------- c purpose: c -------- c see above c c Reinhard Furrer 2012-04-04 c----------------------------------------------------------------------- implicit none integer ia(*),ja(*), nrw double precision a(*), cs(*) c c local variables. c integer ij c do ij = 1,ia(nrw+1)-1 cs( ja( ij)) = cs( ja( ij)) + a(ij) enddo return c--------end-of-colsums------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine colmeans(a,ja,ia, nrw, ncl, flag, cs,nnzc) c----------------------------------------------------------------------- c purpose: c -------- c see above c c nnzc needs to be initialized by R!!!! c Reinhard Furrer 2012-04-04 c----------------------------------------------------------------------- implicit none integer ia(*),ja(*), nrw, ncl, flag, nnzc(ncl) double precision a(*), cs(*) c c local variables. c integer ij c do ij = 1,ia(nrw+1)-1 cs( ja( ij)) = cs( ja( ij)) + a(ij) nnzc( ja( ij)) = nnzc( ja( ij)) + 1 enddo if (flag.eq.1) then do ij = 1, ncl if (nnzc(ij).gt.0) then cs(ij)=cs(ij)/ nnzc(ij) endif enddo else do ij = 1, ncl cs(ij)=cs(ij)/nrw enddo endif return c--------end-of-colmeans------------------------------------------------ c----------------------------------------------------------------------- end spam/src/permutation.f0000644000176000001440000003403412403556057014562 0ustar ripleyusersc It has been tested that embedding the loop over the right hand c side into the backsolve routine is not faster. c----------------------------------------------------------------------- subroutine getbwd(n,a,ja,ia,ml,mu) c----------------------------------------------------------------------- c gets the bandwidth of lower part and upper part of A. c does not assume that A is sorted. c----------------------------------------------------------------------- c on entry: c---------- c n = integer = the row dimension of the matrix c a, ja, c ia = matrix in compressed sparse row format. c c on return: c----------- c ml = integer. The bandwidth of the strict lower part of A c mu = integer. The bandwidth of the strict upper part of A c c Notes: c ===== ml and mu are allowed to be negative or return. This may be c useful since it will tell us whether a band is confined c in the strict upper/lower triangular part. c indeed the definitions of ml and mu are c c ml = max ( (i-j) s.t. a(i,j) .ne. 0 ) c mu = max ( (j-i) s.t. a(i,j) .ne. 0 ) c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c implicit none double precision a(*) integer n,ja(*),ia(n+1),ml,mu integer ldist,i,k ml = - n mu = - n do 3 i=1,n do 31 k=ia(i),ia(i+1)-1 ldist = i-ja(k) ml = max(ml,ldist) mu = max(mu,-ldist) 31 continue 3 continue return c---------------end-of-getbwd ------------------------------------------ c----------------------------------------------------------------------- end c functions slightly modified from sparsekit: c cperm,rperm,dperm: job argument is eliminated c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine rperm (nrow,a,ja,ia,ao,jao,iao,perm) implicit none integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(nrow) double precision a(*),ao(*) c----------------------------------------------------------------------- c this subroutine permutes the rows of a matrix in CSR format. c rperm computes B = P A where P is a permutation matrix. c the permutation P is defined through the array perm: for each j, c perm(j) represents the destination row number of row number j. c Youcef Saad -- recoded Jan 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c a, ja, ia = input matrix in csr format c perm = integer array of length nrow containing the permutation arrays c for the rows: perm(i) is the destination of row i in the c permuted matrix. c ---> a(i,j) in the original matrix becomes a(perm(i),j) c in the output matrix. c c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format c----------------------------------------------------------------------c c Y. Saad, May 2, 1990 c c----------------------------------------------------------------------c integer i,j,k,ko,ii c determine pointers for output matix. c do 50 j=1,nrow i = perm(j) iao(i+1) = ia(j+1) - ia(j) 50 continue c c get pointers from lengths c iao(1) = 1 do 51 j=1,nrow iao(j+1)=iao(j+1)+iao(j) 51 continue c c copying c do 100 ii=1,nrow c c old row = ii -- new row = iperm(ii) -- ko = new pointer c ko = iao(perm(ii)) do 60 k=ia(ii), ia(ii+1)-1 jao(ko) = ja(k) ao(ko) = a(k) ko = ko+1 60 continue 100 continue c return c---------end-of-rperm ------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine cperm (nrow,a,ja,ia,ao,jao,iao,perm) implicit none integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(*) double precision a(*), ao(*) c----------------------------------------------------------------------- c this subroutine permutes the columns of a matrix a, ja, ia. c the result is written in the output matrix ao, jao, iao. c cperm computes B = A P, where P is a permutation matrix c that maps column j into column perm(j), i.e., on return c a(i,j) becomes a(i,perm(j)) in new matrix c Y. Saad, May 2, 1990 / modified Jan. 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c nrow = row dimension of the matrix c c a, ja, ia = input matrix in csr format. c c perm = integer array of length ncol (number of columns of A c containing the permutation array the columns: c a(i,j) in the original matrix becomes a(i,perm(j)) c in the output matrix. c c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format c c Notes: c------- c 1. if job=1 then ao, iao are not used. c 2. This routine is in place: ja, jao can be the same. c 3. If the matrix is initially sorted (by increasing column number) c then ao,jao,iao may not be on return, hence a call to csort. c c----------------------------------------------------------------------c c local parameters: integer k, i, nnz c nnz = ia(nrow+1)-1 do 100 k=1,nnz jao(k) = perm(ja(k)) 100 continue c c done with ja array. c do 1 i=1, nrow+1 iao(i) = ia(i) 1 continue c do 2 k=1, nnz ao(k) = a(k) 2 continue c call sortrows(nrow,ao,jao,iao) c call csort (nrow,ao,jao,iao,iwork) _does not work_ return c---------end-of-cperm-------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine dperm (nrow,a,ja,ia,ao,jao,iao,pperm,qperm) implicit none integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),pperm(nrow), + qperm(*) double precision a(*),ao(*) c----------------------------------------------------------------------- c This routine permutes the rows and columns of a matrix stored in CSR c format. i.e., it computes P A Q, where P, Q are permutation matrices. c P maps row i into row perm(i) and Q maps column j into column qperm(j): c a(i,j) becomes a(pperm(i),qperm(j)) in new matrix c note that qperm should be of length ncol (number of columns) but this c is not checked. c----------------------------------------------------------------------- c Y. Saad, Sep. 21 1989 / recoded Jan. 28 1991. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c a, ja, c ia = input matrix in a, ja, ia format c pperm = integer array of length n containing the permutation arrays c for the rows: pperm(i) is the destination of row i in the c permuted matrix c c qperm = same thing for the columns. c iwork = working array passed to cperm c c on return: c----------- c ao, jao, iao = input matrix in a, ja, ia format c c Notes: c------- c 1) algorithm is in place c----------------------------------------------------------------------c c local variables c c permute rows first c call rperm (nrow,a,ja,ia, ao,jao,iao,pperm) c c then permute columns c c call cperm (nrow,ao,jao,iao,ao,jao,iao,qperm) c return c-------end-of-dperm---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine dvperm (n, x, perm) implicit none integer n integer perm(n) double precision x(n) c----------------------------------------------------------------------- c this subroutine performs an in-place permutation of a real vector x c according to the permutation array perm(*), i.e., on return, c the vector x satisfies, c c x(perm(j)) :== x(j), j=1,2,.., n c c----------------------------------------------------------------------- c on entry: c--------- c n = length of vector x. c perm = integer array of length n containing the permutation array. c x = input vector c c on return: c---------- c x = vector x permuted according to x(perm(*)) := x(*) c c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c c local variables integer init,next,k, ii, j double precision tmp, tmp1 c init = 1 tmp = x(init) ii = perm(init) perm(init)= -perm(init) k = 0 c c loop c 6 k = k+1 c c save the chased element -- c tmp1 = x(ii) x(ii) = tmp next = perm(ii) if (next .lt. 0 ) goto 65 c c test for end c if (k .gt. n) goto 101 tmp = tmp1 perm(ii) = - perm(ii) ii = next c c end loop c goto 6 c c reinitilaize cycle -- c 65 init = init+1 if (init .gt. n) goto 101 if (perm(init) .lt. 0) goto 65 tmp = x(init) ii = perm(init) perm(init)=-perm(init) goto 6 c 101 continue do 200 j=1, n perm(j) = -perm(j) 200 continue c return c-------------------end-of-dvperm--------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine ivperm (n, ix, perm) implicit none integer n, perm(n+1), ix(n) c----------------------------------------------------------------------- c this subroutine performs an in-place permutation of an integer vector c ix according to the permutation array perm(*), i.e., on return, c the vector x satisfies, c c ix(perm(j)) :== ix(j), j=1,2,.., n c c----------------------------------------------------------------------- c on entry: c--------- c n = length of vector x. c perm = integer array of length n containing the permutation array. c ix = input vector c c on return: c---------- c ix = vector x permuted according to ix(perm(*)) := ix(*) c c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c c local variables integer ii,k,j,next,init,tmp, tmp1 c init = 1 tmp = ix(init) ii = perm(init) perm(init)= -perm(init) k = 0 c c loop c 6 k = k+1 c c save the chased element -- c tmp1 = ix(ii) ix(ii) = tmp next = perm(ii) if (next .lt. 0 ) goto 65 c c test for end c if (k .gt. n) goto 101 tmp = tmp1 perm(ii) = - perm(ii) ii = next c c end loop c goto 6 c c reinitilaize cycle -- c 65 init = init+1 if (init .gt. n) goto 101 if (perm(init) .lt. 0) goto 65 tmp = ix(init) ii = perm(init) perm(init)=-perm(init) goto 6 c 101 continue do 200 j=1, n c if (perm(j) .lt. 0) then perm(j) = -perm(j) c endif 200 continue c return c-------------------end-of-ivperm--------------------------------------- c----------------------------------------------------------------------- end c c----------------------------------------------------------------------- subroutine aplbdg (nrow,ncol,ja,ia,jb,ib,ndegr,nnz,iw) implicit none integer nrow, ncol, nnz integer ja(*),jb(*),ia(nrow+1),ib(nrow+1),iw(ncol),ndegr(nrow) c----------------------------------------------------------------------- c gets the number of nonzero elements in each row of A+B and the total c number of nonzero elements in A+B. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c iw,nnz,ngegr = zero content c c on return: c---------- c ndegr = integer array of length nrow containing the degrees (i.e., c the number of nonzeros in each row of the matrix A + B. c c nnz = total number of nonzero elements found in A * B c c work arrays: c------------ c iw = integer work array of length equal to ncol. c c----------------------------------------------------------------------- integer k,j,ii,jr,last,ldg,jc do 7 ii=1,nrow ldg = 0 c c end-of-linked list c last = -1 c c row of A c do 5 j = ia(ii),ia(ii+1)-1 jr = ja(j) c c add element to the linked list c ldg = ldg + 1 iw(jr) = last last = jr 5 continue c c row of B c do 6 j=ib(ii),ib(ii+1)-1 jc = jb(j) if (iw(jc) .eq. 0) then c c add one element to the linked list c ldg = ldg + 1 iw(jc) = last last = jc endif 6 continue c done with row ii. ndegr(ii) = ldg c c reset iw to zero c do 61 k=1,ldg j = iw(last) iw(last) = 0 last = j 61 continue c----------------------------------------------------------------------- 7 continue c do 8 ii=1, nrow nnz = nnz+ndegr(ii) 8 continue return c----------------end-of-aplbdg ----------------------------------------- c----------------------------------------------------------------------- end spam/src/bckslvmodified.f0000644000176000001440000001510012403556057015171 0ustar ripleyusers subroutine backsolve(m,nsuper,nrhs,lindx,xlindx,lnz, & xlnz,xsuper,b) c see below... implicit none integer m,nsuper,nrhs,lindx(*),xlindx(m+1), & xlnz(m+1),xsuper(m+1) double precision lnz(*),b(m,nrhs) integer j do j = 1,nrhs call blkslb(nsuper,xsuper,xlindx,lindx,xlnz,lnz,b(1,j)) enddo return end subroutine forwardsolve(m,nsuper,nrhs,lindx,xlindx, & lnz,xlnz,xsuper,b) c INPUT: c m -- the number of column in the matrix c lindx -- an nsub-vector of interger which contains, in c column major oder, the row subscripts of the nonzero c entries in L in a compressed storage format c xlindx -- an nsuper-vector of integer of pointers for lindx c lnz -- First contains the non-zero entries of d; later c contains the entries of the Cholesky factor c xlnz -- column pointer for L stored in lnz c xsuper -- array of length m+1 containing the supernode c partitioning c b -- the rhs of the equality constraint c OUTPUT: c b -- the solution implicit none integer m,nsuper,nrhs,lindx(*),xlindx(m+1), & xlnz(m+1),xsuper(m+1) double precision lnz(*),b(m,nrhs) integer j c do j = 1,nrhs call blkslf(nsuper,xsuper,xlindx,lindx,xlnz,lnz,b(1,j)) enddo return end C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C Slight modification by Reinhard Furrer C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C C*********************************************************************** subroutine pivotforwardsolve(m,nsuper,nrhs,lindx,xlindx,lnz, & xlnz,invp,perm,xsuper,newrhs,sol,b) c Sparse least squares solver via Ng-Peyton's sparse Cholesky c factorization for sparse symmetric positive definite c INPUT: c m -- the number of column in the design matrix X c nsubmax -- upper bound of the dimension of lindx c lindx -- an nsub-vector of interger which contains, in c column major oder, the row subscripts of the nonzero c entries in L in a compressed storage format c xlindx -- an nsuper-vector of integer of pointers for lindx c lnz -- First contains the non-zero entries of d; later c contains the entries of the Cholesky factor c xlnz -- column pointer for L stored in lnz c invp -- an m-vector of integer of inverse permutation c vector c perm -- an m-vector of integer of permutation vector c xsuper -- array of length m+1 containing the supernode c partitioning c newrhs -- extra work vector for right-hand side and c solution c sol -- the least squares solution c b -- an m-vector, usualy the rhs of the equality constraint c X'a = (1-tau)X'e in the rq setting c OUTPUT: c y -- an m-vector of least squares solution c WORK ARRAYS: c b -- an m-vector, usually the rhs of the equality constraint c X'a = (1-tau)X'e in the rq setting implicit none integer m,nsuper,nrhs,lindx(*),xlindx(m+1), & invp(m),perm(m),xlnz(m+1), xsuper(m+1) integer i,j double precision lnz(*),b(m,nrhs),newrhs(m),sol(m,nrhs) do j = 1,nrhs do i = 1,m newrhs(i) = b(perm(i),j) enddo call blkslf(nsuper,xsuper,xlindx,lindx,xlnz,lnz,newrhs) do i = 1,m sol(i,j) = newrhs(invp(i)) enddo enddo return end C*********************************************************************** subroutine pivotbacksolve(m,nsuper,nrhs,lindx,xlindx,lnz, & xlnz,invp,perm,xsuper,newrhs,sol,b) c see above implicit none integer m, nsuper,nrhs,lindx(*),xlindx(m+1), & invp(m),perm(m),xlnz(m+1), xsuper(m+1) double precision lnz(*),b(m,nrhs),newrhs(m),sol(m,nrhs) integer i,j do j = 1,nrhs do i = 1,m newrhs(i) = b(perm(i),j) enddo call blkslb(nsuper,xsuper,xlindx,lindx,xlnz,lnz,newrhs) do i = 1,m sol(i,j) = newrhs(invp(i)) enddo enddo return end C*********************************************************************** subroutine backsolves(m,nsuper,nrhs,lindx,xlindx,lnz, & xlnz,invp,perm,xsuper,newrhs,sol,b) c Sparse least squares solver via Ng-Peyton's sparse Cholesky c factorization for sparse symmetric positive definite c INPUT: c m -- the number of column in the design matrix X c nsubmax -- upper bound of the dimension of lindx c lindx -- an nsub-vector of interger which contains, in c column major oder, the row subscripts of the nonzero c entries in L in a compressed storage format c xlindx -- an nsuper-vector of integer of pointers for lindx c nnzlmax -- the upper bound of the non-zero entries in c L stored in lnz, including the diagonal entries c lnz -- First contains the non-zero entries of d; later c contains the entries of the Cholesky factor c xlnz -- column pointer for L stored in lnz c invp -- an m-vector of integer of inverse permutation c vector c perm -- an m-vector of integer of permutation vector c xsuper -- array of length m+1 containing the supernode c partitioning c newrhs -- extra work vector for right-hand side and c solution c sol -- the least squares solution c b -- an m-vector, usualy the rhs of the equality constraint c X'a = (1-tau)X'e in the rq setting c OUTPUT: c y -- an m-vector of least squares solution c WORK ARRAYS: c b -- an m-vector, usually the rhs of the equality constraint c X'a = (1-tau)X'e in the rq setting implicit none integer m,nsuper,nrhs,lindx(*),xlindx(m+1), & invp(m),perm(m),xlnz(m+1), xsuper(m+1) double precision lnz(*),b(m,nrhs),newrhs(m),sol(m,nrhs) integer i,j do j = 1,nrhs do i = 1,m newrhs(i) = b(perm(i),j) enddo call blkslv(nsuper,xsuper,xlindx,lindx,xlnz,lnz,newrhs) do i = 1,m sol(i,j) = newrhs(invp(i)) enddo enddo return end spam/src/cholmodified.f0000644000176000001440000064164612403556057014656 0ustar ripleyusers subroutine updatefactor( m,nnzd, & d,jd,id, invp,perm, & lindx,xlindx, nsuper,lnz,xlnz, & snode, xsuper, & cachesize,ierr) implicit none integer m,nnzd integer nsuper,nnzl,iwsiz,tmpsiz, & ierr, & jd(nnzd),cachesize, & id(m+1),lindx(*),xlindx(*), & invp(m),perm(m),xlnz(m+1), & snode(m),xsuper(m+1) double precision d(nnzd),lnz(*) c temp and working stuff, loops, etc integer iwork(7*m+3) integer split(m) c c Clean L call cleanlnz(nsuper,xsuper,xlnz,lnz) c c Input numerical values into data structures of L call inpnv(id,jd,d,perm,invp,nsuper,xsuper,xlindx,lindx, & xlnz,lnz,iwork) c c Initialization for block factorization call bfinit(m,nsuper,xsuper,snode,xlindx,lindx,cachesize,tmpsiz, & split) c c Numerical factorization call blkfc2(nsuper,xsuper,snode,split,xlindx,lindx,xlnz, & lnz,iwork(1),iwork(nsuper+1),iwork(2*nsuper+1), & iwork(2*nsuper+m+1),tmpsiz,ierr) if (ierr .eq. -1) then ierr = 1 go to 100 elseif (ierr .eq. -2) then ierr = 3 go to 100 endif 100 continue return end subroutine cholstepwise(m,nnzd, & d,jd,id, doperm,invp,perm, & nsub,nsubmax, & lindx,xlindx,nsuper,nnzlmax,lnz,xlnz, & snode,xsuper, & cachsz,ierr) c Modified chol routine c c c Sparse least squares solver via Ng-Peyton's sparse Cholesky c factorization for sparse symmetric positive definite c INPUT: c m -- the number of column in the matrix A c d -- an nnzd-vector of non-zero values of A c jd -- an nnzd-vector of indices in d c id -- an (m+1)-vector of pointers to the begining of each c row in d and jd c nsubmax -- upper bound of the dimension of lindx c lindx -- an nsub-vector of integer which contains, in c column major oder, the row subscripts of the nonzero c entries in L in a compressed storage format c xlindx -- an nsuper-vector of integer of pointers for lindx c nsuper -- the length of xlindx ??? c nnzlmax -- the upper bound of the non-zero entries in c L stored in lnz, including the diagonal entries c lnz -- First contains the non-zero entries of d; later c contains the entries of the Cholesky factor c xlnz -- column pointer for L stored in lnz c invp -- an n-vector of integer of inverse permutation c vector c perm -- an n-vector of integer of permutation vector c colcnt -- array of length m, containing the number of c non-zeros in each column of the factor, including c the diagonal entries c snode -- array of length m for recording supernode c membership c xsuper -- array of length m+1 containing the supernode c partitioning c split -- an m-vector with splitting of supernodes so that c they fit into cache c tmpmax -- upper bound of the dimension of tmpvec c tmpvec -- a tmpmax-vector of temporary vector c cachsz -- size of the cache (in kilobytes) on the target c machine c ierr -- error flag c 1 -- insufficient work space in call to extract c 2 -- insufficient storage in iwork when calling ordmmd; c 3 -- insufficient storage in iwork when calling sfinit; c 4 -- nnzl > nnzlmax when calling sfinit c 5 -- nsub > nsubmax when calling sfinit c 6 -- insufficient work space in iwork when calling symfct c 7 -- inconsistancy in input when calling symfct c 8 -- tmpsiz > tmpmax when calling symfct; increase tmpmax c 9 -- nonpositive diagonal encountered when calling c blkfct c 10 -- insufficient work storage in tmpvec when calling c blkfct c 11 -- insufficient work storage in iwork when calling c blkfct c OUTPUT: c y -- an m-vector of least squares solution c nsub -- number of subscripts in lindx c WORK ARRAYS: c adjncy -- the indices of non diag elements c iwsiz -- set at 7*m+3 c iwork -- an iwsiz-vector of integer as work space c c implicit none integer m,nnzd,doperm integer nsub,nsuper,nnzl,iwsiz,tmpsiz, & nnzlmax,nsubmax,cachsz,ierr, & adj(m+1),adjncy(nnzd-m+1),jd(nnzd), c fix introduced in 29-3 c & adj(m+1),adjncy(nnzd-m),jd(nnzd), & id(m+1),lindx(nsubmax),xlindx(m+1), & invp(m),perm(m),xlnz(m+1), & colcnt(m),snode(m),xsuper(m+1),split(m) double precision d(nnzd),lnz(nnzlmax) c temp and working stuff, loops, etc integer i,j,k, nnzadj, jtmp integer iwork(7*m+3) c iwsiz is used temporalily iwsiz=0 c Create the adjacency matrix: eliminate the diagonal elements from c (d,id,jd) and make two copies: (*,xlindx,lindx),(*,adj,adjncy) c Also to lindx and xlindx, because the matrix structure is destroyed c by the minimum degree ordering routine. nsub = 0 c the adj matrix has m elements less than d nnzadj = nnzd - m k=1 do i=1,m c copy id, but ajust for the missing diagonal. xlindx(i) = id(i)-i+1 adj(i) = xlindx(i) c now cycle over all rows do j=id(i),id(i+1)-1 jtmp=jd(j) if (jtmp.ne.i) then lindx(k) = jtmp adjncy(k) = jtmp k=k+1 else if ( d(j) .le. 0) then ierr = 1 return endif iwsiz = iwsiz + 1 endif enddo enddo jtmp=m+1 xlindx(jtmp) = id(jtmp)-m adj(jtmp) = xlindx(jtmp) c check if we actually had m elements on the diagonal... if ( iwsiz .lt. m) then ierr = 1 return endif c initialize iwsiz to the later used value... iwsiz=7*m+3 c c c reorder the matrix using minimum degree ordering routine. c we call the genmmd function directly (do not pass via ordmmd). if (doperm.eq.1) then c delta - tolerance value for multiple elimination. c set to 0 below c maxint - maximum machine representable (short) integer c (any smaller estimate will do) for marking c nodes. c set to 32767 below call genmmd ( m, xlindx,lindx, invp,perm,0, 1 iwork(1), iwork(m+1), iwork(2*m+1), iwork(3*m+1) , 1 32767, nsub ) endif if (doperm.eq.2) then call genrcm ( m, nnzadj, xlindx,lindx, perm ) do i=1,m invp(perm(i))=i enddo endif if (doperm.eq.0) then do i=1,m invp(perm(i))=i enddo endif c c Call sfinit: Symbolic factorization initialization c to compute supernode partition and storage requirements c for symbolic factorization. New ordering is a postordering c of the nodal elimination tree c call sfinit(m,nnzadj,adj(1),adjncy(1),perm, & invp,colcnt,nnzl,nsub,nsuper,snode,xsuper,iwsiz, & iwork,ierr) c we do not have to test ierr, as we have hardwired iwsiz to 7*m+3 if (nnzl .gt. nnzlmax) then ierr = 4 go to 100 endif if (nsub .gt. nsubmax) then ierr = 5 go to 100 endif c c Call symfct: Perform supernodal symbolic factorization c iwsiz = nsuper + 2 * m + 1 call symfc2(m,nnzadj,adj(1),adjncy(1),perm,invp, & colcnt,nsuper,xsuper,snode,nsub,xlindx,lindx, & xlnz, & iwork(1), iwork(nsuper+1), iwork(nsuper+m+2) ,ierr) c ierr = -2 "inconsistency in the input" if (ierr .eq. -2) then ierr = 6 go to 100 endif c c Input numerical values into data structures of L call inpnv(id,jd,d,perm,invp,nsuper,xsuper,xlindx,lindx, & xlnz,lnz,iwork) c c Initialization for block factorization call bfinit(m,nsuper,xsuper,snode,xlindx,lindx,cachsz,tmpsiz, & split) c c Numerical factorization call blkfc2(nsuper,xsuper,snode,split,xlindx,lindx,xlnz, & lnz,iwork(1),iwork(nsuper+1),iwork(2*nsuper+1), & iwork(2*nsuper+m+1),tmpsiz,ierr) if (ierr .eq. -1) then ierr = 1 go to 100 elseif (ierr .eq. -2) then ierr = 3 go to 100 endif 100 continue return end C*********************************************************************** C*********************************************************************** C C Authors: Reinhard Furrer, based on inpnv C C C*********************************************************************** C*********************************************************************** C C ------------------------------------------------------ C Clean the array lnz C ------------------------------------------------------ C SUBROUTINE CLEANLNZ (NSUPER, XSUPER, XLNZ, LNZ) C IMPLICIT NONE INTEGER NSUPER INTEGER XSUPER(*), XLNZ(*) DOUBLE PRECISION LNZ(*) C INTEGER II, J, JSUPER C DO 500 JSUPER = 1, NSUPER DO 400 J = XSUPER(JSUPER), XSUPER(JSUPER+1)-1 DO 200 II = XLNZ(J), XLNZ(J+1)-1 LNZ(II) = 0.0 200 CONTINUE 400 CONTINUE C 500 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************ ASSMB .... INDEXED ASSEMBLY OPERATION ************ C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS ROUTINE PERFORMS AN INDEXED ASSEMBLY (I.E., SCATTER-ADD) C OPERATION, ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE C CHOLESKY CODES. C C INPUT PARAMETERS: C M - NUMBER OF ROWS IN Y. C Q - NUMBER OF COLUMNS IN Y. C Y - BLOCK UPDATE TO BE INCORPORATED INTO FACTOR C STORAGE. C RELIND - RELATIVE INDICES FOR MAPPING THE UPDATES C ONTO THE TARGET COLUMNS. C XLNZ - POINTERS TO THE START OF EACH COLUMN IN THE C TARGET MATRIX. C C OUTPUT PARAMETERS: C LNZ - CONTAINS COLUMNS MODIFIED BY THE UPDATE C MATRIX. C C*********************************************************************** C SUBROUTINE ASSMB ( M , Q , Y , RELIND, XLNZ , & LNZ , LDA ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER LDA , M , Q INTEGER XLNZ(*) INTEGER RELIND(*) DOUBLE PRECISION LNZ(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER ICOL , IL1 , IR , IY1 , LBOT1 , & YCOL , YOFF1 C C*********************************************************************** C C YOFF1 = 0 DO 200 ICOL = 1, Q YCOL = LDA - RELIND(ICOL) LBOT1 = XLNZ(YCOL+1) - 1 CDIR$ IVDEP DO 100 IR = ICOL, M IL1 = LBOT1 - RELIND(IR) IY1 = YOFF1 + IR LNZ(IL1) = LNZ(IL1) + Y(IY1) Y(IY1) = 0.0D0 100 CONTINUE YOFF1 = IY1 - ICOL 200 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** BETREE ..... BINARY TREE REPRESENTATION OF ETREE ******* C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO DETERMINE THE BINARY TREE REPRESENTATION OF THE ELIMINATION C TREE GIVEN BY THE PARENT VECTOR. THE RETURNED REPRESENTATION C WILL BE GIVEN BY THE FIRST-SON AND BROTHER VECTORS. THE ROOT C OF THE BINARY TREE IS ALWAYS NEQNS. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE. C IT IS ASSUMED THAT PARENT(I) > I EXCEPT OF C THE ROOTS. C C OUTPUT PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C C*********************************************************************** C SUBROUTINE BETREE ( NEQNS , PARENT, FSON , BROTHR ) C C*********************************************************************** C INTEGER*4 BROTHR(*) , FSON(*) , & PARENT(*) C INTEGER*4 NEQNS C C*********************************************************************** C INTEGER*4 LROOT , NODE , NDPAR C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C DO 100 NODE = 1, NEQNS FSON(NODE) = 0 BROTHR(NODE) = 0 100 CONTINUE LROOT = NEQNS C ------------------------------------------------------------ C FOR EACH NODE := NEQNS-1 STEP -1 DOWNTO 1, DO THE FOLLOWING. C ------------------------------------------------------------ IF ( NEQNS .LE. 1 ) RETURN DO 300 NODE = NEQNS-1, 1, -1 NDPAR = PARENT(NODE) IF ( NDPAR .LE. 0 .OR. NDPAR .EQ. NODE ) THEN C ------------------------------------------------- C NODE HAS NO PARENT. GIVEN STRUCTURE IS A FOREST. C SET NODE TO BE ONE OF THE ROOTS OF THE TREES. C ------------------------------------------------- BROTHR(LROOT) = NODE LROOT = NODE ELSE C ------------------------------------------- C OTHERWISE, BECOMES FIRST SON OF ITS PARENT. C ------------------------------------------- BROTHR(NODE) = FSON(NDPAR) FSON(NDPAR) = NODE ENDIF 300 CONTINUE BROTHR(LROOT) = 0 C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** BFINIT ..... INITIALIZATION FOR BLOCK FACTORIZATION ****** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE COMPUTES ITEMS NEEDED BY THE LEFT-LOOKING C BLOCK-TO-BLOCK CHOLESKY FACTORITZATION ROUTINE BLKFCT. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C NSUPER - NUMBER OF SUPERNODES. C XSUPER - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C THE SUPERNODE PARTITIONING. C SNODE - SUPERNODE MEMBERSHIP. C (XLINDX,LINDX) - ARRAYS DESCRIBING THE SUPERNODAL STRUCTURE. C CACHSZ - CACHE SIZE (IN KBYTES). C C OUTPUT PARAMETERS: C TMPSIZ - SIZE OF WORKING STORAGE REQUIRED BY BLKFCT. C SPLIT - SPLITTING OF SUPERNODES SO THAT THEY FIT C INTO CACHE. C C*********************************************************************** C SUBROUTINE BFINIT ( NEQNS , NSUPER, XSUPER, SNODE , XLINDX, & LINDX , CACHSZ, TMPSIZ, SPLIT ) C C*********************************************************************** C INTEGER CACHSZ, NEQNS , NSUPER, TMPSIZ INTEGER XLINDX(*) , XSUPER(*) INTEGER LINDX (*) , SNODE (*) , & SPLIT(*) C C*********************************************************************** C C --------------------------------------------------- C DETERMINE FLOATING POINT WORKING SPACE REQUIREMENT. C --------------------------------------------------- CALL FNTSIZ ( NSUPER, XSUPER, SNODE , XLINDX, LINDX , & TMPSIZ ) C C ------------------------------- C PARTITION SUPERNODES FOR CACHE. C ------------------------------- CALL FNSPLT ( NEQNS , NSUPER, XSUPER, XLINDX, CACHSZ, & SPLIT ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.3 C Last modified: March 6, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C RF eliminated dependence on SMXPY and MMPY C C Mathematical Sciences Section, Oak Ridge National Laboratoy C C*********************************************************************** C*********************************************************************** C********* BLKFC2 ..... BLOCK GENERAL SPARSE CHOLESKY ********* C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE FACTORS A SPARSE POSITIVE DEFINITE MATRIX. C THE COMPUTATION IS ORGANIZED AROUND KERNELS THAT PERFORM C SUPERNODE-TO-SUPERNODE UPDATES, I.E., BLOCK-TO-BLOCK UPDATES. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C SNODE - MAPS EACH COLUMN TO THE SUPERNODE CONTAINING C IT. C SPLIT - SPLITTING OF SUPERNODES SO THAT THEY FIT C INTO CACHE. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE (INCLUDING C THE DIAGONAL ELEMENTS). C (XLNZ,LNZ) - ON INPUT, CONTAINS MATRIX TO BE FACTORED. C TMPSIZ - SIZE OF TEMPORARY WORKING STORAGE. C C OUTPUT PARAMETERS: C LNZ - ON OUTPUT, CONTAINS CHOLESKY FACTOR. C IFLAG - ERROR FLAG. C 0: SUCCESSFUL FACTORIZATION. C -1: NONPOSITIVE DIAGONAL ENCOUNTERED, C MATRIX IS NOT POSITIVE DEFINITE. C -2: INSUFFICIENT WORKING STORAGE C [TEMP(*)]. C C WORKING PARAMETERS: C LINK - LINKS TOGETHER THE SUPERNODES IN A SUPERNODE C ROW. C LENGTH - LENGTH OF THE ACTIVE PORTION OF EACH C SUPERNODE. C INDMAP - VECTOR OF SIZE NEQNS INTO WHICH THE GLOBAL C INDICES ARE SCATTERED. C RELIND - MAPS LOCATIONS IN THE UPDATING COLUMNS TO C THE CORRESPONDING LOCATIONS IN THE UPDATED C COLUMNS. (RELIND IS GATHERED FROM INDMAP). C TEMP - REAL VECTOR FOR ACCUMULATING UPDATES. MUST C ACCOMODATE ALL COLUMNS OF A SUPERNODE. C C*********************************************************************** C SUBROUTINE BLKFC2 ( NSUPER, XSUPER, SNODE , SPLIT , XLINDX, & LINDX , XLNZ , LNZ , LINK , LENGTH, & INDMAP, RELIND, TMPSIZ, IFLAG ) C C********************************************************************* C C ----------- C PARAMETERS. C ----------- C INTEGER XLINDX(*) , XLNZ(*) INTEGER INDMAP(*) , LENGTH(*) , & LINDX(*) , LINK(*) , & RELIND(*) , SNODE(*) , & SPLIT(*) , XSUPER(*) INTEGER IFLAG , NSUPER, TMPSIZ DOUBLE PRECISION LNZ(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER FJCOL , FKCOL , I , ILEN , ILPNT , & INDDIF, JLEN , JLPNT , JSUP , JXPNT , & KFIRST, KLAST , KLEN , KLPNT , KSUP , & KXPNT , LJCOL , NCOLUP, NJCOLS, NKCOLS, & NXKSUP, NXTCOL, NXTSUP, STORE DOUBLE PRECISION TEMP(TMPSIZ) C RF: put TEMP(*) into a local variable DOUBLE PRECISION MXDIAG INTEGER NTINY C********************************************************************* C IFLAG = 0 NTINY = 0 C C ----------------------------------------------------------- C INITIALIZE EMPTY ROW LISTS IN LINK(*) AND ZERO OUT TEMP(*). C ----------------------------------------------------------- DO 100 JSUP = 1, NSUPER LINK(JSUP) = 0 100 CONTINUE DO 200 I = 1, TMPSIZ TEMP(I) = 0.0D+00 200 CONTINUE C COMPUTE MAXIMUM DIAGONAL ELEMENT IN INPUT MATRIX MXDIAG = 0.D0 DO 201 I = 1, XSUPER(NSUPER+1)-1 FJCOL = XLNZ(I) MXDIAG = MAX(MXDIAG, LNZ(FJCOL)) 201 CONTINUE C C --------------------------- C FOR EACH SUPERNODE JSUP ... C --------------------------- DO 600 JSUP = 1, NSUPER C C ------------------------------------------------ C FJCOL ... FIRST COLUMN OF SUPERNODE JSUP. C LJCOL ... LAST COLUMN OF SUPERNODE JSUP. C NJCOLS ... NUMBER OF COLUMNS IN SUPERNODE JSUP. C JLEN ... LENGTH OF COLUMN FJCOL. C JXPNT ... POINTER TO INDEX OF FIRST C NONZERO IN COLUMN FJCOL. C ------------------------------------------------ FJCOL = XSUPER(JSUP) NJCOLS = XSUPER(JSUP+1) - FJCOL LJCOL = FJCOL + NJCOLS - 1 JLEN = XLNZ(FJCOL+1) - XLNZ(FJCOL) JXPNT = XLINDX(JSUP) C print *, 'Super Node: ', JSUP, ' first: ', FJCOL, C . ' last: ', LJCOL C C C ----------------------------------------------------- C SET UP INDMAP(*) TO MAP THE ENTRIES IN UPDATE COLUMNS C TO THEIR CORRESPONDING POSITIONS IN UPDATED COLUMNS, C RELATIVE THE THE BOTTOM OF EACH UPDATED COLUMN. C ----------------------------------------------------- CALL LDINDX ( JLEN, LINDX(JXPNT), INDMAP ) C C ----------------------------------------- C FOR EVERY SUPERNODE KSUP IN ROW(JSUP) ... C ----------------------------------------- KSUP = LINK(JSUP) 300 IF ( KSUP .GT. 0 ) THEN NXKSUP = LINK(KSUP) C C ------------------------------------------------------- C GET INFO ABOUT THE CMOD(JSUP,KSUP) UPDATE. C C FKCOL ... FIRST COLUMN OF SUPERNODE KSUP. C NKCOLS ... NUMBER OF COLUMNS IN SUPERNODE KSUP. C KLEN ... LENGTH OF ACTIVE PORTION OF COLUMN FKCOL. C KXPNT ... POINTER TO INDEX OF FIRST NONZERO IN ACTIVE C PORTION OF COLUMN FJCOL. C ------------------------------------------------------- FKCOL = XSUPER(KSUP) NKCOLS = XSUPER(KSUP+1) - FKCOL KLEN = LENGTH(KSUP) KXPNT = XLINDX(KSUP+1) - KLEN C C ------------------------------------------- C PERFORM CMOD(JSUP,KSUP), WITH SPECIAL CASES C HANDLED DIFFERENTLY. C ------------------------------------------- C IF ( KLEN .NE. JLEN ) THEN C C ------------------------------------------- C SPARSE CMOD(JSUP,KSUP). C C NCOLUP ... NUMBER OF COLUMNS TO BE UPDATED. C ------------------------------------------- C DO 400 I = 0, KLEN-1 NXTCOL = LINDX(KXPNT+I) IF ( NXTCOL .GT. LJCOL ) GO TO 500 400 CONTINUE I = KLEN 500 CONTINUE NCOLUP = I C IF ( NKCOLS .EQ. 1 ) THEN C C ---------------------------------------------- C UPDATING TARGET SUPERNODE BY TRIVIAL C SUPERNODE (WITH ONE COLUMN). C C KLPNT ... POINTER TO FIRST NONZERO IN ACTIVE C PORTION OF COLUMN FKCOL. C ---------------------------------------------- KLPNT = XLNZ(FKCOL+1) - KLEN CALL MMPYI ( KLEN, NCOLUP, LINDX(KXPNT), & LNZ(KLPNT), XLNZ, LNZ, INDMAP ) C ELSE C C -------------------------------------------- C KFIRST ... FIRST INDEX OF ACTIVE PORTION OF C SUPERNODE KSUP (FIRST COLUMN TO C BE UPDATED). C KLAST ... LAST INDEX OF ACTIVE PORTION OF C SUPERNODE KSUP. C -------------------------------------------- C KFIRST = LINDX(KXPNT) KLAST = LINDX(KXPNT+KLEN-1) INDDIF = INDMAP(KFIRST) - INDMAP(KLAST) C IF ( INDDIF .LT. KLEN ) THEN C C --------------------------------------- C DENSE CMOD(JSUP,KSUP). C C ILPNT ... POINTER TO FIRST NONZERO IN C COLUMN KFIRST. C ILEN ... LENGTH OF COLUMN KFIRST. C --------------------------------------- ILPNT = XLNZ(KFIRST) ILEN = XLNZ(KFIRST+1) - ILPNT CALL MMPY ( KLEN, NKCOLS, NCOLUP, & SPLIT(FKCOL), XLNZ(FKCOL), & LNZ, LNZ(ILPNT), ILEN ) C ELSE C C ------------------------------- C GENERAL SPARSE CMOD(JSUP,KSUP). C COMPUTE CMOD(JSUP,KSUP) UPDATE C IN WORK STORAGE. C ------------------------------- STORE = KLEN * NCOLUP - NCOLUP * & (NCOLUP-1) / 2 IF ( STORE .GT. TMPSIZ ) THEN IFLAG = -2 RETURN ENDIF CALL MMPY ( KLEN, NKCOLS, NCOLUP, & SPLIT(FKCOL), XLNZ(FKCOL), & LNZ, TEMP, KLEN ) C ---------------------------------------- C GATHER INDICES OF KSUP RELATIVE TO JSUP. C ---------------------------------------- CALL IGATHR ( KLEN, LINDX(KXPNT), & INDMAP, RELIND ) C -------------------------------------- C INCORPORATE THE CMOD(JSUP,KSUP) BLOCK C UPDATE INTO THE TO APPROPRIATE COLUMNS C OF L. C -------------------------------------- CALL ASSMB ( KLEN, NCOLUP, TEMP, RELIND, & XLNZ(FJCOL), LNZ, JLEN ) C ENDIF C ENDIF C ELSE C C ---------------------------------------------- C DENSE CMOD(JSUP,KSUP). C JSUP AND KSUP HAVE IDENTICAL STRUCTURE. C C JLPNT ... POINTER TO FIRST NONZERO IN COLUMN C FJCOL. C ---------------------------------------------- JLPNT = XLNZ(FJCOL) CALL MMPY ( KLEN, NKCOLS, NJCOLS, SPLIT(FKCOL), & XLNZ(FKCOL), LNZ, LNZ(JLPNT), JLEN) NCOLUP = NJCOLS IF ( KLEN .GT. NJCOLS ) THEN NXTCOL = LINDX(JXPNT+NJCOLS) ENDIF C ENDIF C C ------------------------------------------------ C LINK KSUP INTO LINKED LIST OF THE NEXT SUPERNODE C IT WILL UPDATE AND DECREMENT KSUP'S ACTIVE C LENGTH. C ------------------------------------------------ IF ( KLEN .GT. NCOLUP ) THEN NXTSUP = SNODE(NXTCOL) LINK(KSUP) = LINK(NXTSUP) LINK(NXTSUP) = KSUP LENGTH(KSUP) = KLEN - NCOLUP ELSE LENGTH(KSUP) = 0 ENDIF C C ------------------------------- C NEXT UPDATING SUPERNODE (KSUP). C ------------------------------- KSUP = NXKSUP GO TO 300 C ENDIF C C ---------------------------------------------- C APPLY PARTIAL CHOLESKY TO THE COLUMNS OF JSUP. C ---------------------------------------------- CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC CALL CHLSUP ( JLEN, NJCOLS, SPLIT(FJCOL), XLNZ(FJCOL), LNZ, & MXDIAG, NTINY, IFLAG ) IF ( IFLAG .NE. 0 ) THEN IFLAG = -1 RETURN ENDIF C C ----------------------------------------------- C INSERT JSUP INTO LINKED LIST OF FIRST SUPERNODE C IT WILL UPDATE. C ----------------------------------------------- IF ( JLEN .GT. NJCOLS ) THEN NXTCOL = LINDX(JXPNT+NJCOLS) NXTSUP = SNODE(NXTCOL) LINK(JSUP) = LINK(NXTSUP) LINK(NXTSUP) = JSUP LENGTH(JSUP) = JLEN - NJCOLS ELSE LENGTH(JSUP) = 0 ENDIF C 600 CONTINUE C CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC C IF(NTINY .NE. 0) WRITE(6,699) NTINY C 699 FORMAT(1X,' FOUND ',I6,' TINY DIAGONALS; REPLACED WITH INF') C C SET IFLAG TO -1 TO INDICATE PRESENCE OF TINY DIAGONALS C IF(NTINY .NE. 0) IFLAG = -1 CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC RETURN END C*********************************************************************** C*********************************************************************** C C Written: October 6, 1996 by SJW. Based on routine BLKSLV of C Esmond G. Ng and Barry W. Peyton. C C Modified: Sept 30, 1999 to improve efficiency in the case C in which the right-hand side and solution are both C expected to be sparse. Happens a lot in "dense" C column handling. C C*********************************************************************** C*********************************************************************** C********* BLKSLB ... BACK TRIANGULAR SUBSTITUTION ********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C GIVEN THE CHOLESKY FACTORIZATION OF A SPARSE SYMMETRIC C POSITIVE DEFINITE MATRIX, THIS SUBROUTINE PERFORMS THE C BACKWARD TRIANGULAR SUBSTITUTION. IT USES OUTPUT FROM BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE. C (XLNZ,LNZ) - CHOLESKY FACTOR. C C UPDATED PARAMETERS: C RHS - ON INPUT, CONTAINS THE RIGHT HAND SIDE. ON C OUTPUT, CONTAINS THE SOLUTION. C C*********************************************************************** C SUBROUTINE BLKSLB ( NSUPER, XSUPER, XLINDX, LINDX , XLNZ , & LNZ , RHS ) C C*********************************************************************** C INTEGER NSUPER INTEGER LINDX(*) , XSUPER(*) INTEGER XLINDX(*) , XLNZ(*) DOUBLE PRECISION LNZ(*) , RHS(*) C C*********************************************************************** C INTEGER FJCOL , I , IPNT , IX , IXSTOP, & IXSTRT, JCOL , JPNT , JSUP , LJCOL DOUBLE PRECISION T C C*********************************************************************** C IF ( NSUPER .LE. 0 ) RETURN C ------------------------- C BACKWARD SUBSTITUTION ... C ------------------------- LJCOL = XSUPER(NSUPER+1) - 1 DO 600 JSUP = NSUPER, 1, -1 FJCOL = XSUPER(JSUP) IXSTOP = XLNZ(LJCOL+1) - 1 JPNT = XLINDX(JSUP) + (LJCOL - FJCOL) DO 500 JCOL = LJCOL, FJCOL, -1 IXSTRT = XLNZ(JCOL) IPNT = JPNT + 1 T = RHS(JCOL) CDIR$ IVDEP DO 400 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) IF(RHS(I) .NE. 0.D0) T = T - LNZ(IX)*RHS(I) IPNT = IPNT + 1 400 CONTINUE IF(T .NE. 0.D0) THEN RHS(JCOL) = T/LNZ(IXSTRT) ELSE RHS(JCOL) = 0.D0 ENDIF IXSTOP = IXSTRT - 1 JPNT = JPNT - 1 500 CONTINUE LJCOL = FJCOL - 1 600 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Written: October 6, 1996 by SJW. Based on routine BLKSLV of C Esmond G. Ng and Barry W. Peyton. C C Modified: Sept 30, 1999 to improve efficiency in the case C in which the right-hand side and solution are both C expected to be sparse. Happens a lot in "dense" C column handling. C C*********************************************************************** C*********************************************************************** C********* BLKSLF ... FORWARD TRIANGULAR SUBSTITUTION ********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C GIVEN THE CHOLESKY FACTORIZATION OF A SPARSE SYMMETRIC C POSITIVE DEFINITE MATRIX, THIS SUBROUTINE PERFORMS THE C FORWARD TRIANGULAR SUBSTITUTIOn. IT USES OUTPUT FROM BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE. C (XLNZ,LNZ) - CHOLESKY FACTOR. C C UPDATED PARAMETERS: C RHS - ON INPUT, CONTAINS THE RIGHT HAND SIDE. ON C OUTPUT, CONTAINS THE SOLUTION. C C*********************************************************************** C SUBROUTINE BLKSLF ( NSUPER, XSUPER, XLINDX, LINDX , XLNZ , & LNZ , RHS ) C C*********************************************************************** C INTEGER NSUPER INTEGER LINDX(*) , XSUPER(*) INTEGER XLINDX(*) , XLNZ(*) DOUBLE PRECISION LNZ(*) , RHS(*) C C*********************************************************************** C INTEGER FJCOL , I , IPNT , IX , IXSTOP, & IXSTRT, JCOL , JPNT , JSUP , LJCOL DOUBLE PRECISION T C C*********************************************************************** C IF ( NSUPER .LE. 0 ) RETURN C C ------------------------ C FORWARD SUBSTITUTION ... C ------------------------ FJCOL = XSUPER(1) DO 300 JSUP = 1, NSUPER LJCOL = XSUPER(JSUP+1) - 1 IXSTRT = XLNZ(FJCOL) JPNT = XLINDX(JSUP) DO 200 JCOL = FJCOL, LJCOL IXSTOP = XLNZ(JCOL+1) - 1 IF(RHS(JCOL) .NE. 0.D0) THEN T = RHS(JCOL)/LNZ(IXSTRT) RHS(JCOL) = T IPNT = JPNT + 1 CDIR$ IVDEP DO 100 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) RHS(I) = RHS(I) - T*LNZ(IX) IPNT = IPNT + 1 100 CONTINUE ENDIF IXSTRT = IXSTOP + 1 JPNT = JPNT + 1 200 CONTINUE FJCOL = LJCOL + 1 300 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C Modified: Sept 30, 1999 to improve efficiency in the case C in which the right-hand side and solution are both C expected to be sparse. Happens a lot in "dense" C column handling. C C*********************************************************************** C*********************************************************************** C********* BLKSLV ... BLOCK TRIANGULAR SOLUTIONS ********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C GIVEN THE CHOLESKY FACTORIZATION OF A SPARSE SYMMETRIC C POSITIVE DEFINITE MATRIX, THIS SUBROUTINE PERFORMS THE C TRIANGULAR SOLUTION. IT USES OUTPUT FROM BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE. C (XLNZ,LNZ) - CHOLESKY FACTOR. C C UPDATED PARAMETERS: C RHS - ON INPUT, CONTAINS THE RIGHT HAND SIDE. ON C OUTPUT, CONTAINS THE SOLUTION. C C*********************************************************************** C SUBROUTINE BLKSLV ( NSUPER, XSUPER, XLINDX, LINDX , XLNZ , & LNZ , RHS ) C C*********************************************************************** C INTEGER NSUPER INTEGER LINDX(*) , XSUPER(*) INTEGER XLINDX(*) , XLNZ(*) DOUBLE PRECISION LNZ(*) , RHS(*) C C*********************************************************************** C INTEGER FJCOL , I , IPNT , IX , IXSTOP, & IXSTRT, JCOL , JPNT , JSUP , LJCOL DOUBLE PRECISION T C C*********************************************************************** C IF ( NSUPER .LE. 0 ) RETURN C C ------------------------ C FORWARD SUBSTITUTION ... C ------------------------ FJCOL = XSUPER(1) DO 300 JSUP = 1, NSUPER LJCOL = XSUPER(JSUP+1) - 1 IXSTRT = XLNZ(FJCOL) JPNT = XLINDX(JSUP) DO 200 JCOL = FJCOL, LJCOL IXSTOP = XLNZ(JCOL+1) - 1 IF(RHS(JCOL) .NE. 0.D0) THEN T = RHS(JCOL)/LNZ(IXSTRT) RHS(JCOL) = T IPNT = JPNT + 1 CDIR$ IVDEP DO 100 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) RHS(I) = RHS(I) - T*LNZ(IX) IPNT = IPNT + 1 100 CONTINUE ENDIF IXSTRT = IXSTOP + 1 JPNT = JPNT + 1 200 CONTINUE FJCOL = LJCOL + 1 300 CONTINUE C C ------------------------- C BACKWARD SUBSTITUTION ... C ------------------------- LJCOL = XSUPER(NSUPER+1) - 1 DO 600 JSUP = NSUPER, 1, -1 FJCOL = XSUPER(JSUP) IXSTOP = XLNZ(LJCOL+1) - 1 JPNT = XLINDX(JSUP) + (LJCOL - FJCOL) DO 500 JCOL = LJCOL, FJCOL, -1 IXSTRT = XLNZ(JCOL) IPNT = JPNT + 1 T = RHS(JCOL) CDIR$ IVDEP DO 400 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) IF(RHS(I) .NE. 0.D0) T = T - LNZ(IX)*RHS(I) IPNT = IPNT + 1 400 CONTINUE IF(T .NE. 0.D0) THEN RHS(JCOL) = T/LNZ(IXSTRT) ELSE RHS(JCOL) = 0.D0 ENDIF IXSTOP = IXSTRT - 1 JPNT = JPNT - 1 500 CONTINUE LJCOL = FJCOL - 1 600 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: January 12, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** BTREE2 ..... BINARY TREE REPRESENTATION OF ETREE ******* C*********************************************************************** C*********************************************************************** C C PURPOSE: C TO DETERMINE A BINARY TREE REPRESENTATION OF THE ELIMINATION C TREE, FOR WHICH EVERY "LAST CHILD" HAS THE MAXIMUM POSSIBLE C COLUMN NONZERO COUNT IN THE FACTOR. THE RETURNED REPRESENTATION C WILL BE GIVEN BY THE FIRST-SON AND BROTHER VECTORS. THE ROOT OF C THE BINARY TREE IS ALWAYS NEQNS. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE. C IT IS ASSUMED THAT PARENT(I) > I EXCEPT OF C THE ROOTS. C COLCNT - COLUMN NONZERO COUNTS OF THE FACTOR. C C OUTPUT PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C C WORKING PARAMETERS: C LSON - LAST SON VECTOR. C C*********************************************************************** C SUBROUTINE BTREE2 ( NEQNS , PARENT, COLCNT, FSON , BROTHR, & LSON ) C C*********************************************************************** C INTEGER BROTHR(*) , COLCNT(*) , & FSON(*) , LSON(*) , & PARENT(*) C INTEGER NEQNS C C*********************************************************************** C INTEGER*4 LROOT , NODE , NDLSON, NDPAR C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C DO 100 NODE = 1, NEQNS FSON(NODE) = 0 BROTHR(NODE) = 0 LSON(NODE) = 0 100 CONTINUE LROOT = NEQNS C ------------------------------------------------------------ C FOR EACH NODE := NEQNS-1 STEP -1 DOWNTO 1, DO THE FOLLOWING. C ------------------------------------------------------------ IF ( NEQNS .LE. 1 ) RETURN DO 300 NODE = NEQNS-1, 1, -1 NDPAR = PARENT(NODE) IF ( NDPAR .LE. 0 .OR. NDPAR .EQ. NODE ) THEN C ------------------------------------------------- C NODE HAS NO PARENT. GIVEN STRUCTURE IS A FOREST. C SET NODE TO BE ONE OF THE ROOTS OF THE TREES. C ------------------------------------------------- BROTHR(LROOT) = NODE LROOT = NODE ELSE C ------------------------------------------- C OTHERWISE, BECOMES FIRST SON OF ITS PARENT. C ------------------------------------------- NDLSON = LSON(NDPAR) IF ( NDLSON .NE. 0 ) THEN IF ( COLCNT(NODE) .GE. COLCNT(NDLSON) ) THEN BROTHR(NODE) = FSON(NDPAR) FSON(NDPAR) = NODE ELSE BROTHR(NDLSON) = NODE LSON(NDPAR) = NODE ENDIF ELSE FSON(NDPAR) = NODE LSON(NDPAR) = NODE ENDIF ENDIF 300 CONTINUE BROTHR(LROOT) = 0 C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.3 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Modified by RF: Eliminated the MMPYN, SMXPY as arguments C C Mathematical Sciences Section, Oak Ridge National Laboratoy C C*********************************************************************** C*********************************************************************** C****** CHLSUP .... DENSE CHOLESKY WITHIN SUPERNODE ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS CHOLESKY C FACTORIZATION ON THE COLUMNS OF A SUPERNODE C THAT HAVE RECEIVED ALL UPDATES FROM COLUMNS C EXTERNAL TO THE SUPERNODE. C C INPUT PARAMETERS - C M - NUMBER OF ROWS (LENGTH OF THE FIRST COLUMN). C N - NUMBER OF COLUMNS IN THE SUPERNODE. C XPNT - XPNT(J+1) POINTS ONE LOCATION BEYOND THE END C OF THE J-TH COLUMN OF THE SUPERNODE. C X(*) - CONTAINS THE COLUMNS OF OF THE SUPERNODE TO C BE FACTORED. C C EXTERNAL ROUTINES - C MMPY8 - MATRIX-MATRIX MULTIPLY WITH 8 LOOP UNROLLING. C C OUTPUT PARAMETERS - C X(*) - ON OUTPUT, CONTAINS THE FACTORED COLUMNS OF C THE SUPERNODE. C IFLAG - UNCHANGED IF THERE IS NO ERROR. C =1 IF NONPOSITIVE DIAGONAL ENTRY IS ENCOUNTERED. C C*********************************************************************** C SUBROUTINE CHLSUP ( M, N, SPLIT, XPNT, X, MXDIAG, NTINY, & IFLAG ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C EXTERNAL MMPY8 C INTEGER M, N, IFLAG C INTEGER XPNT(*), SPLIT(*) C DOUBLE PRECISION X(*), MXDIAG INTEGER NTINY C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER FSTCOL, JBLK , JPNT , MM , NN , & NXTCOL, Q C C*********************************************************************** C JBLK = 0 FSTCOL = 1 MM = M JPNT = XPNT(FSTCOL) C C ---------------------------------------- C FOR EACH BLOCK JBLK IN THE SUPERNODE ... C ---------------------------------------- 100 CONTINUE IF ( FSTCOL .LE. N ) THEN JBLK = JBLK + 1 NN = SPLIT(JBLK) C ------------------------------------------ C ... PERFORM PARTIAL CHOLESKY FACTORIZATION C ON THE BLOCK. C ------------------------------------------ CALL PCHOL ( MM, NN, XPNT(FSTCOL), X, MXDIAG, NTINY) C ---------------------------------------------- C ... APPLY THE COLUMNS IN JBLK TO ANY COLUMNS C OF THE SUPERNODE REMAINING TO BE COMPUTED. C ---------------------------------------------- NXTCOL = FSTCOL + NN Q = N - NXTCOL + 1 MM = MM - NN JPNT = XPNT(NXTCOL) IF ( Q .GT. 0 ) THEN CALL MMPY8( MM, NN, Q, XPNT(FSTCOL), X, X(JPNT), MM ) ENDIF FSTCOL = NXTCOL GO TO 100 ENDIF C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C********** CHORDR ..... CHILD REORDERING *********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C REARRANGE THE CHILDREN OF EACH VERTEX SO THAT THE LAST ONE C MAXIMIZES (AMONG THE CHILDREN) THE NUMBER OF NONZEROS IN THE C CORRESPONDING COLUMN OF L. ALSO DETERMINE AN NEW POSTORDERING C BASED ON THE STRUCTURE OF THE MODIFIED ELIMINATION TREE. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C C UPDATED PARAMETERS: C (PERM,INVP) - ON INPUT, THE GIVEN PERM AND INVERSE PERM C VECTORS. ON OUTPUT, THE NEW PERM AND C INVERSE PERM VECTORS OF THE NEW C POSTORDERING. C COLCNT - COLUMN COUNTS IN L UNDER INITIAL ORDERING; C MODIFIED TO REFLECT THE NEW ORDERING. C C OUTPUT PARAMETERS: C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE C ASSOCIATED WITH THE NEW ORDERING. C C WORKING PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C INVPOS - THE INVERSE PERM VECTOR FOR THE C POSTORDERING. C C PROGRAM SUBROUTINES: C BTREE2, EPOST2, INVINV. C C*********************************************************************** C SUBROUTINE CHORDR ( NEQNS , PERM , INVP , & COLCNT, PARENT, FSON , BROTHR, INVPOS ) C C*********************************************************************** C INTEGER BROTHR(*) , & COLCNT(*) , FSON(*) , & INVP(*) , INVPOS(*) , & PARENT(*) , PERM(*) C INTEGER NEQNS C C*********************************************************************** C C ---------------------------------------------------------- C COMPUTE A BINARY REPRESENTATION OF THE ELIMINATION TREE, C SO THAT EACH "LAST CHILD" MAXIMIZES AMONG ITS SIBLINGS THE C NUMBER OF NONZEROS IN THE CORRESPONDING COLUMNS OF L. C ---------------------------------------------------------- CALL BTREE2 ( NEQNS , PARENT, COLCNT, FSON , BROTHR, & INVPOS ) C C ---------------------------------------------------- C POSTORDER THE ELIMINATION TREE (USING THE NEW BINARY C REPRESENTATION. C ---------------------------------------------------- CALL EPOST2 ( NEQNS , FSON , BROTHR, INVPOS, PARENT, & COLCNT, PERM ) C C -------------------------------------------------------- C COMPOSE THE ORIGINAL ORDERING WITH THE NEW POSTORDERING. C -------------------------------------------------------- CALL INVINV ( NEQNS , INVP , INVPOS, PERM ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** DSCAL1 .... SCALE A VECTOR ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE COMPUTES A <-- AX, WHERE A IS A C SCALAR AND X IS A VECTOR. C C INPUT PARAMETERS - C N - LENGTH OF THE VECTOR X. C A - SCALAR MULIPLIER. C X - VECTOR TO BE SCALED. C C OUTPUT PARAMETERS - C X - REPLACED BY THE SCALED VECTOR, AX. C C*********************************************************************** C SUBROUTINE DSCAL1 ( N, A, X ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER N DOUBLE PRECISION A, X(N) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER I C C*********************************************************************** C DO 100 I = 1, N X(I) = A * X(I) 100 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C*************** EPOST2 ..... ETREE POSTORDERING #2 *************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C BASED ON THE BINARY REPRESENTATION (FIRST-SON,BROTHER) OF THE C ELIMINATION TREE, A POSTORDERING IS DETERMINED. THE C CORRESPONDING PARENT AND COLCNT VECTORS ARE ALSO MODIFIED TO C REFLECT THE REORDERING. C C INPUT PARAMETERS: C ROOT - ROOT OF THE ELIMINATION TREE (USUALLY IT C IS NEQNS). C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHR VECTOR. C C UPDATED PARAMETERS: C PARENT - THE PARENT VECTOR. C COLCNT - COLUMN NONZERO COUNTS OF THE FACTOR. C C OUTPUT PARAMETERS: C INVPOS - INVERSE PERMUTATION FOR THE POSTORDERING. C C WORKING PARAMETERS: C STACK - THE STACK FOR POSTORDER TRAVERSAL OF THE C TREE. C C*********************************************************************** C SUBROUTINE EPOST2 ( ROOT , FSON , BROTHR, INVPOS, PARENT, & COLCNT, STACK ) C C*********************************************************************** C INTEGER*4 BROTHR(*) , COLCNT(*) , & FSON(*) , INVPOS(*) , & PARENT(*) , STACK(*) C INTEGER*4 ROOT C C*********************************************************************** C INTEGER*4 ITOP , NDPAR , NODE , NUM , NUNODE C C*********************************************************************** C NUM = 0 ITOP = 0 NODE = ROOT C ------------------------------------------------------------- C TRAVERSE ALONG THE FIRST SONS POINTER AND PUSH THE TREE NODES C ALONG THE TRAVERSAL INTO THE STACK. C ------------------------------------------------------------- 100 CONTINUE ITOP = ITOP + 1 STACK(ITOP) = NODE NODE = FSON(NODE) IF ( NODE .GT. 0 ) GO TO 100 C ---------------------------------------------------------- C IF POSSIBLE, POP A TREE NODE FROM THE STACK AND NUMBER IT. C ---------------------------------------------------------- 200 CONTINUE IF ( ITOP .LE. 0 ) GO TO 300 NODE = STACK(ITOP) ITOP = ITOP - 1 NUM = NUM + 1 INVPOS(NODE) = NUM C ---------------------------------------------------- C THEN, TRAVERSE TO ITS YOUNGER BROTHER IF IT HAS ONE. C ---------------------------------------------------- NODE = BROTHR(NODE) IF ( NODE .LE. 0 ) GO TO 200 GO TO 100 C 300 CONTINUE C ------------------------------------------------------------ C DETERMINE THE NEW PARENT VECTOR OF THE POSTORDERING. BROTHR C IS USED TEMPORARILY FOR THE NEW PARENT VECTOR. C ------------------------------------------------------------ DO 400 NODE = 1, NUM NUNODE = INVPOS(NODE) NDPAR = PARENT(NODE) IF ( NDPAR .GT. 0 ) NDPAR = INVPOS(NDPAR) BROTHR(NUNODE) = NDPAR 400 CONTINUE C DO 500 NUNODE = 1, NUM PARENT(NUNODE) = BROTHR(NUNODE) 500 CONTINUE C C ---------------------------------------------- C PERMUTE COLCNT(*) TO REFLECT THE NEW ORDERING. C ---------------------------------------------- DO 600 NODE = 1, NUM NUNODE = INVPOS(NODE) STACK(NUNODE) = COLCNT(NODE) 600 CONTINUE C DO 700 NODE = 1, NUM COLCNT(NODE) = STACK(NODE) 700 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C********** ETORDR ..... ELIMINATION TREE REORDERING *********** C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO DETERMINE AN EQUIVALENT REORDERING BASED ON THE STRUCTURE OF C THE ELIMINATION TREE. A POSTORDERING OF THE GIVEN ELIMINATION C TREE IS RETURNED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C C UPDATED PARAMETERS: C (PERM,INVP) - ON INPUT, THE GIVEN PERM AND INVERSE PERM C VECTORS. ON OUTPUT, THE NEW PERM AND C INVERSE PERM VECTORS OF THE EQUIVALENT C ORDERING. C C OUTPUT PARAMETERS: C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE C ASSOCIATED WITH THE NEW ORDERING. C C WORKING PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C INVPOS - THE INVERSE PERM VECTOR FOR THE C POSTORDERING. C C PROGRAM SUBROUTINES: C BETREE, ETPOST, ETREE , INVINV. C C*********************************************************************** C SUBROUTINE ETORDR ( NEQNS , XADJ , ADJNCY, PERM , INVP , & PARENT, FSON , BROTHR, INVPOS ) C C*********************************************************************** C INTEGER*4 ADJNCY(*) , BROTHR(*) , & FSON(*) , INVP(*) , & INVPOS(*) , PARENT(*) , & PERM(*) C INTEGER*4 XADJ(*) INTEGER*4 NEQNS C C*********************************************************************** C C ----------------------------- C COMPUTE THE ELIMINATION TREE. C ----------------------------- CALL ETREE ( NEQNS, XADJ, ADJNCY, PERM, INVP, PARENT, INVPOS ) C C -------------------------------------------------------- C COMPUTE A BINARY REPRESENTATION OF THE ELIMINATION TREE. C -------------------------------------------------------- CALL BETREE ( NEQNS, PARENT, FSON, BROTHR ) C C ------------------------------- C POSTORDER THE ELIMINATION TREE. C ------------------------------- CALL ETPOST ( NEQNS, FSON, BROTHR, INVPOS, PARENT, PERM ) C C -------------------------------------------------------- C COMPOSE THE ORIGINAL ORDERING WITH THE NEW POSTORDERING. C -------------------------------------------------------- CALL INVINV ( NEQNS, INVP, INVPOS, PERM ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C*************** ETPOST ..... ETREE POSTORDERING *************** C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (SEPT 17, 1986) C C PURPOSE: C BASED ON THE BINARY REPRESENTATION (FIRST-SON,BROTHER) OF C THE ELIMINATION TREE, A POSTORDERING IS DETERMINED. THE C CORRESPONDING PARENT VECTOR IS ALSO MODIFIED TO REFLECT C THE REORDERING. C C INPUT PARAMETERS: C ROOT - ROOT OF THE ELIMINATION TREE (USUALLY IT C IS NEQNS). C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHR VECTOR. C C UPDATED PARAMETERS: C PARENT - THE PARENT VECTOR. C C OUTPUT PARAMETERS: C INVPOS - INVERSE PERMUTATION FOR THE POSTORDERING. C C WORKING PARAMETERS: C STACK - THE STACK FOR POSTORDER TRAVERSAL OF THE C TREE. C C*********************************************************************** C SUBROUTINE ETPOST ( ROOT , FSON , BROTHR, INVPOS, PARENT, & STACK ) C C*********************************************************************** C INTEGER*4 BROTHR(*) , FSON(*) , & INVPOS(*) , PARENT(*) , & STACK(*) C INTEGER*4 ROOT C C*********************************************************************** C INTEGER*4 ITOP , NDPAR , NODE , NUM , NUNODE C C*********************************************************************** C NUM = 0 ITOP = 0 NODE = ROOT C ------------------------------------------------------------- C TRAVERSE ALONG THE FIRST SONS POINTER AND PUSH THE TREE NODES C ALONG THE TRAVERSAL INTO THE STACK. C ------------------------------------------------------------- 100 CONTINUE ITOP = ITOP + 1 STACK(ITOP) = NODE NODE = FSON(NODE) IF ( NODE .GT. 0 ) GO TO 100 C ---------------------------------------------------------- C IF POSSIBLE, POP A TREE NODE FROM THE STACK AND NUMBER IT. C ---------------------------------------------------------- 200 CONTINUE IF ( ITOP .LE. 0 ) GO TO 300 NODE = STACK(ITOP) ITOP = ITOP - 1 NUM = NUM + 1 INVPOS(NODE) = NUM C ---------------------------------------------------- C THEN, TRAVERSE TO ITS YOUNGER BROTHER IF IT HAS ONE. C ---------------------------------------------------- NODE = BROTHR(NODE) IF ( NODE .LE. 0 ) GO TO 200 GO TO 100 C 300 CONTINUE C ------------------------------------------------------------ C DETERMINE THE NEW PARENT VECTOR OF THE POSTORDERING. BROTHR C IS USED TEMPORARILY FOR THE NEW PARENT VECTOR. C ------------------------------------------------------------ DO 400 NODE = 1, NUM NUNODE = INVPOS(NODE) NDPAR = PARENT(NODE) IF ( NDPAR .GT. 0 ) NDPAR = INVPOS(NDPAR) BROTHR(NUNODE) = NDPAR 400 CONTINUE C DO 500 NUNODE = 1, NUM PARENT(NUNODE) = BROTHR(NUNODE) 500 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**************** ETREE ..... ELIMINATION TREE ***************** C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO DETERMINE THE ELIMINATION TREE FROM A GIVEN ORDERING AND C THE ADJACENCY STRUCTURE. THE PARENT VECTOR IS RETURNED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C (PERM,INVP) - PERMUTATION AND INVERSE PERMUTATION VECTORS C C OUTPUT PARAMETERS: C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE. C C WORKING PARAMETERS: C ANCSTR - THE ANCESTOR VECTOR. C C*********************************************************************** C SUBROUTINE ETREE ( NEQNS , XADJ , ADJNCY, PERM , INVP , & PARENT, ANCSTR ) C C*********************************************************************** C INTEGER*4 ADJNCY(*) , ANCSTR(*) , & INVP(*) , PARENT(*) , & PERM(*) C INTEGER*4 NEQNS INTEGER*4 XADJ(*) C C*********************************************************************** C INTEGER*4 I , J , JSTOP , JSTRT , NBR , & NEXT , NODE C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C DO 400 I = 1, NEQNS PARENT(I) = 0 ANCSTR(I) = 0 NODE = PERM(I) C JSTRT = XADJ(NODE) JSTOP = XADJ(NODE+1) - 1 IF ( JSTRT .LE. JSTOP ) THEN DO 300 J = JSTRT, JSTOP NBR = ADJNCY(J) NBR = INVP(NBR) IF ( NBR .LT. I ) THEN C ------------------------------------------- C FOR EACH NBR, FIND THE ROOT OF ITS CURRENT C ELIMINATION TREE. PERFORM PATH COMPRESSION C AS THE SUBTREE IS TRAVERSED. C ------------------------------------------- 100 CONTINUE IF ( ANCSTR(NBR) .EQ. I ) GO TO 300 IF ( ANCSTR(NBR) .GT. 0 ) THEN NEXT = ANCSTR(NBR) ANCSTR(NBR) = I NBR = NEXT GO TO 100 ENDIF C -------------------------------------------- C NOW, NBR IS THE ROOT OF THE SUBTREE. MAKE I C THE PARENT NODE OF THIS ROOT. C -------------------------------------------- PARENT(NBR) = I ANCSTR(NBR) = I ENDIF 300 CONTINUE ENDIF 400 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: January 12, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************** FCNTHN ..... FIND NONZERO COUNTS *************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE DETERMINES THE ROW COUNTS AND COLUMN COUNTS IN C THE CHOLESKY FACTOR. IT USES A DISJOINT SET UNION ALGORITHM. C C TECHNIQUES: C 1) SUPERNODE DETECTION. C 2) PATH HALVING. C 3) NO UNION BY RANK. C C NOTES: C 1) ASSUMES A POSTORDERING OF THE ELIMINATION TREE. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS. C (I) ADJLEN - LENGTH OF ADJACENCY STRUCTURE. C (I) XADJ(*) - ARRAY OF LENGTH NEQNS+1, CONTAINING POINTERS C TO THE ADJACENCY STRUCTURE. C (I) ADJNCY(*) - ARRAY OF LENGTH XADJ(NEQNS+1)-1, CONTAINING C THE ADJACENCY STRUCTURE. C (I) PERM(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C POSTORDERING. C (I) INVP(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C INVERSE OF THE POSTORDERING. C (I) ETPAR(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C ELIMINATION TREE OF THE POSTORDERED MATRIX. C C OUTPUT PARAMETERS: C (I) ROWCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH ROW OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C (I) COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH COLUMN OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C (I) NLNZ - NUMBER OF NONZEROS IN THE FACTOR, INCLUDING C THE DIAGONAL ENTRIES. C C WORK PARAMETERS: C (I) SET(*) - ARRAY OF LENGTH NEQNS USED TO MAINTAIN THE C DISJOINT SETS (I.E., SUBTREES). C (I) PRVLF(*) - ARRAY OF LENGTH NEQNS USED TO RECORD THE C PREVIOUS LEAF OF EACH ROW SUBTREE. C (I) LEVEL(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING THE LEVEL C (DISTANCE FROM THE ROOT). C (I) WEIGHT(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING WEIGHTS C USED TO COMPUTE COLUMN COUNTS. C (I) FDESC(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING THE C FIRST (I.E., LOWEST-NUMBERED) DESCENDANT. C (I) NCHILD(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING THE C NUMBER OF CHILDREN. C (I) PRVNBR(*) - ARRAY OF LENGTH NEQNS USED TO RECORD THE C PREVIOUS ``LOWER NEIGHBOR'' OF EACH NODE. C C FIRST CREATED ON APRIL 12, 1990. C LAST UPDATED ON JANUARY 12, 1995. C C*********************************************************************** C SUBROUTINE FCNTHN ( NEQNS , ADJLEN, XADJ , ADJNCY, PERM , & INVP , ETPAR , ROWCNT, COLCNT, NLNZ , & SET , PRVLF , LEVEL , WEIGHT, FDESC , & NCHILD, PRVNBR ) C C ----------- C PARAMETERS. C ----------- INTEGER ADJLEN, NEQNS , NLNZ INTEGER ADJNCY(ADJLEN) , COLCNT(NEQNS) , & ETPAR(NEQNS) , FDESC(0:NEQNS), & INVP(NEQNS) , LEVEL(0:NEQNS), & NCHILD(0:NEQNS) , PERM(NEQNS) , & PRVLF(NEQNS) , PRVNBR(NEQNS) , & ROWCNT(NEQNS) , SET(NEQNS) , & WEIGHT(0:NEQNS) INTEGER XADJ(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER HINBR , IFDESC, J , JSTOP , JSTRT , & K , LAST1 , LAST2 , LCA , LFLAG , & LOWNBR, OLDNBR, PARENT, PLEAF , TEMP , & XSUP C C*********************************************************************** C C -------------------------------------------------- C COMPUTE LEVEL(*), FDESC(*), NCHILD(*). C INITIALIZE XSUP, ROWCNT(*), COLCNT(*), C SET(*), PRVLF(*), WEIGHT(*), PRVNBR(*). C -------------------------------------------------- XSUP = 1 LEVEL(0) = 0 DO 100 K = NEQNS, 1, -1 ROWCNT(K) = 1 COLCNT(K) = 0 SET(K) = K PRVLF(K) = 0 LEVEL(K) = LEVEL(ETPAR(K)) + 1 WEIGHT(K) = 1 FDESC(K) = K NCHILD(K) = 0 PRVNBR(K) = 0 100 CONTINUE NCHILD(0) = 0 FDESC(0) = 0 DO 200 K = 1, NEQNS PARENT = ETPAR(K) WEIGHT(PARENT) = 0 NCHILD(PARENT) = NCHILD(PARENT) + 1 IFDESC = FDESC(K) IF ( IFDESC .LT. FDESC(PARENT) ) THEN FDESC(PARENT) = IFDESC ENDIF 200 CONTINUE C ------------------------------------ C FOR EACH ``LOW NEIGHBOR'' LOWNBR ... C ------------------------------------ DO 600 LOWNBR = 1, NEQNS LFLAG = 0 IFDESC = FDESC(LOWNBR) OLDNBR = PERM(LOWNBR) JSTRT = XADJ(OLDNBR) JSTOP = XADJ(OLDNBR+1) - 1 C ----------------------------------------------- C FOR EACH ``HIGH NEIGHBOR'', HINBR OF LOWNBR ... C ----------------------------------------------- DO 500 J = JSTRT, JSTOP HINBR = INVP(ADJNCY(J)) IF ( HINBR .GT. LOWNBR ) THEN IF ( IFDESC .GT. PRVNBR(HINBR) ) THEN C ------------------------- C INCREMENT WEIGHT(LOWNBR). C ------------------------- WEIGHT(LOWNBR) = WEIGHT(LOWNBR) + 1 PLEAF = PRVLF(HINBR) C ----------------------------------------- C IF HINBR HAS NO PREVIOUS ``LOW NEIGHBOR'' C THEN ... C ----------------------------------------- IF ( PLEAF .EQ. 0 ) THEN C ----------------------------------------- C ... ACCUMULATE LOWNBR-->HINBR PATH LENGTH C IN ROWCNT(HINBR). C ----------------------------------------- ROWCNT(HINBR) = ROWCNT(HINBR) + & LEVEL(LOWNBR) - LEVEL(HINBR) ELSE C ----------------------------------------- C ... OTHERWISE, LCA <-- FIND(PLEAF), WHICH C IS THE LEAST COMMON ANCESTOR OF PLEAF C AND LOWNBR. C (PATH HALVING.) C ----------------------------------------- LAST1 = PLEAF LAST2 = SET(LAST1) LCA = SET(LAST2) 300 CONTINUE IF ( LCA .NE. LAST2 ) THEN SET(LAST1) = LCA LAST1 = LCA LAST2 = SET(LAST1) LCA = SET(LAST2) GO TO 300 ENDIF C ------------------------------------- C ACCUMULATE PLEAF-->LCA PATH LENGTH IN C ROWCNT(HINBR). C DECREMENT WEIGHT(LCA). C ------------------------------------- ROWCNT(HINBR) = ROWCNT(HINBR) & + LEVEL(LOWNBR) - LEVEL(LCA) WEIGHT(LCA) = WEIGHT(LCA) - 1 ENDIF C ---------------------------------------------- C LOWNBR NOW BECOMES ``PREVIOUS LEAF'' OF HINBR. C ---------------------------------------------- PRVLF(HINBR) = LOWNBR LFLAG = 1 ENDIF C -------------------------------------------------- C LOWNBR NOW BECOMES ``PREVIOUS NEIGHBOR'' OF HINBR. C -------------------------------------------------- PRVNBR(HINBR) = LOWNBR ENDIF 500 CONTINUE C ---------------------------------------------------- C DECREMENT WEIGHT ( PARENT(LOWNBR) ). C SET ( P(LOWNBR) ) <-- SET ( P(LOWNBR) ) + SET(XSUP). C ---------------------------------------------------- PARENT = ETPAR(LOWNBR) WEIGHT(PARENT) = WEIGHT(PARENT) - 1 IF ( LFLAG .EQ. 1 .OR. & NCHILD(LOWNBR) .GE. 2 ) THEN XSUP = LOWNBR ENDIF SET(XSUP) = PARENT 600 CONTINUE C --------------------------------------------------------- C USE WEIGHTS TO COMPUTE COLUMN (AND TOTAL) NONZERO COUNTS. C --------------------------------------------------------- NLNZ = 0 DO 700 K = 1, NEQNS TEMP = COLCNT(K) + WEIGHT(K) COLCNT(K) = TEMP NLNZ = NLNZ + TEMP PARENT = ETPAR(K) IF ( PARENT .NE. 0 ) THEN COLCNT(PARENT) = COLCNT(PARENT) + TEMP ENDIF 700 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: May 26, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**** FNSPLT ..... COMPUTE FINE PARTITIONING OF SUPERNODES ***** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE DETERMINES A FINE PARTITIONING OF SUPERNODES C WHEN THERE IS A CACHE AVAILABLE ON THE MACHINE. THE FINE C PARTITIONING IS CHOSEN SO THAT DATA RE-USE IS MAXIMIZED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C NSUPER - NUMBER OF SUPERNODES. C XSUPER - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C THE SUPERNODE PARTITIONING. C XLINDX - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C POINTERS IN THE SUPERNODE INDICES. C CACHSZ - CACHE SIZE IN KILO BYTES. C IF THERE IS NO CACHE, SET CACHSZ = 0. C C OUTPUT PARAMETERS: C SPLIT - INTEGER ARRAY OF SIZE NEQNS CONTAINING THE C FINE PARTITIONING. C C*********************************************************************** C SUBROUTINE FNSPLT ( NEQNS , NSUPER, XSUPER, XLINDX, & CACHSZ, SPLIT ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER CACHSZ, NEQNS , NSUPER INTEGER XSUPER(*), SPLIT(*) INTEGER XLINDX(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER CACHE , CURCOL, FSTCOL, HEIGHT, KCOL , 1 KSUP , LSTCOL, NCOLS , NXTBLK, USED , 1 WIDTH C C ******************************************************************* C C -------------------------------------------- C COMPUTE THE NUMBER OF 8-BYTE WORDS IN CACHE. C -------------------------------------------- IF ( CACHSZ .LE. 0 ) THEN CACHE = 2 000 000 000 ELSE CACHE = ( FLOAT(CACHSZ) * 1024. / 8. ) * 0.9 ENDIF C C --------------- C INITIALIZATION. C --------------- DO 100 KCOL = 1, NEQNS SPLIT(KCOL) = 0 100 CONTINUE C C --------------------------- C FOR EACH SUPERNODE KSUP ... C --------------------------- DO 1000 KSUP = 1, NSUPER C ----------------------- C ... GET SUPERNODE INFO. C ----------------------- HEIGHT = XLINDX(KSUP+1) - XLINDX(KSUP) FSTCOL = XSUPER(KSUP) LSTCOL = XSUPER(KSUP+1) - 1 WIDTH = LSTCOL - FSTCOL + 1 NXTBLK = FSTCOL C -------------------------------------- C ... UNTIL ALL COLUMNS OF THE SUPERNODE C HAVE BEEN PROCESSED ... C -------------------------------------- CURCOL = FSTCOL - 1 200 CONTINUE C ------------------------------------------- C ... PLACE THE FIRST COLUMN(S) IN THE CACHE. C ------------------------------------------- CURCOL = CURCOL + 1 IF ( CURCOL .LT. LSTCOL ) THEN CURCOL = CURCOL + 1 NCOLS = 2 USED = 4 * HEIGHT - 1 HEIGHT = HEIGHT - 2 ELSE NCOLS = 1 USED = 3 * HEIGHT HEIGHT = HEIGHT - 1 ENDIF C C -------------------------------------- C ... WHILE THE CACHE IS NOT FILLED AND C THERE ARE COLUMNS OF THE SUPERNODE C REMAINING TO BE PROCESSED ... C -------------------------------------- 300 CONTINUE IF ( USED+HEIGHT .LT. CACHE .AND. & CURCOL .LT. LSTCOL ) THEN C -------------------------------- C ... ADD ANOTHER COLUMN TO CACHE. C -------------------------------- CURCOL = CURCOL + 1 NCOLS = NCOLS + 1 USED = USED + HEIGHT HEIGHT = HEIGHT - 1 GO TO 300 ENDIF C ------------------------------------- C ... RECORD THE NUMBER OF COLUMNS THAT C FILLED THE CACHE. C ------------------------------------- SPLIT(NXTBLK) = NCOLS NXTBLK = NXTBLK + 1 C -------------------------- C ... GO PROCESS NEXT BLOCK. C -------------------------- IF ( CURCOL .LT. LSTCOL ) GO TO 200 1000 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** FNTSIZ ..... COMPUTE WORK STORAGE SIZE FOR BLKFCT ****** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE DETERMINES THE SIZE OF THE WORKING STORAGE C REQUIRED BY BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C THE SUPERNODE PARTITIONING. C SNODE - SUPERNODE MEMBERSHIP. C (XLINDX,LINDX) - ARRAYS DESCRIBING THE SUPERNODAL STRUCTURE. C C OUTPUT PARAMETERS: C TMPSIZ - SIZE OF WORKING STORAGE REQUIRED BY BLKFCT. C C*********************************************************************** C SUBROUTINE FNTSIZ ( NSUPER, XSUPER, SNODE , XLINDX, & LINDX , TMPSIZ ) C C*********************************************************************** C INTEGER NSUPER, TMPSIZ INTEGER XLINDX(*) , XSUPER(*) INTEGER LINDX (*) , SNODE (*) C INTEGER BOUND , CLEN , CURSUP, I , IBEGIN, IEND , & KSUP , LENGTH, NCOLS , NXTSUP, & TSIZE , WIDTH C C*********************************************************************** C C RETURNS SIZE OF TEMP ARRAY USED BY BLKFCT FACTORIZATION ROUTINE. C NOTE THAT THE VALUE RETURNED IS AN ESTIMATE, THOUGH IT IS USUALLY C TIGHT. C C ---------------------------------------- C COMPUTE SIZE OF TEMPORARY STORAGE VECTOR C NEEDED BY BLKFCT. C ---------------------------------------- TMPSIZ = 0 DO 500 KSUP = NSUPER, 1, -1 NCOLS = XSUPER(KSUP+1) - XSUPER(KSUP) IBEGIN = XLINDX(KSUP) + NCOLS IEND = XLINDX(KSUP+1) - 1 LENGTH = IEND - IBEGIN + 1 BOUND = LENGTH * (LENGTH + 1) / 2 IF ( BOUND .GT. TMPSIZ ) THEN CURSUP = SNODE(LINDX(IBEGIN)) CLEN = XLINDX(CURSUP+1) - XLINDX(CURSUP) WIDTH = 0 DO 400 I = IBEGIN, IEND NXTSUP = SNODE(LINDX(I)) IF ( NXTSUP .EQ. CURSUP ) THEN WIDTH = WIDTH + 1 IF ( I .EQ. IEND ) THEN IF ( CLEN .GT. LENGTH ) THEN TSIZE = LENGTH * WIDTH - & (WIDTH - 1) * WIDTH / 2 TMPSIZ = MAX ( TSIZE , TMPSIZ ) ENDIF ENDIF ELSE IF ( CLEN .GT. LENGTH ) THEN TSIZE = LENGTH * WIDTH - & (WIDTH - 1) * WIDTH / 2 TMPSIZ = MAX ( TSIZE , TMPSIZ ) ENDIF LENGTH = LENGTH - WIDTH BOUND = LENGTH * (LENGTH + 1) / 2 IF ( BOUND .LE. TMPSIZ ) GO TO 500 WIDTH = 1 CURSUP = NXTSUP CLEN = XLINDX(CURSUP+1) - XLINDX(CURSUP) ENDIF 400 CONTINUE ENDIF 500 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**************** FSUP1 ..... FIND SUPERNODES #1 ***************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE IS THE FIRST OF TWO ROUTINES FOR FINDING A C MAXIMAL SUPERNODE PARTITION. IT RETURNS ONLY THE NUMBER OF C SUPERNODES NSUPER AND THE SUPERNODE MEMBERSHIP VECTOR SNODE(*), C WHICH IS OF LENGTH NEQNS. THE VECTORS OF LENGTH NSUPER ARE C COMPUTED SUBSEQUENTLY BY THE COMPANION ROUTINE FSUP2. C C METHOD AND ASSUMPTIONS: C THIS ROUTINE USES THE ELIMINATION TREE AND THE FACTOR COLUMN C COUNTS TO COMPUTE THE SUPERNODE PARTITION; IT ALSO ASSUMES A C POSTORDERING OF THE ELIMINATION TREE. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS. C (I) ETPAR(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C ELIMINATION TREE OF THE POSTORDERED MATRIX. C (I) COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C FACTOR COLUMN COUNTS: I.E., THE NUMBER OF C NONZERO ENTRIES IN EACH COLUMN OF L C (INCLUDING THE DIAGONAL ENTRY). C C OUTPUT PARAMETERS: C (I) NOFSUB - NUMBER OF SUBSCRIPTS. C (I) NSUPER - NUMBER OF SUPERNODES (<= NEQNS). C (I) SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C C FIRST CREATED ON JANUARY 18, 1992. C LAST UPDATED ON NOVEMBER 11, 1994. C C*********************************************************************** C SUBROUTINE FSUP1 ( NEQNS , ETPAR , COLCNT, NOFSUB, NSUPER, & SNODE ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER NEQNS , NOFSUB, NSUPER INTEGER COLCNT(*) , ETPAR(*) , & SNODE(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER KCOL C C*********************************************************************** C C -------------------------------------------- C COMPUTE THE FUNDAMENTAL SUPERNODE PARTITION. C -------------------------------------------- NSUPER = 1 SNODE(1) = 1 NOFSUB = COLCNT(1) DO 300 KCOL = 2, NEQNS IF ( ETPAR(KCOL-1) .EQ. KCOL ) THEN IF ( COLCNT(KCOL-1) .EQ. COLCNT(KCOL)+1 ) THEN SNODE(KCOL) = NSUPER GO TO 300 ENDIF ENDIF NSUPER = NSUPER + 1 SNODE(KCOL) = NSUPER NOFSUB = NOFSUB + COLCNT(KCOL) 300 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**************** FSUP2 ..... FIND SUPERNODES #2 ***************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE IS THE SECOND OF TWO ROUTINES FOR FINDING A C MAXIMAL SUPERNODE PARTITION. IT'S SOLE PURPOSE IS TO C CONSTRUCT THE NEEDED VECTOR OF LENGTH NSUPER: XSUPER(*). THE C FIRST ROUTINE FSUP1 COMPUTES THE NUMBER OF SUPERNODES AND THE C SUPERNODE MEMBERSHIP VECTOR SNODE(*), WHICH IS OF LENGTH NEQNS. C C C ASSUMPTIONS: C THIS ROUTINE ASSUMES A POSTORDERING OF THE ELIMINATION TREE. IT C ALSO ASSUMES THAT THE OUTPUT FROM FSUP1 IS AVAILABLE. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS. C (I) NSUPER - NUMBER OF SUPERNODES (<= NEQNS). C (I) SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C C OUTPUT PARAMETERS: C (I) XSUPER(*) - ARRAY OF LENGTH NSUPER+1, CONTAINING THE C SUPERNODE PARTITIONING. C C FIRST CREATED ON JANUARY 18, 1992. C LAST UPDATED ON NOVEMEBER 22, 1994. C C*********************************************************************** C SUBROUTINE FSUP2 ( NEQNS , NSUPER, SNODE , XSUPER ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER NEQNS , NSUPER INTEGER SNODE(*) , & XSUPER(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER KCOL , KSUP , LSTSUP C C*********************************************************************** C C ------------------------------------------------- C COMPUTE THE SUPERNODE PARTITION VECTOR XSUPER(*). C ------------------------------------------------- LSTSUP = NSUPER + 1 DO 100 KCOL = NEQNS, 1, -1 KSUP = SNODE(KCOL) IF ( KSUP .NE. LSTSUP ) THEN XSUPER(LSTSUP) = KCOL + 1 ENDIF LSTSUP = KSUP 100 CONTINUE XSUPER(1) = 1 C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = GENMMD C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C**** GENMMD ..... MULTIPLE MINIMUM EXTERNAL DEGREE ************ C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE IMPLEMENTS THE MINIMUM DEGREE C ALGORITHM. IT MAKES USE OF THE IMPLICIT REPRESENTATION C OF ELIMINATION GRAPHS BY QUOTIENT GRAPHS, AND THE C NOTION OF INDISTINGUISHABLE NODES. IT ALSO IMPLEMENTS C THE MODIFICATIONS BY MULTIPLE ELIMINATION AND MINIMUM C EXTERNAL DEGREE. C --------------------------------------------- C CAUTION - THE ADJACENCY VECTOR ADJNCY WILL BE C DESTROYED. C --------------------------------------------- C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. C MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) INTEGER C (ANY SMALLER ESTIMATE WILL DO) FOR MARKING C NODES. C C OUTPUT PARAMETERS - C PERM - THE MINIMUM DEGREE ORDERING. C INVP - THE INVERSE OF PERM. C NOFSUB - AN UPPER BOUND ON THE NUMBER OF NONZERO C SUBSCRIPTS FOR THE COMPRESSED STORAGE SCHEME. C C WORKING PARAMETERS - C DHEAD - VECTOR FOR HEAD OF DEGREE LISTS. C INVP - USED TEMPORARILY FOR DEGREE FORWARD LINK. C PERM - USED TEMPORARILY FOR DEGREE BACKWARD LINK. C QSIZE - VECTOR FOR SIZE OF SUPERNODES. C LLIST - VECTOR FOR TEMPORARY LINKED LISTS. C MARKER - A TEMPORARY MARKER VECTOR. C C PROGRAM SUBROUTINES - C MMDELM, MMDINT, MMDNUM, MMDUPD. C C*********************************************************************** C SUBROUTINE GENMMD ( NEQNS, XADJ, ADJNCY, INVP, PERM, 1 DELTA, DHEAD, QSIZE, LLIST, MARKER, 1 MAXINT, NOFSUB ) C C*********************************************************************** C INTEGER ADJNCY(*), DHEAD(*) , INVP(*) , LLIST(*) , 1 MARKER(*), PERM(*) , QSIZE(*) INTEGER XADJ(*) INTEGER DELTA , EHEAD , I , MAXINT, MDEG , 1 MDLMT , MDNODE, NEQNS , NEXTMD, NOFSUB, 1 NUM, TAG C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C C ------------------------------------------------ C INITIALIZATION FOR THE MINIMUM DEGREE ALGORITHM. C ------------------------------------------------ NOFSUB = 0 CALL MMDINT ( NEQNS, XADJ, DHEAD, INVP, PERM, 1 QSIZE, LLIST, MARKER ) C C ---------------------------------------------- C NUM COUNTS THE NUMBER OF ORDERED NODES PLUS 1. C ---------------------------------------------- NUM = 1 C C ----------------------------- C ELIMINATE ALL ISOLATED NODES. C ----------------------------- NEXTMD = DHEAD(1) 100 CONTINUE IF ( NEXTMD .LE. 0 ) GO TO 200 MDNODE = NEXTMD NEXTMD = INVP(MDNODE) MARKER(MDNODE) = MAXINT INVP(MDNODE) = - NUM NUM = NUM + 1 GO TO 100 C 200 CONTINUE C ---------------------------------------- C SEARCH FOR NODE OF THE MINIMUM DEGREE. C MDEG IS THE CURRENT MINIMUM DEGREE; C TAG IS USED TO FACILITATE MARKING NODES. C ---------------------------------------- IF ( NUM .GT. NEQNS ) GO TO 1000 TAG = 1 DHEAD(1) = 0 MDEG = 2 300 CONTINUE IF ( DHEAD(MDEG) .GT. 0 ) GO TO 400 MDEG = MDEG + 1 GO TO 300 400 CONTINUE C ------------------------------------------------- C USE VALUE OF DELTA TO SET UP MDLMT, WHICH GOVERNS C WHEN A DEGREE UPDATE IS TO BE PERFORMED. C ------------------------------------------------- MDLMT = MDEG + DELTA EHEAD = 0 C 500 CONTINUE MDNODE = DHEAD(MDEG) IF ( MDNODE .GT. 0 ) GO TO 600 MDEG = MDEG + 1 IF ( MDEG .GT. MDLMT ) GO TO 900 GO TO 500 600 CONTINUE C ---------------------------------------- C REMOVE MDNODE FROM THE DEGREE STRUCTURE. C ---------------------------------------- NEXTMD = INVP(MDNODE) DHEAD(MDEG) = NEXTMD IF ( NEXTMD .GT. 0 ) PERM(NEXTMD) = - MDEG INVP(MDNODE) = - NUM NOFSUB = NOFSUB + MDEG + QSIZE(MDNODE) - 2 IF ( NUM+QSIZE(MDNODE) .GT. NEQNS ) GO TO 1000 C ---------------------------------------------- C ELIMINATE MDNODE AND PERFORM QUOTIENT GRAPH C TRANSFORMATION. RESET TAG VALUE IF NECESSARY. C ---------------------------------------------- TAG = TAG + 1 IF ( TAG .LT. MAXINT ) GO TO 800 TAG = 1 DO 700 I = 1, NEQNS IF ( MARKER(I) .LT. MAXINT ) MARKER(I) = 0 700 CONTINUE 800 CONTINUE CALL MMDELM ( MDNODE, XADJ, ADJNCY, DHEAD, INVP, 1 PERM, QSIZE, LLIST, MARKER, MAXINT, 1 TAG ) NUM = NUM + QSIZE(MDNODE) LLIST(MDNODE) = EHEAD EHEAD = MDNODE IF ( DELTA .GE. 0 ) GO TO 500 900 CONTINUE C ------------------------------------------- C UPDATE DEGREES OF THE NODES INVOLVED IN THE C MINIMUM DEGREE NODES ELIMINATION. C ------------------------------------------- IF ( NUM .GT. NEQNS ) GO TO 1000 CALL MMDUPD ( EHEAD, NEQNS, XADJ, ADJNCY, DELTA, MDEG, 1 DHEAD, INVP, PERM, QSIZE, LLIST, MARKER, 1 MAXINT, TAG ) GO TO 300 C 1000 CONTINUE CALL MMDNUM ( NEQNS, PERM, INVP, QSIZE ) RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** IGATHR .... INTEGER GATHER OPERATION ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS A STANDARD INTEGER GATHER C OPERATION. C C INPUT PARAMETERS - C KLEN - LENGTH OF THE LIST OF GLOBAL INDICES. C LINDX - LIST OF GLOBAL INDICES. C INDMAP - INDEXED BY GLOBAL INDICES, IT CONTAINS THE C REQUIRED RELATIVE INDICES. C C OUTPUT PARAMETERS - C RELIND - LIST RELATIVE INDICES. C C*********************************************************************** C SUBROUTINE IGATHR ( KLEN , LINDX, INDMAP, RELIND ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER KLEN INTEGER INDMAP(*), LINDX (*), RELIND(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER I C C*********************************************************************** C CDIR$ IVDEP DO 100 I = 1, KLEN RELIND(I) = INDMAP(LINDX(I)) 100 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C C ------------------------------------------------------ C INPUT NUMERICAL VALUES INTO SPARSE DATA STRUCTURES ... C ------------------------------------------------------ C SUBROUTINE INPNV ( XADJF, ADJF, ANZF, PERM, INVP, & NSUPER, XSUPER, XLINDX, LINDX, & XLNZ, LNZ, OFFSET ) C INTEGER XADJF(*), ADJF(*) DOUBLE PRECISION ANZF(*) INTEGER PERM(*), INVP(*) INTEGER NSUPER INTEGER XSUPER(*), XLINDX(*), LINDX(*) INTEGER XLNZ(*) DOUBLE PRECISION LNZ(*) INTEGER OFFSET(*) C INTEGER I, II, J, JLEN, JSUPER, LAST, OLDJ C DO 500 JSUPER = 1, NSUPER C C ---------------------------------------- C FOR EACH SUPERNODE, DO THE FOLLOWING ... C ---------------------------------------- C C ----------------------------------------------- C FIRST GET OFFSET TO FACILITATE NUMERICAL INPUT. C ----------------------------------------------- JLEN = XLINDX(JSUPER+1) - XLINDX(JSUPER) DO 100 II = XLINDX(JSUPER), XLINDX(JSUPER+1)-1 I = LINDX(II) JLEN = JLEN - 1 OFFSET(I) = JLEN 100 CONTINUE C DO 400 J = XSUPER(JSUPER), XSUPER(JSUPER+1)-1 C ----------------------------------------- C FOR EACH COLUMN IN THE CURRENT SUPERNODE, C FIRST INITIALIZE THE DATA STRUCTURE. C ----------------------------------------- c DO 200 II = XLNZ(J), XLNZ(J+1)-1 c LNZ(II) = 0.0 c 200 CONTINUE c The previous lines are not required as R initializes the arrays c Reinhard Furrer, Nov 19, 2007 C C ----------------------------------- C NEXT INPUT THE INDIVIDUAL NONZEROS. C ----------------------------------- OLDJ = PERM(J) LAST = XLNZ(J+1) - 1 DO 300 II = XADJF(OLDJ), XADJF(OLDJ+1)-1 I = INVP(ADJF(II)) IF ( I .GE. J ) THEN LNZ(LAST-OFFSET(I)) = ANZF(II) ENDIF 300 CONTINUE 400 CONTINUE C 500 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C*********** INVINV ..... CONCATENATION OF TWO INVP ************ C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO PERFORM THE MAPPING OF C ORIGINAL-INVP --> INTERMEDIATE-INVP --> NEW INVP C AND THE RESULTING ORDERING REPLACES INVP. THE NEW PERMUTATION C VECTOR PERM IS ALSO COMPUTED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C INVP2 - THE SECOND INVERSE PERMUTATION VECTOR. C C UPDATED PARAMETERS: C INVP - THE FIRST INVERSE PERMUTATION VECTOR. ON C OUTPUT, IT CONTAINS THE NEW INVERSE C PERMUTATION. C C OUTPUT PARAMETER: C PERM - NEW PERMUTATION VECTOR (CAN BE THE SAME AS C INVP2). C C*********************************************************************** C SUBROUTINE INVINV ( NEQNS , INVP , INVP2 , PERM ) C C*********************************************************************** C INTEGER*4 INVP(*) , INVP2(*) , & PERM(*) C INTEGER*4 NEQNS C C*********************************************************************** C INTEGER*4 I , INTERM, NODE C C*********************************************************************** C DO 100 I = 1, NEQNS INTERM = INVP(I) INVP(I) = INVP2(INTERM) 100 CONTINUE C DO 200 I = 1, NEQNS NODE = INVP(I) PERM(NODE) = I 200 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** LDINDX .... LOAD INDEX VECTOR ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE COMPUTES THE SECOND INDEX VECTOR C USED TO IMPLEMENT THE DOUBLY-INDIRECT SAXPY-LIKE C LOOPS THAT ALLOW US TO ACCUMULATE UPDATE C COLUMNS DIRECTLY INTO FACTOR STORAGE. C C INPUT PARAMETERS - C JLEN - LENGTH OF THE FIRST COLUMN OF THE SUPERNODE, C INCLUDING THE DIAGONAL ENTRY. C LINDX - THE OFF-DIAGONAL ROW INDICES OF THE SUPERNODE, C I.E., THE ROW INDICES OF THE NONZERO ENTRIES C LYING BELOW THE DIAGONAL ENTRY OF THE FIRST C COLUMN OF THE SUPERNODE. C C OUTPUT PARAMETERS - C INDMAP - THIS INDEX VECTOR MAPS EVERY GLOBAL ROW INDEX C OF NONZERO ENTRIES IN THE FIRST COLUMN OF THE C SUPERNODE TO ITS POSITION IN THE INDEX LIST C RELATIVE TO THE LAST INDEX IN THE LIST. MORE C PRECISELY, IT GIVES THE DISTANCE OF EACH INDEX C FROM THE LAST INDEX IN THE LIST. C C*********************************************************************** C SUBROUTINE LDINDX ( JLEN, LINDX, INDMAP ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER JLEN INTEGER LINDX(*), INDMAP(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER CURLEN, J, JSUB C C*********************************************************************** C CURLEN = JLEN DO 200 J = 1, JLEN JSUB = LINDX(J) CURLEN = CURLEN - 1 INDMAP(JSUB) = CURLEN 200 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDELM C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C** MMDELM ..... MULTIPLE MINIMUM DEGREE ELIMINATION *********** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE ELIMINATES THE NODE MDNODE OF C MINIMUM DEGREE FROM THE ADJACENCY STRUCTURE, WHICH C IS STORED IN THE QUOTIENT GRAPH FORMAT. IT ALSO C TRANSFORMS THE QUOTIENT GRAPH REPRESENTATION OF THE C ELIMINATION GRAPH. C C INPUT PARAMETERS - C MDNODE - NODE OF MINIMUM DEGREE. C MAXINT - ESTIMATE OF MAXIMUM REPRESENTABLE (SHORT) C INTEGER. C TAG - TAG VALUE. C C UPDATED PARAMETERS - C (XADJ,ADJNCY) - UPDATED ADJACENCY STRUCTURE. C (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. C QSIZE - SIZE OF SUPERNODE. C MARKER - MARKER VECTOR. C LLIST - TEMPORARY LINKED LIST OF ELIMINATED NABORS. C C*********************************************************************** C SUBROUTINE MMDELM ( MDNODE, XADJ, ADJNCY, DHEAD, DFORW, 1 DBAKW, QSIZE, LLIST, MARKER, MAXINT, 1 TAG ) C C*********************************************************************** C INTEGER ADJNCY(*), DBAKW(*) , DFORW(*) , DHEAD(*) , 1 LLIST(*) , MARKER(*), QSIZE(*) INTEGER XADJ(*) INTEGER ELMNT , I , ISTOP , ISTRT , J , 1 JSTOP , JSTRT , LINK , MAXINT, MDNODE, 1 NABOR , NODE , NPV , NQNBRS, NXNODE, 1 PVNODE, RLMT , RLOC , RNODE , TAG , 1 XQNBR C C*********************************************************************** C C ----------------------------------------------- C FIND REACHABLE SET AND PLACE IN DATA STRUCTURE. C ----------------------------------------------- MARKER(MDNODE) = TAG ISTRT = XADJ(MDNODE) ISTOP = XADJ(MDNODE+1) - 1 C ------------------------------------------------------- C ELMNT POINTS TO THE BEGINNING OF THE LIST OF ELIMINATED C NABORS OF MDNODE, AND RLOC GIVES THE STORAGE LOCATION C FOR THE NEXT REACHABLE NODE. C ------------------------------------------------------- ELMNT = 0 RLOC = ISTRT RLMT = ISTOP DO 200 I = ISTRT, ISTOP NABOR = ADJNCY(I) IF ( NABOR .EQ. 0 ) GO TO 300 IF ( MARKER(NABOR) .GE. TAG ) GO TO 200 MARKER(NABOR) = TAG IF ( DFORW(NABOR) .LT. 0 ) GO TO 100 ADJNCY(RLOC) = NABOR RLOC = RLOC + 1 GO TO 200 100 CONTINUE LLIST(NABOR) = ELMNT ELMNT = NABOR 200 CONTINUE 300 CONTINUE C ----------------------------------------------------- C MERGE WITH REACHABLE NODES FROM GENERALIZED ELEMENTS. C ----------------------------------------------------- IF ( ELMNT .LE. 0 ) GO TO 1000 ADJNCY(RLMT) = - ELMNT LINK = ELMNT 400 CONTINUE JSTRT = XADJ(LINK) JSTOP = XADJ(LINK+1) - 1 DO 800 J = JSTRT, JSTOP NODE = ADJNCY(J) LINK = - NODE IF ( NODE ) 400, 900, 500 500 CONTINUE IF ( MARKER(NODE) .GE. TAG .OR. 1 DFORW(NODE) .LT. 0 ) GO TO 800 MARKER(NODE) = TAG C --------------------------------- C USE STORAGE FROM ELIMINATED NODES C IF NECESSARY. C --------------------------------- 600 CONTINUE IF ( RLOC .LT. RLMT ) GO TO 700 LINK = - ADJNCY(RLMT) RLOC = XADJ(LINK) RLMT = XADJ(LINK+1) - 1 GO TO 600 700 CONTINUE ADJNCY(RLOC) = NODE RLOC = RLOC + 1 800 CONTINUE 900 CONTINUE ELMNT = LLIST(ELMNT) GO TO 300 1000 CONTINUE IF ( RLOC .LE. RLMT ) ADJNCY(RLOC) = 0 C -------------------------------------------------------- C FOR EACH NODE IN THE REACHABLE SET, DO THE FOLLOWING ... C -------------------------------------------------------- LINK = MDNODE 1100 CONTINUE ISTRT = XADJ(LINK) ISTOP = XADJ(LINK+1) - 1 DO 1700 I = ISTRT, ISTOP RNODE = ADJNCY(I) LINK = - RNODE IF ( RNODE ) 1100, 1800, 1200 1200 CONTINUE C -------------------------------------------- C IF RNODE IS IN THE DEGREE LIST STRUCTURE ... C -------------------------------------------- PVNODE = DBAKW(RNODE) IF ( PVNODE .EQ. 0 .OR. 1 PVNODE .EQ. (-MAXINT) ) GO TO 1300 C ------------------------------------- C THEN REMOVE RNODE FROM THE STRUCTURE. C ------------------------------------- NXNODE = DFORW(RNODE) IF ( NXNODE .GT. 0 ) DBAKW(NXNODE) = PVNODE IF ( PVNODE .GT. 0 ) DFORW(PVNODE) = NXNODE NPV = - PVNODE IF ( PVNODE .LT. 0 ) DHEAD(NPV) = NXNODE 1300 CONTINUE C ---------------------------------------- C PURGE INACTIVE QUOTIENT NABORS OF RNODE. C ---------------------------------------- JSTRT = XADJ(RNODE) JSTOP = XADJ(RNODE+1) - 1 XQNBR = JSTRT DO 1400 J = JSTRT, JSTOP NABOR = ADJNCY(J) IF ( NABOR .EQ. 0 ) GO TO 1500 IF ( MARKER(NABOR) .GE. TAG ) GO TO 1400 ADJNCY(XQNBR) = NABOR XQNBR = XQNBR + 1 1400 CONTINUE 1500 CONTINUE C ---------------------------------------- C IF NO ACTIVE NABOR AFTER THE PURGING ... C ---------------------------------------- NQNBRS = XQNBR - JSTRT IF ( NQNBRS .GT. 0 ) GO TO 1600 C ----------------------------- C THEN MERGE RNODE WITH MDNODE. C ----------------------------- QSIZE(MDNODE) = QSIZE(MDNODE) + QSIZE(RNODE) QSIZE(RNODE) = 0 MARKER(RNODE) = MAXINT DFORW(RNODE) = - MDNODE DBAKW(RNODE) = - MAXINT GO TO 1700 1600 CONTINUE C -------------------------------------- C ELSE FLAG RNODE FOR DEGREE UPDATE, AND C ADD MDNODE AS A NABOR OF RNODE. C -------------------------------------- DFORW(RNODE) = NQNBRS + 1 DBAKW(RNODE) = 0 ADJNCY(XQNBR) = MDNODE XQNBR = XQNBR + 1 IF ( XQNBR .LE. JSTOP ) ADJNCY(XQNBR) = 0 C 1700 CONTINUE 1800 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDINT C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C*** MMDINT ..... MULT MINIMUM DEGREE INITIALIZATION *********** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS INITIALIZATION FOR THE C MULTIPLE ELIMINATION VERSION OF THE MINIMUM DEGREE C ALGORITHM. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - ADJACENCY STRUCTURE. C C OUTPUT PARAMETERS - C (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. C QSIZE - SIZE OF SUPERNODE (INITIALIZED TO ONE). C LLIST - LINKED LIST. C MARKER - MARKER VECTOR. C C*********************************************************************** C SUBROUTINE MMDINT ( NEQNS, XADJ, DHEAD, DFORW, 1 DBAKW, QSIZE, LLIST, MARKER ) C C*********************************************************************** C INTEGER DBAKW(*) , DFORW(*) , DHEAD(*) , 1 LLIST(*) , MARKER(*), QSIZE(*) INTEGER XADJ(*) INTEGER FNODE , NDEG , NEQNS , NODE C C*********************************************************************** C DO 100 NODE = 1, NEQNS DHEAD(NODE) = 0 QSIZE(NODE) = 1 MARKER(NODE) = 0 LLIST(NODE) = 0 100 CONTINUE C ------------------------------------------ C INITIALIZE THE DEGREE DOUBLY LINKED LISTS. C ------------------------------------------ DO 200 NODE = 1, NEQNS NDEG = XADJ(NODE+1) - XADJ(NODE) + 1 FNODE = DHEAD(NDEG) DFORW(NODE) = FNODE DHEAD(NDEG) = NODE IF ( FNODE .GT. 0 ) DBAKW(FNODE) = NODE DBAKW(NODE) = - NDEG 200 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDNUM C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C***** MMDNUM ..... MULTI MINIMUM DEGREE NUMBERING ************* C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS THE FINAL STEP IN C PRODUCING THE PERMUTATION AND INVERSE PERMUTATION C VECTORS IN THE MULTIPLE ELIMINATION VERSION OF THE C MINIMUM DEGREE ORDERING ALGORITHM. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C QSIZE - SIZE OF SUPERNODES AT ELIMINATION. C C UPDATED PARAMETERS - C INVP - INVERSE PERMUTATION VECTOR. ON INPUT, C IF QSIZE(NODE)=0, THEN NODE HAS BEEN MERGED C INTO THE NODE -INVP(NODE); OTHERWISE, C -INVP(NODE) IS ITS INVERSE LABELLING. C C OUTPUT PARAMETERS - C PERM - THE PERMUTATION VECTOR. C C*********************************************************************** C SUBROUTINE MMDNUM ( NEQNS, PERM, INVP, QSIZE ) C C*********************************************************************** C INTEGER INVP(*) , PERM(*) , QSIZE(*) INTEGER FATHER, NEQNS , NEXTF , NODE , NQSIZE, 1 NUM , ROOT C C*********************************************************************** C DO 100 NODE = 1, NEQNS NQSIZE = QSIZE(NODE) IF ( NQSIZE .LE. 0 ) PERM(NODE) = INVP(NODE) IF ( NQSIZE .GT. 0 ) PERM(NODE) = - INVP(NODE) 100 CONTINUE C ------------------------------------------------------ C FOR EACH NODE WHICH HAS BEEN MERGED, DO THE FOLLOWING. C ------------------------------------------------------ DO 500 NODE = 1, NEQNS IF ( PERM(NODE) .GT. 0 ) GO TO 500 C ----------------------------------------- C TRACE THE MERGED TREE UNTIL ONE WHICH HAS C NOT BEEN MERGED, CALL IT ROOT. C ----------------------------------------- FATHER = NODE 200 CONTINUE IF ( PERM(FATHER) .GT. 0 ) GO TO 300 FATHER = - PERM(FATHER) GO TO 200 300 CONTINUE C ----------------------- C NUMBER NODE AFTER ROOT. C ----------------------- ROOT = FATHER NUM = PERM(ROOT) + 1 INVP(NODE) = - NUM PERM(ROOT) = NUM C ------------------------ C SHORTEN THE MERGED TREE. C ------------------------ FATHER = NODE 400 CONTINUE NEXTF = - PERM(FATHER) IF ( NEXTF .LE. 0 ) GO TO 500 PERM(FATHER) = - ROOT FATHER = NEXTF GO TO 400 500 CONTINUE C ---------------------- C READY TO COMPUTE PERM. C ---------------------- DO 600 NODE = 1, NEQNS NUM = - INVP(NODE) INVP(NODE) = NUM PERM(NUM) = NODE 600 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDUPD C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C***** MMDUPD ..... MULTIPLE MINIMUM DEGREE UPDATE ************* C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE UPDATES THE DEGREES OF NODES C AFTER A MULTIPLE ELIMINATION STEP. C C INPUT PARAMETERS - C EHEAD - THE BEGINNING OF THE LIST OF ELIMINATED C NODES (I.E., NEWLY FORMED ELEMENTS). C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - ADJACENCY STRUCTURE. C DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. C MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) C INTEGER. C C UPDATED PARAMETERS - C MDEG - NEW MINIMUM DEGREE AFTER DEGREE UPDATE. C (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. C QSIZE - SIZE OF SUPERNODE. C LLIST - WORKING LINKED LIST. C MARKER - MARKER VECTOR FOR DEGREE UPDATE. C TAG - TAG VALUE. C C*********************************************************************** C SUBROUTINE MMDUPD ( EHEAD, NEQNS, XADJ, ADJNCY, DELTA, 1 MDEG, DHEAD, DFORW, DBAKW, QSIZE, 1 LLIST, MARKER, MAXINT, TAG ) C C*********************************************************************** C INTEGER ADJNCY(*), DBAKW(*) , DFORW(*) , DHEAD(*) , 1 LLIST(*) , MARKER(*), QSIZE(*) INTEGER XADJ(*) INTEGER DEG , DEG0 , DELTA , EHEAD , ELMNT , 1 ENODE , FNODE , I , IQ2 , ISTOP , 1 ISTRT , J , JSTOP , JSTRT , LINK , 1 MAXINT, MDEG , MDEG0 , MTAG , NABOR , 1 NEQNS , NODE , Q2HEAD, QXHEAD, TAG C C*********************************************************************** C MDEG0 = MDEG + DELTA ELMNT = EHEAD 100 CONTINUE C ------------------------------------------------------- C FOR EACH OF THE NEWLY FORMED ELEMENT, DO THE FOLLOWING. C (RESET TAG VALUE IF NECESSARY.) C ------------------------------------------------------- IF ( ELMNT .LE. 0 ) RETURN MTAG = TAG + MDEG0 IF ( MTAG .LT. MAXINT ) GO TO 300 TAG = 1 DO 200 I = 1, NEQNS IF ( MARKER(I) .LT. MAXINT ) MARKER(I) = 0 200 CONTINUE MTAG = TAG + MDEG0 300 CONTINUE C --------------------------------------------- C CREATE TWO LINKED LISTS FROM NODES ASSOCIATED C WITH ELMNT: ONE WITH TWO NABORS (Q2HEAD) IN C ADJACENCY STRUCTURE, AND THE OTHER WITH MORE C THAN TWO NABORS (QXHEAD). ALSO COMPUTE DEG0, C NUMBER OF NODES IN THIS ELEMENT. C --------------------------------------------- Q2HEAD = 0 QXHEAD = 0 DEG0 = 0 LINK = ELMNT 400 CONTINUE ISTRT = XADJ(LINK) ISTOP = XADJ(LINK+1) - 1 DO 700 I = ISTRT, ISTOP ENODE = ADJNCY(I) LINK = - ENODE IF ( ENODE ) 400, 800, 500 C 500 CONTINUE IF ( QSIZE(ENODE) .EQ. 0 ) GO TO 700 DEG0 = DEG0 + QSIZE(ENODE) MARKER(ENODE) = MTAG C ---------------------------------- C IF ENODE REQUIRES A DEGREE UPDATE, C THEN DO THE FOLLOWING. C ---------------------------------- IF ( DBAKW(ENODE) .NE. 0 ) GO TO 700 C --------------------------------------- C PLACE EITHER IN QXHEAD OR Q2HEAD LISTS. C --------------------------------------- IF ( DFORW(ENODE) .EQ. 2 ) GO TO 600 LLIST(ENODE) = QXHEAD QXHEAD = ENODE GO TO 700 600 CONTINUE LLIST(ENODE) = Q2HEAD Q2HEAD = ENODE 700 CONTINUE 800 CONTINUE C -------------------------------------------- C FOR EACH ENODE IN Q2 LIST, DO THE FOLLOWING. C -------------------------------------------- ENODE = Q2HEAD IQ2 = 1 900 CONTINUE IF ( ENODE .LE. 0 ) GO TO 1500 IF ( DBAKW(ENODE) .NE. 0 ) GO TO 2200 TAG = TAG + 1 DEG = DEG0 C ------------------------------------------ C IDENTIFY THE OTHER ADJACENT ELEMENT NABOR. C ------------------------------------------ ISTRT = XADJ(ENODE) NABOR = ADJNCY(ISTRT) IF ( NABOR .EQ. ELMNT ) NABOR = ADJNCY(ISTRT+1) C ------------------------------------------------ C IF NABOR IS UNELIMINATED, INCREASE DEGREE COUNT. C ------------------------------------------------ LINK = NABOR IF ( DFORW(NABOR) .LT. 0 ) GO TO 1000 DEG = DEG + QSIZE(NABOR) GO TO 2100 1000 CONTINUE C -------------------------------------------- C OTHERWISE, FOR EACH NODE IN THE 2ND ELEMENT, C DO THE FOLLOWING. C -------------------------------------------- ISTRT = XADJ(LINK) ISTOP = XADJ(LINK+1) - 1 DO 1400 I = ISTRT, ISTOP NODE = ADJNCY(I) LINK = - NODE IF ( NODE .EQ. ENODE ) GO TO 1400 IF ( NODE ) 1000, 2100, 1100 C 1100 CONTINUE IF ( QSIZE(NODE) .EQ. 0 ) GO TO 1400 IF ( MARKER(NODE) .GE. TAG ) GO TO 1200 C ------------------------------------- C CASE WHEN NODE IS NOT YET CONSIDERED. C ------------------------------------- MARKER(NODE) = TAG DEG = DEG + QSIZE(NODE) GO TO 1400 1200 CONTINUE C ---------------------------------------- C CASE WHEN NODE IS INDISTINGUISHABLE FROM C ENODE. MERGE THEM INTO A NEW SUPERNODE. C ---------------------------------------- IF ( DBAKW(NODE) .NE. 0 ) GO TO 1400 IF ( DFORW(NODE) .NE. 2 ) GO TO 1300 QSIZE(ENODE) = QSIZE(ENODE) + 1 QSIZE(NODE) QSIZE(NODE) = 0 MARKER(NODE) = MAXINT DFORW(NODE) = - ENODE DBAKW(NODE) = - MAXINT GO TO 1400 1300 CONTINUE C -------------------------------------- C CASE WHEN NODE IS OUTMATCHED BY ENODE. C -------------------------------------- IF ( DBAKW(NODE) .EQ.0 ) 1 DBAKW(NODE) = - MAXINT 1400 CONTINUE GO TO 2100 1500 CONTINUE C ------------------------------------------------ C FOR EACH ENODE IN THE QX LIST, DO THE FOLLOWING. C ------------------------------------------------ ENODE = QXHEAD IQ2 = 0 1600 CONTINUE IF ( ENODE .LE. 0 ) GO TO 2300 IF ( DBAKW(ENODE) .NE. 0 ) GO TO 2200 TAG = TAG + 1 DEG = DEG0 C --------------------------------- C FOR EACH UNMARKED NABOR OF ENODE, C DO THE FOLLOWING. C --------------------------------- ISTRT = XADJ(ENODE) ISTOP = XADJ(ENODE+1) - 1 DO 2000 I = ISTRT, ISTOP NABOR = ADJNCY(I) IF ( NABOR .EQ. 0 ) GO TO 2100 IF ( MARKER(NABOR) .GE. TAG ) GO TO 2000 MARKER(NABOR) = TAG LINK = NABOR C ------------------------------ C IF UNELIMINATED, INCLUDE IT IN C DEG COUNT. C ------------------------------ IF ( DFORW(NABOR) .LT. 0 ) GO TO 1700 DEG = DEG + QSIZE(NABOR) GO TO 2000 1700 CONTINUE C ------------------------------- C IF ELIMINATED, INCLUDE UNMARKED C NODES IN THIS ELEMENT INTO THE C DEGREE COUNT. C ------------------------------- JSTRT = XADJ(LINK) JSTOP = XADJ(LINK+1) - 1 DO 1900 J = JSTRT, JSTOP NODE = ADJNCY(J) LINK = - NODE IF ( NODE ) 1700, 2000, 1800 C 1800 CONTINUE IF ( MARKER(NODE) .GE. TAG ) 1 GO TO 1900 MARKER(NODE) = TAG DEG = DEG + QSIZE(NODE) 1900 CONTINUE 2000 CONTINUE 2100 CONTINUE C ------------------------------------------- C UPDATE EXTERNAL DEGREE OF ENODE IN DEGREE C STRUCTURE, AND MDEG (MIN DEG) IF NECESSARY. C ------------------------------------------- DEG = DEG - QSIZE(ENODE) + 1 FNODE = DHEAD(DEG) DFORW(ENODE) = FNODE DBAKW(ENODE) = - DEG IF ( FNODE .GT. 0 ) DBAKW(FNODE) = ENODE DHEAD(DEG) = ENODE IF ( DEG .LT. MDEG ) MDEG = DEG 2200 CONTINUE C ---------------------------------- C GET NEXT ENODE IN CURRENT ELEMENT. C ---------------------------------- ENODE = LLIST(ENODE) IF ( IQ2 .EQ. 1 ) GO TO 900 GO TO 1600 2300 CONTINUE C ----------------------------- C GET NEXT ELEMENT IN THE LIST. C ----------------------------- TAG = MTAG ELMNT = LLIST(ELMNT) GO TO 100 C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C RF: modified mmpy8 dependence C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************** MMPY .... MATRIX-MATRIX MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - C THIS ROUTINE PERFORMS A MATRIX-MATRIX MULTIPLY, Y = Y + XA, C ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE CHOLESKY C CODES. C C INPUT PARAMETERS - C M - NUMBER OF ROWS IN X AND IN Y. C N - NUMBER OF COLUMNS IN X AND NUMBER OF ROWS C IN A. C Q - NUMBER OF COLUMNS IN A AND Y. C SPLIT(*) - BLOCK PARTITIONING OF X. C XPNT(*) - XPNT(J+1) POINTS ONE LOCATION BEYOND THE C END OF THE J-TH COLUMN OF X. XPNT IS ALSO C USED TO ACCESS THE ROWS OF A. C X(*) - CONTAINS THE COLUMNS OF X AND THE ROWS OF A. C LDY - LENGTH OF FIRST COLUMN OF Y. C C EXTERNAL ROUTINES: C MMPYN - MATRIX-MATRIX MULTIPLY, C WITH LEVEL 8 LOOP UNROLLING. C C UPDATED PARAMETERS - C Y(*) - ON OUTPUT, Y = Y + AX. C C*********************************************************************** C SUBROUTINE MMPY ( M , N , Q , SPLIT , XPNT , & X , Y , LDY ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C EXTERNAL MMPY8 INTEGER LDY , M , N , Q INTEGER SPLIT(*) , XPNT(*) DOUBLE PRECISION X(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER BLK , FSTCOL, NN C C*********************************************************************** C BLK = 1 FSTCOL = 1 100 CONTINUE IF ( FSTCOL .LE. N ) THEN NN = SPLIT(BLK) CALL MMPY8 ( M, NN, Q, XPNT(FSTCOL), X, Y, LDY ) FSTCOL = FSTCOL + NN BLK = BLK + 1 GO TO 100 ENDIF RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: May 26, 1995 C Authors: Esmond G. Ng, Barry W. Peyton, and Guodong Zhang C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************* MMPY8 .... MATRIX-MATRIX MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - C THIS ROUTINE PERFORMS A MATRIX-MATRIX MULTIPLY, Y = Y + XA, C ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE CHOLESKY C CODES. C C LOOP UNROLLING: LEVEL 8 UPDATING TWO COLUMNS AT A TIME C C INPUT PARAMETERS - C M - NUMBER OF ROWS IN X AND IN Y. C N - NUMBER OF COLUMNS IN X AND NUMBER OF ROWS C IN A. C Q - NUMBER OF COLUMNS IN A AND Y. C XPNT(*) - XPNT(J+1) POINTS ONE LOCATION BEYOND THE C END OF THE J-TH COLUMN OF X. XPNT IS ALSO C USED TO ACCESS THE ROWS OF A. C X(*) - CONTAINS THE COLUMNS OF X AND THE ROWS OF A. C LDY - LENGTH OF FIRST COLUMN OF Y. C C UPDATED PARAMETERS - C Y(*) - ON OUTPUT, Y = Y + AX. C C*********************************************************************** C SUBROUTINE MMPY8 ( M , N , Q , XPNT , X , & Y , LDY ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER LDY , M , N , Q INTEGER XPNT(*) DOUBLE PRECISION X(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER I , J , K , QQ INTEGER I1 , I2 , I3 , I4 , I5 , & I6 , I7 , I8 INTEGER IYBEG , IYBEG1, IYBEG2, LENY , MM DOUBLE PRECISION A1 , A2 , A3 , A4 , A5 , & A6 , A7 , A8 , A9 , A10 , & A11 , A12 , A13 , A14 , A15 , & A16 DOUBLE PRECISION B1 , B2 , B3 , B4 , B5 , & B6 , B7 , B8 , Y1 , Y2 C C*********************************************************************** C C ---------------------------------------------------- C COMPUTE EACH DIAGONAL ENTRY OF THE ODD COLUMNS OF Y. C ---------------------------------------------------- C MM = M QQ = MIN(M,Q) IYBEG = 1 LENY = LDY - 1 DO 200 J = 1, QQ-1 , 2 CDIR$ IVDEP DO 100 I = 1, N I1 = XPNT(I+1) - MM A1 = X(I1) Y(IYBEG) = Y(IYBEG) - A1*A1 100 CONTINUE IYBEG = IYBEG + 2*LENY + 1 LENY = LENY - 2 MM = MM - 2 200 CONTINUE C C ------------------------------------------------------- C UPDATE TWO COLUMNS OF Y AT A TIME, EXCEPT THE DIAGONAL C ELEMENT. C NOTE: THE DIAGONAL ELEMENT OF THE ODD COLUMN HAS C BEEN COMPUTED, SO WE COMPUTE THE SAME NUMBER OF C ELEMENTS FOR THE TWO COLUMNS. C ------------------------------------------------------- C MM = M IYBEG = 1 LENY = LDY - 1 C DO 3000 J = 1, QQ-1, 2 C IYBEG1 = IYBEG IYBEG2 = IYBEG + LENY C DO 400 K = 1, N-7, 8 C C ----------------------------------- C EIGHT COLUMNS UPDATING TWO COLUMNS. C ----------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM I6 = XPNT(K+6) - MM I7 = XPNT(K+7) - MM I8 = XPNT(K+8) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A6 = X(I6) A7 = X(I7) A8 = X(I8) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) A14 = X(I6+1) A15 = X(I7+1) A16 = X(I8+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 - & A6*A14 - A7*A15 - A8*A16 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 - & A14*A14 - A15*A15 - A16*A16 C DO 300 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 B6 = X(I6+I) Y2 = Y2 - B5 * A13 Y1 = Y1 - B6 * A6 B7 = X(I7+I) Y2 = Y2 - B6 * A14 Y1 = Y1 - B7 * A7 B8 = X(I8+I) Y2 = Y2 - B7 * A15 Y1 = Y1 - B8 * A8 Y(IYBEG1+I) = Y1 Y2 = Y2 - B8 * A16 Y(IYBEG2+I) = Y2 300 CONTINUE C 400 CONTINUE C C ----------------------------- C BOUNDARY CODE FOR THE K LOOP. C ----------------------------- C GO TO ( 2000, 1700, 1500, 1300, & 1100, 900, 700, 500 ), N-K+2 C 500 CONTINUE C C ----------------------------------- C SEVEN COLUMNS UPDATING TWO COLUMNS. C ----------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM I6 = XPNT(K+6) - MM I7 = XPNT(K+7) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A6 = X(I6) A7 = X(I7) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) A14 = X(I6+1) A15 = X(I7+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 - & A6*A14 - A7*A15 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 - & A14*A14 - A15*A15 C DO 600 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 B6 = X(I6+I) Y2 = Y2 - B5 * A13 Y1 = Y1 - B6 * A6 B7 = X(I7+I) Y2 = Y2 - B6 * A14 Y1 = Y1 - B7 * A7 Y(IYBEG1+I) = Y1 Y2 = Y2 - B7 * A15 Y(IYBEG2+I) = Y2 600 CONTINUE C GO TO 2000 C 700 CONTINUE C C --------------------------------- C SIX COLUMNS UPDATING TWO COLUMNS. C --------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM I6 = XPNT(K+6) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A6 = X(I6) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) A14 = X(I6+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 - & A6*A14 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 - & A14*A14 C DO 800 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 B6 = X(I6+I) Y2 = Y2 - B5 * A13 Y1 = Y1 - B6 * A6 Y(IYBEG1+I) = Y1 Y2 = Y2 - B6 * A14 Y(IYBEG2+I) = Y2 800 CONTINUE C GO TO 2000 C 900 CONTINUE C C ---------------------------------- C FIVE COLUMNS UPDATING TWO COLUMNS. C ---------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 C DO 1000 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 Y(IYBEG1+I) = Y1 Y2 = Y2 - B5 * A13 Y(IYBEG2+I) = Y2 1000 CONTINUE C GO TO 2000 C 1100 CONTINUE C C ---------------------------------- C FOUR COLUMNS UPDATING TWO COLUMNS. C ---------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 C DO 1200 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 Y(IYBEG1+I) = Y1 Y2 = Y2 - B4 * A12 Y(IYBEG2+I) = Y2 1200 CONTINUE C GO TO 2000 C 1300 CONTINUE C C ----------------------------------- C THREE COLUMNS UPDATING TWO COLUMNS. C ----------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 C DO 1400 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 Y(IYBEG1+I) = Y1 Y2 = Y2 - B3 * A11 Y(IYBEG2+I) = Y2 1400 CONTINUE C GO TO 2000 C 1500 CONTINUE C C --------------------------------- C TWO COLUMNS UPDATING TWO COLUMNS. C --------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM A1 = X(I1) A2 = X(I2) A9 = X(I1+1) A10 = X(I2+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 C DO 1600 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 Y(IYBEG1+I) = Y1 Y2 = Y2 - B2 * A10 Y(IYBEG2+I) = Y2 1600 CONTINUE C GO TO 2000 C 1700 CONTINUE C C -------------------------------- C ONE COLUMN UPDATING TWO COLUMNS. C -------------------------------- C I1 = XPNT(K+1) - MM A1 = X(I1) A9 = X(I1+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 C DO 1800 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) Y(IYBEG1+I) = Y1 Y2 = Y2 - B1 * A9 Y(IYBEG2+I) = Y2 1800 CONTINUE C GO TO 2000 C C ----------------------------------------------- C PREPARE FOR NEXT PAIR OF COLUMNS TO BE UPDATED. C ----------------------------------------------- C 2000 CONTINUE MM = MM - 2 IYBEG = IYBEG2 + LENY + 1 LENY = LENY - 2 C 3000 CONTINUE C C ----------------------------------------------------- C BOUNDARY CODE FOR J LOOP: EXECUTED WHENVER Q IS ODD. C ----------------------------------------------------- C IF ( J .EQ. QQ ) THEN CALL SMXPY8 ( MM, N, Y(IYBEG), XPNT, X ) ENDIF C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************* MMPYI .... MATRIX-MATRIX MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - C THIS ROUTINE PERFORMS A MATRIX-MATRIX MULTIPLY, Y = Y + XA, C ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE CHOLESKY C CODES. C C MATRIX X HAS ONLY 1 COLUMN. C C INPUT PARAMETERS - C M - NUMBER OF ROWS IN X AND IN Y. C Q - NUMBER OF COLUMNS IN A AND Y. C XPNT(*) - XPNT(J+1) POINTS ONE LOCATION BEYOND THE C END OF THE J-TH COLUMN OF X. XPNT IS ALSO C USED TO ACCESS THE ROWS OF A. C X(*) - CONTAINS THE COLUMNS OF X AND THE ROWS OF A. C IY(*) - IY(COL) POINTS TO THE BEGINNING OF COLUMN C RELIND(*) - RELATIVE INDICES. C C UPDATED PARAMETERS - C Y(*) - ON OUTPUT, Y = Y + AX. C C*********************************************************************** C SUBROUTINE MMPYI ( M , Q , XPNT , X , IY , & Y , RELIND ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER M , Q INTEGER IY(*) , RELIND(*) , & XPNT(*) DOUBLE PRECISION X(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER COL , I , ISUB , K , YLAST DOUBLE PRECISION A C C*********************************************************************** C DO 200 K = 1, Q COL = XPNT(K) YLAST = IY(COL+1) - 1 A = - X(K) CDIR$ IVDEP DO 100 I = K, M ISUB = XPNT(I) ISUB = YLAST - RELIND(ISUB) Y(ISUB) = Y(ISUB) + A*X(I) 100 CONTINUE 200 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**** ORDMMD ..... MULTIPLE MINIMUM EXTERNAL DEGREE ************ C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE CALLS LIU'S MULTIPLE MINIMUM DEGREE C ROUTINE. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C IWSIZ - SIZE OF INTEGER WORKING STORAGE. C C OUTPUT PARAMETERS - C PERM - THE MINIMUM DEGREE ORDERING. C INVP - THE INVERSE OF PERM. C NOFSUB - AN UPPER BOUND ON THE NUMBER OF NONZERO C SUBSCRIPTS FOR THE COMPRESSED STORAGE SCHEME. C IFLAG - ERROR FLAG. C 0: SUCCESSFUL ORDERING C -1: INSUFFICIENT WORKING STORAGE C [IWORK(*)]. C C WORKING PARAMETERS - C IWORK - INTEGER WORKSPACE OF LENGTH 4*NEQNS. C C*********************************************************************** C SUBROUTINE ORDMMD ( NEQNS , XADJ , ADJNCY, INVP , PERM , 1 IWSIZ , IWORK , NOFSUB, IFLAG ) C C*********************************************************************** C INTEGER ADJNCY(*), INVP(*) , IWORK(*) , PERM(*) INTEGER XADJ(*) INTEGER DELTA , IFLAG , IWSIZ , MAXINT, NEQNS , & NOFSUB C C********************************************************************* C IFLAG = 0 IF ( IWSIZ .LT. 4*NEQNS ) THEN IFLAG = -1 RETURN ENDIF C C DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. C MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) INTEGER C (ANY SMALLER ESTIMATE WILL DO) FOR MARKING C NODES. C DELTA = 0 MAXINT = 32767 CALL GENMMD ( NEQNS , XADJ , ADJNCY, INVP , PERM , 1 DELTA , 1 IWORK(1) , 1 IWORK(NEQNS+1) , 1 IWORK(2*NEQNS+1) , 1 IWORK(3*NEQNS+1) , 1 MAXINT, NOFSUB ) RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.3 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratoy C C*********************************************************************** C*********************************************************************** C****** PCHOL .... DENSE PARTIAL CHOLESKY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS CHOLESKY C FACTORIZATION ON THE COLUMNS OF A SUPERNODE C THAT HAVE RECEIVED ALL UPDATES FROM COLUMNS C EXTERNAL TO THE SUPERNODE. C C INPUT PARAMETERS - C M - NUMBER OF ROWS (LENGTH OF THE FIRST COLUMN). C N - NUMBER OF COLUMNS IN THE SUPERNODE. C XPNT - XPNT(J+1) POINTS ONE LOCATION BEYOND THE END C OF THE J-TH COLUMN OF THE SUPERNODE. C X(*) - CONTAINS THE COLUMNS OF OF THE SUPERNODE TO C BE FACTORED. C C EXTERNAL ROUTINE: C SMXPY8 - MATRIX-VECTOR MULTIPLY WITH 8 LOOP UNROLLING. C C OUTPUT PARAMETERS - C X(*) - ON OUTPUT, CONTAINS THE FACTORED COLUMNS OF C THE SUPERNODE. C C*********************************************************************** C SUBROUTINE PCHOL ( M, N, XPNT, X, MXDIAG, NTINY ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C EXTERNAL SMXPY8 C INTEGER M, N, IFLAG C INTEGER XPNT(*) C CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC DOUBLE PRECISION X(*), MXDIAG INTEGER NTINY C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER JPNT , JCOL , MM C DOUBLE PRECISION DIAG C C*********************************************************************** C C ------------------------------------------ C FOR EVERY COLUMN JCOL IN THE SUPERNODE ... C ------------------------------------------ MM = M JPNT = XPNT(1) DO 100 JCOL = 1, N C C ---------------------------------- C UPDATE JCOL WITH PREVIOUS COLUMNS. C ---------------------------------- IF ( JCOL .GT. 1 ) THEN CALL SMXPY8 ( MM, JCOL-1, X(JPNT), XPNT, X ) ENDIF C C --------------------------- C COMPUTE THE DIAGONAL ENTRY. C --------------------------- DIAG = X(JPNT) CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC IF (DIAG .LE. 1.0D-30*MXDIAG) THEN DIAG = 1.0D+128 NTINY = NTINY+1 ENDIF CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC DIAG = SQRT ( DIAG ) X(JPNT) = DIAG DIAG = 1.0D+00 / DIAG C C ---------------------------------------------------- C SCALE COLUMN JCOL WITH RECIPROCAL OF DIAGONAL ENTRY. C ---------------------------------------------------- MM = MM - 1 JPNT = JPNT + 1 CALL DSCAL1 ( MM, DIAG, X(JPNT) ) JPNT = JPNT + MM C 100 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: January 12, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************** SFINIT ..... SET UP FOR SYMB. FACT. ************ C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE COMPUTES THE STORAGE REQUIREMENTS AND SETS UP C PRELIMINARY DATA STRUCTURES FOR THE SYMBOLIC FACTORIZATION. C C NOTE: C THIS VERSION PRODUCES THE MAXIMAL SUPERNODE PARTITION (I.E., C THE ONE WITH THE FEWEST POSSIBLE SUPERNODES). C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C NNZA - LENGTH OF ADJACENCY STRUCTURE. C XADJ(*) - ARRAY OF LENGTH NEQNS+1, CONTAINING POINTERS C TO THE ADJACENCY STRUCTURE. C ADJNCY(*) - ARRAY OF LENGTH XADJ(NEQNS+1)-1, CONTAINING C THE ADJACENCY STRUCTURE. C PERM(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C POSTORDERING. C INVP(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C INVERSE OF THE POSTORDERING. C IWSIZ - SIZE OF INTEGER WORKING STORAGE. C C OUTPUT PARAMETERS: C COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH COLUMN OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C NNZL - NUMBER OF NONZEROS IN THE FACTOR, INCLUDING C THE DIAGONAL ENTRIES. C NSUB - NUMBER OF SUBSCRIPTS. C NSUPER - NUMBER OF SUPERNODES (<= NEQNS). C SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C XSUPER(*) - ARRAY OF LENGTH NEQNS+1, CONTAINING THE C SUPERNODE PARTITIONING. C IFLAG(*) - ERROR FLAG. C 0: SUCCESSFUL SF INITIALIZATION. C -1: INSUFFICENT WORKING STORAGE C [IWORK(*)]. C C WORK PARAMETERS: C IWORK(*) - INTEGER WORK ARRAY OF LENGTH 7*NEQNS+3. C C FIRST CREATED ON NOVEMEBER 14, 1994. C LAST UPDATED ON January 12, 1995. C C*********************************************************************** C SUBROUTINE SFINIT ( NEQNS , NNZA , XADJ , ADJNCY, PERM , & INVP , COLCNT, NNZL , NSUB , NSUPER, & SNODE , XSUPER, IWSIZ , IWORK , IFLAG ) C C ----------- C PARAMETERS. C ----------- INTEGER IFLAG , IWSIZ , NNZA , NEQNS , NNZL , & NSUB , NSUPER INTEGER ADJNCY(NNZA) , COLCNT(NEQNS) , & INVP(NEQNS) , IWORK(7*NEQNS+3), & PERM(NEQNS) , SNODE(NEQNS) , & XADJ(NEQNS+1) , XSUPER(NEQNS+1) C C*********************************************************************** C C -------------------------------------------------------- C RETURN IF THERE IS INSUFFICIENT INTEGER WORKING STORAGE. C -------------------------------------------------------- IFLAG = 0 IF ( IWSIZ .LT. 7*NEQNS+3 ) THEN IFLAG = -1 RETURN ENDIF C C ------------------------------------------ C COMPUTE ELIMINATION TREE AND POSTORDERING. C ------------------------------------------ CALL ETORDR ( NEQNS , XADJ , ADJNCY, PERM , INVP , & IWORK(1) , & IWORK(NEQNS+1) , & IWORK(2*NEQNS+1) , & IWORK(3*NEQNS+1) ) C C --------------------------------------------- C COMPUTE ROW AND COLUMN FACTOR NONZERO COUNTS. C --------------------------------------------- CALL FCNTHN ( NEQNS , NNZA , XADJ , ADJNCY, PERM , & INVP , IWORK(1) , SNODE , COLCNT, & NNZL , & IWORK(NEQNS+1) , & IWORK(2*NEQNS+1) , & XSUPER , & IWORK(3*NEQNS+1) , & IWORK(4*NEQNS+2) , & IWORK(5*NEQNS+3) , & IWORK(6*NEQNS+4) ) C C --------------------------------------------------------- C REARRANGE CHILDREN SO THAT THE LAST CHILD HAS THE MAXIMUM C NUMBER OF NONZEROS IN ITS COLUMN OF L. C --------------------------------------------------------- CALL CHORDR ( NEQNS , PERM , INVP , & COLCNT, & IWORK(1) , & IWORK(NEQNS+1) , & IWORK(2*NEQNS+1) , & IWORK(3*NEQNS+1) ) C C ---------------- C FIND SUPERNODES. C ---------------- CALL FSUP1 ( NEQNS , IWORK(1) , COLCNT, NSUB , & NSUPER, SNODE ) CALL FSUP2 ( NEQNS , NSUPER, SNODE, XSUPER ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** SMXPY8 .... MATRIX-VECTOR MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS A MATRIX-VECTOR MULTIPLY, C Y = Y + AX, ASSUMING DATA STRUCTURES USED IN C RECENTLY DEVELOPED SPARSE CHOLESKY CODES. THE C '8' SIGNIFIES LEVEL 8 LOOP UNROLLING. C C INPUT PARAMETERS - C M - NUMBER OF ROWS. C N - NUMBER OF COLUMNS. C Y - M-VECTOR TO WHICH AX WILL BE ADDED. C APNT - INDEX VECTOR FOR A. APNT(I) POINTS TO THE C FIRST NONZERO IN COLUMN I OF A. C Y - ON OUTPUT, CONTAINS Y = Y + AX. C C*********************************************************************** C SUBROUTINE SMXPY8 ( M, N, Y, APNT, A ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER M, N, LEVEL C INTEGER APNT(*) C DOUBLE PRECISION Y(*), A(*) C PARAMETER ( LEVEL = 8 ) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, & J, REMAIN C DOUBLE PRECISION A1, A2, A3, A4, A5, A6, A7, A8 C C*********************************************************************** C REMAIN = MOD ( N, LEVEL ) C GO TO ( 2000, 100, 200, 300, & 400, 500, 600, 700 ), REMAIN+1 C 100 CONTINUE I1 = APNT(1+1) - M A1 = - A(I1) DO 150 I = 1, M Y(I) = Y(I) + A1*A(I1) I1 = I1 + 1 150 CONTINUE GO TO 2000 C 200 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M A1 = - A(I1) A2 = - A(I2) DO 250 I = 1, M Y(I) = ( (Y(I)) & + A1*A(I1)) + A2*A(I2) I1 = I1 + 1 I2 = I2 + 1 250 CONTINUE GO TO 2000 C 300 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) DO 350 I = 1, M Y(I) = (( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 350 CONTINUE GO TO 2000 C 400 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) DO 450 I = 1, M Y(I) = ((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 450 CONTINUE GO TO 2000 C 500 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M I5 = APNT(1+5) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) DO 550 I = 1, M Y(I) = (((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 550 CONTINUE GO TO 2000 C 600 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M I5 = APNT(1+5) - M I6 = APNT(1+6) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) A6 = - A(I6) DO 650 I = 1, M Y(I) = ((((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5)) + A6*A(I6) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 I6 = I6 + 1 650 CONTINUE GO TO 2000 C 700 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M I5 = APNT(1+5) - M I6 = APNT(1+6) - M I7 = APNT(1+7) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) A6 = - A(I6) A7 = - A(I7) DO 750 I = 1, M Y(I) = (((((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5)) + A6*A(I6)) & + A7*A(I7) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 I6 = I6 + 1 I7 = I7 + 1 750 CONTINUE GO TO 2000 C 2000 CONTINUE DO 4000 J = REMAIN+1, N, LEVEL I1 = APNT(J+1) - M I2 = APNT(J+2) - M I3 = APNT(J+3) - M I4 = APNT(J+4) - M I5 = APNT(J+5) - M I6 = APNT(J+6) - M I7 = APNT(J+7) - M I8 = APNT(J+8) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) A6 = - A(I6) A7 = - A(I7) A8 = - A(I8) DO 3000 I = 1, M Y(I) = ((((((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5)) + A6*A(I6)) & + A7*A(I7)) + A8*A(I8) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 I6 = I6 + 1 I7 = I7 + 1 I8 = I8 + 1 3000 CONTINUE 4000 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: February 13, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************* SYMFC2 ..... SYMBOLIC FACTORIZATION ************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS ROUTINE PERFORMS SUPERNODAL SYMBOLIC FACTORIZATION ON A C REORDERED LINEAR SYSTEM. IT ASSUMES ACCESS TO THE COLUMNS C COUNTS, SUPERNODE PARTITION, AND SUPERNODAL ELIMINATION TREE C ASSOCIATED WITH THE FACTOR MATRIX L. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS C (I) ADJLEN - LENGTH OF THE ADJACENCY LIST. C (I) XADJ(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING POINTERS C TO THE ADJACENCY STRUCTURE. C (I) ADJNCY(*) - ARRAY OF LENGTH XADJ(NEQNS+1)-1 CONTAINING C THE ADJACENCY STRUCTURE. C (I) PERM(*) - ARRAY OF LENGTH NEQNS CONTAINING THE C POSTORDERING. C (I) INVP(*) - ARRAY OF LENGTH NEQNS CONTAINING THE C INVERSE OF THE POSTORDERING. C (I) COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH COLUMN OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C (I) NSUPER - NUMBER OF SUPERNODES. C (I) XSUPER(*) - ARRAY OF LENGTH NSUPER+1, CONTAINING THE C FIRST COLUMN OF EACH SUPERNODE. C (I) SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C (I) NOFSUB - NUMBER OF SUBSCRIPTS TO BE STORED IN C LINDX(*). C C OUTPUT PARAMETERS: C (I) XLINDX - ARRAY OF LENGTH NEQNS+1, CONTAINING POINTERS C INTO THE SUBSCRIPT VECTOR. C (I) LINDX - ARRAY OF LENGTH MAXSUB, CONTAINING THE C COMPRESSED SUBSCRIPTS. C (I) XLNZ - COLUMN POINTERS FOR L. C (I) FLAG - ERROR FLAG: C 0 - NO ERROR. C 1 - INCONSISTANCY IN THE INPUT. C C WORKING PARAMETERS: C (I) MRGLNK - ARRAY OF LENGTH NSUPER, CONTAINING THE C CHILDREN OF EACH SUPERNODE AS A LINKED LIST. C (I) RCHLNK - ARRAY OF LENGTH NEQNS+1, CONTAINING THE C CURRENT LINKED LIST OF MERGED INDICES (THE C "REACH" SET). C (I) MARKER - ARRAY OF LENGTH NEQNS USED TO MARK INDICES C AS THEY ARE INTRODUCED INTO EACH SUPERNODE'S C INDEX SET. C C*********************************************************************** C SUBROUTINE SYMFC2 ( NEQNS , ADJLEN, XADJ , ADJNCY, PERM , & INVP , COLCNT, NSUPER, XSUPER, SNODE , & NOFSUB, XLINDX, LINDX , XLNZ , MRGLNK, & RCHLNK, MARKER, FLAG ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER ADJLEN, FLAG , NEQNS , NOFSUB, NSUPER INTEGER ADJNCY(ADJLEN), COLCNT(NEQNS) , & INVP(NEQNS) , MARKER(NEQNS) , & MRGLNK(NSUPER), LINDX(NOFSUB) , & PERM(NEQNS) , RCHLNK(0:NEQNS), & SNODE(NEQNS) , XSUPER(NSUPER+1) INTEGER XADJ(NEQNS+1) , XLINDX(NSUPER+1), & XLNZ(NEQNS+1) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER FSTCOL, HEAD , I , JNZBEG, JNZEND, & JPTR , JSUP , JWIDTH, KNZ , KNZBEG, & KNZEND, KPTR , KSUP , LENGTH, LSTCOL, & NEWI , NEXTI , NODE , NZBEG , NZEND , & PCOL , PSUP , POINT , TAIL , WIDTH C C*********************************************************************** C FLAG = 0 IF ( NEQNS .LE. 0 ) RETURN C C --------------------------------------------------- C INITIALIZATIONS ... C NZEND : POINTS TO THE LAST USED SLOT IN LINDX. C TAIL : END OF LIST INDICATOR C (IN RCHLNK(*), NOT MRGLNK(*)). C MRGLNK : CREATE EMPTY LISTS. C MARKER : "UNMARK" THE INDICES. C --------------------------------------------------- NZEND = 0 HEAD = 0 TAIL = NEQNS + 1 POINT = 1 DO 50 I = 1, NEQNS MARKER(I) = 0 XLNZ(I) = POINT POINT = POINT + COLCNT(I) 50 CONTINUE XLNZ(NEQNS+1) = POINT POINT = 1 DO 100 KSUP = 1, NSUPER MRGLNK(KSUP) = 0 FSTCOL = XSUPER(KSUP) XLINDX(KSUP) = POINT POINT = POINT + COLCNT(FSTCOL) 100 CONTINUE XLINDX(NSUPER+1) = POINT C C --------------------------- C FOR EACH SUPERNODE KSUP ... C --------------------------- DO 1000 KSUP = 1, NSUPER C C --------------------------------------------------------- C INITIALIZATIONS ... C FSTCOL : FIRST COLUMN OF SUPERNODE KSUP. C LSTCOL : LAST COLUMN OF SUPERNODE KSUP. C KNZ : WILL COUNT THE NONZEROS OF L IN COLUMN KCOL. C RCHLNK : INITIALIZE EMPTY INDEX LIST FOR KCOL. C --------------------------------------------------------- FSTCOL = XSUPER(KSUP) LSTCOL = XSUPER(KSUP+1) - 1 WIDTH = LSTCOL - FSTCOL + 1 LENGTH = COLCNT(FSTCOL) KNZ = 0 RCHLNK(HEAD) = TAIL JSUP = MRGLNK(KSUP) C C ------------------------------------------------- C IF KSUP HAS CHILDREN IN THE SUPERNODAL E-TREE ... C ------------------------------------------------- IF ( JSUP .GT. 0 ) THEN C --------------------------------------------- C COPY THE INDICES OF THE FIRST CHILD JSUP INTO C THE LINKED LIST, AND MARK EACH WITH THE VALUE C KSUP. C --------------------------------------------- JWIDTH = XSUPER(JSUP+1) - XSUPER(JSUP) JNZBEG = XLINDX(JSUP) + JWIDTH JNZEND = XLINDX(JSUP+1) - 1 DO 200 JPTR = JNZEND, JNZBEG, -1 NEWI = LINDX(JPTR) KNZ = KNZ+1 MARKER(NEWI) = KSUP RCHLNK(NEWI) = RCHLNK(HEAD) RCHLNK(HEAD) = NEWI 200 CONTINUE C ------------------------------------------ C FOR EACH SUBSEQUENT CHILD JSUP OF KSUP ... C ------------------------------------------ JSUP = MRGLNK(JSUP) 300 CONTINUE IF ( JSUP .NE. 0 .AND. KNZ .LT. LENGTH ) THEN C ---------------------------------------- C MERGE THE INDICES OF JSUP INTO THE LIST, C AND MARK NEW INDICES WITH VALUE KSUP. C ---------------------------------------- JWIDTH = XSUPER(JSUP+1) - XSUPER(JSUP) JNZBEG = XLINDX(JSUP) + JWIDTH JNZEND = XLINDX(JSUP+1) - 1 NEXTI = HEAD DO 500 JPTR = JNZBEG, JNZEND NEWI = LINDX(JPTR) 400 CONTINUE I = NEXTI NEXTI = RCHLNK(I) IF ( NEWI .GT. NEXTI ) GO TO 400 IF ( NEWI .LT. NEXTI ) THEN KNZ = KNZ+1 RCHLNK(I) = NEWI RCHLNK(NEWI) = NEXTI MARKER(NEWI) = KSUP NEXTI = NEWI ENDIF 500 CONTINUE JSUP = MRGLNK(JSUP) GO TO 300 ENDIF ENDIF C --------------------------------------------------- C STRUCTURE OF A(*,FSTCOL) HAS NOT BEEN EXAMINED YET. C "SORT" ITS STRUCTURE INTO THE LINKED LIST, C INSERTING ONLY THOSE INDICES NOT ALREADY IN THE C LIST. C --------------------------------------------------- IF ( KNZ .LT. LENGTH ) THEN NODE = PERM(FSTCOL) KNZBEG = XADJ(NODE) KNZEND = XADJ(NODE+1) - 1 DO 700 KPTR = KNZBEG, KNZEND NEWI = ADJNCY(KPTR) NEWI = INVP(NEWI) IF ( NEWI .GT. FSTCOL .AND. & MARKER(NEWI) .NE. KSUP ) THEN C -------------------------------- C POSITION AND INSERT NEWI IN LIST C AND MARK IT WITH KCOL. C -------------------------------- NEXTI = HEAD 600 CONTINUE I = NEXTI NEXTI = RCHLNK(I) IF ( NEWI .GT. NEXTI ) GO TO 600 KNZ = KNZ + 1 RCHLNK(I) = NEWI RCHLNK(NEWI) = NEXTI MARKER(NEWI) = KSUP ENDIF 700 CONTINUE ENDIF C ------------------------------------------------------------ C IF KSUP HAS NO CHILDREN, INSERT FSTCOL INTO THE LINKED LIST. C ------------------------------------------------------------ IF ( RCHLNK(HEAD) .NE. FSTCOL ) THEN RCHLNK(FSTCOL) = RCHLNK(HEAD) RCHLNK(HEAD) = FSTCOL KNZ = KNZ + 1 ENDIF C C -------------------------------------------- C COPY INDICES FROM LINKED LIST INTO LINDX(*). C -------------------------------------------- NZBEG = NZEND + 1 NZEND = NZEND + KNZ IF ( NZEND+1 .NE. XLINDX(KSUP+1) ) GO TO 8000 I = HEAD DO 800 KPTR = NZBEG, NZEND I = RCHLNK(I) LINDX(KPTR) = I 800 CONTINUE C C --------------------------------------------------- C IF KSUP HAS A PARENT, INSERT KSUP INTO ITS PARENT'S C "MERGE" LIST. C --------------------------------------------------- IF ( LENGTH .GT. WIDTH ) THEN PCOL = LINDX ( XLINDX(KSUP) + WIDTH ) PSUP = SNODE(PCOL) MRGLNK(KSUP) = MRGLNK(PSUP) MRGLNK(PSUP) = KSUP ENDIF C 1000 CONTINUE C RETURN C C ----------------------------------------------- C INCONSISTENCY IN DATA STRUCTURE WAS DISCOVERED. C ----------------------------------------------- 8000 CONTINUE FLAG = -2 RETURN C END subroutine genrcm ( node_num, adj_num, adj_row, adj, perm ) !*****************************************************************************80 ! !! GENRCM finds the reverse Cuthill-Mckee ordering for a general graph. ! ! Discussion: ! ! For each connected component in the graph, the routine obtains ! an ordering by calling RCM. ! ! Modified: ! ! 04 January 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer NODE_NUM, the number of nodes. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Output, integer PERM(NODE_NUM), the RCM ordering. ! ! Local Parameters: ! ! Local, integer LEVEL_ROW(NODE_NUM+1), the index vector for a level ! structure. The level structure is stored in the currently unused ! spaces in the permutation vector PERM. ! ! Local, integer MASK(NODE_NUM), marks variables that have been numbered. ! implicit none integer adj_num,node_num integer adj(adj_num) integer adj_row(node_num+1) integer i integer iccsze integer mask(node_num) integer level_num integer level_row(node_num+1) integer num integer perm(node_num) integer root do i=1,node_num mask(i) = 1 enddo num = 1 do i = 1, node_num ! ! For each masked connected component... ! if ( mask(i).ne. 0 ) then root = i ! ! Find a pseudo-peripheral node ROOT. The level structure found by ! ROOT_FIND is stored starting at PERM(NUM). ! call root_find ( root, adj_num, adj_row, adj, mask, & level_num, level_row, perm(num), node_num ) ! ! RCM orders the component using ROOT as the starting node. ! call rcm ( root, adj_num, adj_row, adj, mask, perm(num), & iccsze, node_num ) num = num + iccsze ! ! We can stop once every node is in one of the connected components. ! if ( node_num .lt. num ) then return endif endif enddo return end subroutine rcm ( root, adj_num, adj_row, adj, mask, perm, iccsze, & node_num ) !*****************************************************************************80 ! !! RCM renumbers a connected component by the reverse Cuthill McKee algorithm. ! ! Discussion: ! ! The connected component is specified by a node ROOT and a mask. ! The numbering starts at the root node. ! ! An outline of the algorithm is as follows: ! ! X(1) = ROOT. ! ! for ( I = 1 to N-1) ! Find all unlabeled neighbors of X(I), ! assign them the next available labels, in order of increasing degree. ! ! When done, reverse the ordering. ! ! Modified: ! ! 02 January 2007 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer ROOT, the node that defines the connected component. ! It is used as the starting point for the RCM ordering. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input/output, integer MASK(NODE_NUM), a mask for the nodes. Only ! those nodes with nonzero input mask values are considered by the ! routine. The nodes numbered by RCM will have their mask values ! set to zero. ! ! Output, integer PERM(NODE_NUM), the RCM ordering. ! ! Output, integer ICCSZE, the size of the connected component ! that has been numbered. ! ! Input, integer NODE_NUM, the number of nodes. ! ! Local Parameters: ! ! Workspace, integer DEG(NODE_NUM), a temporary vector used to hold ! the degree of the nodes in the section graph specified by mask and root. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer deg(node_num) integer fnbr integer i integer iccsze integer j integer jstop integer jstrt integer k integer l integer lbegin integer lnbr integer lperm integer lvlend integer mask(node_num) integer nbr integer node integer perm(node_num) integer root ! ! Find the degrees of the nodes in the component specified by MASK and ROOT. ! call degree ( root, adj_num, adj_row, adj, mask, deg, iccsze, & perm, node_num ) mask(root) = 0 if ( iccsze .le. 1 ) then return end if lvlend = 0 lnbr = 1 ! ! LBEGIN and LVLEND point to the beginning and ! the end of the current level respectively. ! do while ( lvlend .lt. lnbr ) lbegin = lvlend + 1 lvlend = lnbr do i = lbegin, lvlend ! ! For each node in the current level... ! node = perm(i) jstrt = adj_row(node) jstop = adj_row(node+1) - 1 ! ! Find the unnumbered neighbors of NODE. ! ! FNBR and LNBR point to the first and last neighbors ! of the current node in PERM. ! fnbr = lnbr + 1 do j = jstrt, jstop nbr = adj(j) if ( mask(nbr) .ne. 0 ) then lnbr = lnbr + 1 mask(nbr) = 0 perm(lnbr) = nbr end if end do ! ! If no neighbors, skip to next node in this level. ! cc if ( lnbr .le. fnbr ) then cc cycle cc end if if ( lnbr .gt. fnbr ) then ! ! Sort the neighbors of NODE in increasing order by degree. ! Linear insertion is used. ! k = fnbr do while ( k .lt. lnbr ) l = k k = k + 1 nbr = perm(k) do while ( fnbr .lt. l ) lperm = perm(l) if ( deg(lperm) .le. deg(nbr) ) then exit end if perm(l+1) = lperm l = l - 1 end do perm(l+1) = nbr end do end if end do end do ! ! We now have the Cuthill-McKee ordering. Reverse it. ! k=iccsze/2 l=iccsze do i=1,k lperm=perm(l) perm(l)=perm(i) perm(i)=lperm l=l-1 enddo return end subroutine root_find ( root, adj_num, adj_row, adj, mask, & level_num, level_row, level, node_num ) !*****************************************************************************80 ! !! ROOT_FIND finds a pseudo-peripheral node. ! ! Discussion: ! ! The diameter of a graph is the maximum distance (number of edges) ! between any two nodes of the graph. ! ! The eccentricity of a node is the maximum distance between that ! node and any other node of the graph. ! ! A peripheral node is a node whose eccentricity equals the ! diameter of the graph. ! ! A pseudo-peripheral node is an approximation to a peripheral node; ! it may be a peripheral node, but all we know is that we tried our ! best. ! ! The routine is given a graph, and seeks pseudo-peripheral nodes, ! using a modified version of the scheme of Gibbs, Poole and ! Stockmeyer. It determines such a node for the section subgraph ! specified by MASK and ROOT. ! ! The routine also determines the level structure associated with ! the given pseudo-peripheral node; that is, how far each node ! is from the pseudo-peripheral node. The level structure is ! returned as a list of nodes LS, and pointers to the beginning ! of the list of nodes that are at a distance of 0, 1, 2, ..., ! NODE_NUM-1 from the pseudo-peripheral node. ! ! Modified: ! ! 28 October 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Norman Gibbs, William Poole, Paul Stockmeyer, ! An Algorithm for Reducing the Bandwidth and Profile of a Sparse Matrix, ! SIAM Journal on Numerical Analysis, ! Volume 13, pages 236-250, 1976. ! ! Norman Gibbs, ! Algorithm 509: A Hybrid Profile Reduction Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 2, pages 378-387, 1976. ! ! Parameters: ! ! Input/output, integer ROOT. On input, ROOT is a node in the ! the component of the graph for which a pseudo-peripheral node is ! sought. On output, ROOT is the pseudo-peripheral node obtained. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input, integer MASK(NODE_NUM), specifies a section subgraph. Nodes ! for which MASK is zero are ignored by FNROOT. ! ! Output, integer LEVEL_NUM, is the number of levels in the level structure ! rooted at the node ROOT. ! ! Output, integer LEVEL_ROW(NODE_NUM+1), LEVEL(NODE_NUM), the ! level structure array pair containing the level structure found. ! ! Input, integer NODE_NUM, the number of nodes. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer iccsze integer j integer jstrt integer k integer kstop integer kstrt integer level(node_num) integer level_num integer level_num2 integer level_row(node_num+1) integer mask(node_num) integer mindeg integer nabor integer ndeg integer node integer root ! ! Determine the level structure rooted at ROOT. ! call level_set ( root, adj_num, adj_row, adj, mask, level_num, & level_row, level, node_num ) ! ! Count the number of nodes in this level structure. ! iccsze = level_row(level_num+1) - 1 ! ! Extreme case: ! A complete graph has a level set of only a single level. ! Every node is equally good (or bad). ! if ( level_num .eq. 1 ) then return end if ! ! Extreme case: ! A "line graph" 0--0--0--0--0 has every node in its only level. ! By chance, we've stumbled on the ideal root. ! if ( level_num .eq. iccsze ) then return end if ! ! Pick any node from the last level that has minimum degree ! as the starting point to generate a new level set. ! do mindeg = iccsze jstrt = level_row(level_num) root = level(jstrt) if ( jstrt .lt. iccsze ) then do j = jstrt, iccsze node = level(j) ndeg = 0 kstrt = adj_row(node) kstop = adj_row(node+1) - 1 do k = kstrt, kstop nabor = adj(k) if ( 0 .lt. mask(nabor) ) then ndeg = ndeg + 1 end if end do if ( ndeg .lt. mindeg ) then root = node mindeg = ndeg end if end do end if ! ! Generate the rooted level structure associated with this node. ! call level_set ( root, adj_num, adj_row, adj, mask, & level_num2, level_row, level, node_num ) ! ! If the number of levels did not increase, accept the new ROOT. ! if ( level_num2 .le. level_num ) then exit end if level_num = level_num2 ! ! In the unlikely case that ROOT is one endpoint of a line graph, ! we can exit now. ! if ( iccsze .le. level_num ) then exit end if end do return end subroutine level_set ( root, adj_num, adj_row, adj, mask, & level_num, level_row, level, node_num ) !*****************************************************************************80 ! !! LEVEL_SET generates the connected level structure rooted at a given node. ! ! Discussion: ! ! Only nodes for which MASK is nonzero will be considered. ! ! The root node chosen by the user is assigned level 1, and masked. ! All (unmasked) nodes reachable from a node in level 1 are ! assigned level 2 and masked. The process continues until there ! are no unmasked nodes adjacent to any node in the current level. ! The number of levels may vary between 2 and NODE_NUM. ! ! Modified: ! ! 28 October 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer ROOT, the node at which the level structure ! is to be rooted. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input/output, integer MASK(NODE_NUM). On input, only nodes with nonzero ! MASK are to be processed. On output, those nodes which were included ! in the level set have MASK set to 1. ! ! Output, integer LEVEL_NUM, the number of levels in the level ! structure. ROOT is in level 1. The neighbors of ROOT ! are in level 2, and so on. ! ! Output, integer LEVEL_ROW(NODE_NUM+1), LEVEL(NODE_NUM), the rooted ! level structure. ! ! Input, integer NODE_NUM, the number of nodes. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer i integer iccsze integer j integer jstop integer jstrt integer lbegin integer level_num integer level_row(node_num+1) integer level(node_num) integer lvlend integer lvsize integer mask(node_num) integer nbr integer node integer root mask(root) = 0 level(1) = root level_num = 0 lvlend = 0 iccsze = 1 ! ! LBEGIN is the pointer to the beginning of the current level, and ! LVLEND points to the end of this level. ! do lbegin = lvlend + 1 lvlend = iccsze level_num = level_num + 1 level_row(level_num) = lbegin ! ! Generate the next level by finding all the masked neighbors of nodes ! in the current level. ! do i = lbegin, lvlend node = level(i) jstrt = adj_row(node) jstop = adj_row(node+1) - 1 do j = jstrt, jstop nbr = adj(j) if ( mask(nbr) .ne. 0 ) then iccsze = iccsze + 1 level(iccsze) = nbr mask(nbr) = 0 end if end do end do ! ! Compute the current level width (the number of nodes encountered.) ! If it is positive, generate the next level. ! lvsize = iccsze - lvlend if ( lvsize .le. 0 ) then exit end if end do level_row(level_num+1) = lvlend + 1 ! ! Reset MASK to 1 for the nodes in the level structure. ! do i =1 ,iccsze mask(level(i)) = 1 enddo return end subroutine degree ( root, adj_num, adj_row, adj, mask, deg, & iccsze, ls, node_num ) !*****************************************************************************80 ! !! DEGREE computes the degrees of the nodes in the connected component. ! ! Discussion: ! ! The connected component is specified by MASK and ROOT. ! Nodes for which MASK is zero are ignored. ! ! Modified: ! ! 05 January 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer ROOT, the node that defines the connected component. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input, integer MASK(NODE_NUM), is nonzero for those nodes which are ! to be considered. ! ! Output, integer DEG(NODE_NUM), contains, for each node in the connected ! component, its degree. ! ! Output, integer ICCSIZE, the number of nodes in the connected component. ! ! Output, integer LS(NODE_NUM), stores in entries 1 through ICCSIZE the nodes ! in the connected component, starting with ROOT, and proceeding ! by levels. ! ! Input, integer NODE_NUM, the number of nodes. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer deg(node_num) integer i integer iccsze integer ideg integer j integer jstop integer jstrt integer lbegin integer ls(node_num) integer lvlend integer lvsize integer mask(node_num) integer nbr integer node integer root ! ! The sign of ADJ_ROW(I) is used to indicate if node I has been considered. ls(1) = root adj_row(root) = -adj_row(root) lvlend = 0 iccsze = 1 ! ! LBEGIN is the pointer to the beginning of the current level, and ! LVLEND points to the end of this level. do lbegin = lvlend + 1 lvlend = iccsze ! ! Find the degrees of nodes in the current level, ! and at the same time, generate the next level. do i = lbegin, lvlend node = ls(i) jstrt = -adj_row(node) jstop = abs ( adj_row(node+1) ) - 1 ideg = 0 do j = jstrt, jstop nbr = adj(j) if ( mask(nbr) .ne. 0 ) then ideg = ideg + 1 if ( 0 .le. adj_row(nbr) ) then adj_row(nbr) = -adj_row(nbr) iccsze = iccsze + 1 ls(iccsze) = nbr end if end if end do deg(node) = ideg end do ! ! Compute the current level width. lvsize = iccsze - lvlend ! ! If the current level width is nonzero, generate another level. if ( lvsize .eq. 0 ) then exit end if end do ! ! Reset ADJ_ROW to its correct sign and return. do i = 1, iccsze node = ls(i) adj_row(node) = -adj_row(node) end do return end spam/src/spamown.f0000644000176000001440000015354512403556057013710 0ustar ripleyusers subroutine amuxmat (n,m,p, x, y, a,ja,ia) implicit none integer n, m, p, ja(*), ia(*) double precision x(m,p), y(n,p), a(*) c----------------------------------------------------------------------- c Multiplies a sparse matrix by a full matrix using consecutive dot c products, cf. subroutine amux from sparse kit. c Matrix A is stored in compressed sparse row storage. c c on entry: c---------- c n = row dimension of A c p = column dimension of x c x = array of dimension mxp, m column dimension of A. c a, ja, c ia = input matrix in compressed sparse row format. c c on return: c----------- c y = array of dimension nxp, containing the product y=Ax c c Reinhard Furrer c----------------------------------------------------------------------- c local variables c double precision t integer j, i, k c----------------------------------------------------------------------- do j = 1,p do i = 1,n c c compute the inner product of row i with vector x c t = 0.0d0 do k=ia(i), ia(i+1)-1 t = t + a(k)*x(ja(k),j) enddo c y(i,j) = t enddo enddo c return c---------end-of-amuxmat------------------------------------------------ c----------------------------------------------------------------------- end c subroutine notzero (ja,ia,nrow,ncol,nnz,nz,jao,iao) c Return the structure of the zero entries in ra,ja,ia, in c compressed sparse row format via rao, jao, iao. c INPUT: c ja, ia -- sparse structure of the matrix A c nrow -- number of rows in `a' c ncol -- number of columns in `a' c nnz -- number of non-zero elements c nz -- number of zero elements c OUTPUT: c jao, iao -- sparse structure of the zero entries c WORK ARRAY: c colmn -- logical vector of length ncol implicit none integer nrow,ncol,nnz,nz,inz, & ja(nnz),ia(nrow+1),jao(nz),iao(nrow+1) logical colmn(ncol) integer i,j,k inz = 0 iao(1) = 1 do i = 1,nrow iao(i+1) = iao(i) do k = 1,ncol colmn(k) = .true. enddo do j = ia(i),ia(i+1)-1 colmn(ja(j)) = .false. enddo do k = 1,ncol if(colmn(k)) then inz = inz + 1 jao(inz) = k iao(i+1) = iao(i+1) + 1 endif enddo enddo return end subroutine setdiagmat (nrow, n, a, ja, ia, diag, iw) implicit none integer nrow, n double precision a(*), diag(n) integer ja(*), ia(nrow+1), iw(nrow) c----------------------------------------------------------------------- c Sets the diagonal entries of a sparse matrix c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c n = integer. Smallest dimension of A c c a, ja, ia = Matrix A in compressed sparse row format. Sorted. c diag = diagonal matrix stored as a vector diag(1:n) c iw = n vector of zeros. c c on return: c---------- c updated matrix A c iw = iw contains the positions of the diagonal entries in the c output matrix. (i.e., a(iw(k)), ja(iw(k)), k=1,...n, c are the values/column indices of the diagonal elements c of the output matrix. ). c c Reinhard Furrer c----------------------------------------------------------------- logical insert integer i,j, k, k1, k2, icount c c get positions of diagonal elements in data structure. c do 11 i=1,n do 21 j= ia(i),ia(i+1)-1 if (ja(j) .ge. i) then if (ja(j) .eq. i) then iw(i) = j endif goto 11 endif 21 continue 11 continue c c count number of holes in diagonal and add diag(*) elements to c valid diagonal entries. c icount = 0 do 31 i=1, n if (iw(i) .eq. 0) then icount = icount+1 else a(iw(i)) = diag(i) endif 31 continue c c if no diagonal elements to insert return c if (icount .eq. 0) return c c shift the nonzero elements if needed, to allow for created c diagonal elements. c c c copy rows backward c do 5 i=nrow, 1, -1 c c go through row ii c k1 = ia(i) k2 = ia(i+1)-1 ia(i+1) = ia(i+1)+icount if ((i .gt. n) .or. (iw(i) .gt. 0)) then c iw(ii) equal to 0, means no diagonal element in a, we need to insert it c test is thus true. c no fill-in, only copying do 4 k = k2,k1,-1 ja(k+icount)=ja(k) a(k+icount)=a(k) 4 continue iw(i)=-i else insert=.TRUE. if (k2.lt.k1) then ja(k2+icount)=i a(k2+icount)=diag(i) iw(i)=k2+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return else do 6 k = k2,k1,-1 if (ja(k).gt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) else if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif if (ja(k).lt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) endif 6 continue c in case there is only one element, larger than i, we still need to c add the diagonal element if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif endif endif 5 continue return c----------------------------------------------------------------------- c------------end-of-diagaddmat------------------------------------------ end subroutine diagaddmat (nrow, n, a, ja, ia, diag, iw) implicit none integer nrow, n double precision a(*), diag(n) integer ja(*), ia(nrow+1), iw(nrow) c----------------------------------------------------------------------- c Adds a diagonal matrix to a sparse matrix: A = Diag + A c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c n = integer. Smallest dimension of A c c a, ja, ia = Matrix A in compressed sparse row format. Sorted. c diag = diagonal matrix stored as a vector diag(1:n) c iw = n vector of zeros. c c on return: c---------- c updated matrix A c iw = iw contains the positions of the diagonal entries in the c output matrix. (i.e., a(iw(k)), ja(iw(k)), k=1,...n, c are the values/column indices of the diagonal elements c of the output matrix. ). c c Reinhard Furrer c----------------------------------------------------------------- logical insert integer i,j, k, k1, k2, icount c c get positions of diagonal elements in data structure. c do 11 i=1,n do 21 j= ia(i),ia(i+1)-1 if (ja(j) .ge. i) then if (ja(j) .eq. i) then iw(i) = j endif goto 11 endif 21 continue 11 continue c c count number of holes in diagonal and add diag(*) elements to c valid diagonal entries. c icount = 0 do 31 i=1, n if (iw(i) .eq. 0) then icount = icount+1 else a(iw(i)) = a(iw(i)) + diag(i) endif 31 continue c c if no diagonal elements to insert return c if (icount .eq. 0) return c c shift the nonzero elements if needed, to allow for created c diagonal elements. c c c copy rows backward c do 5 i=nrow, 1, -1 c c go through row ii c k1 = ia(i) k2 = ia(i+1)-1 ia(i+1) = ia(i+1)+icount if ((i .gt. n) .or. (iw(i) .gt. 0)) then c iw(ii) equal to 0, means no diagonal element in a, we need to insert it c test is thus true. c no fill-in, only copying do 4 k = k2,k1,-1 ja(k+icount)=ja(k) a(k+icount)=a(k) 4 continue iw(i)=-i else insert=.TRUE. if (k2.lt.k1) then ja(k2+icount)=i a(k2+icount)=diag(i) iw(i)=k2+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return else do 6 k = k2,k1,-1 if (ja(k).gt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) else if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif if (ja(k).lt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) endif 6 continue c in case there is only one element, larger than i, we still need to c add the diagonal element if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif endif endif 5 continue return c----------------------------------------------------------------------- c------------end-of-setdiagmat------------------------------------------ end c----------------------------------------------------------------------- subroutine diagmua (nrow, a, ia, diag) implicit none integer nrow, ia(nrow+1) double precision a(*), diag(nrow), scal c----------------------------------------------------------------------- c performs the matrix by matrix product A = Diag * A (in place) c (diamua from sparsekit provides more functionality) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c a, ia = Matrix A in compressed sparse row format. c (ja is not needed) c c diag = diagonal matrix stored as a vector diag(1:n) c c on return: c---------- c a, = resulting matrix A in compressed sparse row sparse format. c c Notes: c------- c Reinhard Furrer 2007-06-21 c c----------------------------------------------------------------- c local variables integer ii, k, k1, k2 do 1 ii=1,nrow c c normalize each row c k1 = ia(ii) k2 = ia(ii+1)-1 scal = diag(ii) do 2 k=k1, k2 a(k) = a(k)*scal 2 continue 1 continue c return c----------end-of-diagmua------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine getdiag (a,ja,ia,len,diag) implicit none double precision diag(*),a(*) integer len, ia(*), ja(*) c----------------------------------------------------------------------- c This subroutine extracts the main diagonal. c (getdia from sparsekit provides more functionality) c----------------------------------------------------------------------- c c on entry: c---------- c c len= min(nrow, ncol) = min dimension of the matrix a. c a,ja,ia = matrix stored in sorted compressed sparse row a,ja,ia,format c diag = array of zeros. c c on return: c----------- c diag = array of length containing the wanted diagonal. c c Notes: c------- c Reinhard Furrer 2006-11-02 c----------------------------------------------------------------------c c local variables integer i, k c c extract diagonal elements c do 1 i=1, len do k= ia(i),ia(i+1) -1 if (ja(k) .ge. i) then c we are at or beyond the diagonal. if (ja(k) .eq. i) then diag(i)= a(k) endif goto 1 endif enddo 1 continue return c------------end-of-getdiag---------------------------------------------- c----------------------------------------------------------------------- end c Functions that are new or modified. subroutine subsparsefull(nrow,a,ja,ia,b) c c subtracts a sparse matrix from a full one c algorithm is in-place, i.e. b is changed c c c Notes: c------- c Reinhard Furrer 2006-09-21 c----------------------------------------------------------------------- implicit none integer nrow,ja(*),ia(nrow+1) double precision a(*), b(nrow,*) integer i,k do i=1,nrow do k=ia(i),ia(i+1)-1 b(i,ja(k)) = b(i,ja(k))-a(k) enddo enddo return end subroutine subfullsparse(nrow,ncol,a,ja,ia,b) c c subtracts a full matrix from a sparse one c algorithm is in-place, i.e. b is changed c c c Notes: c------- c Reinhard Furrer 2006-09-21 c----------------------------------------------------------------------- implicit none integer nrow,ncol,ja(*),ia(nrow+1) double precision a(*), b(nrow,*) integer i,j,k do i=1,nrow do j=1,ncol b(i,j) = -b(i,j) enddo do k=ia(i),ia(i+1)-1 b(i,ja(k)) = b(i,ja(k))+a(k) enddo enddo return end subroutine addsparsefull(nrow,a,ja,ia,b) c c adds a sparse matrix to a full one c algorithm is in-place, i.e. b is changed c c c Notes: c------- c Reinhard Furrer 2006-09-21 c----------------------------------------------------------------------- implicit none integer nrow,ja(*),ia(nrow+1) double precision a(*), b(nrow,*) integer i,k do i=1,nrow do k=ia(i),ia(i+1)-1 b(i,ja(k)) = b(i,ja(k))+a(k) enddo enddo return end subroutine constructia(nrow,nir,ia,ir) c c constructs from a regular row index vector a sparse ia vector. c note that a regular column index vector corresponds to the c sparse ja vector. for example: c A[ir,jc] => A@ja = jc, A@ia = constructia(nrow,nir,ia,ir)$ia c c nrow: row dimension of A c nir: length of ir c ir: array of length nir+1!!! c c Notes: c------- c _*Row indices have to be ordered!*_ c c Reinhard Furrer 2006-09-13 c----------------------------------------------------------------------- implicit none integer nrow,nir integer ia(nrow+1),ir(*) integer i,k k=1 ia(1)=1 do i=1,nrow 5 continue if (ir(k) .eq. i) then k=k+1 if (k .le. nir) goto 5 endif ia(i+1)=k enddo ia(nrow+1)=nir+1 return end subroutine disttospam(nrow,x,a,ja,ia,eps) implicit none integer nrow, ia(nrow+1), ja(*) double precision x(*), a(*), eps c c Convertion of an R dist object (removes zero entries as well). c c On entry: c---------- c nrow -- row dimension of the matrix c x -- elements of the dist object (is lower diagonal) c n*(i-1) - i*(i-1)/2 + j-i for i < j c c a,ja,ia -- input matrix in CSR format c c On return: c----------- c a,ja,ia -- cleaned matrix c c Notes: c------- c Reinhard Furrer 2008-08-13 c----------------------------------------------------------------------- c c Local integer i,j,k, tmp ia(1) = 1 k = 1 do i = 2, nrow ia(i) = k do j=1 , i-1 tmp = nrow*(j-1)-j*(j-1)/2+i-j if (.not.(dabs(x(tmp)) .le. eps)) then ja(k) = j a(k) = x(tmp) k = k + 1 endif enddo enddo ia(nrow+1) = k return c---- end of disttospam ------------------------------------------------- c----------------------------------------------------------------------- end subroutine setdiaold (nrow,ncol,a,ja,ia,c,jc,ic,cmax,diag,eps) implicit none double precision a(*),c(*),diag(*),eps integer nrow, ncol, ia(*), ja(*), ic(*), jc(*), cmax c c this routine sets the diagonal entries of a matix, provided they c are non-zero. c c On entry: c---------- c nrow,ncol -- dimensions of the matrix c a,ja,ia -- input matrix in CSR format c c,jc,ic -- input matrix in CSR format with enough space, see below c diag -- diagonal values to set c eps -- what is smaller than zero? c c On return: c----------- c c,jc,ic -- matrix with modified diag in CSR format c c Notes: c------- c Reinhard Furrer 2006-10-30 c----------------------------------------------------------------------- c c Local double precision b(nrow) integer i,k, len, ib(nrow+1), jb(nrow) c len=0 ib(1)=1 do i=1,nrow jb(i)=0 enddo do 10 i=1,nrow do 15 k= ia(i),ia(i+1) -1 if (ja(k) .eq. i) then a(k)=diag(i) c(k)=diag(i) ib(i+1)=ib(i) goto 10 endif if (ja(k) .gt. i) then if (diag(i).gt.eps) then len=len+1 jb(len)=i ib(i+1)=ib(i)+1 b(len)=diag(i) else ib(i+1)=ib(i) endif goto 10 endif 15 continue 10 continue if (len .eq. 0) return c c set nonexisiting elements. c call subass(nrow,ncol,a,ja,ia,b,jb,ib,c,jc,ic,cmax) return c------------end of setdia---------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine subass(nrow,ncol,a,ja,ia,b,jb,ib,c,jc,ic,nzmax) implicit none integer nrow,ncol,nzmax integer ja(*),jb(*),jc(*),ia(*),ib(*),ic(*) double precision a(*), b(*), c(*) c----------------------------------------------------------------------- c replaces the elements of A with those of B for matrices in sorted CSR c format. we assume that each row is sorted with increasing column c indices. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a,ja,ia, c b,jb,ib = Matrices A and B in compressed sparse row format with column c entries sorted ascendly in each row c c nzmax = integer. The max length of the arrays c and jc. c c on return: c---------- c c,jc,ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c Notes: c------- c Reinhard Furrer 2006-09-13, based on sparsekit2 subroutine aplb1 c----------------------------------------------------------------------- c local variables integer i,j1,j2,ka,kb,kc,kamax,kbmax kc = 1 ic(1) = kc c c looping over the rows: do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue c If we have one or more entries then ka <= kamax c If we do not have any entries in both A and B c we will not enter the if clause. In which case c we repeatedly copy ic(i+1) <- ic(i). if (ka .le. kamax .or. kb .le. kbmax) then c j1 and j2 are left hand pointers of the first entry c of A and B. If no entry, they are set to ncol+1 if (ka .le. kamax) then j1 = ja(ka) else j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else j2 = ncol+1 endif c c Three cases: c j1=j2: copy element of b in c, incr. all three pointers c j1j2: copy element of b in c, incr. b and c pointers if (j1 .eq. j2) then c(kc) = b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then jc(kc) = j1 c(kc) = a(ka) ka = ka+1 kc = kc+1 else if (j1 .gt. j2) then jc(kc) = j2 c(kc) = b(kb) kb = kb+1 kc = kc+1 endif C the next four lines should not be required... if (kc .gt. nzmax+1) then c write (*,*) "exceeding array capacities...",i,nzmax, c & ka,kb,kc,j1,j2,kamax,kbmax,ncol,jb(kb) return endif goto 5 endif ic(i+1) = kc 6 continue return c------------end-of-subass---------------------------------------------- c----------------------------------------------------------------------- end subroutine spamcsrdns(nrow,a,ja,ia,dns) implicit none integer i,k integer nrow,ja(*),ia(*) double precision dns(nrow,*),a(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Dense c----------------------------------------------------------------------- c c converts a row-stored sparse matrix into a densely stored one c c On entry: c---------- c c nrow = row-dimension of a c a, c ja, c ia = input matrix in compressed sparse row format. c (a=value array, ja=column array, ia=pointer array) c dns = array where to store dense matrix c c on return: c----------- c dns = the sparse matrix a, ja, ia has been stored in dns(nrow,*) c c changes: c--------- c eliminated the ierr c eliminated the filling of zeros: all done with c----------------------------------------------------------------------- do i=1,nrow do k=ia(i),ia(i+1)-1 dns(i,ja(k)) = a(k) enddo enddo return c---- end of csrdns ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine spamdnscsr(nrow,ncol,dns,ndns,a,ja,ia,eps) implicit none integer i,j,next integer nrow,ncol,ndns,ia(*),ja(*) double precision dns(ndns,*),a(*),eps c----------------------------------------------------------------------- c Converts a densely stored matrix into a CSR sparse matrix. c----------------------------------------------------------------------- c on entry: c--------- c c nrow = row-dimension of a c ncol = column dimension of a c nzmax = maximum number of nonzero elements allowed. This c should be set to be the lengths of the arrays a and ja. c dns = input nrow x ncol (dense) matrix. c ndns = first dimension of dns. c c on return: c---------- c c a, ja, ia = value, column, pointer arrays for output matrix c c changes: c--------- c eliminated the ierr c introduced epsilon c----------------------------------------------------------------------- next = 1 ia(1) = 1 do i=1,nrow do j=1, ncol if (.not.(dabs(dns(i,j)) .le. eps)) then ja(next) = j a(next) = dns(i,j) next = next+1 endif enddo ia(i+1) = next enddo return c---- end of dnscsr ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getmask(nrow,nnz,ir,jc,jao,iao) c----------------------------------------------------------------------- implicit none integer nrow,nnz,ir(*),jc(*),jao(*),iao(*) integer k,k0,j,i,iad c----------------------------------------------------------------------- c Gets Compressed Sparse Row indices from Coordinate ones c----------------------------------------------------------------------- c Loosely based on coocsr from Sparsekit. c c on entry: c--------- c nrow = dimension of the matrix c nnz = number of nonzero elements in matrix c ir, c jc = matrix in coordinate format. ir(k), jc(k) store the nnz c nonzero index. The order of the elements is arbitrary. c iao = vector of 0 of size nrow+1 c c on return: c----------- c ir is destroyed c c jao, iao = matrix index in general sparse matrix format with c jao containing the column indices, c and iao being the pointer to the beginning of the row c c------------------------------------------------------------------------ c determine row-lengths. do 2 k=1, nnz iao(ir(k)) = iao(ir(k))+1 2 continue c starting position of each row.. k = 1 do 3 j=1,nrow+1 k0 = iao(j) iao(j) = k k = k+k0 3 continue c go through the structure once more. Fill in output matrix. do 4 k=1, nnz i = ir(k) j = jc(k) iad = iao(i) jao(iad) = j iao(i) = iad+1 4 continue c shift back iao do 5 j=nrow,1,-1 iao(j+1) = iao(j) 5 continue iao(1) = 1 return c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getblock(a,ja,ia, nrw, rw, ncl, cl, bnz, b,jb,ib) c----------------------------------------------------------------------- c purpose: c -------- c this function returns the elements a(rw,cl) of a matrix a, c for any index vector rw and cl. the matrix is assumed to be stored c in compressed sparse row (csr) format. c c c Reinhard Furrer 2006-09-12 c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c a,ja,ia = the matrix a in compressed sparse row format (input). c nrw,rw c ncl,cl = length of and the vector containing the rows and columns c to extract c c on return: c----------- c bnz = nonzero elements of b c b,jb,ib = the matrix a(rw,cl) in compressed sparse row format. c c note: c------ c no error testing is done. It is assumed that b has enough space c allocated. c----------------------------------------------------------------------- implicit none integer nrw,rw(*), ncl, cl(*) integer bnz, ia(*),ja(*), ib(*),jb(*) double precision a(*),b(*) c c local variables. c integer irw, jcl, jja c c write(*,*) cl(1),cl(2) bnz = 1 ib(1) = 1 do irw = 1,nrw do jcl = 1,ncl do jja = ia(rw(irw)),ia(rw(irw)+1)-1 if (cl(jcl) .eq. ja(jja)) then c we've found one... b(bnz) = a(jja) jb(bnz) = jcl bnz = bnz + 1 endif enddo enddo ib(irw+1) = bnz c end irw, we've cycled over all lines enddo bnz = bnz - 1 c write(*,*) cl(1),cl(2) return c--------end-of-getblock------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getlines(a,ja,ia, nrw, rw, bnz, b,jb,ib) c----------------------------------------------------------------------- c purpose: c -------- c this function returns the lines rw of a matrix a. c the matrix is assumed to be stored c in compressed sparse row (csr) format. c c c Reinhard Furrer 2012-04-04 c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c a,ja,ia = the matrix a in compressed sparse row format (input). c nrw,rw = length of and the vector containing the rows and columns c to extract c c on return: c----------- c bnz = nonzero elements of b c b,jb,ib = the matrix a(rw,cl) in compressed sparse row format. c c note: c------ c no error testing is done. It is assumed that b has enough space c allocated. c----------------------------------------------------------------------- implicit none integer nrw,rw(*) integer bnz, ia(*),ja(*), ib(*),jb(*) double precision a(*),b(*) c c local variables. c integer irw, jja c bnz = 1 ib(1) = 1 do irw = 1,nrw do jja = ia(rw(irw)),ia(rw(irw)+1)-1 b(bnz) = a(jja) jb(bnz) = ja(jja) bnz = bnz + 1 enddo ib(irw+1) = bnz c end irw, we've cycled over all lines enddo bnz = bnz - 1 return c--------end-of-getlines------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getelem(i,j,a,ja,ia,iadd,elem) c----------------------------------------------------------------------- c purpose: c -------- c this function returns the element a(i,j) of a matrix a, c for any pair (i,j). the matrix is assumed to be stored c in compressed sparse row (csr) format. getelem performs a c binary search. c also returns (in iadd) the address of the element a(i,j) in c arrays a and ja when the search is successsful (zero if not). c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c i = the row index of the element sought (input). c j = the column index of the element sought (input). c a = the matrix a in compressed sparse row format (input). c ja = the array of column indices (input). c ia = the array of pointers to the rows' data (input). c on return: c----------- c elem = value of a(i,j). c iadd = address of element a(i,j) in arrays a, ja if found, c zero if not found. (output) c c note: the inputs i and j are not checked for validity. c----------------------------------------------------------------------- c noel m. nachtigal october 28, 1990 -- youcef saad jan 20, 1991. c c Reinhard Furrer: converted to subroutine and eliminated sorted c many manipulations... last for 0.31; Sept 13 c----------------------------------------------------------------------- implicit none integer i, ia(*), iadd, j, ja(*) double precision a(*),elem c c local variables. c integer ibeg, iend, imid, k c c initialization c iadd = 0 ibeg = ia(i) iend = ia(i+1)-1 c empty line! test at beginning 10 if (iend .lt. ibeg) return c c begin binary search: c test of bounds if (ja(ibeg).gt.j) return if (ja(iend).lt.j) return if (ja(ibeg).eq.j) then iadd = ibeg goto 20 endif if (ja(iend).eq.j) then iadd = iend goto 20 endif c compute the middle index and test if found imid = ( ibeg + iend ) / 2 if (ja(imid).eq.j) then iadd = imid goto 20 endif c update the interval bounds. if (ja(imid).gt.j) then iend = imid -1 else ibeg = imid +1 endif goto 10 c c set iadd and elem before returning 20 elem = a(iadd) return c--------end-of-getelem------------------------------------------------- c----------------------------------------------------------------------- end subroutine getallelem(nir,ir,jr,a,ja,ia,alliadd,allelem) c----------------------------------------------------------------------- c purpose: c -------- c wrapper to getelem to retrieve several elements. c----------------------------------------------------------------------- c Reinhard Furrer 2006-09-12 c----------------------------------------------------------------------- implicit none integer nir,ir(nir),jr(nir),ja(*),ia(*),alliadd(nir) double precision a(*),allelem(nir) c local vars integer i do i = 1,nir call getelem(ir(i),jr(i),a,ja,ia,alliadd(i),allelem(i)) enddo return c--------end-of-allgetelem---------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------- c- c- Modified by P. T. Ng from sparsekit c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine aemub (nrow,ncol,a,ja,ia,amask,jmask,imask, * c,jc,ic,iw,aw,nzmax,ierr) c--------------------------------------------------------------------- real*8 a(*),c(*),amask(*),aw(ncol) integer ia(nrow+1),ja(*),jc(*),ic(nrow+1),jmask(*),imask(nrow+1) logical iw(ncol) c----------------------------------------------------------------------- c Modified from amask by Pin T. Ng on 2/27/03 to perform c element-wise multiplication c----------------------------------------------------------------------- c On entry: c--------- c nrow = integer. row dimension of input matrix c ncol = integer. Column dimension of input matrix. c c a, c ja, c ia = the A matrix in Compressed Sparse Row format c c amask, c jmask, c imask = matrix defining mask stored in compressed c sparse row format. (This is the B matrix) c c nzmax = length of arrays c and jc. see ierr. c c On return: c----------- c c a, ja, ia and amask, jmask, imask are unchanged. c c c c jc, c ic = the output matrix in Compressed Sparse Row format. c c ierr = integer. serving as error message.c c ierr = 1 means normal return c ierr .gt. 1 means that amask stopped when processing c row number ierr, because there was not enough space in c c, jc according to the value of nzmax. c c work arrays: c------------- c iw = logical work array of length ncol. c aw = real work array of length ncol. c c note: c------ the algorithm is in place: c, jc, ic can be the same as c a, ja, ia in which cas the code will overwrite the matrix c c on a, ja, ia c c----------------------------------------------------------------------- ierr = 0 len = 0 do 1 j=1, ncol iw(j) = .false. aw(j) = 0.0 1 continue c unpack the mask for row ii in iw do 100 ii=1, nrow c save pointer and value in order to be able to do things in place do 2 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .true. aw(jmask(k)) = amask(k) 2 continue c add umasked elemnts of row ii k1 = ia(ii) k2 = ia(ii+1)-1 ic(ii) = len+1 do 200 k=k1,k2 j = ja(k) if (iw(j)) then len = len+1 if (len .gt. nzmax) then ierr = ii return endif jc(len) = j c(len) = a(k)*aw(j) endif 200 continue c do 3 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .false. aw(jmask(k)) = 0.0 3 continue 100 continue ic(nrow+1)=len+1 c return c-----end-of-aemub ----------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aemub1 (nrow,ncol,a,ja,ia,b,jb,ib,c,jc,ic, * nzmax,ierr) real*8 a(*), b(*), c(*) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1) c----------------------------------------------------------------------- c A modification of aplsb by Pin Ng on 6/12/02 to c perform the element-wise operation C = A*B for matrices in c sorted CSR format. c the difference with aplsb is that the resulting matrix is such that c the elements of each row are sorted with increasing column indices in c each row, provided the original matrices are sorted in the same way. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a, c ja, c ia = Matrix A in compressed sparse row format with entries sorted c c b, c jb, c ib = Matrix B in compressed sparse row format with entries sorted c ascendly in each row c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c Notes: c------- c this will not work if any of the two input matrices is not sorted c----------------------------------------------------------------------- ierr = 0 kc = 1 ic(1) = kc c c the following loop does a merge of two sparse rows and c multiplies them. c do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue c c this is a while -- do loop -- c if (ka .le. kamax .or. kb .le. kbmax) then c if (ka .le. kamax) then j1 = ja(ka) else c take j1 large enough that always j2 .lt. j1 j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else c similarly take j2 large enough that always j1 .lt. j2 j2 = ncol+1 endif c c three cases c if (j1 .eq. j2) then c(kc) = a(ka)*b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then ka = ka+1 else if (j1 .gt. j2) then kb = kb+1 endif if (kc .gt. nzmax) goto 999 goto 5 c c end while loop c endif ic(i+1) = kc 6 continue return 999 ierr = i return c------------end-of-aemub1 --------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aedib (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,aw,ierr) real*8 a(*), b(*), c(*), aw(ncol) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1), * iw(ncol) c----------------------------------------------------------------------- c performs the element-wise matrix division C = A/B. c Modified from aplsb by Pin Ng on 2/27/03 c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length equal to the number of c columns in A. c aw = real work array of length equal to the number of c columns in A. c c----------------------------------------------------------------------- logical values values = (job .ne. 0) ierr = 0 len = 0 ic(1) = 1 do 1 j=1, ncol iw(j) = 0 1 continue c do 500 ii=1, nrow c row i do 200 ka=ia(ii), ia(ii+1)-1 len = len+1 jcol = ja(ka) if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = a(ka)/0.0 iw(jcol)= len aw(jcol) = a(ka) 200 continue c do 300 kb=ib(ii),ib(ii+1)-1 jcol = jb(kb) jpos = iw(jcol) if (jpos .eq. 0) then len = len+1 if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = 0.0 iw(jcol)= len else if (values) c(jpos) = aw(jcol)/b(kb) endif 300 continue do 301 k=ic(ii), len iw(jc(k)) = 0 301 continue ic(ii+1) = len+1 500 continue return 999 ierr = ii return c------------end of aedib ----------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aeexpb (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,aw,ierr) real*8 a(*), b(*), c(*), aw(ncol) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1), * iw(ncol) c----------------------------------------------------------------------- c performs the element-wise matrix division C = A/B. c Modified from aplsb by Pin Ng on 2/27/03 c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length equal to the number of c columns in A. c aw = real work array of length equal to the number of c columns in A. c c----------------------------------------------------------------------- logical values values = (job .ne. 0) ierr = 0 len = 0 ic(1) = 1 do 1 j=1, ncol iw(j) = 0 1 continue c do 500 ii=1, nrow c row i do 200 ka=ia(ii), ia(ii+1)-1 len = len+1 jcol = ja(ka) if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = 1.0 iw(jcol)= len aw(jcol) = a(ka) 200 continue c do 300 kb=ib(ii),ib(ii+1)-1 jcol = jb(kb) jpos = iw(jcol) if (jpos .eq. 0) then len = len+1 if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = 0.0**b(kb) iw(jcol)= len else if (values) c(jpos) = aw(jcol)**b(kb) endif 300 continue do 301 k=ic(ii), len iw(jc(k)) = 0 301 continue ic(ii+1) = len+1 500 continue return 999 ierr = ii return c------------end of aeexpb ----------------------------------------------- c----------------------------------------------------------------------- end SUBROUTINE CALCJA(nrow,nsuper, % xsuper,lindx,xlindx,xlnz, % cholcja) c small function to calculate ja for the cholesky factor c as they use a condensed format. GRATULIERU LIT! c INPUT: c nrow (integer) number of rows c nsuper (integer) number of supernodes c xsuper (integer) supernode partition c xlindx,lindx (integer) row indices for each supernode c xlnz (integer) ia for cholesky factor c c OUTPUT: c cholcja (integer) ja for cholesky factor IMPLICIT NONE INTEGER nrow,nsuper INTEGER xsuper(nrow),lindx(*),xlindx(nrow+1),xlnz(nrow+1) INTEGER cholcja(*) INTEGER k, i, j, m, n k=1 m=1 DO i=1,nsuper DO j=1,( xsuper(i+1)-xsuper(i)) DO n=1,(xlnz(k+1)-xlnz(k)) cholcja(m)=lindx( xlindx(i)+j-2 + n) m=m+1 ENDDO k=k+1 ENDDO ENDDO RETURN END subroutine transpose(n,m,a,ja,ia,ao,jao,iao) implicit none integer n,m,ia(n+1),iao(m+1),ja(*),jao(*) double precision a(*),ao(*) integer i,j,k,next c----------------------------------------------------------------------- c Transposition c similar to csrcsc from sparsekit c----------------------------------------------------------------------- c on entry: c---------- c n = number of rows of CSR matrix. c m = number of columns of CSC matrix. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- c----------------- compute lengths of rows of transp(A) ---------------- do i=1, n do k=ia(i), ia(i+1)-1 j = ja(k)+1 iao(j) = iao(j)+1 enddo enddo c---------- compute pointers from lengths ------------------------------ iao(1) = 1 do i=1,m iao(i+1) = iao(i) + iao(i+1) enddo c--------------- now do the actual copying ----------------------------- do i=1,n do k=ia(i),ia(i+1)-1 j = ja(k) next = iao(j) ao(next) = a(k) jao(next) = i iao(j) = next+1 enddo enddo c-------------------------- reshift iao and leave ---------------------- do i=m,1,-1 iao(i+1) = iao(i) enddo iao(1) = 1 c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine reducedim(a,ja,ia,eps,bnrow,bncol,k,b,jb,ib) implicit none double precision a(*),b(*),eps integer bnrow, bncol,k integer ia(*),ja(*),ib(*),jb(*) integer i, j, jaj c----------------------------------------------------------------------- c Reduces the dimension of A to (,bnrow,bncol) by copying it to B. c (Hence not in place - for R purposes). c Only elements smaller than eps are copied. c----------------------------------------------------------------------- c on entry: c--------- c c------------------------------------------------------------------------ k=1 do i=1,bnrow ib(i)=k do j=ia(i), ia(i+1)-1 jaj=ja(j) if (jaj .le.bncol) then if (abs( a(j)) .gt. eps) then b(k)=a(j) jb(k)=jaj k=k+1 endif endif enddo enddo ib(bnrow+1)=k return c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c Currently not used... subroutine reducediminplace(eps,nrow,ncol,k,a,ja,ia) implicit none double precision a(*),eps integer nrow, ncol,k integer ia(*),ja(*) integer i, j, jj, itmp c----------------------------------------------------------------------- c Reduces the dimension of A to (nrow,ncol) _in place_ c Only elements smaller than eps are copied. c----------------------------------------------------------------------- c Reinhard Furrer, June 2008 c------------------------------------------------------------------------ k=1 do i=1,nrow itmp = ia(i) ia(i)=k do j=itmp, ia(i+1)-1 jj=ja(j) if (jj .le. ncol) then if (abs( a(jj)) .gt. eps) then a(k)=a(jj) ja(k)=jj k=k+1 endif endif enddo enddo ia(nrow+1)=k return c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------c c T R I A N G U L A R S Y S T E M S O L U T I O N S c c c c spamforward and spamback c c----------------------------------------------------------------------c subroutine spamforward (n,p,x,b,l,jl,il) implicit none integer n, p, jl(*),il(n+1) double precision x(n,p), b(n,p), l(*) integer i, k, j double precision t c----------------------------------------------------------------------- c solves L x = y ; L = lower triang. / CSR format c sequential forward elimination c----------------------------------------------------------------------- c c On entry: c---------- c n,p = integer. dimensions of problem. c b = real array containg the right side. c c l, jl, il, = Lower triangular matrix stored in CSR format. c c On return: c----------- c x = The solution of L x = b. c-------------------------------------------------------------------- c Reinhard Furrer June 2008, April 2012 c if first diagonal element is zero, break if (l(1) .eq. 0.0 ) goto 5 c cycle over all columns of b do i=1,p c first row has one element then cycle over all rows x(1,i) = b(1,i) / l(1) do 3 k = 2, n t = b(k,i) do 1 j = il(k), il(k+1)-1 if (jl(j) .lt. k) then t = t-l(j)*x(jl(j),i) else if (jl(j) .eq. k) then if (l(j) .eq. 0.0) goto 5 c diagonal element is not zero, hence we divide and leave the loop x(k,i) = t / l(j) goto 3 endif endif 1 continue 3 continue enddo return 5 n = -k return end c----------------------------------------------------------------------- subroutine spamback (n,p,x,b,r,jr,ir) implicit none integer n, p, jr(*),ir(n+1) double precision x(n,p), b(n,p), r(*) integer l, k, j double precision t c----------------------------------------------------------------------- c Solves R x = b R = upper triangular. c----------------------------------------------------------------------- c c On entry: c---------- c n,p = integers. dimension of problem. c b = real array containg the right side. c c r, jr, ir, = Upper triangular matrix stored in CSR format. c c On return: c----------- c x = The solution of R x = b . c-------------------------------------------------------------------- c Reinhard Furrer June 2008, April 2012 if (r(ir(n+1)-1) .eq. 0.0 ) goto 5 do l=1,p x(n,l) = b(n,l) / r(ir(n+1)-1) do 3 k = n-1,1,-1 t = b(k,l) do 1 j = ir(k+1)-1,ir(k),-1 if (jr(j) .gt. k) then t = t - r(j)*x(jr(j),l) else if (jr(j) .eq. k) then if (r(j) .eq. 0.0) goto 5 c diagonal element is not zero, hence we divide and leave the loop x(k,l) = t / r(j) goto 3 endif endif 1 continue 3 continue enddo return 5 n = -k return end c----------------------------------------------------------------------- spam/src/kronecker.f0000644000176000001440000000340412403556057014173 0ustar ripleyusers subroutine kroneckermult(xnrow,xent,xcol,xrow, & ynrow,yncol,yent,ycol,yrow, & ent, col, row) implicit none integer xnrow,ynrow,yncol, xcol(*), xrow(*) integer ycol(*), yrow(*), col(*), row(*) double precision xent(*), yent(*), ent(*) integer i,k,j,l,n,nr,xdiffi,ydiffk n = 1 nr = 2 row(1) = 1 do i = 1,xnrow xdiffi = xrow(i+1)-xrow(i) do k = 1,ynrow ydiffk = yrow(k+1)-yrow(k) do j = 1,xdiffi do l = 1,ydiffk ent(n) = xent(j+xrow(i)-1)*yent(l+yrow(k)-1) col(n) = ycol(l+yrow(k)-1)+ & (xcol(j+xrow(i)-1)-1)*yncol n=n+1 enddo enddo row(nr) = n nr = nr+1 enddo enddo return end subroutine kronecker(xnrow,xent,xcol,xrow, & ynrow,yncol,yent,ycol,yrow, & ent1, ent2, col, row) implicit none integer xnrow,ynrow,yncol, xcol(*), xrow(*) integer ycol(*), yrow(*), col(*), row(*) double precision xent(*), yent(*), ent1(*), ent2(*) integer i,k,j,l,n,nr,xdiffi,ydiffk n = 1 nr = 2 row(1) = 1 do i = 1,xnrow xdiffi = xrow(i+1)-xrow(i)-1 do k = 1,ynrow ydiffk = yrow(k+1)-yrow(k)-1 do j = 0,xdiffi do l = 0,ydiffk ent1(n) = xent(j+xrow(i)) ent2(n)= yent(l+yrow(k)) col(n) = ycol(l+yrow(k))+ & (xcol(j+xrow(i))-1)*yncol n=n+1 enddo enddo row(nr) = n nr = nr+1 enddo enddo return end spam/NAMESPACE0000644000176000001440000001167212403542135012467 0ustar ripleyusersuseDynLib(spam) importFrom("graphics",image) importFrom("graphics",plot) import(grid) # Next two paragraphs are from Matrix.... # Currently, group generics need to be explicitly imported (Bug?): importFrom("methods", #Arith,Compare, Math, Math2, Summary#, Complex ) # Generic functions export( "todo", "spam.history", "spam.options", "spam.getOption", "is.spam", "spam.version", "spam.Version", "validspamobject", "nearest.dist", "spam_rdist", "spam_rdist.earth", "as.spam.matrix", "as.spam.numeric", "as.spam.spam", "as.spam.dist", "as.spam.chol.NgPeyton", "as.spam.list", "as.vector.spam", "as.matrix.spam", "spam.list", "spam.numeric", "diag.of.spam", "diag.spam", "diag<-.spam", "diag.spam<-", "rbind.spam", "cbind.spam", "upper.tri.spam", "lower.tri.spam", "t.spam", "dim<-.spam", "pad<-.spam", "isSymmetric.spam", "all.equal.spam", "kronecker.default", "kronecker.spam", "diff.spam", "circulant.spam", "toeplitz.spam", "determinant.spam", "determinant.spam.chol.NgPeyton", "chol.spam", "solve.spam", "forwardsolve.spam", "backsolve.spam", "update.spam.chol.NgPeyton", "norm.spam", "plot.spam", "display.spam", "image.spam", "print.spam", "summary.spam", "print.spam.chol.NgPeyton", "summary.spam.chol.NgPeyton", "apply.spam", "rmvnorm.spam", "rmvnorm.canonical", "rmvnorm.prec", "rmvnorm.const", "rmvnorm.canonical.const", "rmvnorm.prec.const", "precmat", "precmat.RW1", "precmat.RW2", "precmat.RWn", "precmat.season", "precmat.IGMRFreglat", "precmat.IGMRFirreglat", "precmat.GMRFreglat", "covmat", "cov.exp", "cov.sph", "cov.nug", "cov.wu1", "cov.wu2", "cov.wu3", "cov.wend1", "cov.wend2", "cov.mat", "rowSums.spam", "colSums.spam", "rowMeans.spam", "colMeans.spam", "head.spam", "tail.spam", "chol2inv.spam", "mle.spam", "mle.nomean.spam", "neg2loglikelihood.spam", "mle", "mle.nomean", "neg2loglikelihood", "bdiag.spam", "var.spam", "eigen.spam", "bandwidth", # ".spam.matmul.mat", # ".spam.matmul", # "solve.spam.mat", # "solve.spam.dummy", "subset.spam", "subset.rows.spam", "triplet", "as.spam.matrix.csr", "as.matrix.csr.spam", "as.dgRMatrix.spam", "as.dgCMatrix.spam", "as.spam.dgRMatrix", "as.spam.dgCMatrix", "read.MM", "read.HB", "powerboost", "permutation.spam", "crossprod.spam", "tcrossprod.spam", "map.landkreis", "adjacency.landkreis", "germany.plot", "grid_trace2", "grid_zoom", "rowpointers<-", "entries<-", "colindices<-", "dimension<-", "cleanup" # "backsolve" ) # export the two classes exportClasses("spam", "spam.chol.NgPeyton") exportMethods( "Math", "Math2", "Summary", "show", "print", "image", "display", "spam", "as.spam", "isSymmetric", "all.equal", "summary", "length", "length<-", "c", "dim", "dim<-", "pad<-", "rbind", "cbind", "as.spam", "spam", "as.vector", "as.matrix", "determinant", "t", "diag", "diag<-", "diag<-", "upper.tri", "lower.tri", "norm", "rowSums", "rowMeans", "colSums", "colMeans", "head", "tail", "chol", "ordering", "forwardsolve", "backsolve", "solve", "chol2inv", "kronecker", "permutation", "crossprod", "tcrossprod", "[", "[<-", "%*%", "%d*%", "%d+%", "-", "+", "*", "/", "&", "|") spam/demo/0000755000176000001440000000000012377602331012172 5ustar ripleyusersspam/demo/article-jss.R0000644000176000001440000002714712377112736014555 0ustar ripleyusers# This is file ../spam/demo/article-jss.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # This demo contains the R code to construct the figures and the table of the # JSS article: # "spam: A Sparse Matrix R Package with Emphasis on # MCMC Methods for Gaussian Markov Random Fields" # The code presented here differs in the following points form the actually used # one: # - Very large grid sizes or very high order neighbor structures are not included # here; # - Instead of (100+1) factorizations only (50+1) are performed here; # - No figure fine-tuning is done here. # - We had a few additional gc(), just to be sure. # - Minor change due to evolved of 'spam' # SETUP: spam.options(structurebased=TRUE) # just to be sure ###################################################################### # Figure 1: i <- c( 2,4,4,5,5) j <- c( 1,1,2,1,3) A <- spam(0,5,5) A[cbind(i,j)] <- rep(.5, length(i)) A <- t( A)+A+diag.spam(5) U <- chol( A) pivot <- U@pivot B <- A[pivot,pivot] R <- chol( B) U@pivot U@snmember U@supernodes U@entries U@colindices U@colpointers U@rowpointers display( A) display( as.spam( chol(as.matrix( A)))) display( B) display( as.spam(R)) abline( h=-U@supernodes+.5,col=3,lty=2) ###################################################################### # Figure 2: theta1 <- .1 theta2 <- .01 n <- dim( UScounties.storder)[1] USmat <- diag.spam(n) + theta1 * UScounties.storder + theta2 * UScounties.ndorder U <- chol( USmat,memory=list(nnzR=146735)) display( as.spam(U)) text(400,-2200,"MMD\nz=146735\nw=30182\ns=1262",adj=0) U <- chol( USmat, pivot="RCM",memory=list(nnzR=256198,nnzcolindices=140960)) display( as.spam(U)) text(400,-2200,"RCM\nz=256198\nw=140960\ns=1706",adj=0) U <- chol( USmat, pivot=FALSE,memory=list(nnzR=689615,nnzcolindices=96463)) display( as.spam(U)) text(400,-2200,"no permutation\nz=689615\nw=96463\ns=711",adj=0) ###################################################################### # Figure 3: # general parameters for the following figures N <- 50 # would be 100 in the article stsel <- 1 # user.self rPsx <- 1 # for function "system.time" rPsy <- 3 # memory usage rPint <- .0001 # small interval theta1 <- .1 theta2 <- .05 xseq <- ceiling(4 + exp(seq(0.5,to=5.5,by=.5))/2) # would be seq(0,to=6,by=.5) in the article xseql <- length(xseq) table <- array(NA,c(xseql,4)) for (ix in 1:xseql) { egdx <- expand.grid(1:xseq[ix],1:xseq[ix]) Cspam <- nearest.dist( egdx, delta=1., upper=NULL) Dspam <- nearest.dist( egdx, delta=1.5,upper=NULL) mat <- diag.spam(xseq[ix]^2) + theta1 * Cspam + theta2 * Dspam Rprof( memory.profiling=TRUE, interval = rPint) table[ix,1] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch1 <- chol(mat)} )[stsel] Rprof( NULL) table[ix,2] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[ix,3] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch2 <- update(ch1,mat) } )[stsel] Rprof( NULL) table[ix,4] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] } # Since we have a small N, elements in table might be zero. table <- pmax(table, 0.0001) par(mfcol=c(1,2)) plot(xseq, table[,1], type="l", log="xy", ylim=range(table[,c(1,3)]), xlab="L (log scale)", ylab="seconds (log scale)") lines(xseq, table[,3], lty=2) lines(xseq,table[,1]/table[,3],col=4,lty=3) plot(xseq, table[,2], type="l", log="xy", ylim=range(table[,c(2,4)]+0.01), xlab="L (log scale)", ylab="Mbytes (log scale)") lines(xseq, table[,4], lty=2) lines(xseq,table[,2]/table[,4],col=4,lty=3) ###################################################################### # Figure 4: # general parameters for the following figures N <- 50 # would be 100 in the article stsel <- 1 # user.self rPsx <- 1 # for function "system.time" rPsy <- 3 # memory usage rPint <- .0001 # small interval x <- 50 # was 50 in article maxnn <- 6 # was 6 in article egdx <- expand.grid( 1:(maxnn+1), 1:(maxnn+1)) dval <- sort(unique(nearest.dist( egdx, delta=maxnn)@entries))[-1] dvall <- length( dval) egdx <- expand.grid( 1:x, 1:x) table <- array(NA, c(dvall,5)) for (id in 1:dvall) { mat <- nearest.dist( egdx, delta=dval[id],upper=NULL) mat@entries <- exp(-2*mat@entries) # arbitrary values to get a spd precision matrix table[id,5] <- length(Cspam) Rprof( memory.profiling=TRUE, interval = rPint) table[id,1] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch1 <- chol(mat)} )[stsel] Rprof( NULL) table[id,2] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[id,3] <- system.time( { ch1 <- chol(mat); for (i in 1:N) ch2 <- update(ch1,mat) } )[stsel] Rprof( NULL) table[id,4] <- summaryRprof( memory="both")$by.total[rPsx,rPsy] } # If we have a small N, elements in table might be zero. table <- pmax(table, 0.0001) par(mfcol=c(1,2)) plot( dval, table[,1], type="l", log="xy",ylim=range(table[,c(1,3)]), xlab="distance (log scale)", ylab="seconds (log scale)") lines( dval, table[,3],lty=2) lines( dval, table[,1]/table[,3],col=4,lty=3) plot( dval, table[,2], type="l", log="xy",ylim=range(table[,c(2,4)]), xlab="distance (log scale)", ylab="Mbytes (log scale)") lines( dval, table[,4],lty=2) lines( dval, table[,2]/table[,4],col=4,lty=3) ###################################################################### # Figure 5 In <- diag.spam(nrow(UScounties.storder)) struct <- chol(In + .2 * UScounties.storder + .1 * UScounties.ndorder) len.1 <- 90 # in the article, is set to 180 len.2 <- 50 # in the article, is set to 100 theta.1 <- seq(-.225, to=.515, len=len.1) theta.2 <- seq(-.09, to=.235, len=len.2) grid <- array(NA, c(len.1, len.2)) spam.options("cholupdatesingular"="null") for (i in 1:len.1) for(j in 1:len.2) grid[i,j] <- !is.null(update(struct, In + theta.1[i]*UScounties.storder + theta.2[j]* UScounties.ndorder)) image(theta.1, theta.2, grid, xlab=expression(theta[1]), ylab=expression(theta[2]), xlim=c(-.3,.6),ylim=c(-.1,.25),col=c(0,"gray")) abline(v=0,h=0, lty=2) ###################################################################### # Table 1: table <- array(NA,c(9,4)) x <- 50 # was 50 in article egdx <- expand.grid(1:x,1:x) # As above hence shortend gridmat <- diag.spam(x^2) + .2 * nearest.dist( egdx, delta=1.,upper=NULL) + .1 * nearest.dist( egdx, delta=1.5,upper=NULL) # USmat was constructed above. # Generic call first: Rprof( memory.profiling=TRUE, interval = rPint) table[1,1] <- system.time( for (i in 1:N) ch1 <- chol(gridmat) )[stsel] Rprof( NULL) table[1,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[1,3] <- system.time( for (i in 1:N) ch2 <- chol(USmat) )[stsel] Rprof( NULL) table[1,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Call a chol.spam directly Rprof( memory.profiling=TRUE, interval = rPint) table[2,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat))[stsel] Rprof( NULL) table[2,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[2,3] <- system.time( for (i in 1:N) ch2 <- chol.spam(USmat) )[stsel] Rprof( NULL) table[2,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Less checking: spam.options( safemode=c(FALSE, FALSE, FALSE)) Rprof( memory.profiling=TRUE, interval = rPint) table[3,1] <- system.time( for (i in 1:N) ch1 <- chol( gridmat) )[stsel] Rprof( NULL) table[3,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[3,3] <- system.time( for (i in 1:N) ch2 <- chol( USmat) )[stsel] Rprof( NULL) table[3,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] spam.options( safemode=c(TRUE, TRUE, TRUE)) # lesser checking spam.options( cholsymmetrycheck=FALSE) Rprof( memory.profiling=TRUE, interval = rPint) table[4,1] <- system.time( for (i in 1:N) ch1 <- chol( gridmat) )[stsel] Rprof( NULL) table[4,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[4,3] <- system.time( for (i in 1:N) ch2 <- chol( USmat) )[stsel] Rprof( NULL) table[4,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] spam.options( cholsymmetrycheck=TRUE) # Pass optimal memory parameters (from above) memory1 = summary(ch1)[1:2] memory2 = summary(ch2)[1:2] Rprof( memory.profiling=TRUE, interval = rPint) table[5,1] <- system.time( for (i in 1:N) ch1 <- chol( gridmat,memory=memory1) )[stsel] Rprof( NULL) table[5,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[5,3] <- system.time( for (i in 1:N) ch2 <- chol( USmat,memory=memory2) )[stsel] Rprof( NULL) table[5,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # All of the above spam.options( cholsymmetrycheck=FALSE, safemode=c(FALSE,FALSE,FALSE)) Rprof( memory.profiling=TRUE, interval = rPint) table[6,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat,memory=memory1) )[stsel] Rprof( NULL) table[6,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[6,3] <- system.time( for (i in 1:N) ch2 <- chol.spam(USmat,memory=memory2) )[stsel] Rprof( NULL) table[6,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # supply the permutation pivot1 <- ch1@pivot pivot2 <- ch2@pivot Rprof( memory.profiling=TRUE, interval = rPint) table[7,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat,pivot=pivot1, memory=memory1) )[stsel] Rprof( NULL) table[7,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[7,3] <- system.time( for (i in 1:N) ch1 <- chol.spam(USmat,pivot=pivot2, memory=memory2) )[stsel] Rprof( NULL) table[7,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Do not check the permutation spam.options( cholpivotcheck=FALSE) Rprof( memory.profiling=TRUE, interval = rPint) table[8,1] <- system.time( for (i in 1:N) ch1 <- chol.spam(gridmat,pivot=pivot1, memory=memory1) )[stsel] Rprof( NULL) table[8,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[8,3] <- system.time( for (i in 1:N) ch2 <- chol.spam(USmat,pivot=pivot2, memory=memory2) )[stsel] Rprof( NULL) table[8,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # Update only Rprof( memory.profiling=TRUE, interval = rPint) table[9,1] <- system.time( for (i in 1:N) ch1 <- update(ch1,gridmat) )[stsel] Rprof( NULL) table[9,2] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] Rprof( memory.profiling=TRUE, interval = rPint) table[9,3] <- system.time( for (i in 1:N) ch2 <- update(ch2,USmat) )[stsel] Rprof( NULL) table[9,4] <- summaryRprof(memory="both")$by.total[rPsx,rPsy] # assemble the table colnames(table) <- c("grid_time","grid_mem","US_time","US_mem") rownames(table) <- c("Generic chol","chol.spam","safemode", "symmetrycheck","memory","all","reusing pivot","best cast","update only") normed.table <- t( round( t(table[-1,])/table[1,],3)) print( t( round( t(table[-1,])/table[1,],3))) spam/demo/cholesky.R0000644000176000001440000001017612346261543014145 0ustar ripleyusers# This is file ../spam/demo/cholesky.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # We illustrate the Cholesky decompostion approaches set.seed(14) # first start with a full matrix. xn <- 750 fmat1 <- matrix(rnorm(xn*xn),xn,xn) fmat1 <- t( fmat1) %*% fmat1 smat1 <- as.spam(fmat1) smat2 <- smat1 + diag.spam(xn) # Generic Cholesky tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( fmat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, direct call tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, without symmetry check spam.options(cholsymmetrycheck=FALSE) tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, reusing pivoting tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1,pivot=ch1@pivot) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, updating tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- update.spam.chol.NgPeyton( ch1, smat2) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # reset to default spam.options(cholsymmetrycheck=TRUE) # now create a sparse matrix. fmat1[fmat1<3] <- 0 smat1 <- as.spam(fmat1) smat2 <- smat1 + diag.spam(xn) # Generic Cholesky tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( fmat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, direct call tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, without symmetry check spam.options(cholsymmetrycheck=FALSE) tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, reusing pivoting tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1,pivot=ch1@pivot) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, updating tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- update.spam.chol.NgPeyton( ch1, smat2) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # reset to default spam.options(cholsymmetrycheck=TRUE) # now create an even sparser matrix. fmat1 <- fmat1+20*diag(xn) fmat1[fmat1<32] <- 0 smat1 <- as.spam(fmat1) smat2 <- smat1 + 1* diag.spam(xn) # Generic Cholesky tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( fmat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, direct call tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, without symmetry check spam.options(cholsymmetrycheck=FALSE) tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, reusing pivoting spam.options(cholsymmetrycheck=FALSE) tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- chol.spam( smat1,pivot=ch1@pivot) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # Sparse Cholesky, updating spam.options(cholsymmetrycheck=FALSE) tmp <- gc(F);Rprof(memory.profiling=TRUE, interval = 0.01) ch1 <- update.spam.chol.NgPeyton( ch1, smat2) Rprof(NULL);print( summaryRprof(memory="both")$by.total) # reset to default spam.options(cholsymmetrycheck=TRUE) spam/demo/article-jss-example2.R0000644000176000001440000001422512377602347016263 0ustar ripleyusers# This is file ../spam/demo/article-jss-example2.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # This demo contains the R code of the example in Section 5.2 of the # JSS article: # "spam: A Sparse Matrix R Package with Emphasis on # MCMC Methods for Gaussian Markov Random Fields" # Compared to the R code in the article, here we give: # - improved formatting # - more comments, e.g. how to run the code using regular matrices # - the code to construct the figures # - minor modifcations due to evolvement of spam ################################################################################ cat("\nThis demo contains the R code of the second example in the JSS article.\nAs pointed out by Steve Geinitz and Andrea Riebler, the Gibbs sampler\nis not correct and contains a few bugs. \n\n") cat("A corrected sampler is posted (among other things) in the upcoming JSS article:\n Gerber R. and Furrer R. (2014) Pitfalls in the implementation of \n Bayesian hierarchical modeling of areal count data.\n An illustration using BYM and Leroux models. JSS, accepted.\n\n") # INITALIZE AND FUNCTIONS: require("fields", warn.conflict=FALSE) spam.options(structurebased=TRUE) # READ DATA: attach(Oral) # CONSTRUCT ADJACENCY MATRIX: loc <- system.file("demodata/germany.adjacency", package="spam") A <- adjacency.landkreis(loc) n <- dim(A)[1] # Verification that we have a symmetric matrix: # norm(A-t(A)); display(A) # GIBBS SETUP: set.seed(14) # Construct the individual block precisions # (based on unit precision parameters kappa, denoted with k): Q1 <- R <- diag.spam( diff(A@rowpointers)) - A # this is R in (2) pad(Q1) <- c(2*n,2*n) # previously: dim(Q1) <- c(2*n,2*n) Q2 <- rbind(cbind( diag.spam(n), -diag.spam(n)), cbind(-diag.spam(n), diag.spam(n))) # Hence the precision Q in (2) is: # Q <- kappau*Q1 + kappav*Q2 # pre-define diagC <- as.spam( diag.spam(c(rep(0,n),rep(1,n)))) # Recall: # k=( kappa_u, kappa_y)' # hyperparameters ahyper <- c( 1, 1) bhyper <- c( .5, .01) # Gibbs sampler burnin <- 500 ngibbs <- 1500 totalg <- burnin+ngibbs # Initialize parameters: upost <- array(0, c(totalg, n)) npost <- array(0, c(totalg, n)) kpost <- array(0, c(totalg, 2)) # Starting values: kpost[1,] <- c(40,500) upost[1,] <- u <- rnorm(n,sd=.2) *1 npost[1,] <- eta <- u + rnorm(n,sd=.05)*1 uRu <- t(u) %*% (R %*% u)/2 etauetau <- t(eta-u) %*% (eta-u)/2 postshape <- ahyper + c(n-1,n)/2 accept <- numeric(totalg) struct <- chol(Q1 + Q2 + diag.spam(2*n), memory=list(nnzcolindices=5500)) # struct <- NULL # If no update steps are wanted # R <- as.matrix(R) # If no spam analysis is wanted. # Q1 <- as.matrix(Q1) # Q2 <- as.matrix(Q2) timing <- system.time({ for (ig in 2:totalg) { kstar <- rgamma(2,postshape, bhyper + c(uRu, etauetau)) expeta0E <- exp(eta)*E expeta0Eeta01 <- expeta0E *(eta-1) diagC@entries <- expeta0E Q <- kstar[1]*Q1 + kstar[2]*Q2 + diagC b <- c( rep(0,n), Y + expeta0Eeta01) xstar <- rmvnorm.canonical(1, # vector b: b, # Precision matrix Q, Rstruct=struct) ustar <- xstar[1:n] nstar <- xstar[1:n+n] uRustar <- t(ustar) %*% (R %*% ustar)/2 etauetaustar <- t(nstar-ustar) %*% (nstar-ustar)/2 # we work on the log scale: # logalpha <- min(0, log(ratios))=min(0, expterm+(...)log(kappa)- exptmp <- sum(expeta0Eeta01*(eta-nstar) - E*(exp(eta)-exp(nstar))) - sum( nstar^2*expeta0E)/2 + sum(eta^2*expeta0E)/2 - kstar[1] * uRu + kpost[ig-1,1] * uRustar - kstar[2] * etauetau + kpost[ig-1,2] * etauetaustar factmp <- (postshape-1)*(log(kstar)-log(kpost[ig-1,1])) logalpha <- min(0, exptmp + sum(factmp)) logU <- log(runif(1)) if (logU < logalpha) { # ACCEPT draw upost[ig,] <- u <- ustar npost[ig,] <- eta <- nstar kpost[ig,] <- kstar uRu <- uRustar etauetau <- etauetaustar accept[ig] <- 1 } else { upost[ig,] <- upost[ig-1,] npost[ig,] <- npost[ig-1,] kpost[ig,] <- kpost[ig-1,] } if( (ig%%10)==0) cat(".") } }) # POSTPROCESSING: cat("\nTotal time:",timing[1],"per iteration:",timing[1]/totalg) accept <- accept[-c(1:burnin)] cat("\nAcceptance rate:",mean(accept),"\n") kpost <- kpost[-c(1:burnin),] upost <- upost[-c(1:burnin),] npost <- npost[-c(1:burnin),] kpostmean <- apply(kpost,2,mean) upostmean <- apply(upost,2,mean) npostmean <- apply(npost,2,mean) kpostmedian <- apply(kpost,2,median) upostmedian <- apply(upost,2,median) npostmedian <- apply(npost,2,median) vpost <- npost-upost vpostmedian <- apply(vpost,2,median) # ###################################################################### # Figure 8: par(mfcol=c(1,3),mai=rep(0,4)) map.landkreis(log(Y)) map.landkreis(Y/E,zlim=c(.1,2.4)) map.landkreis(exp(upostmedian),zlim=c(.1,2.4)) # Figure 9: par(mfcol=c(2,4),mai=c(.5,.5,.05,.1),mgp=c(2.3,.8,0)) hist(kpost[,1],main="",xlab=expression(kappa[u]),prob=TRUE) lines(density(kpost[,1]),col=2) tmp <- seq(0,to=max(kpost[,1]),l=500) lines(tmp,dgamma(tmp,ahyper[1],bhyper[1]),col=4) abline(v=kpostmedian[1],col=3) hist(kpost[,2],main="",xlab=expression(kappa[y]),prob=TRUE) lines(density(kpost[,2]),col=2) tmp <- seq(0,to=max(kpost[,2]),l=500) lines(tmp,dgamma(tmp,ahyper[2],bhyper[2]),col=4) abline(v=kpostmedian[2],col=3) # Trace plots: plot(kpost[,1],ylab=expression(kappa[u]),type="l") abline(h=kpostmedian[1],col=3) plot(kpost[,2],ylab=expression(kappa[y]),type="l") abline(h=kpostmedian[2],col=3) # ACF: acf(kpost[,1],ylab=expression(kappa[u])) acf(kpost[,2],ylab=expression(kappa[y])) # scatter plots plot(kpost[,1],kpost[,2],xlab=expression(kappa[u]),ylab=expression(kappa[y])) abline(v=kpostmedian[1],h=kpostmedian[2],col=3) plot(accept+rnorm(ngibbs,sd=.05),pch=".",ylim=c(-1,2),yaxt="n",ylab="") text(ngibbs/2,1/2,paste("Acceptance rate:",round(mean(accept),3))) axis(2,at=c(0,1),label=c("Reject","Accept")) detach(Oral) ###################################################################### spam/demo/article-jss-example1.R0000644000176000001440000001256012377112316016252 0ustar ripleyusers# This is file ../spam/demo/article-jss-example1.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # This demo contains the R code of the example in Section 5.1 of the # JSS article: # "spam: A Sparse Matrix R Package with Emphasis on # MCMC Methods for Gaussian Markov Random Fields" # # Compared to the R code given in the article, here we give: # - improved formatting # - more comments # - the R code to construct the figures # SETUP: library("spam") spam.options(structurebased=TRUE) data("UKDriverDeaths") y <- sqrt(c(UKDriverDeaths)) # square root counts n <- length(y) # n=192 m <- 12 # We want to predict for one season. nm <- n+m # Total length of s and t priorshape <- c(4, 1, 1) # alpha's, as in Rue & Held (2005) priorinvscale <- c(4, 0.1, 0.0005) # beta's # Construct the individual block precisions # (based on unit precision parameters kappa, denoted with k): # Qsy, Qty are trivial: Qsy <- diag.spam(n) pad(Qsy) <- c(n+m, n) # previously: dim(Qsy) <- c(n+m, n) Qty <- Qsy Qst <- spam(0, nm, nm) Qst[cbind(1:n, 1:n)] <- rep(1, n) # The form of Qss is given by (Rue and Held equation 3.59). # Qss can be constructed with a loop: Qss <- spam(0, nm, nm) for (i in 0:(nm-m)) { Qss[i+1:m,i+1:m] <- Qss[i+1:m, i+1:m] + matrix(1,m,m) # Qss[i+1:m,i+1:m] <- Qss[i+1:m, i+1:m] + 1 # for older versions of spam } # Note that for the final version we need: # Qss <- k_s * Qss + k_y * diag.spam(nm) # The form of Qtt is given by (Rue and Held equation 3.40). # Similar approaches to construct Qtt: Qtt <- spam(0,nm,nm) Qtt[cbind(1:(nm-1),2:nm)] <- -c(2,rep(4,nm-3),2) Qtt[cbind(1:(nm-2),3:nm)] <- rep(1,nm-2) Qtt <- Qtt + t( Qtt) diag(Qtt) <- c(1,5,rep(6,nm-4),5,1) # Create temporary kappa and precision matrix to illustrate # adjacency matrix and ordering. k <- c(1,1,1) Qst_yk <- rbind(cbind(k[2]*Qss + k[1]*diag.spam(nm), k[1]*Qst), cbind(k[1]*Qst, k[3]*Qtt + k[1]*diag.spam(nm))) struct <- chol(Qst_yk) # Figure 6: display(Qst_yk) display(struct) # Note that we do not provide the exactly the same ordering # algorithms. Hence, the following is sightly different than # Figure RH4.2. cholQst_yk <- chol(Qst_yk,pivot="RCM") P <- ordering(cholQst_yk) display(Qst_yk[P,P]) # Recall: # k=( kappa_y, kappa_s, kappa_t)' # Gibbs sampler ngibbs <- 500 # Is very fast! burnin <- 10 # > 0 totalg <- ngibbs+burnin set.seed(14) # Initialize parameters: spost <- tpost <- array(0, c(totalg, nm)) kpost <- array(0, c(totalg, 3)) # Starting values: kpost[1,] <- c(.5,28,500) tpost[1,] <- 40 # calculation of a few variables: postshape <- priorshape + c( n/2, (n+1)/2, (n+m-2)/2) # GIBBS' ITERATIONS: timing <- system.time({ for (ig in 2:totalg) { Q <- rbind(cbind(kpost[ig-1,2]*Qss + kpost[ig-1,1]*Qst, kpost[ig-1,1]*Qst), cbind(kpost[ig-1,1]*Qst, kpost[ig-1,3]*Qtt + kpost[ig-1,1]*Qst)) b <- c(kpost[ig-1,1]*Qsy %*% y, kpost[ig-1,1]*Qsy %*% y) tmp <- rmvnorm.canonical(1, b, Q, Lstruct=struct) spost[ig,] <- tmp[1:nm] tpost[ig,] <- tmp[1:nm+nm] tmp <- y-spost[ig,1:n]-tpost[ig,1:n] postinvscale <- priorinvscale + # prior contribution c( sum( tmp^2)/2, # Qyy_st is the identity t(spost[ig,]) %*% (Qss %*% spost[ig,])/2, t(tpost[ig,]) %*% (Qtt %*% tpost[ig,])/2) kpost[ig,] <- rgamma(3, postshape, postinvscale) if( (ig%%10)==0) cat(".") } }) # POSTPROCESSING: cat("\nTotal time:",timing[1],"per iteration:",timing[1]/totalg,"\n") # Eliminate burn-in: kpost <- kpost[-c(1:burnin),] spost <- spost[-c(1:burnin),] tpost <- tpost[-c(1:burnin),] print(summary(kpost)) postquant <- apply(spost+tpost, 2, quantile,c(.025,.975)) postmean <- apply(spost+tpost, 2, mean) postmedi <- apply(spost+tpost, 2, median) ###################################################################### # Figure 7: par(mfcol=c(1,1),mai=c(.6,.8,.01,.01)) plot( y^2, ylim=c(800,2900),xlim=c(0,nm),ylab="Counts") #lines( postmean^2, col=2) lines( postmedi^2, col=2) matlines( t(postquant)^2, col=4,lty=1) legend("topright",legend=c("Posterior median", "Quantiles of posterior sample", "Quantiles of predictive distribution"), bty="n",col=c(2,4,3),lty=1) # Constructing a predictive distribution: ypred <- rnorm( ngibbs*nm, c(spost+tpost),sd=rep( 1/sqrt(kpost[,1]), nm)) dim(ypred) <- c(ngibbs,nm) postpredquant <- apply(ypred, 2, quantile,c(.025,.975)) matlines( t(postpredquant)^2, col=3,lty=1) points(y^2) kpostmedian <- apply(kpost,2,median) par(mfcol=c(1,3),mai=c(.65,.65,.01,.01),cex=.85,mgp=c(2.6,1,0)) matplot( log( kpost), lty=1, type="l",xlab="Index") abline(h=log(kpostmedian),col=3) acf( kpost[,3],ylab=expression(kappa[t])) plot(kpost[,2:3],ylab=expression(kappa[t]),xlab=expression(kappa[s]),cex=.8) abline(h=kpostmedian[3],v=kpostmedian[2],col=3) allkappas <- rbind(apply(kpost,2,mean), apply(kpost,2,median), apply(1/kpost,2,mean), apply(1/kpost,2,median)) colnames(allkappas) <- c("kappa_y", "kappa_s", "kappa_t") rownames(allkappas) <- c("Prec (mean)", "Prec (median)", "Var (mean)", "Var (median) ") print(allkappas,4) spam/demo/spam.R0000644000176000001440000000211112346261543013252 0ustar ripleyusers# This is file ../spam/demo/spam.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # This is a simple demo, wrapping up the functionality of spam. set.seed(14) nrow <- 5 ncol <- 7 fmat <- matrix(rnorm(nrow*ncol),nrow) smat <- as.spam(fmat) smat[1,] smat[,1] <- 0 as.spam(smat) ssmat <- smat %*% t(smat) b <- c(-2:2) solve(ssmat,b) cholssmat <- chol(ssmat) # works also for large matrices: set.seed(14) nz <- 1000 nrow <- 1000 ncol <- 1000 smat <- diag.spam(1,nrow,ncol) smat[cbind(sample(1:(nrow*ncol),size=nz))] <- runif(nz) smat <- smat %*% t(smat) b <- rnorm(nz) smatinvb <- solve(smat,b) cholssmat <- chol(smat) # displaying matrices opar <- par(no.readonly = TRUE) par(ask=interactive() && (.Device %in% c("X11","GTK","gnome","windows","quartz"))) display(smat, main="'scatterplot'-type display, very efficient") spam.options("imagesize"=prod(smat@dimension)+1) display(smat, main="'image'-type display, may be slow and heavy") par(opar) spam/demo/00Index0000644000176000001440000000062112346261543013325 0ustar ripleyuserscholesky Illustrates the decompostion of the Cholesky factorization spam Explore some properties of the sparse matrix package timing Compare times required to perform operations on full and sparse matrices article-jss Code to reproduce the figures and the table of the JSS article article-jss-example1 Code of example 1 of the JSS article article-jss-example2 Code of example 2 of the JSS article spam/demo/timing.R0000644000176000001440000000332012346261543013604 0ustar ripleyusers# This is file ../spam/demo/timing.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # We construct a few large matrices and we compare how much faster (slower) # we are compared to the full matrix analysis. # Since all the calculation are also done with full matrices, we do not # exagerate with the sizes. set.seed(14) compare <- function(expr1,expr2,tag=NULL) { if( !is.null(tag)) cat( "Comparing: ", tag, fill=TRUE) print(data.frame(full=system.time( expr1, TRUE)[1:3], sparse=system.time( expr2, TRUE)[1:3], row.names=c("user","system","elapsed"))) } xn <- 1000 xm <- 1200 # first start with a full matrix. fmat1 <- matrix(rnorm(xn*xm),xn,xm) smat1 <- as.spam(fmat1) compare(fmat2 <- t(fmat1), smat2 <- t(smat1), "Transpose") compare(ffmat <- fmat1 %*% fmat2, ssmat <- smat1 %*% smat2, "multiplication") compare( solve(ffmat), solve(ssmat), "solving") compare(rbind(fmat1,fmat1),rbind(smat1,smat1)) compare(cbind(fmat1,fmat1),cbind(smat1,smat1)) # now create a sparse matrix. fmat1[fmat1<3] <- 0 smat1 <- as.spam(fmat1) compare(fmat2 <- t(fmat1), smat2 <- t(smat1), "Transpose") compare(ffmat <- fmat1 %*% fmat2, ssmat <- smat1 %*% smat2, "multiplication") compare(ffmat <- ffmat + diag(xn), ssmat <- ssmat + diag.spam(xn), "add identity") compare(ffmat <- 1:xn %d+% ffmat, ssmat <- 1:xn %d+% ssmat, "add identity quicker") compare( solve(ffmat), solve(ssmat), "solving") summary(ssmat) # compare a few cbind/rbinds compare(rbind(fmat1,fmat1),rbind(smat1,smat1)) compare(cbind(fmat1,fmat1),cbind(smat1,smat1)) spam/data/0000755000176000001440000000000012346261543012161 5ustar ripleyusersspam/data/USprecip.rda0000644000176000001440000027445412346261543014423 0ustar ripleyusers7zXZi"6!Xv])TW"nRʟX^#&'ƯNQyeVlٌ-P3)LY|EGre e9<Ĉ]Ϩn:޿̜|0p?f>¿<E#?\5 n`ZU<ذ 3w9ubH_}茩PD Qja07 B@i' 3ƽ*p`3 kўd6$^E^H!^"oUrd_?T7SHc;S:≐f(M!d{D,z"3$I#2 K(7Wπ|lQ卬߲͆3w:[*OaT=I~,4+!!v 3m`aVEbY[ξT͵#.P d]ep4a6][_` ] Q.L8TY SGgKwzxՠ3b,lHnV9un3 P]8^M\.~.Jǀ6Hዴe><=NLat[6g,hXt  ]Z2\jTU[k}swOHcg( hd֥K+;|{;&{X"d%_pZ&Pb<:Pک&0`| 3,(UO #u:5-OSfq*13Lz^RU0JddIg܄jq:W<`fXu" " u#a HZv\FSO_cv~ YS2ޠc>b̳n'/sW =Y[yݒuW+Xb=&+?e hçFV2/̾b$(rMd|n"ez<#S 37US~#URF,j2:A*齐%Z~Cu|COZ%]Xa%^7xh/bGqvBx3*^UXĄ\ lO R.+,"Td9U)9l7nA<}u^(MSwD#gʫOtVhW@ "yh4>Ik Gyɝn¦E0/7>(N]@(>^t2eCQ_X ƯZ;_OТrSK:jfUhlM_rC5z J%kjU ܑ5u HbAwӗ,c\&OpKIA~ZpHv9c'bq_~R~\ySji{2+AMM9G#qe#AU|X|JvM{_ ˋh;_WS\`X{r4ݷ}ۺ=D$v˺dL}[SMc!UbYS5%)r{<"[/]:gSSVhÍ,$BKY_'NJQ4se(בPf{Շ. .7^8g}St!.JVXz@RCTs #qX> +XP+ ( V|KO*@w@&d wZ㡪YQ3MݾGیٲ.xoh252{ݝӳ }_ 3H߼j RL;q;S-Y@]Qp0EzBE&OrAPa޿^(bX_~Cح Jb4<\&*鉈UI0O:AY1/4`P٢7t$'4Ӝ(; ekQg~DJx8Lv3x!iʼOss` t;DV{ 586Bi\<ȭHו7ɵ{#Kc#"bvwƒt3?|Ÿ_D#nS&RXHJ"GjAy]Ra_"$Ҫї. Eͮ0OMfL&jQPUq. P"Nȍ`85|ON?z&?(ϴs$ؖ:kvA}zc˱DNh'Ṳ$P HUt8>INW/a)z&4P-=D^:㉹q vwRzOU>ع^=85;5/Mo_7+6Q뮂]6AHL'c?<$ N-IPmFY\պhQpگOjss &gAf6.Rm6o`elsB 4vxeK-tK1x-l'>])*0}}oЕwнB z\NRI+匒c68j茚]NC;+%̈́O|h<.Kj̋+/olSiO=i{ԗKr-_ii$GTbG^<TtuY^ccO$`L bv`{$^h4gF^PZ{׸!D׺YnGzrgm<{V^tU()=}a3;w oC.q=󂒕~qAh걹r)tfR& #k.rÊU6$7fq{9 G1ƺZ)2 U$QvyQ@=#wez1ʷXw: 82_ӡrGaQ_mw?HMs0J,Ay`>H=Xv@N."#N@ biZ)F%=Gxlc^$x$Z%f.Fgj"# )$S/0 uKHUUȁ185+C8KQçHFtq$Ph7W\vW$l_3KB*&hh p"D~1I oJGB*K@4> <6''/*C!E{DtgP4RV8;x3QMvۊ͸@:&ub|h 4G#U4HڬӈʦUNbO-3aEFFOo__;"%}w9?bO0B\!)tT(4]Y)q3cDx.2w･v}bj(S+bP-_dkP*;¶F[ =,M+劾TH~q$*Aȅ6^q7Cӫ#ԙ-]0Β1_w[}FC<`üwXmΚRYʡ]LFݝ -][HrH~S:+l|NJ7XrQѐOH( ^gCKܷVk؞ᑒl5Cl./D?#]ԝ,#S*9x9i߂Wo됎cݬG{lҦ\#?nx 2hJ^6.fn!#@# ֬<9d%Tr,sz| <Ph"G"QS8뢩JY;y=+w**1)O}WQ,@6fז -}OFE*@7[OMMYE}^oCqW}z|qq"ŝdQZ,eU13僴S k;F,Wl4P^2t^ &ta}*`.!`oVCNl&dN^&[\_賲`%rRh3Crf&f:?oW^CX<ǻ6Yv!t;%KmIhr].28,nPEfFu_3jV 8SV3//+\ S4_Ȳİru +p`0J^3/JFbKz>Aݦ6xQ 2;`vVZ ":8I %vױt*qۺ5 4 cVRp9X>cry&f-xV ֬?Ȭ8w5J8CYfOԡOkNcYRޕNA=!shܪ’8EB戅ŦI&j]G2ŝP `ڮ#x,o_NYyӹbݩ,4ov''9'OYqDLh3ER0ѨNGiDsqX"G4Wr] wgjyk[Ei,v:/9 YaܮQl/>Oc^v"+}'^[ $-Pr2ToWBe5BC]rx%!}ŦII&s|+@ț7KHAP18{ze,eSm7/!述uv7ȾȰtuYaT"Z;C8 m&8ٗgl](*!^5j&6IUfW7&`!C$ n^{?QGh>.3'XZu0Q)箰g(;qEeAwA?&ě*[xh裚b!~B'ٮZ:l`N ibg#gdF6ql S(6hilZ2U^9_v"cC똚DRnqyHw0 ٣;( Gub2lA1 )D;O5/xp@I` 9HdCnh%$'B%yRm b3%U6V,SE<|uJYa˳P)9 UJk,G"E O3Ë,ʩ>/ U*CdyImLxm՟j3Ѹ"IuQQMNwzvIle4mvwQ0[ V$ƚ8II 2SPlQ'u4Ĭүykwh^''Fg|>Yw.T|i"~^L3-N>Njsx--fI 'B}(ItЊAT_O}ÃX'703|5|+s_bm'G*)W m̨5$Xmk`4ӡs}@} ^76&&1 ՟+pDc9U~I 0)hB=rezU)"j7?MZ1Y nte扠$HŻZyyɔg{^{E֖ƾPqZl^J}!2/;咶ߛ4OkHo=K QWz/q%2_{JΪ@uC9IKwLb,ۯ܏o8_tFГ2J!z{$815o;~zB~,֥FLw9Ap`tK%*Yբ_̇otc+DϦ/"swJIGT"*uri/' *ˋ ׳AmtYxiO/l<#RnMaW`i}@A~~b{}g,7cZSP?WUyJK]}TSQPmśw^~C8A⚰g WzR/oz+p1U2;u=3`зŸ]P>m(m ٫`9Lŋy&89E~IJ3ڝy~Ş=O7|#2{!X$`zFߘs^m0gɳz'eKCG͊`'w\9Xy6M[ݏn:W+o0LXvi"N&ۍ̘@'OTοr3΢۽z-5krrXv=;T2HCM"ROEė9L5= SL&۟jLo"0.뷜 3_xI{TT&TquN;eGN9=AɆDX6 zF/T(;uz+xu\X\諉f \bPu,|[1-v (=/[efݚ:Nu [pe-B\99D!i_^N 65\iL)3+UbA6Hhr=q] nw3&Rgr=Bk.-2v\^|w'8z}mu`ڀl]#}9]GK2K37Nw(yS MR[3H2] GK,rJp#0يO;-Shwj"8xF#}wa)&Yn`ZQ۳O,@/ȠhR 9uCȰ|-i;Z:LAoEܢaKܼuU -W"kd-"S\ȉ!;}0%}pBYpӖ;`J`>o 2XVL䡒&IOM_3rH 1r m~H6z48RG#n^b>7YLcPYt/nVP̢DJ)]9Q^I/Pr\L v؉EFyAeT\͌h*]/!Œ![0oE4#wGūFjN9ׇ ]d fm9OLܥ9 kKܷ&!|1}lR QuRũUךdu{T}!LKWj4|=MdC_beeF1*f#,J'T> Ǩ̘Ҫ7`7śT&JyՐTmK}n aVPWc}:`y21lefJbUo9on R=DmQ̀|șk Tl";5oH5MJ'`٣_RXUi˶H6;xw6b,qX`Dx=>Gؼrf6EG8>Wt> W4i^.q/Jۘu>躅aELSc/l ]0ӿ˦KPSQȞE ׺=oWb7> S}s/C-좼okqf-9o}dW"h1?>ѧcwP3Q9x K (|iճ4)BC-˜ɳx7Y|B89EkZ*-?rGbWYݧ>^m31tsL[~joY_l&J+Hf2J 5Jx KO X0G8sgTi] .߬a.kaIa׾ˋ\ꬱem: ̷2EW'ojE>,Ռ6i3zSl&TӫmݟMij +dVC'2֜HF*տR0@Oj_8^  /foݛ.(, .P7Y_RU%y'#i@OlS^j+&=.M %R5[係Ґš+~θ=$\&8,UEŧMJDT#p5Umhᢍv#^ ـo7 FGa`yXoaCVZqU*ORyu7 &OS'tz\-GK4|ʗD| F1bIsٖ(B RˠCL0{ZX?RrPXhфi6uh2 pA G![9E'q+PEPzSsB[o34xX9AHqyQMX8Y$[W#u޷5dO:7רIDkTx՞K$ZMʕ ;jJD&s9ۿ]~jNHpM\ _.Yd4E%nWs4^nf\k%UM<Q6w _r(ҥFjuGu6#k(bu#m~/fRͩ+!9EiA :̽ތMO8+qB/=l`CnUSeAݯɈ  Iˮ'0%.k<+4=5i} h eu7cO:>gF9+2izlF2؊{Qď-- Rtp aOek-VndR?zre1= JC."Vmvtst.CskoͶQ3QD!g߻b+,R$_3#DZ}ý ЦTo)#fՀ E?Ccwձ{dwO;%RH;o:MϤAT 6 p p/^DvsxhOG}I ;_-n:_˱g^ZǍ' H[HY5wgDdo :N/ D _hV뙴̿N㨯aq/_E"ԗB@`rJ/7;.#n\B!KvBOvݤ=Rbqd,/0>IւX?A48^ ^"3]ɂB@ڦMu.u_g@ ff."@5.*m-dҋ*M405-YnelwNu쾴@괻P}G;<4ezpp4IPfim>ݓڀ  WEPf-Z i[>t4w_@5P4?ćJBZEiMˡABWʁ}uרp.zOZl8w~lUBc;x sj"`B$s+Eh$J^C,{|kτXH#nOZ!Gz{J ‚ICP ] Fsx(:qTI5/BY0gc: d6;k>ZA{::UV[̍-r]JJ^@)D']>-X75 }^OZ2XV4KB]D<]4heO~V|nR4{_0<Ē9ҹ{\*W\Q%Y uy',fᕃ5>+|.#uwX$asYT.*w|f}l*+hHDzs`W|Q ^ O']v4kv%z0wJc >FV"Ptiox熓dMh^.}o-[h>ĜOw8XyWo&J룊ہ'NKw S{x6ٖXk߆'S=5Ic>Yo!dM*sX\df.1JI8 BDk|;`5BЙ$kU-Dsg8K5>2ﶱ"6Gz0L1ʚ| g#5o(ܴEm<XCtZԤpԶ 0RPGc/LiIk3{zT]5kBoT3CG_I햑ZEKO΋ŀ﷼PysZtA7a)%-92_b4Io[[Vm11*/Lj0mA@:jB.R\-|5W&32@\wȄ4BaUqCt-[<4$ XND~60xP%3Y(,a?Ž66nenuZO$`KkzkMWbjNѶV!MرO&mR|7P`gKhUC\n74C@MGUdXMY߃s0TPjh0DGlxlɶ8Ube J%fzjgf a`\lk3g??ݹ*̯?i}ʷ3 ? DJ]Y:#>@M]})HC;^C1:}DIUДiI(3T{825@/ʆ*\d6unJ rbq̏nݥ2\K _㪚3!6q͟"mI OQP SCp%e/_Ts}ʥ,isMYXih`vC-=ߓD. *q)f;/ g 61 㙌&35ѷb-{qg6J}}\] īi0xK1e;BAqˬW)۝6m}–ӆ ݾ{5>{/]vEϷ`Egh6@YxN%r y!bKeW>ƸBH3~k2QʣB|_cf;\\G@uVC>WrhʐXFa5՜ TUqhǼ2ՔVqE~R h~[r-E"s20=hOg~\[xQGEͶmY^n5ˡ \mbqU7;8"IF!aߥ2Lfc.=j)ZlcQ8eZE {>]Y"pL^ kKqSTkW򰦿֎B.eUg60{9Vo?Q1~ZΜJ] bλ "q 7%R>F&Xa&G?i0n 0XtdE]͟If<9 q}RH^đ*!eg*(0t1i>(lC; [=,W'z>aBĭT27]Wr= g!u4tw0|}s)҄'FP~ۈBb\7= S#Έm {@*t)&!+fvCȲ 0\q{BE:MW' Mt&ucT[4 ;083XKo2&$ d_v&`B˘t tpP0[GW6BI %g\7h怣B"PEn{`7w+JrK/W glF`V wy#ڜ*ݳA~1J/>TAڊNhx,!^]\ \w*yubQѪ)\O龴|ڦ 8){x%=?eBUpYse@HYmQXdEPyJ->BҶ,'a`츄*viɫ{_X>^=!3Ȱ(ru,ڣ`yG8 r'_31lsoZ[{u[8ԟ1,g8E:M9aG_l26+jFЌ/$j9K+ÂM?$;&D˅fv~ylaS ,΢W8H=Iq11fF0iOa5[@ jTZ|UV4\4Sz6aYc FS۷*a.i,c9ݚ5;QBA]L8X w; qK= ~ wDɬ}پ7v8 c `*L0d(>s:UZ 9<ńܠK,ҺX\ j԰Rm7;Ϸ/7W5U|! "-@G$FśV9&+ <ЗZ˙hPM !"[}oZv$.Oag A|hoNA*,{Ә\q:kPøsOG F0+xS@a/!F"nD+ ۰;ʛv(x%B]!#jUN`.+Ngf\] 2zFbkeM U'[U!p[r7o<3%Ub,Mֶ=J}59zYvSfHPtApB0)/څ.ח|UA_f!TY;f1P4S s:̎J=bs 5tA&ͬCڷ.mU_sP?c1g]/&~r׽s:Oc@Z#)Z+V:|C\{o^[Z Uŵg*fðOUJb87^,9cfoj-fVv=ָ3?33x3,HHM2hԾ kPtT?ȩq=쑜wUwZ{!@k~QӼ9&(I',?P|K iKV2C):st!&c@СJ&Hf=쏀5*\"KytIQM 0HR#,&~Ƞ &F[>8m:Yt0ʲ9-l.jS4w<;;hnSœpnP/|[ kFUư*' ĉ2YwhPgU'kCyﯻңd?Ezl~ib6[wI[)> &nBh7ĮQi/lG5I 4 " Rr=*!eqS}K(5:@0IEgw0T\pvz|<˼Lz<ֆSb\~lAʁ`{rqq*bO2PO-hh̎ˢzob nIv{Y뺆LG"oZ_lFP8EBz7Px q+H墛琥Cvz%Եӆt=ecViRp&%=5Eli઻Qaj<(jV崸{⥝t*W5.Xm!y]}0f+Nlu-YsJGE- iH dJ}Kn3|9d0n(?w)pO+nwUsx1Y0y5Gxf3j$Ѱ}lXAO섀J3*G 4H!MeaN#+He!BS@BV6. QS,yܥAę`HXo%OPƑ.i? ]R&ٵMz7aimvTU$Q N6u8=Ƃ2t%UcjĦ/ El^&yY|dQ^M@/9ݗ5 bAB搓ٜ.dM5t3XV@~]y%,cgDjmZ<{ѓHw+Hdw{%q\[~b6<8PE`N _O)2F>m*MKQNY]2_pXo:-4͹Nyx==ڐFi)+>6wydö#n Ԫ;uG@ڂձB0>~c>OS5VZ(EW8οQ}lS6̨,ϫL- Zףk˜&Og64\BlB#x9m>!N,| ?+<]!8CԚ/dˊo_%~\]t=N2zatR ςb!+MRॠ>nxE %kbLcm!I;@ræfjpHj$T3#bLWn+w2P)k-!#.^QgMƄRGld 93l;y PV(j-7ej[@)OT.Vh IZ$Q 9Y1#٠w`JDGo" X1#7ruuҒ 7Eje~Jb2~Ӟgp1}A[fUeAPHBLEݍ,;F%D&k]3 Xh*e??ϸ& Dˀ yl,?,tl#"-=^[loF•p@p4 ސWmVntO"Z|~jug颈j4=pZ0]+Tyݜm@u0 VzFŰi$֣z'}]섚C="3`Yͅ-6Zg"Zl!WByU*kL=&_]h e\fez~A׹|=RtWņf\ iAHs UX41S 5fjc_;wNRhaVEt Gɯ*_P.{kiu 0%pT=إ Ml@se )(K3BpOFfV;x QB- T@O\ճMYF:i(MTht+ξ:98x_rƟWR쪛0OL҂xI%`uMEVٶS@ŠCC-v ̣7nԂN!–MF&lB XwUR/I9:cSٰM@-ɩ| h>ߨo/SO_&JbĎGS)9%^}ϻ*KY ?˟}. vE֐ 2z~Uq{QtkοAh~NH=ڡ7Mlهm'tMQ!$"/,f<Z|"Vκa.!YG]~];o,ϓR) *GΛSw}JZn?*9Ks`'ir}|n(Z5["#Qg7ECmQcX_?E)fjjiUX%ap\c7c$L]RͼW'}e+ cB4s[_?]$niOVbBԞaUy &4-T1;ByȘBSd>E G$%qD2YH:\ CbdfT-vea5[=:P*d&@@cRjo9!CPO*wc?غjy4{AЫTzt<7^4}ԏ^XM7^⎛!j5$Tx\x(ۺҽg]4<}Ynמ{/\7]u8kg fީqBڴaá@åR j}J }G8 R+Q(}\9JI#ZU1& kYV>f'+Q,hP*BUd-߈šiݴ<x/lg4SϯDR!$O,,RUiZ\lf!Ŵ j΢zZHk`٨O'O< bIk er,0Koz B`8}#qyJD VbUW9uXZǐ yC5Kx3N(ZPHlB*27}@~AH.m\5åg b? /@V*UY ik"ПR,D?-5!;ZۜY#\YNk3Opf"D-XAL6ejWfY]\ raUjߠ-\-+maF(Gd)˰x\c}Nz@6uFFh|-]wEx2j 6~rnhW!W ȣ wsxoYy(B 6NGZeVSev~\c韄=nO&⼚ ks|ݝʥv΃,%F28rQtӢ4ߟ{ِwy{wRH$P#Ŏ!"lL2/aa-p >f܈kmQhרw7>/]9-ZP\M\aP=E=MrYPcU(5!`\@\k _.`& P~\-4ic1s!˦ H&B&EvB\Zwn{V\Cj-0bDL%&(@19 ٓ˲D(vK =39jsuVIDO=c<.9:bv[LxN\7 N?P ыd Wșc(r.#XW 0PJจdaa m7XxrJ@DMđw)[*Tn"棷KC~"I;ǣ8vn4l`i^sh#daU߰D}(l5x+3 kf+"zͤjl/wqJVzMm@ uP ov2'/ xUpW74c{H^,?J_$}m?{_WRɟ'V 0_Bf-.ţE{jgC7s1T_eAf+WI[ VIv- ÏQ Q]ѳ;zwdIE`:[އFRy O<O_<{ӰY?oe@.$m3,Zˁ5'ZăBV8 G\U vs\e ^*dka"1vv-+>g?[?gǧ%,ه!Qcf晰lKKS5@3 kT.;wR( 36mW"j1D"[+k'[ISD-?(zn靧1/ Ajh-o t*'cW4n3[Ut+eCdZŸWc Lj]nz^J( S'=~AiH 21,: z9a:@hʓӸ/z~,!p2t`bry͝ӬmQsTWV/_ݻ^}_Ea,7jmY[^)>0.+<@3XP1ZZVAV1ۙ^߈hB1--ǽRgخ>pМ<21GUkh"DBmjGd?uMg>2 \Ho1 ^`2&{[UH}PV[U U%t()&F{ wQcP1hg}FRBR{*AR+л3mV#N-^\ܲl;(b(TF'sMo ajMzV L!AuMw:cg:oݽCh,]'SV3ߓ)Ӛ[RJs<{(W$]s385*b@>mE뱖{Ԗp8)oOTֈPa => OL;*t%IYT`PnZ xK.#Ȱ7X#779r(Bad ͻZlv 煪*rdY;zion`FFa^waNxauI>AʒQT "^c]9Jnٓed( JT:}A12n>^|k߄{-y3LTiMԥ,QMwa )7q"!0Ddp8 g'oojaZaWAĿM6q3ʛߕ^9 g8x Zzn*L6N7e&V*pe6l]Qy(fA2iK"F,o)QL ǃ?κҸvRZ_YƕDB޳ O&Jj,#aY\a쬧1ul T+Vρ,sPQAlB6Ž}SuWP%wOG.#5 ~JG ]Gd*! #ej5z-a(yImm^ n7|{\G~ #g!$A5j`Cl5W(.yFlT[ ^F;ա7a-Jڸ|H:X QU!$q(FhH .=H8X{~&ICCb0:kգ3=/ړ6^K&2Y{K;4~|JDP1]&q]>C"kCR/$%.I04sDRuc +i|)77\[lXb ;2爻l`` qnw$8:Hh.(*lD71 ]Ҏ*aKڊeōH3Db9av\@tsNAQiΚBHlG2AtÍ/OFYB]rױUt)D2Ìuv{_A{FvWAzw᪝Bo/&(0Cy4ҚS ;dz1ͽVǔ:? >>f/4t8LAa8+$>q&3&OzZJsF6K2oM i KGL xyuwexS`}2q;>2_anO#TK [d ( ۇ iZr1TGQH5w :: 5q|0 DWqH[J^7(C%睊GVU.Ёs $j[6~2ʤt[roB$꡾f9*%'Vqඅr :"S8O8E/<" q~{PH7mTL+0a|8A;'Wg4˕`)HX3jrppM oIa) eNX搿ѳ0nt ]>Kw&. IFP&Rķ #fg[!.!ͼT2"z 2; Fb3@I(6g&][`ܕ"al^̶Bƭ1'N)M0\m6>WEIY]= ,@'ʼn˼{YƏ]C&;5tg9b>kylTğ(XOmaAI^$^yD=W%b:d%Yyfy K/!"`NY^&27%. jD8>3@8d)B53N!o!d*I?I H0ZXU|d-@9XM,$!)MK8 )v!3aDQYDٷ֤6 g/[`Z?j.o#FOTj; 숔o$eˑCL=CFm!#rpQkmc+O>LB5匘mj$7?eV7^`c驲չuow^kԶKQqT߼Ra]ʘpC.t^mp>ި\p cNh3CP>>ڬkm 'ڥAs/eG hYK7]V'\#)' [C3wq+*6: qŪ|_5i*v%=7]}9,+>It6Цs=Yi%%zd|m̻oyzi+H!szK 7$)v;rXroti/!'BdT:j\]g@TU2;@"nv`_0_NEdqt8>:OȨ $hqÅg]'hfˀ&? ::y4IÙLV0Pɜ.)=.Ȉ藼>c`BA'ż+D|[>$&M,Iv):/d5}/R#Ot0xSeJ7(Aj?W@+zr}ꨅ"BXXʹlj:(<^),Ѱ Q%Mֿ􄴾P~i,eE^u{Lb)ss1w7хV%NciizPjюhө N1{slKʕz2HQC+6+_5~yu n-beUgX.'[اaf}p[=n*@DPAM(w+4*cH,`z@MJ6tg=b]*jR^0|9Q;KNpf57-H &Rsq" \6I,ϳ̆.0W6H-{pJwЬ- e/{}z&5!9Lh3Y eJJFM0q!@MCz'߲ Z:kmO{̓Gӫ" ,/(qH*n c'F#Bƻm zYEu tFȴq'P(];~ISf7\2<6$NH51%`BJOe> "{/?r tWy0t. ,3k4:I9n,<[T0ZfL-as.a&էE*–BT^Xiv-b[[s7e0TQE >!:k[=gsQ&X,c#[cH9{ PC$(1OFg} k$,5B\/-"|/g,o,6Ny گwRB|ژH.đ>7+ʼق +N8kVa;oS;P?N'3풣^Dp*|\3&Q¦]ܸ }al'SRNĠqV ! `VZ66{wGVb/`s/3| |{p&Iz3H9ݽiV lOx2Y0Ճ>U'ʍ)Q7b[+97y@ G Ͷ5g%y?o޿.Fqg]/"Jm{u=a.4,!fߟHnGai8v?CewQa:5nM{X=_2#:,loE; e_ S!:^ܼ*u b/,HTQeyNo hOi&O&d^[WLBuP]99Qo,Ii޳  j _8yg/Y+tdr=u_a*B8 8fzCiR$3ybn Ndl Yh띤- li-P:&U9p]3Ը}]q{;}4Rj:=_}DZ%Z|Kmq~0qs)k򲟩,X:R":zMOSk@~}R;c .`*tW趚QXN42hfXOa'<ˡgL{(nEaRWH:ܳ"̯6 ϷDE!꾘3Gc`*uCS x{@,1) Ɂ 7SlV8 lqsCUy6Ʃdt[ o)'W˗6qª#whsnd`mL/B_L/pwSXffȡ"j^P-TV24((Lw41:gJo\Vz7`SH΋ zV= K淇E@k^Տ!6k槶WCHÂL1b@Mߪ"8l |t晘_8 震 u7QZ;Sm aubl*!diIL;cnCO%D+ˀkBD٧w@85 mM-8E FUO.yHUCu7C6rZ#ŸCFQԓV_{5ma7տ@] I(|`,Ep앦ۍgkCXtƅA:Ed+OKsq :Xb]yL?-`{6)MrCpTWGg3Fx?ڟg |,e}Qa]VH9EMYG֏݃,,#9Me~-@.HT9̘޵ /U,g$'x %g]q%FiȹA[\]<`-y ly(z["g!2wuc$%`rADϖ‘Nw~!eor;^jc#BkSLH|36w9qյҦݹp)hgηۨ);% #\\yGxUa\|Z8Ce3ۡbzuB4 tImޔ{;R9S?@-I}ib2l]l}>lYCפ_9 KᨓinVvp,\~XU{.f^mhoyw~ `񒩚³@KQF_r>3- 'v=s3`:َހ]껔ha[^k'Q[UNSUYg?vZ2@pWJf ҳ.䏏@ޱ:ȳB<9a@OBgze>Acpn?$ε,uwwTȐlbIN#ha/[&ēq`o3f8Ifkc(4W` ;!nn{a3۞V%'E*]88k`E+m6^.{߆a[f%bd|.sm tn'1!'ǐsr4/A2-F%@r>;/ql8m̪>3kvayzV.#rU1[8%J勌nqO*re0>#,%1NvYыf N={(YNu+!!] \f8Ir+ao)}O|Pz[?O#5++TE=rhh2oG9; 2tͳG/[1_qߛ&2S8p'I*FH,B %?K|l Mj=:K~+]<0٩Ő9Ya_o]_ޞXwX‚x,9z&zʦc72kvѝpJ3\s;-8M-| m68f4qs5 Y2'E:zGtXɜAsF|?aUSK?|5\"Z/Qj+#4N톑 Cb7G>".x}rr'"Xn'1[x&~I( T/Pc j\uV~bɴK]#ya"]ǵK| 8Ϩ:W%6kob$Ц8U%)z߯ŶBMҒNJdE!! ?]ןzQPwL_']yՃXힽ)/$}eq0lw7é؂ӳJx>^F6@Z.6Ӭ3H`z˔ݢ4M4 "8أ)8>]HA "ܦA84?m$f\PgA[4d|4T#Q[5ҺӛDj?ɇ2Æ+eU?r7o Kro-Y:FeH R %4"?_@_9PK /[5=k.1Q50H\[Dy4  `o,R 3/VdDmP*lv)#XSrW.&*;%r;܊nY,v*8؋edV3΄xZ`]5FIei 'QŁ<?16BCzvoFUJ}eJ'v97jʵ *K{*ߺJ U[ g1)ےOz'xJ/}`! S8o~QQ[c,&i3N(.mͽtY%%!LRJDTThG Egli!%6xPZj&C*!oHˢ&zxىE˝:y'BZyf3ΛC|?,Uo˙hjlG*ƀ8t_~QX Y硝bkOC f`c 7ٴV\CMNݞWcN5Y1 Ѥuj%Nhc~d&1V$J(0qJy~}E1u[jz["U`?>h&g\K@l~FdyvK(ì; 2Me7 sHq #dP*, wdmr;­6,PIT gV1(%b]u4=z^[V@ ;ū4/mC1uwmx >RCX|.AGq?$s9+ pJXMji]XӲX #a HX{E(XN'{o^&i$oD-o\ f!W- ufyiM<_'vKhAΡS6,Q)KkU3ر_<$r!x+3*_LbJXRii<>Ћh?U39MR˜QL|_$-uk> W=P6d`fSyCw/}Ia1hhp1rCUo\| fU:uv nIdڸ ͮZi9p~:`}$jW3Ns!BC z|gc%d b|Uj串0yGhe9 <?ҙk34F\eb5aviaO9xdꝑI!,]yl"E _$qQ}|^; o!,yG䂆hegp5?FBYwb38IF, U^϶qAV],? aJ$c-5z_kDy41xlUU|UkߪM|.YF~7 .4:36+T#WK9tFNm@{]@b]t.cǰcQ) 87+{7P<{aHqR&(ƪFBmDDQ!ИdCPXZ '+= dհ•S8 uYЦMXqPD/ujqG4K A'HKjDuG .{;ԯ(*6ECB FW]|7e3˨5J0gc5H/pQgݼ1V_N9 s!vuMfﮔUթdf"fS+-M?f1&!vtku&~;L-jCY W҂*|ڙd8f|a1ӐWX=*VAk%lF);Lcc.2=K]pڢQ0)^k0 ;XBnw ],ux9R맓h"^M۫F#pz^c9ic[ U5Wj'N5J'u{FLFFo6ӻ\'9s ƐCZf(U49e~hٽ?8Օ u6zbhvimVh ;I5߹Wd/fڤV88&^8%YLњ9^hrlbbˮ`^ wHr?߲ oO_QfZJM8f& aϾ3h]vЧoq2Tu7%B\F6;_rnn{+ \镼I  /Z A9g%*C>$@i*f8!Rpl0 ᨋt] љa$o16ޛhf&29Rw Ym΅[RE,7}hf7C~:/ =M+;)nWFrDEGJ,_s' 4HhşߎeF2mھZQ8mGbDZ ;A .@To˞MCH3ݫle!v`DvAmYOآ tDsˡ&þ"n5g9# SL%dғA薧Lh jᕿq#)-P5l~S?TR%ٜO`T7.nku2Q?Yֱ}R: k3+prh  kqmu ?y+v6"'! Q2j,");Z@Wor OvQ2DFGA61?s0\ 8ȃ^x "L>2YyTRBcS&Ã[%$c~C2hx +jqITnY?W.n R91o[UŦѦ1q3Jtt{p{o`[Zp}Th UYSHg,5ܡk6g(X[s6kAtGI;P},OEOB8[P۪KJsQWW'8-LV.EY)ଧ>BP^BVz$PEtw?L Aח.p2Q>Lc|9*<v%>n=CcY9g|9t`K#,E?q;<3_%쮈и0/\dK/86 CMr hUZu. x aYrXI֏ @GTj±kFog v0^=?K\:C.B^SG[}`ӯByn$9l@,S>M'$r;znYA"HcչD)Ԣt1A]2a[&z洯70TgIQ=y$Wɮc"ڇh3!ے 3\}Uм5M+fF-A(0z7ahXwy60IҊm%̷-؄W } #˛P;lT,:aVb”N2-SyO(_3׏077T]-12ݑFSXG5MuL{HuN`!_axu۩2ꑖ(kW /Lƺ>Dʛ]'KkU ?QWᴈmTgTMܜj]fфu6 @nT lB1S&Y( $cz]sQ0׷O7Nm5KcVl}[& %k[p7}*?<3%B)yLQ 1=/EPd&;v`k %:'GސBvj~EBvz%"'(SQ4r뾔.qA wGdqA.AD$Ar"Cس2YoSɇRDq' ([J9yǘf wv+ԵPTŒ  }eE|~B4|̖e}9hI' W,8z/`Se%I|/r HOp.*b:QdSY׽tRƎMhݧ6`sxu+d!LBIy/ۧ-,ϡNz3"uK][K[?FPk(oW8Zj:7a=WҡZV?dГ &gzpa@͏Cmm9%m)2x^C4 %g'ăʟ73VKH%)YntV+Dz;Zacu o:|vICl(/ shA @znΙlv&-S'< FK904V~d]sl] /tRic`aʘ9ܵʢ.lkYgXDAgit qqׇLUb[M t}s vV}nClE}d|;Newy3&xlߊ'z$ u SٵdH&aD7{|nb3@?l4Ya\.+g25f6ö(8/36I.2av0ɢ9,+31.@eCgo1 >/gY+lk[rf[#liiwĆ#i$`P ;Ɍ/2 4  Ph?/szvj^r-[%DN鋀Z7R6[6|C:X%6+Y dᡄuF6SubbYӖ2}k-2́Fh@O]}0,qh/j_[{gzFnbsY 3GkGOYѠЃ5^U 8 ח+k+/dNv`3eɍ@὏fq3Z4G&&ɝ?P\]% CB£y[w:[\iV0W}&B ȩ󒠻4E2V /ȢM`KPKZQqGYIo5< ~,$;O`R" Qq0=~Ji}ǵ~H,k bBCP&[HVe0 !=U~ .p%IYOK~OP+?FpWwK ډo%{,h X]b8ЫkF|-BSyiR;J.lXїٔiɞy8 Ѯ ҶLX4SZvw_H"h `!M _g7YD]+ FʨnL,=@]Ֆ2ߑ-Z|\i<}faz6 jGz5F0ʛvU^jiKZW_2 I:o^1[,pCe ^Sgj~iIER)Uywcw\lQܡ##ogWly- {ܮ&Ht mr#<2ZuS}F.i%e׌ d0g]&>X W =ϟr p|U ̷ٟq`"S;L]:IG R1)1qxN6S h8(ņw3 ңxfǶưG$.O¼jKt/|;;GBh.z؍gA8ȑB 4(=ϙD +nORc*LCC&tqV^D#WޣmQWZ#pxnG(h($A,>sED@-;Z.5q4A0ɔpjPL'6YytiR@nuuewr~ D$E]zhKN] HMpY Zdvo7YlGMT7Ϭ_fHu !qt5┛8Q<ކyТUۓY)ptZKRbxKdIgi"yhhFzV4`ޙ9iO~@p+ŵE1lVnWy<,ΨNJ𤘝|프$.~r]yM4 )ְ5Z/9$=awWSVfG9/Qqxؐ Y9 "򜉋 8)'H/9ei ͐nGcW ϊXAiN#V%䤊v=]VFZZ=-?@R ` t[*}9hJu9ߚ*EfлWLـ\&<)/+Y%:w#+?aԃR A7N0"z"*v[Z;3BkA K? R_cry%cYsN ǿ쎻 ~?xˆG 0ɾ7f&֙,XKFD |E쐄'b(XnA$UAI,͔HeELw &():@nu4ooX`?LkNv&1V)G\)"΀W* v*-A~^2޼_J=BDB.71 Dd޽~4kcaNx- %veqOҊ } N!Mf_Dt׬%TTV{XEJU3Ot.Q+$y7 [ܽ!=V핉QwFHdĊa5(vOYX"p+('#*z~ڐ<{Ee1WWzhpG/@u! *-ZCg^M}9 #%庪95hu]xRR>%C.*)rh[}`ҽ~OUV-8|Hs|^\UdZ,Bbޑ͐$y'0:%E i;7ՌZm KE̀Q0|`l5ߢv "i*4sB<#V|UFqp}ƙ7sd6[/!!R_ k;) FTfrȘO^V)(,cu -F(7Di%3T*k=Pqarƅ v_V}<2wLɝGt;N)Y& *¶#Y)1ck o;NIiSX"m ݰodmSinW]5<`Aكϊz1 tȓmY1C_zX,-Wrƒl*hSn6Z7VoÒg+@0,*6?F/;bZ~hbalUApՠ A^3QeC;;-4- 4UQ͒=BktZ l_Q٭cS31,ǣ0;hPȐسgEҦB\j=i"Q*Q{˵48]T^nMy0@ƒ_&x-Hl 3"iv?(-aֽyn+A=n[T_} | V<: M4>Wsc8ȌJϐ Yޔ.*Ai [}[[%cގB ܿ#4C<0'o)E АU4"1XИ&[t5\;}rDpd/!4.vm 6B4;m DXWk 3,[td˶Z:7SkD+3qpPņN uq{}ͺlUZ6RpcUX u{YuRi7]"}dо.EI\rs3MT} G~{Bow+V mb\4_n5y%q GŬxU"ƒ݊b;Z0I3#eȤ{Ϗ{cl+A^W'4뤨v&'0DgRzmvЪ0 {ѵՉ/].OWuÞzږ%@4%y2>4*SñjjWGzV*BݞI{Z>a̶\(7ac~4zf.G`s]!t[nH^LRh~鞤_-m"yـ,U3L R D3lG\3x:E*ނ *,y?9\T u0_v"u+aS{yF!z=$--zX>=ÞfSUDZSjSV}r;; ez>xU&y+W Ƃ|ݓ$tfIiL{eJ;EkLIpSAw"/a<Dvܬ+J%`Np?KMn)uv³߮> \HF&["%ou!!ݧ3BdZ/`=dl}a8r%?q]%P{S*l~Vcf^&L\n|j%GDFӥ5D<zbVA*Qt/_j"`Ͳ{^8uT!*57j2L6̦6e GgnݘR~CC%i_`8:JVsy*E 'U4"Y[c~qHɷ ʦ4y 94ǠtR,_;X@bf g§UZ&NH"w 0ZJN3qDxh)M`*.cx] \ _S=wÔmUI:)O] 4M[:_t@,}oLuUTZ%K"WA:7P"5n1Q50Cε!JL!pVR1[R;JIoU դrRw!)2u Zr5irAWu5O8lۂ`ˆ@kX'6 [:ƅJFYЊ_eWqy% 0, ;،xEEZ]efsN}S zWDs8njBJ8 Q3.q8U+Mޭ|LTqebsJN=O G(C7,Xqgbȍa"b#EU:1%*pZFɼ W=q*Dwe;)wXhs[;A;`KdHg6 $)c;:<ϻ1E]1ޡ v}~sO2A]2*3HxI >Xp%ٝGae{ģt% u~Ӧ79ˌcPtQ M:,i *zl{m HyR"aڰkPWh!' /E%k`i5*H%&J۷wͲ׌qwnl ]҉y:Wg NͶ"tQɢ8̣ZS`lk{6ko ao䖼LHJE#9sNi;/zGNc|RgQDpUK{jAH`Û}/lhVT,;I6 yaƐnx"JTؘf?%h YZp"j`F΃k"ǝ^B~W}HZ2B2яݱ=s)W6Nay q}qn|{\qqzտoqV=Zjhm zF9e7f:7 a<쏧=ydMNU<8puuں1" G:$qj*{ħ}NX~8)jQk,'O=>NaGwiߨ/ 0~¹D}Ʃ#%ћQ&Hnդr=MXV_y`RnTh IC+FP$\QrUi\ԥ~ R ,[|בzwT5=p[,h0uO^`aM'eqa-%]4:9's"5mb(.iCy+U< `B6_~lf~ױiAU=͌eΔXH:3WۇqYAƭ/|gQi3. zx#*zpgcb0}833u8G\t \<г@B 苖=Q_Ǣouǂ6FqFo*,6וLvԖNF:6>dVg/Hp 5ϹYP-@\4F2 2*+!4,7է^W}ڧ#&.{wO~L_I9_pYu8;+.I *d&0lChg]ʡ@l=w ~gZyAg-Ҩ^􎼧j|)#x GUw0z$P#vRc/ nH@s=:q޲C),T hSxN7pEZe"r Kqxd*"u4PeFNW"|3"!V~ B4IV_ 1nxa$Z ;6)8:=K̍]li{ƃ?D4_% X멻WkTG49N^&)&m0ŵhUX(Gd+^|sCYǝk#DM0^d='p)-(˯,8pg]SqG*}.21aTAN}Tʰ2AO;$!zrIuSn G̤xi-C&u߀+7DyDP:#X$CŰM5A4hNWJgF8obW|wjgf"1lƀRRZ:1O$ܵ5g}'c\Vt=NI3*;2;bO^N蕙6}q 37.&6Z0:cR.?Uu]3=b~%b{J/IgE58g <وaC qٕ ⑎$ NlP=R+ue9ZSBbW&Ｆ)R|uz]dW#ސ}׃eH\B sNߪ Ɛ= fKƵ2v﹇{! )ݰ t0i8H<,ciJ7_Ҳ<{IG_,v2Tbwq{Ү[0Sp<{+ښNQ^TK*Y b5)2WݮɩlzhYu o$4c& wϑ\oQ\-G-ۮJ?Fnn0K^;u [ymhB\GQ$&?>">ʽJ݇s *T'X{8ʀ|K` } C콄{JH1ٷG21ֿU'Xd„2RRġl&Kt^0~*̺HCIX׫f킄uݴZ&D?iw?0:CnnFe}dZH+܁Xj Cز%xLME<3zX;!謍MaD<\P\ω6}yh 2ml9qHJvX:UFw%Gn^b0FLlv7"zh0C[yC׃On|Tx!#h^=Fks6ˉJ|j/;Bދ~aͼ5Nxܮ`T 2꟎5R/Ws JwȤ\ϡhW͟@ak>MtOP`"B4\"DUa9{ t'Y~}B:AD4g'k|I 6`>7bѨ[q$0i>{nj"T=K9P 6f⦣)-Hlz)de;6|sfZ@Ϟvi43{qzf-8& pg0YA jyGnIYĔyZ)֞r`/Rfڅ~z3|\de!@DPQf{YAҶ>T%?_!(B$Ϋw*D3yR~z!-IZ9 rTsSLAU\aOuY&L! kG0vEGpB+س(q{\b5º),F U; &Q:xƻ__Yu,7gb:5q=l-0;NWEQOltD6y3Æcz剆 =diACwt2JpTn{V_f!oM?\U&hՇ+QVb3yT.!ao!q"8 S7^Jrhqiz@.")%>K~SCai.0ĥڛ ovY7-_|H Br&t5+WdLXfaeS=;2ܙg(-pṚMm% rHa>o JQLwa:tC:@*83YokE d] lR &O9Xqqu8vħ(K!4ʻ^52)؛G+ 4$ً&3([ ]4Q׾P OR |  er"g~`w:\KP NSB[" !$$7dX#f:g2}qvG@轓U?_T$2, D#f69.g:@?v`)D=BdhF+Et] #`a q{7:+"+ງU<>&]ç&p_%p}L`~_ٙ'Q*oz}nYJB&_⃨]J2^ٟl_  ŋzzz&YQukU/ĮuaHԢMID,a6|7 t8sRaEDe'JacA BUAB  uCk<1˺I#$>2siաvq 耛ۜ

6f7tw(1]rI&]'N7g;@K_W'tuóP)Ĭ[fռmV޷i: e]Y@-@gdE)4,:u<5S~Ě"&)J1p-%`H ?ɾf#tShMY6OՎ< ԓnȊ{^HR$;kd 〿4ϤX 9,Wy2+ċ̩g%>7vm rH !l7%-OI83]ŝ6-a6p@qp^zj38JA<3tX 7E^tiֈ( 73, uMC7 wGU}!g 25j(n,Fi!;ЩlRUY wż GP(.NYͲvp )_eI2{3sHfrZgGiŬaɽ̰ VbUE1эݯ{VOȲ_ŔtC$Ȇmk)wj4& I֋.f3MuRAtM[ex|jQL"QɛVOj) 7\C 7lW~BԞ@k"AAB!Yr`'^bnA*ofEU3p(mU٤^!pLτ2VqSdOdQſ%hSihtG:E&$G7)Iy͛ݕb@B.@s(t0]ۥ73+:dDcVݲ;J!&z=t7yŞQ-Ω  5!*0trY% _zk;NǨ Q(M6$+ѽXt>FA+oeLҎq$KHS駐`}ihnC!f?dX,j,~@d_S$ D+'A(@8Trj G~m'%cs4lEd>`w$FK_"Rrk':EpDj[pH߻]ቬ7j \T,=BY@'T̨*Wup9 Q3?j hԝd|J(p)VcJCtR0ZP9k/d%Yc.L+4cu$VlLS' Z@'y! Ž>25WäǸ»1 8IČ[5gDb0N *8TDUG_aCԸw%E3)L>#l` eDsD'18$- ݚ%|N-(QL_,?U;2U(!,v!:$ kUN$o56GqjerE u>tҦ&Ȁv X [0d 껆1qm s=U6_1Lx/)3{_հT`]SMwűhMtR//fPf:~$}HҨ'jrdaCR]ytkGBVd vTjgMA+-vԞ0{KҭɞeQZl쵽?3meΔ30lR&PHRaُٷFO\.?Jm:%kӛ" ۹ȟ´_Ӏ%(;IAgdrL-MpXɫD"6>Y)GM1 Aʔgc~0'yE'v›wRY"15@a\aD|#G.em&CB| ށ-uۚou/n&ٖ7f'ȀX8rKێyY}1z ?N(]JКHU~O1HVg ˫g+'ri}8 gW"taӭ{7SÒ]9۲htQ)^MߣxI4<=_)psUTv$ XJ{c _n'G nSEb H.jk6%T͟.9yZ'^$VuȏCIc ՁD@-#ti?xj|fp:xv$_N5IF>е[n풮*"hC9wIM{X ěۧtU:1Gsp0v|3Rѱ"!(4=ˍC\6;]61%4O1)}nϤnH6- dg#>ƥSo`eA,>y܉6PvbJ@UtA/LUf=)_@|-u3&Aui:\O'*h > ˉ,pe3 12YηTCeK_!eϵ=&dn [  G$nXi/6 {{|#ݔxtj?,Ƴ[VS FzOV#0kهp.)e|X0Dv*VmCT (D(/Z8 UNAѣ>}gzN  s,MW r@\=ܿES*Yb :bLC`:5h1] F]V!.ѵl. F =D u)de VTVX̬1L][G.dF8ԠlYfטRFO4YSώ p >q{u*6v@]*&d59rJ2(E D+w` pǵ__q?0eK1w4\h& 9Kɵ]h06"W?8c\}B(^Vcb ̐" T=[ '#SNgKi.8ɲP%x"n5I^fAM27(Ơ=2xŃ#2d{(zdo/`|[U 2h %$< Qϻnl ޿s6DJ}o vńAik4C85wy.1iT(Bb}fǸC;:0: :pyXtR=.G{/XacZEϙ@3m1<]mܣxA#=ޫ'fޑ;S>D#k GoL%J^# %_b.ZTLs2~' e>M|FV5ڸ! G2 α|%*0 r`|hX9@ 1 *pR4-FkmaW{FY%JLĜ#dY(y&9ݭ }i&/ƴ$o/{- "Kţ,#} ЖoEk>|s"wKr dLJQܜ,N']ٜ)=EF۳uɛtL yv}e2m$؍aK6~\[+T[`S"tCU]MmZ2j@FT3n_i%uL<+>7B?2h 7a+bp6x)֕]#YQ /;3p%$/ĕgbQSlghl"OuS o &WHk`ukN}v!lR<,:^è`JepE+li7r4n"[xY?po]nҴPj^}z\.UφJPOw!'a 6%-ҭF{]ܓKt!ji".$l?j:h,} $,)F -E)м+@CmN^ZjΜN֌t4˿y'HKu6& !)d; m:JO"kH? Vˉʽ-[3UmttC)ga>9iE' kOAޥ? s%Gs#Ÿ.J=X ?ScxjA&uK"ȷIpIVө7{CӅPa,܉)͑yU]5HP(Xdu5é@ݽ (9>,oYV-G\74B$4b}e5/r|q}ZFD;Riyҭ Jr=#q#* / AZD.*>Tzc%ab: ᄗRkULJK4/yaIPuq3ڨt\6t(.Y$eT(ZכPȼ!7Mq7@7V_`%$}Ӄ$OjoИ9E@Rw$m$)z;E <5_ȤduY=y2ixOc'KUHP>{܁Gt]ߌ`jC>z*Oղ𞡉aa MA >d@ه^*xβgLn]cg+BIq]_CzRfJl6q] t#x"r!GcOѭڳ3KoNʝS-ml?-|X3Z` bC>p Ί M|K_RXQȝBJ[Ӛ`r!c=([8OFhARuۡ: A-5zƠ\|H$ldGόb}G cbD_c:,~wxCS#Hӆ`$Z+XI$εNN5Ma޲_Wvi=P ҧq$Ũr%37]g,G;üGv^2Pc@\7밗 %zVPǚ#3,ݳ'P7()'p~epRb bM<^v x(}Lưeya*]@- $dk^ dJK|@ءu J{u/B[-%CY`c먾*Pz!:`6B~ۦ]QUNw6_Cde4'QB'8+|e"a]B~DY gPtz̰ <d^T40Qq|:iEdaMsUd`]?uAi @ϯ`OBp)}kUEH`E8vexY.H*CE kq(*kj_<<.X^UϏBjPe~)% XDM`b!T13/\s-iB鲙A%Ea~T%N"wI d_c d~N 0jgY/] 64pZ7]h /iFo+3s fSCwǠ|G!Q"L| S?8Va]9J%4 wJ>Kh;YJ`$kV6^2Kf˵p'_ qs E 7N:k=[} )9R(2ӌrVWtYtOvdyUW+`W'-9%KW6b{*GMδgiG)G^Ų/KP26'Aɯ8wH&r^?̾\\) DToq(w63F+"1n>Q]>P G 7,OJ? a8qEYe9}CN86vfyvFs[]7֣ ' !y:IRkYe^ֳAh5rؑc-1>__HLtw;s(HJ۫g-R5 M1B?&O>X.Φ.#dSۺAsq3e TZ>i` [lIY-'&X1@]lmfPh BcK.`ړ[1 mQẀΝ&L%nu}3 Pf_&tRca6v҉mLłf` J)D}Mp'-௺$DLmL䶃; D$Z$r P&Ng"C8Mh})2WW#XvhYk&w>u H#=|9H R+zHu!Bo#RNLD4A:x?;l|}0`f*}~M5༾Vb .V:U 4W|F8},JD-atWTAWF/09GϜ}Jz4% rcAfR>޷IMy` Cv{ is_Tܤͣ|,7#Jjt}I[3Ur^\g,8Ka0z@ bp'aI}Ԭ|,TuJ>*F".#'~ƚ9YQ`c ׋s Cc(8L4hg*mنc4: O˦!4 &v틵>S*2]I Scz("1kU=YU-LT.!H_pҏ6+z[қsJG$m&1\3lzb'Ų/(X\lO\_镌{p*N7eh"'H6P5PL86I̘B8mCб܀%"]1cNXٖ x,ܠ7[LGn0λŬ|"Ϟ uLr!7ow(.\SS'cPMۍ‡gLk3#tҍFjA#հ:Aj71Ux ;H]`.,zg*elbkd6O1{o}h%3N?A+4k^Q`1Џ(p1 |p(Ys$Rx][HY*!Í]+,-Tg4(HStkF:HlFCy)xݏ~a69*={~;%#GOZ+H=bX~"sȰHob"iYV>Q]qw Rko+RBvb7;ɹnE] x`M-%)``5KnjWYz5Gsn)W#Clax6PgIɌ8q΁{)p~w5-lj>36^J!*$Ļ61@'Z|ϳbTAD: iCjP&?.BЛ.OŧX)C̐hc]c1#s6.~,#ObT 8T\zV݅cO T?Ҕ|zjFk!l\[N+pbZ_oauY5R/֗CÐΰX|Ihgj8ڽ =!*5Zsׇ}&y|MқH+6d`'G}Ew#sRabF>ܡ;imbrb ! =_Y İB26.ܪ+3,7J޿g:&4T8'0PnBRb7 # zX;DJE];)e!XBՃچ05+]10gz] ޣ?T2vAuIfh.sgOZ RA&-:SilHSkҔ|RXg}OVkڵqeWfGRUr--!6 %qES*2t%~Ile1XPOs(KRxŵLPM,1" ˶F|]xƄpڳ唓W'Wq 6+5|F{AMlF5fG׮k4n#ι*ŋmÀ3rC_L_q=bkF&T^w^sv cݎC&oZEg%#$E&,g ./lPK?Q~.`bQ4uYI$@H,=ԦqZRyԔ`"09q3鄡zzmc?3uDbŧy]`JA}I'x$z~m3i5X 1+UcqσYa8\^M8A eaE(F[QMҕ+)4n} P$[ʼA8ibپV3c̄t Ndh~`~Y'+e^k|ۿNQL9+Ƌ"im g`VdO((\x̫/CRSkC_ԥM) T-n{`5W֥UHo  )d"#v? 1+ρڔ~⑕lF0>uD@P/cN#dйL0Qx ukݤA]cY"aݧ`!l+!{hõp/ jo739Ж4$ͤےT( 43!^ɯ̤ì&@\J_gBc̃]̜s/4}Wa]Ec]s%`{?zI"iG (4#8Lq; Y 쳀'W`"JOt5 Bkx) C֩WnO7jbj=OH(q-OGwRVC/뱕Fa@Y0Co4fETK˼SG+;%ٴ|!Gs:l# %AA.Ȥk'pQJWvI=eOg 1 !kEt`t#5-{U;_EN ae|ԧ Sb%dl7AtL(.uiI{F5j6|'!vPJ1LPY1̉@z Xʋ8y'hLKY8\+l}f2~A=KӯuqVņlįm(z^㤳,:xI#Վ8WLF]}k7yCM ?Ul sA`GW NiA))ZǓp?o-,4!({#v+mr^{jjvʵ'rsK(]9DElk3 p \N-e±u/+Ѩ)|ĆwCtt*1G%:h\5}AcOKd0Blqde2xwQqτΌbb"~P܉%}ǛVrC{ ȬR|,HW[ch65;($n,g"Ƽ.?U%$:UC -,xs]+Ni1<&mW[Sk N4_q lˌ@Pv"Z21xMp6IXQ?\fv\6R7_c21@23s\4ʨs#s0i6u&G%RsFSy&VJex 5:%j*scĭ )maM%g4S[RggMY}>)k9z/qGb?ղF?JKED5ETg{^q[O= V ]_^"89eu~@a#9 _ɾ017~u?Þ;Ƽ>:׺ݨ:]ES6_/"ZU H5qO$?b77aMUމ|͠V8irI,F1Uwc68Reê0{ kUPf]mm #{JhÓ}\I ;oU/F@u 1z9Zȥ=u劒6V:Þ]fnqtUGNiW>7jbVKHF݉mfUxTcgp]WCaD}*(c.X;O.Kӡ+ D{&>o^YR- W=y@ڱ^_!;H&2N_DDNV?Z#Or씸NXL[ "nf{C~ipFi1I|Y\]X;:)AjzuI4]FU.-b!ڕ};_P'VDݐޞ.H^ģK퓢 XG F@*"+E#c]T^ @>B1,B9*l -fme!(μ+Rsu/(%}$&=7qy3>0,]9>!3gD;d*w-c\ϵg !֠ 1TۃRY+zP峷T]TV~~]<;Z"Oroz:3`Q&A3034]3YPf)-f.D2?~d;uD(R 06Pv"4Tȑ0l=cBT-lQ_˧*#NJ0ݣ@/64xFqVrÒA*0hY~gGܡF/IP;Q'g \UtkWW.E^]tsO626%5 B?!fQ֌ $6]DXv8K[gVj̤Q+GyŠP+:h#< _#KL5ap5@J¶*N0~ңX*LsY>U[@ Pkif _}mTР+欵^W0v q h O}Dm#PY:紨l&8Z'j"%px9b? 7H+\Ix$vӢtykFqR.evFJ͹H} 8\)uIpR9EGio@Lj* Db@>29uk{e. z+Ӈf#!yJ:c?r; #qhl9ug;y)7NB ]05V9qǘ:oN=Kɰι!8Wy N$ߗWA(,1+kke Q<.E{Ѱrw- ɶ5D[^ N$CrR2+b`2Y=VjW/ ff}vU0f ~n$P8O3l }mP8npb+.֦#,晛6+J n"a>)ED/㕹5*8Ə~C% 47\ssFaqbO ${WkII[ӛ:89-C쎎ӃoЧZ 3K~Li=X*iٹ FI6jlR ׅrq!l >S=.Cu/$-lð 'a!h{z1P*+)#xd F%^1ZiaJ yʿQۉ aihUlvSY@cʴSTԫi0KNg]:=(J^UYپ2O#XX48cp-]wg7\ΰa_(8DO:ͿktCh$cHz~߽\+ [^tJ;cI}^ť0gN0GScZts5ŋ< q>!5 k@?c.B*4n_&9;J tFiv;WY)6Rtia⊩/ViՔ9%{fjIyGGp sŊb;6jH)UpfByX8M"HuZ/J` =˭b@2VbsDžx2 ;'wrdݬx2d0‰jخ9 )(Y5W*"6Eɚ*)i]wUѐ=!]"oCE|y+x֧WCLf dƝZ_( o!HzW[+9b3-h?J@*ag/Ҙ@EGjyU:=slI9%žmi0V؎i[A}nM8IŢ2AQ֘tw7`9;;rzyjS_hirg:+q.L; iWStt]D]}ZBefĪW6&f]7`?mB }{ڡaCxX̺ޓ/3 PfEABaQEYm@Q,K)q^[ū Xh$>rUH ($T_9imQI+3KZ /i=Bj$UC= Ez̀]z"nBbb9 k+ŮL z XxFFV XR %bt$<,7G 1"F3 K؃ s11_;, R^bh #JYHYUE#TN 9eq/>=`}1hp~*AX"Z\D Fp{=6T 'd]m)6":3H)Vt]F5N[UK표]M$Se*'$<{/'?Y03e`-uyêl>8)p O}puc,ɚΕP,˾ ^+XYB(1?n[13nݼ{=Ҵe){FO'q0t ̸imƑ;O'[iF#|9ΤF^ S]l\?WӚva7?ͧƂs绥mT. Y]zo,dQToue-ʿ1]a/]NtUK0L`|wSODKoGjH|i"q!6t3rro]LE)Bpz/i hbCܟ.EM۵ Б9+Ą' m]e#0nfb(JLd lQ,B!o'%M,δ:йwJkѺn w5 [T{*ek<xWL"xՓ?y!VsI )ES`v%FC\e܀PRv9Љ"JC.U8`YȌQe3+Ը\5gqSꟄ,ã~V zjWѕTwU';C%W/A 0z sJlx릃fq l4SK}0.$@OD@MLwSjaW8&o;SXNɯWN&-HO5@%9f#ü%$X!&rtIY_jUSፂMn%SEx\nu7R%7} dsH[614Թ(O[GpD<-o734 J׸Mny*ZS^TP8w[6ei E,_??9gU%EmV^ڟ2g&~r ,?Fxq]>LrZzC7%UZ vTzLm+ Cއ7%Em)9LUIN*uj $. d+B .n*f M%1vƀU`ئG-]B# 'f?Ԯ3ԓԸ%: P8z"/ͮM mHc]V/x(O#'0ZCfˉEdZ3NN=8ǐ:HOl⛵Rsѫxh W>_2ˀZ gݚ|nS<=t(y~β"ҷI(^Mk9Noj תNڭ约(]yv^Rv5*sFbS&^J洰j 2͖1s[5^7O|TW(\2%=/̯qPԀn*Z }}<{\Hz~V! IQ+%D su!K?bv7 C1Y7DV&݄e_ǝ [~B^r:ʇwe!Ǻ o3mX=\;ngVz8߄d ]fGTV#eޓ`7ʲ54}%YG< Xڝt)M.8Y.Ʈ2Ф|y1bd6OfĪE%4F -V!ƭR`TV@ڛ[H_\mh$* ~p`PH s[3}C,ҌE m ˺D +R v z!n;U(|5 3#0y^/S$}x |f(a+,B^5nC؀ c]M:pa +L 4Y -rU~-de߻A0mO'fzQvt{ &Ե"E*$ϔ|}Tڣ-}UArl;KFݞ]Cקsd:l.[ڭ*ݺ3ȡ(jC(~%Etoc؞9éʽMocnCJ}Nn>":ur{Qya`Iya*Cځ,F?4pv٨(rǀH3 ?U8\p_/Jov(& X\`g;8 =A\fʵhZ{c']% LүdKOzM[,/)E 垷R.SE f`=)vԜ]&.z@f lz_L*n0*`_wI)e1<"ARiNG/4ĜfIDhxޛv3̻}3}$*1f.|j !װ,3,qCn|2NY Dϴ1wrvqdԑ8ѸC%\x BW9 ͫ`ܿ`@;vOppi/* 6i昫W_ebxOԵ[`y,[I32rHkN۫: 'wk26mdDe|nMAmsFDbmM/JnurJ*X\=k2QS(l1慚GysT&|*0 tH{[Fe0}5v|8k{*?hdwň#+͒& E҃51`hC%?d&bTSo_άOU0XDRyszm5 p,Mc>X}zKX b'yY`$>0¢u5PЇ#ԇb=!%F@4$٭lq ?u%ʨ ݲ2!S&wJa28A@+/2dEu| j,I"']ϕTO$@L  Z6 6c&!ĤX^ZH&tS ןOSܖ ֲ2J]d?)K$lQnA@mOE=ٺ%%E@;`[@6ò(v9m_MnEp+p5\"Lz^NJLTF,p[nh`ĻXe']Uoit[AGpg擴`f>u&{޸6f_UnxnkC_-nAFu5 )JidnFkX֏o/D@ ?Y>P/Z!_ڢ)2lxC$/BzC4W;(u#P}Y!]:fnPځWXBbķQW>܆fy b9Gqۂ@[LJ5ya,G21DiLYkTT{E@5K^/B:"QSn2kKvuVXnOjKBzٽ͔qq$[U=:\=]*&6d-!cC\&72- x?^Ammj'\ %F=宐] xlgj>9UӘ(8ƖlgDPNi15DQ(> t@<[R]kdr^ ]2Gh,CR.i*a(Mrآ8K"49&Ǡ]/K[0g+'HdUvEf o`R 5+VЄ[&zC1󽙜Spau2{jewy0w?63٭(m,qc{1sT4;svHikO >G܂0]9OjIhKLI5ټ6SQeio]Kh e iۅuOJ=n&J!z_^ä.}C%0`8 l;L?`iMvf'|<R$^~<(ȶ_)o5më 'J(>4%޶OGs`Qve;~c1Otj_v:'] P]~ kq4䟔ѻsWb )AcTs@^Ǝjb6.ezYдIS(5aY|v "@T$y ҢϬyUUR/Ѡ%(C[oGLEtDbDf~Vpw>)}NLF@9{b[CLL S(Y _"9.r~GB!{*]њX z0'0k Ec. QK1̯w=WUH$E'3-*\ .=wbYHj3j"˂ř)x7)C0uI'0q0dl ;@f"ӹG}C=bH#x=Fbd|+]?F8a_@"2\;4CVn~In٣ ).Fj'[*%yK(a<}cu$N{gpdH-aDp]MtamAآҤg2%aw8!ZњJBNk#wG<@AdtrϟG݄fZy΂}$='hPD_ފK{;g2ʖZծǦ%W0$Y,D'ZVQ=usաUԫ #t rckĿjEߺuo\? 2T^f`m`d豫B  =vZP*+C{*+}(@50OmIat$Ӽ/o|g5!m뢊iʜ#9@sI =f8'w{pSƟ"f٘mpȔo΍(H @pXǪ]qQlSH'{8cY=UTSGFok,Ey[.!nϰ(L99i׭UłCKAZpz]ȡ!`7 W5Lذ[:_X85wZPf!U v^`\~[Xj5bz~jVFܣ9/z:J1 Pw };rvңNBW=T=; yL:r I4zEo5 KzX=IHE&KR[ކ.6 h PM^NJ/ͥ͟9&:bxb&~\?/HSiD` M-(L,dM%JuˎQa;R J&pWjWo[ _M>$;(dƹ&Na(.pF ҚU6^& [ mG}?&fFpeEVIA_%cђOeleװ'K`S|CY@a?طʢ@ []1p~]׌nX.37wGmt$Vi:2$'g '$o8wn0s!h14.ݢoKuw_np憜ǚޅE.XG N\)Ew!_ 'e.cpZ;ìطN/r*v`;q9RuU7=$=E:hg6.KS..C=?ɃA>Hw¨x =8;B^??ŘEwyif.8Lp҃ٶ| =i9|CS1eзG^e83V0u Hc2l $LduA1X6T3`Yz!Nbwzf; G}Xj 0w^d nEh"iy'V[8幘ٖSǤ76!߫GBCg 0<./kĆ*EJ< U=nqUk{l0fbX%QUCKI!fi#C1V.w H{gIL-G':ḠlQYGcU{|.$jI4iS[38Y PUތF0+m9}oԩ'lrZφ`b'l!mio`ֶD jXnE,HxÉ+׾X4g -`z|=Z/yu*,bdW*QmlїC> 8zm/nMZcsYYQ4&q6|WrگwVÐ  M9C@L+jTm y$=W]ClLZ!?-()-gTD`*!'zYTIHRHp6J&-1'+uF$E 19٦a8Ual0oenQUB;u>ien021:;/")NQ%mI)f{Ӯi h&ZvZjh>jZ<8j{)lr7^eN!VŨ_\w~E֊Byz繄CDEM W-Z7kU)3B[i}19iPĕ&P۬TUЭ>e7?[8$ y'7,uI䒅$ UWJWֳ+P+8 jE+oDF:IP.KܒI,->BnQ (af&{R)7Sa[a!ǻ_v[9.VI)T4]Ty3JfGOՕ XPWW` -d2Gڙ?/utl1(fH°D`[wkrCBaF50-'E5Η' 3Zp*pK&oVctY :8jlft^)Ɵ%t}@+`[&\~)fAҼ+^! ۭLN'n@2xb?Xǣ=u)nEܛ8iöBo7~rb!X߬9V^bK7t[jq]EbSYNXQdb-[["@sn0#f3h65#xt#E?Τ >L/~=⎉*URz= ):]xC`F3"`S1T2I'EkO^?7%5텞bz4fp(Sg|`$z*^ՠ^{\#T׻i"}-@ė^W(Xs['<=5A ZvU>6.eyu;}J*PeEWUEPFiu栝)*|>w;6'r ٟ(X`Xq,S$#1=͜LpB9heQ[hQG (rK.{m]v8O',5 %4!%ѶYpjg9ޝMEXq`{$h.|w{u1;)BS(~JITŏI]wXcX}u\ݘZܹoL@-!"ʳ/Xrl}H/!$džK1 Hk=&< LR7m5r`ŲvFzN-E^p + zxg7J!JvO(P'Ώ z6m -nnf74t ,"Rk'G[}/L:j@.SѱD~MF_;<Ϣ.$U /DWh P1 +'gjXMe#@zoIiz>~C1G$")LSkaަ-"'$hTU覠1[xb9T߽]-bKk/Ok` LCVEI@4P}&ՅxGymXSb] .<)%:q'궴TTC evaZh7)xg-+]i) N8>z0HCsÂц3!iZ<6(Ħ<’wn):hdo9d: M1Ĝv9Ž7ckR=~|Jf!ˁw( NL;zNoqN$k-0EI4Rg7vN'0Kɦz̵8%fVB~|h_>Ep UQZN^1(PBo([ 5\2K2 o'gi2lɐ1rB=ӽf|rd8[7"ŭ !k X'R䡏ڥ N wyb+̓ ꁓVwഔKsyyȰ=WgAx/UUJ_mx{A,Sn+ˍl j;lH \p|Huˋʝp@t\``l4Xhطxx3S,[`za6˕V^AV0̷hSI-D>~5J%=MKoSM:0HMO,Ņn;zhnTL[S){ N?TV̕N-?pcŞjbcog`ՖݥUwNqRn6u^0:'unG oڸ@Yl'IԔÂx OxRx=p]){Ew}1Np A W0GT;*_$TQH[@ [JIjܦUə̬ȟ}SES-K8Ⲩ1=ܯ88yZEaB.S 7Rm( .Jb `ey)#g^Ex]( e%f 0Yn*ӯ˔ɩv愊+]ɛv+˿jz#W::1bfY%Z?r~WyqGd'V6Y)(ʊ*[#/(;AQ1WeRV)y?֡xd<_>W+0b ѢW<9 4bzb+рb'A\̻6|[|X1͠q2aP;;V5ڏ_D!!K:tvwBeޟ}c:b /9-0|(1/`lͱۖO7 !jUqy6-9W9~ HEdMAi6Qiyq %\#~R脷!d3%Ɓ]J!+Y.Ykl1;]KB{F}As&kސ? ^GPZI.ZŠ*+Ӝjdqk*1ՅONYO ة@b&w%}'S԰k/TAZHnuST-lMrNɲ(H]|>s yU?1ٟ/+Ckh9'z"2@`ҝHotT}yU,``X({] !owE #ᴑL{s0-8!LRس=aKr} O7|)wy$9RJU@FŗvF :xk}'!Cvɔ6[';7cBչo?KAGbDo K1jQ?FUE33 )ΊqSYnÃ;<6<RL}[CJ׿1qħ3wPZ?Q؟ZF$3?5j ?QզsYG&`NZ@35&#Q^wHpLЙ:X_CAV4oꤜ>T5 ∂[HGwsTmeNork-{: r5AY exz؛ox(xy$jtwEL Ul7KYAH#eog7ͯX^]LEa8Fm_ϲ аև~ 7uiD"bLY;-6KEHn8(. e;"u}FtyG` $#ĩxYےV~@~ }U@t >ڔ0ޥZ\!n#$yG-/M﬘WGtfLY5^xG8 ^(e[&wVӷ؎8Ky#Ro+gv {|ni <q͝d3e۔`lP6&6o}XN7} C+^p=c0B,1u+Y"Cp;T-77k#;"@o%KTC"VJcs,_pvq=m1}2TE< 'DP)GDrb1_ ?a@0cI7N>x'cѢmwoCcA_;QV|X;3Q@( TBOMT"Åf6<)gRfe$^sx`nlӦ;1smz7MΓ,^,F:vϽyֶȋ?GۓJ{7EwzYw1 ?[O;,@E(B`m3][E z;nNgkk}_Vd +^Wq6Pvv&=~Ԁ̅ʴ'k1U]Ի2%quN{.  JxaC#`ׅ1=LԦ}>I9 mJa| W8y[==ka^j<֛i.Mо$&+;?s{+EsĮ̅)iN#X;9=3KɨWP"Me!~uyI$ڿ8U<=Iũo橪dGF!8e$t1E7-@<#LfbxQ<=AHTsxt= qΣP[0d3䵧tYWMu&i*U9jƽ',1#L0b5ri:{yqZ52/}yBذ# چˆg02X TFlD3wp2m;0suѤE]+{;Y\~a =Av  54;4{OS3hݏ9GCCycn!XՖc ]能R*=P{MefwgMס<םhލAqA6WH9-`Yݥ5iuzݔw{s }YaGEO3pz^|ǀqw$Z/j Pp9㓊%R?xGu&R2Ml?mۍJpcrd1f{`|x (3v ][WBRn5G8ìvLO:)B OU AJXmgZi8$28}:Zk#@ȭKA!u?;r#y5[~f4zl vd\oh*on)/=?5S80u{r}Fi-1r-a!V`mIC-M$`/:' W&5m+vnG= @}QSyh2'k퓈]Ywp7eZِ؉X(N}"?51at!r F@/Zԁ#}B:)1KU~ݯnެf "!A$PK6 !(<88^68l,K؈g>.fGa5ÎA8yM019uj 2_@ίf<\B0#ԮU^ vyBRq[þH2Vn6M0 'LZ5ձu)*#_;LejdKJUbWzrT6M:VAuk`)#=att l9D0k0m8nxLs QDu $.4bE8Ȩ*ߥϙy^ 4&O UjyՊ-mow,C?t/zQ[p|Ry3ٴ?-"nO9jZKb5T`Ŷ"1w2׫H(x3w1\N }SzY:8Bc@Je](\JPs7tu:Cx oWq*rL^;!O~& c<>M&?VY;گ?Y{/em&?b98{Gz $DÐ%XuoŴ6b+}~5}}4  4/r[tv*D~Ƹ1 NU Zoq5 JDսX["1-^:T@B\Et>28́])}>vFB9ÇiGR{st$qFDY%5>#4yd_[4!kzYHm`}Ut((c׸NBaIaKsY|O7=A}k&K=cd_p" a`i7+a~NAJ/HkbA{F+Nu} ,cz[i=s9[03p4 @'>fJIVS!utch^M6BAUG=+_*!Ƅ4_TV7w8N+@ʵ(TKAoVjm/χT`IK}RX/#KsOQ *GUOYjtۜU;jOۉD-5T!2Fx:Ch:a{͵] jJ #e(\!=]%|tM27 ]۾9h"aC݉!EkM~&_.-;6  >0 YZspam/data/germany.rda0000644000176000001440000015335012346261543014322 0ustar ripleyusers7zXZi"6!XI֫])TW"nRʟsef,ť:~ _Mmk*h&]| Vcm4'ZMy֝8^Ir /D~̬|q*U J0$qOC(0 =AdAy 1{Ex.DհL $pSβ[ؕ|<wo7Nw*)vY&\n;[hYcZ00stft*dJHsYhx?972!HO͝Imk% N\ϕOF":ZQl 0c}@ZK_2]Mkbؿ},U\$c}$קW4n sX.Bfvn9<у[JkF9yo5Vv+GwAhԬ3 Y/}F0IǠ(kԀ\ѓʌJ8ݜF8A[OhV]e#BE`io^ ؂ .q>Wd:q(<`k$ܕ&EAta*Ht\3C؄Fg`ܷٺ[뜘A` N6M ?toyaolBS2> u3%AE4yep;xqq•v@Q=K$AH=o]\Zgl_ւы(5H}WlۤRL,8[P=/}#kDT>@qPр[PNfr,zF#Nk^  WٞYax~7HqyK غ "d"ԭqjK!ҋ%?7N0 B #1)V1ގUUJNj6:WU`֎ģ ##M0PAv0WuBcK9\{Kq|,tk$b.w|Rg8=#&4!񍩸\-ALF $Qh'/?ʹ}/L,/9:`zfW*QJh]RMsBbhxՇ_~NL LG&_g 'ow9XAbwB#)pͧ~{gkY=ůхYmQ\ʝFТT+5PNi%Ղ[fj83C^jnou <]Dx&N.l }(W:t.֐S ,A]dHȨW?ul^G4ɒ{JIJ8~0uCvp+3O$4voW'.NtDzt]S<ÝͿ c^ 8 ()sqY Y Pv<e,yN kzCe@ѩݰtΞkafV4 QڬFh4N_`f.- K%$ЂIIzxMGB #`Ὅ%.[ԁE;Gk ֞_)¯.NGh -HzEair"IЪ7l^fEfa˵/`(OZcη`k .3Dj}}>A0`Nw`sxߍbiqY17QI3x-QS=~a2b_戌:bbP䠦21sjPF09:{u"Y<Uza3꽈 ^{aփw0mǒdu ^K_Uqԉcw%T[ǿY(ذÆ e )ؼ2n;/TS)PP NT{7E Ix78}=`ջ+\sH/s%Mݍ !R]G+eIѐ5{]jf$Kݡ Br {b[)m1YeJQlxeWzR:eLVw<:@kRbEt[l̖1|+`Sʊ`/)u%*T;X2)G1=N] p Ź]=!'O+2XU!; %ɃD8@\Մ*: rT֖uב³NJPI3WL]|f4Є+`t K*3ӣqW\$ -~=-Nu{4 Mj>8JOqi^DW >6>(Җu|ns]œsռG WXZ!PL嬡Gt:&"i0 ց81 }bgPLgu-{Cϟs8{NP`Ic%T˘ZϜۅVO'۔zyk@VlWEwi{Iz~:;#S ;r:tٜ^rJsĖW񄙒j{F[U&| nIeC#+׀\Ȍh^ڳ_aIb~åZ?gsB3ݾpGw󫹝%7-jL"nT8f]!ѕ6hXN4xL_3צ.`J J]ël Whp_tQSaL*>M63ȪW m}nRg&C 7M V枘:3Kbm<IVX :ɸ|ti(]xޱB=on9'}44%.#G1=biXfd6Be dJZ~}A;V F]sy|T>{h^VZ?a@B]M~,-)_G]p/&Y:Y_=aȰXu`2˹2o5C+lFt @ݻSզ<8_PiDPx钶漸+#oGTwP?4k7=] t;#\5Yu*8vQIrpCĉ+*N),~s|,e^_eIa1{+CLN}˙8dՓ`Ҍv1*jl8D~a,dCtVki $Y"Cy0LfƊ+~{B3}I Y8'(~[Y4oWq:3ZeFG(-z1ɬ^kVQ/wq>ɦ,Q!^vүsπ(p ҴLk7uwc=_O@O ^YO2t; ۔,n% g"s̀ s< x{Fe!-/xJY#o!gI"GrxևH[2hB5aP.P++ ғ;SY--ܭf P (B|#Z_M8+YRBrbBA0|^wbF$"6Hz:J!!LB͋n {0`0޶A`yWft(F[UoNjzXE aCxީUvb;|9Tʲ=gcm2Z&՚ek#)C7@rɬjෳHg aE%k#{d&RsO}p. !VWjQ -bbK"!إEԖE ]|,Pze6Bڏ),5zYy4[[t$Jlx#9ے[יzF{HrKK5u9 9fS>)GbDBΑz1H k+ʿj`J(/$Bɦ:ң!I"<àPgugˁVM?X mKG+I&l1(y拋*7 *U r_; UlfB_W4hL}h2(˼i~IN,۬I)3d˲fa:q|G09?a8g`Vf^ ކBDzޫ*>@ם;s_i-)`B@Yq1J ?5 R_?" F|w/:ILW75dœ_m@ԴzC-#um,j806b|E` dTA/;@³qT=069fۣ',m [27|cw:MeT˟D/3l-$J'r^1l׀?OV25馷>j_udl\7LJlȵE 3QPki땦l?^st|aω+0 v&vfvoI 1u-F\vQ#vhѭiҧd XKSJTsթo'F K5WHop=o,7s֑ C5C~S#R P "T6al{e;Q{h>a]ߘS'IGa-qש{]Bҫ4+?.օń5Up9}لwzî5$e-J=F,"Z L!)zFB0dN9fusˢER4KHNe}BcHeAʼnFT]{1X[A>;#AYG)xߴ^`=t@b *,_A!Eo ;ߤhXZJ÷)`JdRc b=.a2⽤p >1J&DV΂oа>wqz:qÇc 0 9,Yy;V["#RՈSnmpVlM43ŢS9S!+"d[u{&(L_gW_|ƀXĺܱ~]/*=X tu!`1Mqڨ#hšȮJPpϽɩN JO٧J2 I0|jm^]|3[G1Y>geU_Tp/ Wq5;Jt`U_Ĺ(g6 j >yGsUz Sc\]n Ε(;F@r<'ԕF<ԥ.>8 [5rd':#nWͧIzXb[?qhêoA9N@RhYՇf# =Ag_#s^&?IFA/۾)r35zo&Uף~l.LG}˽ l0x‡ExKd;_ MHϠ 21ym`&ެ;1Li Z-g/&}v1+ H!{L\IJ"[eW,SCPyk]\|{&XPx=qG e;6ՓE%!bRo ]u5h[{jX-5](bt"$QC)%^2DNLF+''L0{hocV\k˽!FQ+cC!5A<ꞽtJ$p4([tG׆ Qw٬-?H/&Cyۤ0-fEbs'H`oX*+%޳ gD)b:$O.O>?lkuLeg  b4 i/yi~!YquSKn.~R9!)F6^HZyT5d-c ո"cVe0C͛p@5\|Tb@մ:E?0Ţգݩ \+Ү\}0lWokl{j)@/3: 2X}g2֛gQvI.  W 7ujnQfv?w#_- 4l;lFdG;YީZykэ)7`^$\vO:9r~&i|\]^e ]3 1.[ sWypD6kA_W^F&E>ߘeDi?x2=Y,;k8as^m82rZ02b&eN^ecY!`T{+ɜ4Y1;V̎qcuV.""Vf;Ci.veⒶڔ=\,wfaLoi]K-3ǐQceR{0OOn1|VXٗEZˣ 050xJ% <9~CJSGx+[+5PzOY =zY=0MƨXE`=XiؽVm$Lҳpe3CoO:ȍی{g3wK{um$g͎ǴLfX(޸BOɸ}W6[Xcod)`@.KibE#Sy7uVK>)54P:TRԂ\;Y2;oja'Pºއ4pLҲdOT"!H;m. z rj$(0Gm B,tLx`~l`tvc$:oٯAJ)4YsM5eO:Zφ+nvx3v?OXG4 hǤIqrHx e { ~(^+O-i7maú  CR 3ҪArRw/epZxƨGx<*o%lW(ټλSʥ gX GG^K=_:R WB&3u\! v`w_lQ q&momUo%  {OK,Qgat^cѢ3@A;XJsаI_AcљsȾe? VAwC|̄:"kV11wDv]VwāzS4j8ƻa9́&{FYV){!_KGO3)TDU74˿ izד! %nZ};!5D.*Oj^Sgvf mK_Ĝh*CXE:{qtz`0pPӕmp≲pdh|~SbrԂZ8ޘhE1 ގ{@\(jz/ ג;=Z l vH*uTk83g &u)t2dm. 3/j\UֺkO3JçkElY.F[qKueBl^-cG埼**w{ދ1[bF=d0UB>n.S+C%)X Avr-D(̄a6-"uWe]b[#jz)y &pHs2_wQf'?Q-f6#1՝<_2Sɽ7b~$LjwG_Kv;/X*C_)s:$΁d-g.7S'\ 8`VluA8D?+xI4~Nf-xF P N@.f0 @|Uu:_H+] |ZF9=oWfo ֓_jPmصCp@AJ7Hf˕4t ޱ3>#Bö:26ƻ;#ާAL! ,B[vEܓAx*ΦΏ ~i찇K\=,$|2O9J_ ̘= $r m༽q,/A(rRq2nq'e&ZNSȋ"QSBFEٰlMb}qՉ)$;H⊸K{tW^a.C&4)lJ聽dʼn+'k>M⼪EWe;qWž6a]FdHq<\j쥂!Nʤ^tW .+7fMPzC(^t>IP~8.@fP;(J4 =YL`m2w#b^_R/,R;Ȳe&|i?͘qB7u?Y@ sk3Y.Yz Je9D'򟊻dA$>kSFuqDQii;R6 Xpn1\M|Z|Z N!u/4*oa8`!W`txBt.sDo4ᄘ֕ŗ} #ad;FP2y"ʮd1∖UDt BO!B-P8x h( h+lii6<7fs 0DbGBQ9gX7[~3<^+bI rwo4pPngHɒ-xmBYrcmL7S^`oh[29؊C?;Mp0wsZ'ѧTGꅭQ0:v$$a/6sCF4 [u痣Th8yŲ,Pf#TFcߌ^,!CyT=\v2̌@*G8F \B ŗ47&u0ܱX43/J `f%i#`2$AifC;Ӟ6l œN/tq^o9s `r&xح *~`@21(əȎ|q@n5#ƘD:}8~[_p6Ǻ}vn=Wx!bַ6~R܈ʁ*9ւ6(HCpODZI"WuiY@ꇄɰ2Jsg 1.i`,$~B§[v߬XrFAy|gܣBa NZCūà4P׃i={wd,.ݩ192{ØtS"hw,Te`+v:)}qo'FbGsa*5.~83ŲH`~>=qYGCPM E( q[iZi@w?$Y-;53ЫZ~+yp7RZ^` [~b@F3J{U'2-y-2݊8pۄjO2mnp9ƧfI!ƃeX1ݼB_8IOaI߰KP¦dJdB2AY_h=}r%iANɷ7n8TӢݫ3xw+( ~V!-OPE+,Q@Ho¤VEG)L!ɢ G3#w EC q&&Q2\ekgCST5ؤ*gkW(k,=UC,K $m/9p#&fh-r-x>BR斶̪mo,u.X]s5H Oi1[ې™T)T"!wk]/,r4~ͲIO4j Vp MLp~IN#N.;͎ H͗E הce9^':Ě`~%亊64M6QoLWq>'5t$֐l]tbRp:RBX`9[oscl>z1|A0U=s?LHk(Ɂl=I=Hހ)T<}[} #z 6E"%R+Zk ɬ1>RHQ$ T$,/2t&~GӶ?Ji2Љu <|NJNNJ;9I%| Al˛:&Z'm =+8D"e -ڹ"^{Wd%P'I3rgWն <쥖nZ*vtzjbCѸlPG($lw#yRL"fr:WY`ʢS Pv>b.ī"IqU܂Jp[S;0:RSPvqA!;1dW$Ҙ3@rd̕iU}HZSGΐ20); 1~1n/g"!\ُVc! :־1A88+p.w,㄂RRR)Uok(ccOIO%;<ۤjyOJF=s$1h6xT`vu46ƾI[ i*d$v_8WҋJ.`FX 닅V^qF΍kg̊Af3mMG= e{UfuchާfUFex] /n`tDH4Na5b'Jݼv= n~x~}&ye^m r<aLfӽC(^>< яQd! <Ϧtt2)Ԩ"ĐHk[9 qkHzJ"tI-=5{ۢDh>y?5ZJ)#Y8k?;y-OB7Xe:K{q {V|le3'OQ}f ,J#!&Ci둓{PrTu8ϑ4)E+>m٠Ā< (QkC=1d3u(+y8@68ㅙ"&W 秹2i4Ep͜3,<GlDz"t5- e&\.zT0޽lt=n\3Py>{ŔGUn10Ő%g!ULOj>?;o%īBiU&Mǣ(1S̆>HUO/?i-fo y?FԝA WpKfbCOfw{:Pę \~j*]񔘠χR TL&sp  tWd?Vhem2! GLit9uRj.vk;@v28Љ❴~H|.[M;X?ɜ|SzσOhHF۠"4OϻMO/?Z9uN"%.Vx8kK 3nzҍi>yyt0v2_mŒً vSYat8ۇ8TZCcz´3|L}[p+NX{8l{-Ӽ3FmxIkP\IJ >U6(UP&C" ^hep$:ڀ[ Ӷ+jx3 6%̌wu̘ a<(\AI*T`b6j"EOz 3cYш_ Eabodaځԁ J'|1h%2 0a# ܄!ٓCnH -p%vś22 Jf' N)"ܤdqDQ]MӀcCQ54w +] ږ'p'޽OV^:酕ўPQsizZv}~w%>L]s'M5ÙJt#K{ێC|H9Q^f&v?]@ke۬sMcef$ Y.3z% cBBI)HpOaa^֮ ऊ[Υ?̋۞2].50,"J+_ ƒ--J6:X -#]ڂV[CVV+=c&27CTjY.wuP;WZ0U^ )>[3EyP7|d#C9]\f\,{M}v,K lgYn"@H `&5HɣO'>3[%=3Yt<#u|PljBlÜA@dm4nΐLh 1҆RX[5 "{M|?zP>ϊ2D.N&9֬uLF.y^cs%=m4:iG&UxZC"{0C$RZ#f%SȱiM)9zXf{ zg@y}R򐆬3wړVX>U".@"Noϟ#qp`|3| 2!}18.Zcv0x=FDަKX^DFvO81C7t4f0fwUKdž-W[+Q+k%ۂT@9ϒGY1'ON]ͭ{5MR"1^3ZAmi*6߃mq'̏ A4 "x"SDުز~Ȅ\/4}@\G9LݞjXJ7 L? HdHEPluk)s.񹋿[Uv9Is/dd< N@DNsoĊ}n~(ĐŬ5P*ovIp#%J?lLDžQP\˚UU{H N4i&<'@|\ӂx[FX!AaN4#-H<gFsKAf0b1Y8@,]o꜊5-3vB|4DxBD4oͲ㱓yoh*i>$q@"D 5(pznT/HIWJ1)pB'-&-Gz{ߘ!3d1\㉐dDAl#}:cAa gE%/~ 2B2dO'NV ؖZ#-cK&#K]V@9^ig\oIW{k6wKjh@dp;[Hk*^[& H+n먯nmْdc{ 8T^jHد:p}(XFx|HgG+u 0^'0,VipLwe$/k2b-TM?, Fq\'}/؋uq? mu8!0QwTr+C}?M摷Vwh@&[;.vF=f܇`jQy!?7!a_z@ϋdkq #*붃J+'p+xw󼪬̍)Öm4i2}YDAo7~S EHTØ@w S{ 4j\cmP^[@`$UEV`!W+~P`^V.7ysmeX*J:ӊuZkǞh9LU@}:َU 4rkhFsKFQ^QӿcYQcN)#7&aɅXհ MkX ;C0ߩ)rҗeΚ//;idͲtL ږ4wt&*[WRށP0|.=BXw5ދ/KvA 8r,.Y B8B% .4`(2`*:]l.ޅX kAHF9ǴWMJU:Aaf r))IR{{xy TdVBڲ78;5X̻SM |}p_Jt2K4|Z(Itj*GQUWY |9zq5Ux.TA 4ӞCY8<ĨyT; /?en_nTE}ARsKSSrIћEŲ~xGil~Mٙ?5_w}t(>NbͭtBߋ$/)vw(4Q{2u=x$&*V9p0 ,&:w ( 4P:,eAQvc5g$giNXؒь;0G}&W%hE%+C^ţ}h tܐK" dnk}hsq\ϛKqxY~x!.Uq)ç3XTTbUc*- &&xprģ4?kT`aAAϭ'{F{7~-0w O$3rpMM PpfO!YFC̸[ZTc=Oa9:Pb~赓{eU\rLD4d 6UKTEYhEl~kxq(ԦHL؈ g+[8b Fڴo'J}rX:FC.7D>G>yhI+`u(ѵ8f+HҊ""puh#[W",jgXцޓu$+-8e/p< BA"dqJ:*2Uѷsۻ-<ohDt[^YiZ'KJ; e8(o0ZqZޖ; ,=ՐK8aqlQ{T깞/N3xwLZF .t@##򁮲L16f`? rU?nOAN<8mQ =}W^by5`W|CiUc~L x6GHkiIS;@I|1r*+MSczHU3O1{=?HE>PiJrPmG>$`pc째#}e`jI<8]-x&ϱrs Nz[~1Kl$A_5ՍpRgƮ_E0. MZ rb[Qoo y1p!8ԏA]&|>1C6C7=Pnns@3 jf;6?Wekp)`F](qmv{/ OeqwHF1xPDAmV;ukW;jlW㟻 &t%Fl L7-]CvZ<׍{}Q={1zdn#Aj *If?Lݾ$8alçgit CgM뭁/k\KIp#-JJ S_OeѻYV2NQ ȤtepXI'g}_P+)x0 _Clxdj"C(qCe.?'M,t5$8AXT3z bL6N4x-ppsw8;1,׫ƱmpLw|ޡᢔ%dUS#;ЊS,j|猟|s:^ԺY7׫!s~{oz җFB]|y'uE!]}ϡ0#~ {Ub<_R٫ͪb։ x>R)-KH693zz6 ZAɩ0;0Khk:7Tyd?Rު(wggH@$]!![XSȺl ╍e.Tc 'aC =B0Xԭeb҆y-,`F?:7Y`?`Uoe3P F5N7mNg|z19FP/A9e1 f va^Adm࿤85Vث$`S+ampʤZX.^M%ܙX:qvf†۪. e@gMAtLĊMO \Kd Ƅl88 ')?O9O@{`P^bAFnw\N[Y8X"]bW^ ꆚRX1c_`֝w׎gk9_;= Ҟ>|)-ե[_ gDt&Խ aN\ <ZiWa-: 򃡈z N)ehW|e|&Zk@Hb8I׮+aa*\9H^TYn亿x{ ԥn-T":W 1"k'-Cu@}tClYtVz׭>q{ I.@ƞmE =KeHMjOVu0hnf=>Lu>@~jk'έfEmϽ^$t_cX.eYcvп{-g -yp@N_3tX KAYiws*|8שڎȂͺY.1FBj9pU+ě"XϺ*Xcv*wg#bs*l2 2m!\MҠ?S^yħ9fۅ o"ou`KIA?ͱ*iJ|QưulvgE&.]!Τ%IeJDC{W3l; yp4 \kQi2 z+sX ҏsD`%$E SڧQuЎ\#_ZϬg1!ґMmsQHڒQ:`T\&6eAנKK|ç >K$}/pPit~l>%MeSڦL{lPTp08@)Z?B=)s !M&YDR+u8:uVE 2i1 q׊^,6ҸI6oQ?C]6ZK _s֩k/ C>m>&~GC {pxorQS@78vO.P8l30PՈɺX;Ј%g| AV-`"ӆFT I6 [?_0u$?Nym;D+zUX빊|PH) bJ=8oo㴨.൳E)L^)!Lw`ဘA#dZ.#rvS?~+ӗAbǽ?C7ovDH3vYLA^{55`Dl}w#LU)Kԯڶ9ܧ*.s\8MxPT퓃gL:unvo:O,bZ| @h1>NyQw.@hU|MEˉ@%y$07 c ot] BiFr5s*lcvCj!FRZĬ^hlGtY(C@wmܑa PXӔyLs)К!mT6-IHJpcG&ˁ3:KmdڠTR+ٜ/> >eK SO1۠g@d k,(c4E|U:U\iKIND=JKn=i$C{ [lehFv⏺8K'oQ`c-\ VOVl(A0!h~n,[f|`V*Acl2Zdo@2jԼįyLiFO bDR.A 1"LA*<4ΈS@}7 a8KGZYy'BA?̿t&*/OHWVY76TRdf"b&@p>z¿],(m A2&DXYhoG#A9n#RGZ`|QފT^9t.CJm_~9X9P81vD\äu~UQ?]NȈBGʏ]F3"#W:;T|'ϙK@QQDu ȟ/$~FOiS1M g#~ꞅG`.:^"R]pLRwd oVy?5d8QhތbwĮA%/O0̈9uocX o ȴç3>%sz9X{gDx[7e=`5譾-j|Ἲ7Z"c$YV6k6LgNun('t ָw˫|.NG`QZrVf\NAu&Z_PDӷ&0^~=S4=R̕n,ql z^C5݈[7!8c}8> JU8U9 \91XqHoh ÊKq 9޻06 IwAO?ß%kKnN,PG|mt'K*QyhC/ɵ:,ȋe"}!pS .&oZzȼSA#\*c)-UO\ka Ps nۖ>RQf!ZnިtOe /@4'{ nF !5r7 yɐZ$'v0B߮vyQ}- l;OvҒ ݹN>MQ+cO{$cm3;Q!.衕0:m0 #tS' }+eX'y\Ai ؖ;&GQv/?%ˠ*ρ)aV,L?ew^tvu6|^;70=}fĥhaSg ,7!Pt>ۘ6oYKrP{ji^WitVěKtL=a粔zea}SWAT;79ώl:"T4>;Wl~Y_ a,5 mJ~JJ^nS~.LLpdI!^\&Vlq_,8îurvPk$01f%3 %&p_eDV|=s?Zgzމ͉`9]?b)Q& wbQA[ xD$KF8&3Xhy'V4SfIFs3GI#(y]OtNשAaN3.ECyk]vYlnRY//&% =L ;ؠKq.JVQi] 5a]Ʌ=Mj`^"2HӃXQ {-pEFD&Px qTrTUT!It#_5(׻甎.!:f}ZCY`Kf/C=4x$O_GXuTR9  ӆSyf&6r?n/,sȱH*܊IF[w^1$i%ƿ+һ܉!WM:?UTeŁCyOUGjl R依 \Y>Xpі\ 63]tg\u].i*l>ş0a]͟g,&~5CgK)\t"=gǪT- 8H&=/;oq?A~:A(@O^/Òj%rw2uX4OWݝy#th1LjV&ë)lk:j4GW1Tmf$I4uMN~#'y#CRw( أQOMXᑂ١tTw/ 5 !*.,|/07EJplAu;$}ҍ67_!jV9k*\extB'$2 }Q-'VAh >Rꈺ?}#񼔊d&y-bBOmQV#Bq7Y .#N{7B3g @n_QykdY2Ap# nLsHm M;G>/֌2w _@ˋмcٓ㶡7<]DUGJ9`30I%[?uvF(KMc.}̫#hcxqzaX -{-j{ße'.K1G:zͤ)L[rE^:(3_7GOlW&6ǕK|U0;zĿ&pjds_yGIF5rB>-$UI #2 ּ;lrmQ߆.0FysR砲m4\áMjQfI2OC -Ag}V_\-6 }MD?=]ۃ_V^`ZɯU YӓNk(L&~mƚi>U؀]fMVL!s+V3ݑFB*GxmbՓvOBs^V߬ƌM&! jBF'{} fTe8R z& n)[^N*W2U*6>Eb/gUܠͬh_}1`[^]SRgdZdyt@ɩ)qP:U|ƫhn!wZL#(֒hh#смreڬtg=^xhk- .k\Z*|C[M"Oq!'=݁|$>D2,fȁZ3`RgVIydJgP[mv%ti[,a ɘ-9T-j8yb/qWGW6ZkC4LkVV] W_:rË|W0l(iEr-rxLp |K{r\^?Ф.d@[#SX7|J+vˡ[hSIC t5Gk_g ^2nNAdum 8`%Vl3E҂y bx죸|3oOiȇUVsmY?%~1հ.  h8,]Tj.?[wf9[F~K`LݢßQJ)\0|pనؤEV :G{FwVاW/ř) Wl'RpxS=UMɋa"vAh.v3aRFEҍѬm ' o'A={'cNřggjF]ru2@‘+zBe8RL$2v.8WQt̒$<`IsV%'x >6ؠZ,|6+"As Z>Y֥=U94>wARXhqLcODq n1fSZ[(zl˛XW@mkR#=5lBUw/Z@)KЃ/{6['diBEiL4ޝeG*ಛ/|aΨ72K3ؔH 1K^%/6_qWr+({>A<6;1+ܤ&~$AO[fd!'Ӳ]qwKSʉ8:CRj͂k8Q ,MwU!抹]Q`C?Rx$ {0Ea8`?aޒGL4q{w2H;fUqn} V»N\d{3Az*rLk.o͢Tْ6B"a`o-r\x {B{s<à"Cݰ4q=7TFi:C d%WPN7 J"3m@ɳ9&^=D?~s P#Ǩ,.f*t1Kqm!94P;\I|B!Dj:I^LʲX_֬6O@)M|GC@$~|j$#] kdmq2"P 4H=)hjs=>Bع>XcisV5Ry*oa~ٍ25,WלReN;`u XgmrrFl%9/d- Ӗ=!d(^$VWV 89ϔn^WTGlWÂ[)5m8G-<`$P;Sxooq  bAKpUyr3,h7ƲŁ@5I[LЛU"(1?VT!80JsIFi>SmG%ﮢlXmNx$Gk.֊CVnx*S Y٩r'_o],+旉?ci4D MFA G8$}o_2~xXD(+KXPL#<f߿zp0E]l\hidz.+?W08:5ݫ+QFݍt+Ibĥ&܃=$KJUJYA/2BAiZ fr&1/`soNwvN5mwf\zoHH3~0p"2fDR~/˕]gs,qp).F;S_v05- @*-~gHFM|D7MErjReQ* [ #EB3 /;>uCYvh\ɕnT{WI^t0M[i&L4XzDr= w;&GLIog,lbe1>דݦc \}e' P82ZՅ|ԑէU"d̶,LՉiI (9GniT\eDq*t8$ 䊒Hwcȿ̀馡QE\`ao^UQD] G]wuk SMG}ft.xʭ @H[;]`9?AP>]hhDt~m ujK #MtU-Jɮvkgs6?6%ۜH *sKjWۚ@kSˈ's!K ~jZDEִ{;Ƌ^i *|$6')TeEg"޼mP>6DCJt is4r xFVV 䰶vDzQBK30Ѐ%WVDgCk {ZݾWϭleD&g]:=d=0ډbE4zd I,JN<hK-_Ynm7?EA@VgtpMu>S?w,CKnes@"|( 9/;2Bx@2%ݯl{ yIpQ(l.oP~x$b\v^2b yt,T1(ڭ%" YCUdoQ}i;xUsxz/5t벊SѲ(h- (t LYF Z]':f?@ vqw]#ZKHϴAcr4J[޲cSDPwmqRp/uoz>8O<&ݗ}ȯ\*rF%H K)J;NdB-LBH$[j@֖ (jL_vrA8stFQB7l3j,Vrx ОG5R596#xGPEva3/CgCm5gc%gh0|, ĵNBOf`H~- &md?F~&<6`od<;s8z@WfHl؛ APE#6 .K 41yQCXB'NGPKߧ;Fw53$+>@o$&xN ( ^'c7&l}*5Eb\Kfx ] F6hl Uv`r,WM#6' Ƒ~]2$b0]Iڮ}T`U`FX^3KX7k2N~|LAD)tpѬϮ2FwMyabꜰgUluzXT-wE};_+݊)8H4'!+*~{6Ra,1M'#EP=GN% ϏqRU[|hqŚNU;T\?Z'Bٵq9KEsN&Q+Nm . 8 ~.Ajvcux۾pDqͿNo lkd]6,}UKyQn0ah+x#w@L}z4f_6b>VEET𬵃24AG2,|.:cϸ6xx"75.B!B])?6vb-UqTcrܛ;3s#e):7N"9m3DST?hK+>vߐ="ƠGlYYp+-M]K /08 w Q/_#Mv3{ h,|qń/]V2n3 )Z b .mO8.$3{. mtY[۵̞le]У'"KTDƮ3Yw=f}LySJ1܏(w_DQJ~9of[ p.一v;bFn 0oX k"ril($;A(䁟J_lbk`3C@//@UxccTG/J,.s;(C|7h!$%_9`z p2_h{8e}2 z{x ΋_*ybz7icli86hWnSEńx6шȨo'0t499s:)N6- n?rja':o>: kjΒY#tWܸ3`jDA |eh~"{1Sr06,b 4O},g`uY*fSJI-ߥzo)݃^rɥ &9Oz8z4>m𥈎r繅xZ~<X"n6Ba#m|}em5ި <^LѦad HIb!sKT$czHbf#i_jz=K@ڛT!ckޢD !Ǣw$hn{ n&qRh]ԀZ&j{t:&FEM }tNd֏))GUb.y=4qa e9E zrVOߝ,LVzR\>0O8%_JRHmN&1{~y*b*@KcV2J!K 19'\euEVj][f}2 Go[GmnփD#r\w ao~$K G9t!U)8/̯(J%HsNĔ*tYEӸlcgo$GIgkG "6۹Ȼ/q 0履 Y>~vQ]{LN.Yތy 1y%,ڊi #>*/$%X%],9ePީQJ't\lZ0q·ͤD9mP*W~QH oYJMxo?3$&R>1v){GAs+YAujvƢȠ 8TL:{k3jB4@?YN4J */Ƃ1cÛDFL74aGng =WW"i>D$eW}Lڲx$L%L(>=8\tx..ˊwP|?F0y̼]8qר xlGlL?Ys XiVJ3z{Q, Kg1"pM8,.~ˌRzQ׽d&#mkQUڤty(ѪT-M /fxP NzƎ͒NcR Qw'F=&aW~F ٭p-0Qf8j}^ͣF:Rc N{C3'ة3 lYZ<8$] *'ںDߎ㞺B`KevwIU]62ߝ~Ǝkw(b>YԩqrOEQ;Lw~H`ž]]Uºls&SxָΝb ϓ{IԺ羵?SeC@i6}m%s _dK~wI$>]VfJ"歰Θ]"~I.^ÌfG<| D{=[<Q@Xy׋CDr?Ceޫ0:okMr$,4&u0}Vw-f3#4)M3*~'ޏ+0K(SGj*Kh6[J*RF&ǎX);%7$*AL9=W[.BAK+\G*eÜ$.H] ;$}A64b-^wLo{Ls$,epdcfq<Ej}fOs(w?rꩻ~Cy54S xIxU5HV)qTw<{{#a#@Pm o RnZF8N[,]Dutq_t%NCsozz+ڃxҁ|.xy., *+ELaWj0|D|t'^ s.7id\H(5h67r'-BYh/SttBʇln%Y6?RcC4#f4_e\ >yFC3,Qܑ aBMs^ʊRs k(xsMFv6w*00'V7Ci4G9 :J2 4:q5B[%3Se'/UxUrRwgT :X`XZ6EPr_@+3kfؔn7WPa&#*U}YE@P6)aAa0]ʛUlZB7 xHzl%r*b,$]Q$v;<ɣl1:lwԑFYnث["TB񯽥VWDC>w+ :T BOEḴʧHPP2\J~( CK$mO1'\{R4*GԠ^0t0)#nq#W^J89Tz/DEФW:$Xٳ/Y,7?$9"zRZTiRD+SYu1]<&!sPLϸvL &A]5p(4mKhliOcE-OFnZn-d 'w>S] @"^QBK1?^dĔyr*"ܚeR3x72qܽ=SHmy7GԼbYzZ˽A%eh%%~V]@즈V?sT1'}]nT,)yY۬V;L&:^}6B\y/3A^Utu&0 &iϩ=F(E W w۩Gk'dI2l(㾌e2z2R^h87wȰ亿Vck/gLǜ| "hӥMogGhLTN?״gR^%>>A)!6`Z6Ai|` G,iK["rt[9i"J wl\)(;D`KM 4}vF $5wEw]N "wQ_0(`*1A|MZȁ!Pլ;pҟJh*iwSeRhI9HL"A3Rxu;' |6H>ͩCrw&>i/б%#cuS[۬]ya( ;g)^6UW<=A 2wH;0g iuNn{W f]:*jE9ϮS^EV28y\L`F #~Ifי|QB(,eN!4"xM:o5# >yB@jɡY0g0˲t?eFe&9we5'Ԩu {F$ZXƿXҽ-BOrȈ1>!ڍ͒N~i[<3=B֙UFK LlR[?t1 εE4 _$gr>7αVX.?4)X}lȦ7jހ1_x0ڕ׿OM0^{3%A#|814aF3 rrG#6A66(,2h|RoNG~> d?t~ݡE"}av]; lt"j8 Kl!e;^7ŜkTG^9{a7 Կ=\p9r) 4ϗ́XaCQq@^rɻ#T d ~ZJ>>m^1 8Bp=݊a>O~TÀwTRHq^Jko T(;0+Dϻ-gX?zM QYv@#ҠYPTi;gt"$;n8D$] in3K7p9W>jցCoF{]fTɽ<fUM(bzxn2j&-7|M{S njIW#Ka (9|Ll7elٵQ҃ <EL*|oKGF~ A|Q* tyeȼJU(B1bs='eC{=F*x4O#E3!|_jHO?Jc2swFj9`@c_V :LhSU\AA̗c{6!){'U ްE'tr/~z22x* (b7kӻAi5\W^lUr=;xłMRtS M} ՙƪ  &Tbwx}1^@jbToz+EJ`kMUЅaMl7F$B1֩K] Oh<媞cd!hsP-n]βAz1[SN=4y20:n.-bxF`8l\0ge:l7Y6K{Ud <iSfY]weKu`nNưmAaj&)0|3 ۜM6< =N͌W㧋@<n.h/~r_zuIB5,xihӍ>VX "?6o˿0eq75;HK+nn-s~ݫp4%w{-q9iǏr2Ʋ+LfݎfZAҗ9W4YBM`FPJ9X.gCe)xDŽ W>g ]%x`ldWۡC@ UQaw?e}u-Cp+QhuˇX*'qeCAaO|TvülbHYݴc !5fڰ\:췡6# E1)F^k#)YDq/=5qɝQ4/Pd!4Dyr^ &2؎rS"9SߝDN/N4V2+ue>- {?dA椄 |,%u:=" <M"| -eɽX*dPIQ#݅k={7|8&] F1œH_S?h]D/>;}m#D6E~ģľu!& ,՟9Huҍ; ` & %5 v+:ߊY}RYFhSLwDYxN 2lV%MJE|.u[%KHé;JvCwm`anpGNxI_NW> E$TOJ=Hc??{/$90ZRD.ˢb"a-75};©92mo};|G}#Ar4͆c@c~ꋴ1Xج> z{eBp{% ǖm0$кxG Ʌӊv9HCE9 (" ^zex] #~q$.d0?nFltsef";I E#·զMGZ޸ dF'1!怒"ZFHPU|qZm^-(jd.ޮzqOMdͫ `lrU!H:BF?H.l7/c, ҃ba0,JNpZΜjnNשPd<:b"9n-,:{vٚH- LXϳd#tLt<5 d"JA1-٢uu/?tsd6qQE{P((g /2.@ w Y" sN;;8u !9C TZJIbHQ#U`z9cTG:d"#%VP:N&9ՈYeH"D`_sΥ/`˪vuܵ D0Vƍv]KӡbfPjE?c(de#0 5Hdsı:$z3eCy J) 7IƺcqulG1ĝ/ߏF8 %^n_}>LA&QP)G&bQV$}14SOo&9yӹO1EL՛c5qSD|uZF~Gh6uME>M% {֟fn|@0vmB\o6_kt">FF|"hgD#e HAPPHA-dz9a[3;jP@WW`j!lٝvsY ycԪUc%Zt[S̱۳4y/jMF M߾S;E,9:_6@>_yR6NS Q5hF-36Huh!V5kQ7g]J+9ڜãg FU{G'SpڢKreʊ5왕sy:DBl qNR~[彩1z7+I17G:ÒZTf{gm w]xr g9(R2bbrսT'd6kkwFy!mX#*Q5/XYK}# <*`p)2AIWbW}'d.8~fN^z8;${^ݜ?>$k?>څ98S;0bw-+LMH}| O""saM@~)N/A -U/& ђ*&)}o{z/B\hWd\,xlB O3KEwkVў{d]!b539I)RaàVn(8.W&`6钥i??^o8s}1` ٴ"5 p2 9:rsߟ^'m-9daJ"0H3afZo=~ɇp$"% Z8;2,2ᅍ#N}BX5Ebxnſ˅[⿔FW$\hs4pSJcvOE^WJH_"?||i:+nx &y\[r0ȓ[E{]sDPH©ɟЙjz/ O(ɷOnIVJT}\"yX| 8J>^c])xc#J/gW8"â<\߄s3ul43=8 _pD׳}.۳zwG5UWZM㻿R Cf&՞!y^q;Ql_mQjOC =\_s+Yۻi`4ʩ`r@hJ6f yX.#&qy<Т CZOG{.Z:vGQ"m_ڰ̄^}1?f/J c69c Ƚʈ/d!3Aq.Xv]%+LNdqF!B:tH4LVzƞA'|ʉά$HĭIp{;ѪFTT"kBnsy2 xw]=l\dcj",>JЌGn ݔفMEo0[:K^Q h_^ڢ{ f~Rc~=j!_e2Knm $-:lYcIt3XkU!:G_Ln2FZ/dhU7$2^ ) YO(ƨ7(o МzKpiflI@pFc#`Gx.~ZdQ+o#2wW.l?嘲,,aZ,z7TD\ME%d=vS"U 6UN˙pCɗ>XRybk z/9h{U;f=Fƒ5xq!P. FV}(` 9bUmv_S9ODbaD9:(D)D*d~!2!58!a1|PX}fhFGz(wnQ;RZ˾Ek8#$N.)48t*H%k)E&9eWscҠk=*:ffz)ҟ~ۼϞDt/:PG MS/5OB^"j"$-\e˔Goz#Ó#ѣޣ#zV=_(7><-n0v8AX;5 /R*wUCBPg7l}>S``{Y4f5-ew~cfm*lbw_P0qln4ZjZN qsy|{oB񏟵j0y*( l[3E 3ӧD*Idk,ZW52Ca4s83096Rr2iҘ|,ݝONyhf4: #&t8~ukx{* QF`zQj*yy*&2ED.mW'U*(sMhTRQ28z\ }kcG%7 -uCy!(? ŭS'WP HyڅIW*nڜ2:|7W<C+&Waz)7+K9%jKFۜ)Ho]U>idLD0#D橦-6Ҕ?FK_&֒A<&FDe㳙wT^N/}Th)NWr Behh< 9bā￐=?Oؖ*#~zXH='eS,k ?ۃqzT jWEqPs-Bfox {hxU O>xܷkǻ۲^6 $"HUYdYpp*OM&gșG32Yt7ے%Xm'/#c;txßSRhKA 3"kuȇ-K;yTIQA7FBVէ0QԠ| m%ܗa1FeQ{N:N/(͠ҷWݹHuqȌzD:JYV?, ipFCBv^3wVqeM9+2Pq怘"8ُͧjsWkc+QӺí-۲'>0 YZspam/data/Oral.rda0000644000176000001440000002221212346261543013545 0ustar ripleyusersmzw8gvٲ>OY٣dg4I* J(R*oR! 'WMWή鹽+]HiW\>Vm GuѬrK,Z7<]}_Tn8Gct'dHƭs$‡7m;pm%& ׿6UE׭"Mhk~%;ܯDSrj> W~Q} ׯmc+tyˋc ߖgErklh3ܦ։6+?o[oKf {܌%G. Z ihB{/ʝD𨶏0CoEv-AÄ7SEhe/0fXq*ڥ}{(?2k++vJYӍBrAy|Ůqcf;ыn*_-*NF y卓]`+#t +$mbUԠa5/h%]ˌ +{7E]Fg/OnE:w*Qc-G~t||n$hL M"e&[eQhj(\yhv+-A{Z}ԝK bxTUq]JhgVˉ3ڥpѸSb 7gٸ^s~J،m4,Yy/,Su* N۞ .GSzkϴx`|D2Wa~}j?(Yڷ)*P~gI;B"Rzg+"QAHW(:a.xNCKhjSp,ʜ<9>+vmTٛc*#ԯ3dݯw>e6@͸v޺ov9X5MS?{vV;Rц_(ARϬh:1yJ3.ʊ&Ty1|.h+EQ?PohVShނ:#FWU@x[4 *]8t~VHےxlEG a49}݊ l#6X&+QkiQkj-`ޟbZ*OPέZ X1'ڀPLdLUgVE͏SbzST??|~"M=cbZF!,Tr-tVJPhB*Z5EÏ4ԡ?-͒Y!rmy" ;ZrP>{+& aԬkgCP3h +e2fT?fyjp dD۬PYcjme9r UuvΜG#4TZo|umh9YGlF>굆zjz>6AS5lрv]W#UDBLOW5+i~AU 2TI8!MUw8AqB I߲*)IS mDwɑWBcϞD)3ICWdPٸmzyj~uz+f~˭b8vA&nG쪼&]He"DhJU*]z25j}jtnG^hFƺ*^=dN9Q{^j\BybE3V>Nw۪*w*eGaV$_P<#\VP"+Pb_^c/T QA9J:797*^_c&#"q:Wps;neB'onDXto(>̻~ n3|53)U#=?TeN۲e~-)yuOZ՞g il]3ϏGDSvuM y}lsU/~;Pm(ضVM9$_ }!Q*{JKy K砹U:4de|z65zNL@'(gK6Gs{{PYa[i2r8yu@ ,?WuP/ìqMR(F騻NCcQ8-ȪQvwg͢lԈ;JPVmLnddu .}WFyW_Ȏ8*iwE(qOV(E{enAh?gk 7/h,'kU.tl+mim'TR櫇?N1gxTVXy{*TM^]J7FWC hT^gj;PuXJ W:W8o-WFm Pr+=U{JQi/u`@o|hF]|(j[\c3[ LoBK`5>ٮY@6(ZU} :5P}oVKwǺZAu=nf׵(v꽈꧸&8Ie ՉKt"Tw$^3BMTOA6!'Vұ|sP9N5[rK+c75(p~g+d-jlW"kw9z|sŀoRsPHRVY<*;o؉; Q'qS(Du**uT+ g %̴mm|Eotg~cF(fK::+ YGQC(y|9}c3y}dϻ2. 9tCμw@;oաTWO3C3<|1j G!wNPA.OF^mBmn,(sMe(z=}%v\Us彧 QB6[[WO+=_zb.{PMLW]c&)Zzѕ(A;ȉDV~C (dM ,l~}V+I4W5-Q B?xQҲEtJ2H/<W[߀Kjȭ#@F'S^cLcgv\zwPu0r?%v5 ȝ<u{ʎoMƅsoAv&) E/@Oȓ@=b|5+?_4d01c[LdAwÄ6C ʦ=;wϧNUnZMJNmP=qu]8lfY|X ]*&@ 8v|a8ޔ a`nRl>1Qq~0d'4s t;^̞(rnP˺{b&»SM5`cv͌Ca.@Mz08qh;EB'*Ǯ<Y>͇W-bOAв=9a0 @(8=Ղob<`WY}1Pei!Wr`_;00a-㲌/ =^v53PKX ?0QYU>joVF>L ՙ| ݹYQ'`(.H M ^'+ 4 \zb GkC`_Pis0qS2 6$gC?%w߃/02y'HS _U%d?Àx[{vS[68ߊ{]J^7r^JwHJ$(:L9 V> FrTB(akя0:Pog%/>&#&n8C~8YS?٪h!01~u&X,-`¯d$>_ݭz&rẒ}+NXʄl -0Y20`,PöDiP6*$U|~Le%ɵ@Q𮴸{&.l1;wヸa |'f|}ښVj3,X2)osQ<ۡOg3 5nCn.>nCB?+v9ҩ@i$#19I7aTM' X'-&B_:Nl5zt?L\Ou_a& :T%^# @v eH0躼 F^ sWd{!px& 2fݝCɔV"LY[} ʀ 60JT\9"6=αQB 0̾-|~N$UHVx-MvD:?|I0Sڏgͺ[\hlֱR'`fʦ:Jwy<<0X>j]g`B~K^ @=]MA ǪԯnoC>UmEǑ|j *)#OcL2W L@*O /o?]ho>, Su:>9{'9<{!#202JW&'LeʘW xw;a-wG'ĸGظ yo T?Cq9%ݞ(LԝJ ~0T49 46g[.xL MaOa@W T-b`;sK0q!Jih=} >FֽԾ 4O~6@}a Vqf_Ȧ_ ֱ+ 3EWl>}Qe^w[um&q=:*8ah;71&ϋ=b^܍].Dl,L|: =2y}asUW& tw[Cԅ K@)bB$-;X~ `E{QP.*Z=+oC7#.0ߎykOUIC﬈3CMhᔂA}0*Ŏ LA[~..eF ?^ t"6üY<1N jO$f3jf:[ܻ h<ܾc-LvWF*%"5-I>VJP_@2 D:_a*fùK0]>0_/f4)@o'Mxo?~,b_߿/'\-V0}!Gl;3w!l6tzC@kb)}F ZiZ8kCkl =cfE0zؘY-hX{VIq:=a94vx̝z>0y&P8Wn? }mSajrYk-;z)ve҉KșgJ}LTeh:k&P6lȅ~ `gQ1LZr #rOh ݒgr|^wϞ Lbsi۵a_:R9ta;Qǒo?LZ3Ы3V*mcOgܲXL/vHӾ׿@q֑g0[%8 VߞU# 3$!j_e@=x#v3yS{lv%; 7b`gx#fA|r iZ|""Y\oy`ZT"6PG*&~Y O.]7,i ]U?Z:4Qm.ҽcrfwW?0ޠwMWadJ hL0Z29xV~Y0%\b{F^i-Q z~)93Bm~F7Bf} P9$+bZ*H{'~HQmU `8֘xp熈Dt2t^Wq%W*>V5s=@ӔLMx6AǼbߚ0yЧYyz#~EPs&kšK(@2rcˬkkzc.g(+_: F܆'ʯOCwd Y}ù @*1Ketw ^_ 5 8;_'pl|̏f;C=Yul=X|W(֛ e;@O_շ399 E+a=;=ia &N6{ޮJ /wvP`FsT/L)lp z"#+|Orb; (xeTnAgj{WA.DT!~I$M0unQ7շtqѤ"-m>84|ù7{1&gwr<4\U<Ԓ!7``GFKq: OkeՀ VQ9W=Q9^PE!.h:&xίn' ߔ3Нcs_4x=ͫR^@i}7ֻӥl^LVh0#ж\ZWXF\ҽ7N+,q_kjwѰAkZAO񞏿)ad ly}`]\qsm|\1a~fy^͵(yQ^D$n2: =߂!ذbN\nc5 vz5 =BO*6ghm(W ʆ6;fQW#*^=X~ܳlRǂ0lwMUBMYX..Xd Q OE?qa+spam/data/UScounties.ndorder.rda0000644000176000001440000011506012346261543016411 0ustar ripleyusers7zXZi"6!XM])TW"nRʟX^#&'ƯN^CA kyQ{^/E!W1cڔV[l$$03~+ȝnpv1{*aSu1xi5whHfW{ugCLM5A"|)ՖzQcE ?y$(VMڊ//$p#_(˅чUP<|g+;\(jҰ泌SWnϊ~L>?V?V+bER=85 W{H Q ,/RD"g !;HN#ZXC~iQ}sZf#wd"㞚Rg^N_iӬYܙXWl`85̄: xz"p11B??k.,\XV뒹EfOjDW 84?imbhhje(AB zw]ԯ5/.cXe8v2.G+NhZ3>z>: vd6&6H|ux Ab9/Y@3FEUA/pI4ŸBlsY]g>̻ڝ$PCZ֨!Y2+!QOEM̪C8"%M&3xrQt֩'-m?GUoMTSvm" -Z;Co ;Ǻs1AL%&7E 2>nl ɜL6QnQղ4+0OB/坍;3^<{ {e*>rG@gXdJG ۍr@/{lZY栤DWTɉezhO#Л~#rfHM ߷H1,@@mvXTFιuNs mbƴ} MQ9|ɫ\0/*})M}wty}R^@;<=AqsͮXKT{ ShڐtӠ+ `UaW2Mޙ?qpuO'(!:@m'+725yl؇$cށ֚W(frdXmC3|̍:?+K~NBTw0s1\3 뿤վ ,dpA_3"_ޢ_bd&J 2=FQe֓ cW)\N"")3qё_Yytb~ ]dh }6qZt$j^&EzEN_ɮ3LO߱vFME‰`8m$AļtΥ(1ʼn4G^Niɿ2}7q;u~|΁F>fG|E}N䝽aOBh?iX\#:EBn1gKfDZ2ԴyMz%Bw|$>FfQyjS[vcКw8M[Ջ($p $>]: OkU^exV9]uFlo!{aKf*_rЕiV*0tiUc)tZ O1YS$hr$(9MQ)>py 9*3?{`&12:j+`~O*9Z&ڛ)drN.Ԓq`QeivwzNl!onyn' H sLHt}jە.JEb7M?lS/dWA\+ڻ7&~T'VODJYZVKƎbqX&~*Y薥N$H}8U*.k?S3u<[T 89pY)O˝)8ݡs`+Sy$ PG\/ls"=%w[Gfī-?IJԾK8dC7> 9E. >ciÝ*ld o+ğg Y*.4iq l<ѥX]4Lw2>4iNaNzv[SAYh Y?a,8}i~,>m]Io/Gɥ t4id/H4w\7ڄ7)=3vhlr_r-D#4gx$9gJ}{#^)"BAt(nEFقo[sA*~k?d (ɀQȄ3GN:|iE3@# ZK4>%wh]+ǘC5ȫPVT 3:hŜ`G0aASa8>!;7HsT~43ͦB-֮j:DDED^\ڜC%X1ԸWkt6x<4/tD(o;\@y6r*!`ƞy*ra>m{[I,-;iêBIbpPx ݏFX@TwaӚ 7:"6q}k^N)%̠,T%3\hΕ⊫Xpf!Ĵ:yrƩEG]#)IH˯!”)bkK9L!…K\/ٷe.Iuh4LV)ۻ*:C[gԅamu\.#Ze+E2_tZSoYb[qH؞u;Y噷]}}~4|KxL6%j0ϰiLjhY5^2,\'2Xyk 'I}1h>! t/*ߗkgcC ^U؋$r7`^F 0oe-o?Keޏg32e0d(3"#ƿ@W(X$ۊ#%F]-ں"w,tAeqJHF$҇QIˬQ%*)qtǬvv\9EB}j= Q3ɉ,h 1J$_}Ѓu5k3˽SH[T-΍WG& |9ԗ q,h遢\ّina*aGXk,>Af1UYOF Ř5ro̓jӱ4]?nDf!xK|-%QoYG-\w(}g1ַ#r(P ghU% ihO8}a}c%IЕ3MAv(u@Ree/y ڑqzdFJ $ֻ%-:h6XQ` N`@_GC_Qȟ;ym|hh~Bn Qk1A Ud V-D ?C ؝7xj\hލclJV[bo;ιņ1tG̱Db kY4בxO$>8"ߴCn@٦џgMLj=cIAw|~Qn.W(7>(c0['F6r3 nhs^~5:) +;v;,$,)UaM-{V={Ov8!ލ>ic`$g./*p!"{x j|+eU(GM1CHoAPP_X:enj0`M@'8܈$%qW)v f女IBTmg`K؞J{+K0U2e.0 ʔK /3_sNjno[Wӥ $pViY7jg ychX_nKC7W06to xK;Stc4' [z+ F#L'-n% s<ɖGu＊gMBh5|> Ft (ah 69 T{l`Uh :M{b4ԷKMB/B> mܹz\| ^ 2p%,~:y` Ye o.?Ng 3JwC $mDkЬL:ܗ_&YHpϥyXVuyUV2OIijc5xv 6\>tqXp?7dJ3 fCnM{ lirۻ Aga{iKj,:vH`'ofk[3Gr9f@a+_[mprmB^CDk2x.| \㓑=a`Fk/Rx*7Q)G,؄yQʌB21E]K)!ݢ'nvvI׼+y[qK- k=s<Hkv>tڋORylA]ͻIf)Ho_ɯWИf9B&5;/YY~l&Wѫ#6oԤvQ5AdDSūKhv"sp!o%%|;93^] Z4KNݫE6k*ZC1q]UiZȦ1Cg@EONcqzo“8=IرBNv:Hֹ6 40Ul|`j=`"L:`s*t9d6sPMB-cYؘz;y^yq( 1^>CgE2K?r\88_s~ Z49*bfnsiHLfP[,^ {Y'k&H%~Ӥ94%;q:wխٝH2.Y d _KXe P#WIgAP«Fg#os5NylO}AʂQ]@ń41-+oAΫkGNeŭ?!`9SFƯS TW cg)I窞!+xl舚\G퉖3vOrGCg59W2\jz$‡$UPi’piBuE*ٹq^*bE͟i9V6R{w6CE Oygz3ܧ:oj$nog=e4o^w^a|>2%,ҴPdiNzRѰIa}TE|e:o Ȳ5ykս+ЉTy{P.]3 O)LY#D /wz?QLE;Qf{Ek?fUslf' _ v7 QC*1 l>CPh~LA+d_˸7ǥQYN5 =%3Aӡ6*̄m?)S9A"%v8CBzC`AoGUL@43,Kʖs.mN1܈^IpT%}tR@AGճJU;z9΃T '<)?o5ueg Ŧ1~Y@^cD7˺˪((e7g^sZʀxIB[~l^eBe@)|BAˀlj[ 6׍LO=XpGZkyz{"٘nM"ou1x~+h)Ͽ3hTZ_aֽ-g|wmQ&AHRX2(z;0HƻJ/e+L;ՁX:@tU3o~.hq ~"i@QРIFϗ @uR4z tiAc|\y&U_P^Q& d `GD-1r5CeŔO9ƀ?%#`n5 xUrՌL55;w^ΪѤjHCP){^CΊNnݚ7T2:P t2 !iy"yl{*ZzeZga(F])|\ײюYu?j݉l;³ΑZ̄P:!{/EuiQ\r&4Iki"s~ ¾N[џ_h5!y:qSn) (7k.2RX Zj{5lОGRX~h/s_ZZ%O3 Q~Wb[xD/U ǔy&jWŬ243u@ RI˫& b0]6Ojy?AѺm.O0 _a[+ŞDp4@R,wp }WF` {$XMl i0AMO6/K &6A%c r"}:tnR9 o3LG{Ok8q<;2gX.`ʱ%?psp|_he8rQGM[6˩u># Y;N M}OB3TG<sv8-9MrRUO<%ukl+)^raU`Uj״hR RM_fXܽ*[0գCt;{ÒMu]Јn49k&d&){[V稸8 G`a& (}YM:P{ 6UܣàJg@9#Dkd&Bb)ms8Y\tIկ\b -9d!vғI- RX?1Mw1z%,O)\}6қt тK_RJf;%_wC VѦCk)kp1|]z9H\W쏭v!YvGq |$g,l+GtNi 9ƣ&*8 OST(e2nHA SfM\F;O(:@sukʯŜbBsXV#H{BF !e]$f]SWDh1¢g˾ ɟs+oR'*Ɗbv1֚-}Ӓ -7C1y} =9Q~V2>Un݃Q&rSuwt $$?<ڡ\h9f`Է:93O@/y^$,g/3ʥI#W丨 IV(ZW+9x*Di7>fZK!0Ț/p:e:Ő<Dı%έsǺKm)ie۔wUZz:m\:3 +{(:@J^y5j1U<.Ѫr EtG][ wb!FHs)kۭ.%SzCZh~1J0 [ܵ >l>?AɲoN4IoY/iܜn}"ح ^%D2sBS>`I ?LY+U-$u0+v!WR= feWc`A7>9tt9nFDW _y/jEJ#:r62r JK+ V$︻pl>胑}mO^#U!`2~T@όFT2i^]y>ogQ`nOTFSD$A4Hne3O꜉"4sv qlܐ`1f9Gu&)^.LV-斠I)Ped{ȱ~IxŹfzH` ZT;t%srjA5崕OK&\ h*ְIys6Ip)^=@8E( 3ka:{Sf &\ɩ.d2/Ǡ}aVګc7뺴l1p%8Jwt @.9Nq˷Oj4똚04o>JN#ܱ5[ t/IʓѬµ/5Aӂw&ĄEwd S9wUkM (<>+Ĉ$+{CYX6͑TDNw֝.|5'd-HLoEk)1H7? GU JŮ DAPl1ohR^# bhUƙ}^A'Ẍ[~1͌UT,.f@t(y4 jU`G_.jIA"n0*)G6"JRvKxLoM{͖e GF? 0 chW=W$h\.۽hW eBI(yR?% D 7KhOPxȑ ve8]Iό0>@B WPY(.ԱV a<@"Rq tQT9:Dax#v֖F+EfB\O.FՒt!Wq7ǒx6KwJIJ%6l~;^<[ @#H 9+?R`f7i.^a<%P iT{pW 38ߠLoqixVf' ,.f/;ʚw5(QI7"~o2pFXx֏{l3?N,ty4˙ןͲPjОzChA* 'QZnϬte1nthlƃ8.\,uvUQ:\IT+2^md2Tw .$w )@?z6d5rM!BMiLIIQRa1Id"Sy|]i |9㭽@vjrq/BBxy1Q.//Mb>RVO\OlF JŶ,^`W5ߛFjQ3[[eaUN}.uh@rt|,* OUhS|a mpH[iO']2v:j\?DI!"KdD}V~zX{y~겾@t|.EB]6 P\B]Lm_p+3z2/ކ?c֚\Y{ aRt8)-nhQ:%L/%}p^bDkOg]Q\3;.wW5~8C%4dG$"Ç̟i8m$PI>ܩ0QewSO^a)[F)R4^u'G^if 2uK+VWCPiE2Bհ(itY9wdhie:@3Aԛ |fQ0J;]i9eE`==g쟼V:ObFۃ5Ja:/hO^t5hs(my{ۧʓoGԶ y+]V?GB 1p϶>Q#Ao+sG͔suYíZU|ƹ_{)L?9әNhUݶqjԭu~.pUҹwXk_ {kc9s̼\<&ɢKr̵%=Fm[Pn+EbV;4bTs\*>*GϩHVrk۰ m:wxlS/Ybievy.*h&2ocy>'8? 8-)|PioWsf}@9KVҀzV'6Ԗq2j=1OANxM-(%UX=Kʌ<(;&|9z3ۄ &'{Q a8<1&KKL^ieE bOאgU/,+YMBRLTecW9["-Q*N+nOT_.  ⽝#xvW֧R1xS 5ݜD5  1=)PlfOz J5Z F1nIg*y*_;MX"^2})L@١pJd)(P6^gZll  v~qɈ09(L_TĠ|Ʋ|7l Ž팧Wqk ;<'v[hǫq%hUua8ս:c&]mj{Nb+I0(WoO":MRn>MA| G+aii!$EAL$A,5_`&lW|:W-H j`> Id@wei$%2 .OI`$ PD1Oo~l+VȦWߕ\r.,'N(qwr]9ag9v wsTagg{ w9Yp?3Z]l{)2%ra8*µO,vf2`9~N5MAwcك3[dWs:.U9KBG EA:HUoDPeØC䵲O=wO\0cYqQ\!(8{A`sXyߢ堽tR!u<;?#\;/9㌈[+uiBEr6@DRSt]鱥m)KNA`c!0,3H w~){MV>7+/T9ۀCjQn' _|D2EɎ_ѭ><-}ÅXjS4B#.s,8nhN`AfhܳbU+1ݲh=6EE u:R^fprOpxyZB>zjXh+PP䯟EӷgR y:e谪W PQ%~ؿ%4oF=n*tK;-2;u3($'A跻vBՎNtồIKg8N)O Տ .zUUwۏm\R Ui?=Vy&MaXq'J\>7~EE;k/U5%>:G I:e7eCcpexvJ4#T~H%l=a[(b_'z׃a xVK@.=m .|,.!w#9)y"7& w ~`P" e9^t{\HQ~ =H1%ĨN\GĶ-,.U1ιɨ`ho!jm7Q.4u'X߳Wm@q UX_3򴴖^":uI(6.Ք ?• )䧌ۃ̼U\MVFGEwJ&Bu-c>ttYBao yj3P6`JBȇ5ào6eA=8L ">yP+m, (E6p__DTT~^T~|+I;N2DF8zf o@'f8F"iMಕMq&vC +O7ϋk"m(ft.lx,j Ϫ*Koot P>"cP;܉ۇVPTj6)X~U.kjL|-4p dL1@,"v?ꗬ/7rd2F'>߰{l&tW}@גq!I+li}Dm~bٙV16cZ߱f\jhBYlĄoPm>5ZV E%sB b>IB٢%*Y` 98gpr.x0Nou* Y]Fr)}b)QK@ɔq#[Fvpeʏ Q&:`c{~D:9ە+7܌d1 N5+-6'dFatHwID$05~ izfw4KY.YMC9T 2j6)mRf鉔$Pegt:k+;Ig2/>D.=[Ю:5 -f˺s>L5s n$#|XD;]fK%mpc6ҙ]-r4,CS*{!r ]D#[<; O:UD \n7h;mCN hk9Wi8jl]}~d ;r?mr̓Щoᄼӿ|Jz8pN;l'XHd6J +-Z|5u;ĕ7bF\.TH4]i`<{i%{+/Mp&(+}El*{N]1xuG~"0bGJD]( 1@ISn{=·e芻@'{\p<òӕB{ٯl/ǽhk}nLHH=pun4N`[d%lx]oaf3(٠*]n;F E3 (=OB-s'D raXBw?zaJg?tz.t;Mö̡x y3ךnIǾ {q dvCyO~وȺ]A~/w&$ؿ)LL[VjNmkؙX,χ#(MnUN;H#n#60bA[7D~܈jxH谖kM unڮGN>`MaxJ.`n _zK>,d 5h.rٍ=9 w kcc/,D0Rimy79),?+F䫢0WoZ&MKz`%Ošwv: 2yos]^G{{|. ¡ݍ{ xƉXS&fn,kzN}Gp\j$hL<4ڿ*8$>6nlnQGVW&N!ٰ)ESyҬ:&M; {Ǧה4~g3oDX藖EԅFnGS<%M@̉Rt8=7hՈ]MPG hoT,jHK8sr tTƲd~8֊Kщ1FgIHEF ]Ⱦg,g;\׹Ak@Y]xʏ A) ,?~JǧEV[bdzgd u:tZĂf=BI|;}RM0"f=Ēg.בxeuO$,d;ޭߑٖ4W)ݴ̍tW 1+3c feիfoN@BL/O^Z<?*_df0΁&P`dtF!'h'vN7*fh aǍ${F #jW8̵3؆ԟ8ue;sŰP LBUYՐD>*ϖJ;SP0-ZI2SHg[)?ң$,jh\/H/UYs5 ~ $沏9l(=,rr "tuAf8M 3D*qMRi, ,8 6'{|(] )9t7֪р#FJET@Y\'b JLΗ=)g)C +Ȩ-~q=x(o ItN ww2cC UG+nc DEJb] !n5@7+s$>s 性7{+)^ń3GW |3)GFx3F5܉~sӂԜ~vR1-RǾn ԑ̭54L!NW,K\PjXv4N^},~t>G1AMWRIŧUڀyu$y3ZR  @7.K-$ yͫT}'7i.%lenw[u6 r?{sC>u2pḯձiqU4 Ϝo]=Jb^99j̵-FPA[_5ѥ{ܾWq%(*8N@>@C#S6m$/GQͫpgw0?ږiDx8@TSw$u}2pA!.>pZv+9+|sv#LuQv8Sr_;i`n9ځߟH`d;¥5|".o9J ΚD2 !opŞ8YE^Ӟ}bZ^r0CBȴg 8V_)>i|s/qA yy+1a5Ϛ(21gn7U GJ㧇ŷJD9N-LBK:+(OﯫgG|)QQBֺ$~\WRO2$6DN1iU+z#-L+-<&Q`}]^ w1J5m7=\nFa>z W^&~Uq".&R`c4 ZQև2 v4r-j '%;VUCăSQrL܂vgv7j!H19Fwy3onfu3ǐih;@9s-@߫ipSbUyƛIu v*LȄaoLY B(c$:ʖ[hq^qSJ8=!rlJ I:Kz5[E0БJ:W1j:-G2/&S/Ky 9@!H8U*CQ4+^G\贠e7,Rh@o= ]n+cARM'W;Lreޞ]VZ"h4j]ItPhN`oN(b̂Za8N9=Uj~ КޜY#)wnsOfD*6YnW' jGFى.i/poTɉq|zUFrYoCI^@YHa'y +0,R zsG^)`kǎ:=#V*78ŴUvNp3<7Ѓϵ޵MK#*,Xs=֋*x| ʯ!lj$C*ُ ̥?ʦQ}T}gLZZ]/JRQ룯3Td,ꇗCtSNbѯ+" "`R Yήc߯JQd"ـ_TPǸI;0q4<t8]SOb?D.sxrZ7+ϧB>H;{s{ m.NfAr1cQiFfX[Ts\@Pql'j9d: VuE߈:ZMGջ>PnB!\3AxӢSI\$X>VEv'H$!(ݒ~ɾ"Rpzc܎3\j.+Sޭ-!O&^"Z:!h4Is\si"LճkPYy> pF@zr{û#ξg7_7ڇ{ *l""\@@PY7`R*qL >DUe~Z?m6V%8 p.j) ]wT“HE~߻e?&N>)Vc!Zt!SDSeAwMDՙQuRKdZMJ}8T|'^"VʆkaUP9MLR;qu,KEh+c*761 ^L8I#= ?>VRn C3F3./;Wvzmf^:;iqe^k,r{mrfǜ5Gjk]a]#txxZ66[%v\o%Ub6 ^P х,l_*PldMIvKFے>*(a0LkeN\ƇFPޓ_cAĐ?AV}tm3]0]llp3OdM"tNaӽfFF7 `u<|!S/Rzy^Zih/ aF%U E E*qQuh \PSkza&`/x11' ݰΦofJ5񉖉w|%3aW}p|~"5էU`W%4YcE(fN85mCc¡ޜnY_|+]ꪃg9G:)޾R{nm2Fg*8r8Jm\c}l쉲V4r,zVEy~v?Z: fƃoڽY0%D 5 3mdQ@JFlow  XxrN6"EvDh ּF*EѼW"&'Umn_#^&-i%RȌA"_ F4p)5E\9QW`iB 2XYw_d\_쯐`Iy<$ I=U ٜ= c[ln‡l^@hsrj~2KS틼RҖlvg/Uﯧ\sǴ׋}E|

I[I T|c!2rJN$eƒM,t?}-Z֢]舂Xm-Ժôtf?s(!مs- ɼ}$Po#eG`AQXIXBjOfY/0psݘ3 q5ݲ((, (L_2'ޫNJ]w S_ǻBEXt᧘qTkB}' H 8a MN1#B)ڮj{!hL;20sAXhAJg]T8s)RKvz]اa#ڋlKiH&eAf'>EoM鬰ϐa%yA݆{涓5AUMOoMĶ.BQl oȸb[)XX8j0y--y\ő@w\![ ހ̜˲%X 5-.Ǜyý@M1Ɵi/8Qˎ~ڦ'+ ,aC ͓,#7t~[!9i: `Af7nNTRfAn3HFO7PRIŖUGY"t=:c*5;G'Y{$~ҀjxMMcINFʀw.[ gH d #B$7%DrrH?]tιG*t'+9`o85RT%X&B頗Sj]%WQ];ܣpLS٣^,jjt_M6Se7H7jʾD dz |=v=l7"(`9;jV "ePݠ%9YJIxP{ au0V_Ӱjdd8$NB8%H 3Hg| >P'p[^k0wI\㗰|a!H &[lJ_˷1/#Tt]q^U/0d+^8l$1|1KP{9yع#^S3U?;orGdص*w Ḱst! '&uNQs{k2T_c &$)6oܞ[i1<A!ڗd֐KwO❝wG '.ߒO_TU;4Ʋ&LV6M5 faKWI7dQq 9K?(? ﴾t·+awTP?a:@u}<_i6c TK'İ6LG_ekPڀ^%"=L¯,k]U,w}ۓnNS8Q4V?!z)Q(+HQ!1͘A쾑N0xyDGo/qsИxY\Q)NIڐha"9"$~$"g‘GMvϱ'JSղ:k%kMjG՗Ԗ>02z%:9R{{:Feyu eCv2<ڣʂ@?<'fAQDC`Z@XUҏ'lEܡ آ9osvWڍiqp7/Tb~ǘ?"7 g%44؆HޡN!/<~,93DdGTyVM8I tnCߛۻ@VӃTT IcRjudxHx;ux4 zc3eM8v rYٞCr,f'IB/ ҫD$B;=|9k=p9. TEʠt84 ~ \`|M8 ѲTqy|qĻv6ӡ)]l3 7vW$`u kѕa(+ ttJaK0ۓl-$2Ӻ Bc[Ȍ-OD7V3iΩ65췮}Ԥ'ܾ0`H[P"f:h~)~-onGf|$t/ZC9sR9D!KłiDcʨb A.v 9\F3q0лD]9}W#-+ꕥy$/*qLa'9O*mصֵ *>F~"R!YSW.絻MԕŃHK*5婟EL/HVQdxp]d5 ?Wiq|oC#0sL&i"hY;qu iF;n:5(*Nwg8('٘rݵ2z9Hu?OK|1|)/ NhJR&8+ear) o%RUCvRH/CxH$.NNNщrrYBuadƾC,fH|!JfZ,ՆTSTPfh0+=xٵ4G=ؐ;tocI\NmI^F|_+nq\dIj?쬩 89}pZhoY6S1rfvHc3)_ H =41q8& !OMgQn M;: )KdL+ 9D6Z9ڄb%0kb#SK|`sM{Q/ 2~&S^]Su_{LX01xR5nrGlp)]jV;CETz EjAI&JmV%-#X~x#oc~AUt({ FHnp=lHm$W1AwAs).5^ћ&ڡy>hV9Y@liI7Z]jg̺+E&>WlWlf ۹zOMsu@@^ر,?$+]9J3Xz%ۻj}7$̟PtpI&a @Vΐomk?nhm)a睺O3"g(#n馟Y"t#>4X$N:,7#@W샥o[R$)&(3z53pS" xs7)3*chaL^7!tE1{G=2 Q_;ϙ4ޚ8g a!j^reK͕T V4{Mޞ~&%)f ,یe|/xJ^O0 gJ\fP,#<48(Dhك G ;Uz/Oc؆j] ˃Ov66q*y<B;lanX~mZO3 Q"샚lnRsEg{/w{\")znrCV^}H$Jba"vkcQn 2'AV|`S4Ϙ[,lxυAÆqnh>ShNԮ9 5r)[+Kͽ&a60o5x^3ٵft53pu$stNF38ShqD Նgh=r X! YBF 0ޜEYCp^2cWi PV"ؒЁOܐ~?bF vVf@vnr|~O-*xܿĐp|d@|R\<L뽳 RVvET0( hl ;HJ'_bU_0[ItqΟRӤD9.{N(tf@ݶrq1f>N7-m("npzHҎ/>xuѾ5Bms[F*./r"zf&*DbHu Rۿ#9@G$2!њg0;/g1BTemah\c$Z>}~+`Oa>&[EbPsj$K\D! c){*ٯ9.ܕQ%-eZn%h4d=XWVgd)N e*f(;mZX䯁IeIlŝO]K]P<S7=01`"~wyVQF*/hka9̭B4 kt})n*Zhiw&jBo7ܩFOn! uJ΋:ٌZ¬n[R _|X+;Q%L3I1la 6>R<]rsM)1/rdE(穅b/U6qUKAm }>G;þS*C :T$ @/W9 6Ok?}98}{ڒNC"47;2^J }+9JƂ0 M ~4S8p˜5#iЄ;͍"n04'9Y%W>Gy 8<ځ.U˫2[D+N1/Xt%h31v&qSdf/mӃfMpS}PY;leѤ .N3z||U|UCfdUs}L۪tŗ&93mc '_׻$ &H9 vE7$!MoBlmOڕWz` R5{_A%$GS01;{D$۔Z]:?0k“GY^ڧ"gx\sY u[=~>w$HKTOn97w;LxY<3H̓G0SפLo}F`cd6B N2d*KϐYzftCq-W&ԟ[bJ'55՚ܟb4ͳHy*ӳ9DY嗎Q[ jG^.RblŜ@?4(࿆9&L ^6Ss;WV`Yet@Jnqtq3Yqɨ]QME܊$ؙi?=L`' B~O&ݼ 2F5^ BrRuݴ~n}7WFp#Ph(KhX=;W* 0J I%RrEu1CK;}ȭ[M~NOl)9q -!1w ϙ)eA-zvVywx" F+8yaL\(->tjD/f֧_Mj2 F>gM,g]۽XIؓ]r^pܖQ>Ly9i4#TgW?L_7T[q1Pҙ+ T pzO)54}";ee':6c{2!-$)mPThˈJv`] :GfkWvT?x\9Y=Au[/Ĥlv(C=g3I $􀡳L>L(K:U? 2&3qcjv͛-@WOM:btaX KSkJQ PGdPȂl96VtQoqU0L-(b,|aLGoՁa=>.[ OVu>93}~NP=˂ZW/(mJ4%ؿO?ШJ @O.`̙f`s|.9g\PKdž(O\O92Z,?3b扏$#N7>'e)|i6'O|VGNH1ye!FYN{xGFј$;ȣw\X x6Z '@OQT,d;Qg}~cȣ;R]kUa(MjdH0UoVDľCj%>ښ5_/?%Z+.0TKes>5me" M8RgH(ס &]ܬX{/Vӯk,HuUby2@uH3RWlTHEbÀvWj_Me*/U>~&q(Q%XKC<, ]z\xd5s׭S#\[-_{5{dF6 k#%i m2>}\IUc<5Nv͙zRVY(\kyd j{I;ƈ&uD8eiȃSIWWYd! rWPC<+u@!An(( -&{_o"wWT* ^,HǁPX2'ۜ[pvrceܠ*)"yUULIì;[f qӘM泵c<|QӥZpd#ȂO#FǏFW1qvOVB##]'-ؙ_L ;=)RzG,u!9$|&WF@2WzvIpN×ovxL~rtZb?ZPճ~1LSN>m\t;Qg  #tEAuoe`=q mù}ｳ>ˍprHn3u_0(@xF3u+3ɳ?\pѓV0]>!OdH-JHV$ˊCMSmB"F#&d"Dy[rFIVÛu5Z>l}|f3م,TX(#^+bp2{bDTi'܄Di3RX=R}]$;gHÆ%Ce{p\ND۩ӳ {BuS +wEHan#2&1鐃oٌy7c`إ9Eaa*7LxKm*4r{ λQx!olD2f ׫=@ 8AdԢґL*;psi5DvO$UKf=RĶ>>/o-?*\ӾY@N` ܭԊ+ Uڰu#mȎߗh-{kǔMH@O&T}8CerbqvAL)cX5k!cgY̫/ 3 T|`1( I4^̣R $~%fÇ_^.ͺC1D0zjR * Mv:!X@!A<]H/=; ITFv,bod0YR]jnar}a1vH' " UvFOsx7~Zc/ˁp/_Q^ U6`V$]~N:"pnte Q2,c81=U\۶ ;}RO*'a}Vlzj+D( gտ/_Ga 6g8.fbb4JkV}֖j %G_-Yb*ZHHD⢯v{s}@Is@&c~HXRt2JTut'fh!D .tAόѸ>cb 0Ps] ;$r/cp<ƥ ozĻ00 $A@Q?-[H&Q Pe5^cFybIrl5 +sJnIxFཱི+R LS"\] $y5:x*ADiaϷ19Pfm q2[OɐϠW=Q˥fxȚ0 6'ǣ[|*ĺk ׊e0KG`'|Wbul."'_KTX_ZLۧB/niPu}!#w3y:2P";I%Ŧλ՝&ƈWZ|ۺT~8ϴpJMC̨Jw/}_^m& *Vd('3X?}niV%h_WG!&WGc񊨟xVoXޅ bjns5,Kqt]dҖӆ3N0tDlWWİ w|8#%hm)Hu"/CFJ>23E &,+# X KHhZc/C|O{MI`g~ޮSPq"NacaX7":@>8E=fOSfo2=[*&  rd]'Il*a bK\#"?V%GoZiU)ԢKϨ vFk*$} U ܀6SbLZ[M&kj >0v#ฦ^NuOaѱ)}+g^zTj$ #!!툖̀䍌b@J<nlLg%.i<^džq)qu qdggS7}}21x88w'zTF9{K]8A =k>"5 K1Hf@9q!dMM S=/Ǜ{.Y(GH".sGBux`f6a `'tz)ƨ's%bbg{taXΆ5dы?'S5faF 4(ggAD+b6tgI'N\Fq"`i RC&Cq#gfmgw)swV>%v=KB$F2 D#zѡZĦO\yj~kӥaY,؉O)cqzRuo ]6LWyٟK"RQAjY+jDk#kfͬ%5U nHpmy??ƧG',_fk(R6J', _LSIeB:ǖ95YFd3Kl~O#"f!7-EwN&]!]q': 8hVOe&YCWDc:Cs.{8dJnG7r$18IcY`pMQ>A8SV Hg>Pp3YM1"|RFϫ*3׬Opt7o aۦ!@V>39L5 xPC(27.if-WP8LVt΀q_}';мң,T2 2,ͤ:37\v&YP )ӥ'٦Sٶqtzs8MK{P]+ 66%=P!J&\ oNr4}G˝#֛t ' y`l'|26]Y'giVK/?|}~ "=ĵDʖDs+&FJZ{\-o GrE\mw$}+%-aR zYznkeRbq gyR$rPbA+wuR룚VIAy9+NfԝK@՗ ?:{@ѐ*}TI]&1,Eh8r#1C9tw8=9#r#)+,ljN{%niz!t[<-  $`tވAY:MS9ZkԙXP NWW!4s'<9Q֒ub|VTRpv ^2ՓpU"HfSf5MbO_ Z?ʙ}_%'GNhE@66"<p kA{ϻZx4|Mϰ9c[#kdR~oYgcA&)%o-i*zUayqzoL\rr|c2+犛ѩq (&2ވxqH>W/ |& +'ķ3 <Q8!#3)8r YB@N njNefУ[·ZX]\k1l]N(M/ݬ>ը8M;p}p7DZpˣNhMml <_WKS);F P&|,`!4:_؈ўP 8>*x WqYBf aY l /I$Bo`iz w( rYͧhCm8fG*x֭ӄrW+ퟮ5s]F{8!g/Fs|ӯ w >'+ntSo̕@R=Ȯ5qXC`Uq{*םn˼#vH^k /"|iԗOrԱ=l`"C*,FxU R) h'wC"}~ţ~5EPon]3r-Ak^A$kH0roixf6ɓ7).܀r?QL1=@d9a;>OMnAna [maʒm]fMG`p68 ܜiF'6+fE pP0`%ikAE6v<8۞JJu_4$a=ez]EH-F5ڙ&gY*++(I({u_úOUtLQEe}9<_VxF]rtp T1sylDB8R&jaK[&{\,d?2Q`QDF:UWqwwC!˚yLbeJJF$;KMxyX@K *lRȃ55sy`:'1<[.ƾ S_\ɍP[ڼNYkPӊG`ΨV|-*u@x3Y5x H:bb {y" /7\b` 0nZ *,МһGY@h;[abWuwǥ1ՑnLf"xfe4gF!y$}iP b?Ƃ]"BQBD[4}NK@U%k FGժ2o+b6+s 5O twvr-RVӻb"7@NXȐp] `uW `nFc6"Ih^Z @i kv)k؍E)X"z}ӫ7}rv!{Q0\kb|ӓ.s~\r,XPO݇N)sͰP<pJ&8Sxű~#U$Z^Kdxt`4 n6z$1RGr& x.>Ĥ!N}b . <5ǧIPֈYk[|<.T);LS T߆:FpK71]S')c5w <Nv6Sy@ZLŒ|܃ I= 9cpqLYc3>0T׬_ DKEr0dA a)Ҵ+>3q>.=W?氇-v+]]|x uSq3?hx*J"o!Jx44c"*>]z|#N&]eh;wIά{#>0 YZspam/data/UScounties.storder.rda0000644000176000001440000005244412346261543016444 0ustar ripleyusers7zXZi"6!XyT])TW"nRʟX^#&'ƯN^CA kyVEXG'3 1=*x&="`錄X+B:J}pm2nCƭ=7* CK7VkpEafei0Fw_{E5b ^Ň,q }١޼:=uD1Nyzs[=5o(fp;4B[ݡwn_>'/O:Aq%Y6dyƺ4Sr;E42@nQ7ϙgz{_Watѝ>NVc ,(q{}2oVRCdZO@C0!-S,VcaЏJXa\Pc嵽2)бbIi|-B 8ϿI%TcWz 2v\_YlʡZS+l_'cPqMi&;+Z?q~1W}u<t >Xja03|̳{n+vEsz?r=ЦT)şѦH1wy BjJFF{2Vi OR4Y2bT9 }8 pWhGqˏbo^co'/d]!hl79s}"8>SFlZM`z;MEX3x, f9 # p'%ISUl_BD0=f?)/cS)'& aEuyz0'>qCWʎW"dnI$?S/ޤ.6j ;ā{lΪZU?rZ8e+][3C)/\$ .jHQRE%Rհo4gqՆi3+:ЯZLDB"Lu6\\lőM%Xjuk 6y 镲#)JJL$L%4|UɏX<~C$j,I2Bs|Ln{u H%EuOsjb)r+2j c^PT˫Jul$ GmG}HWN@b7p!ס$|"S̎ 2)Vc$Ճt ThR-q2į>B8$|gCmHׇ (dFp] 6i &_~OzRoG0"ǯfP^?ثµLoN\7nQqY=.SEZL] l3;.-ۙI{GDT%'s,bczФRӦ ohgim@) :xf-&.3, N)Ee\iƾ HT;Y![O|[%Aj;)$h(M?5+YOD8mszC;F~7/PIkzg \8R1 Q01cSjMlSzяxƜӂ^]ube)̾f鋍Uђ{yEhu 샏=dҙ5WaIrB{.6 @с_+c"- * ޿#gL 2% irjkBA)G 5!7$!*oÿQ_WTR-9o7"c}/Ay <)߈ #r*Nbt~:42Z.{# bBfgY"3B!B٧r<ߝKVPGt@tuHz9_7u.],S""*%3vfZ0nglU&V_sjrr'EH6b`bk֠ NYE֒#kb|ӣnMg¹':\jR=F3q|;kYfs ǩM_ Twm op%WΓj$J+V7m(|&cf-[Upև2@DdVȯƣ(=|RްRNx=gKޒDspF552Aɶ&+bx;bVA;^s&qhxYxĉ:PO|1\1"@4r1k#J#zY@h._tw{KP>c:k(j,:LfBʊFp~Pm?0h!sTRK 6Lj8p ]3l7u@kc*HP|^HR`u,~@;: )(U2>#N,sR?Jج'? @*at u !=hn3eMrP17c\nvcsG?1Bn٩$h&zxu;59xdFH5@ .RQkFRYn@ž>=0jxl8X E1y57%@j wKJfgF6)X:%P [-#)]{æ aQMCeZJ{g/*N՛/Z{`2yX5hWmN^£FQ46F^ a=ʑR/T`?,AUa.߅0p#g(;M|T="IFϻs{=A*fM?[=_T@?Ms]\ W9th 7$;2bWfߌC}܋J] //ġe ;}ENKd+9\D]ô랛s'}E_dz Ob_`)=/c1kGC'R}r Z/֞_Qk/ gJ O`,/ιhx*Z|V"fg/HI\[.W }TRB}BwvRR^;@ݶ3>[#UN6,Y1WoA\(dJp{$գZo"eDZTXWW} GǗq~<6. H.T lBڥ\5g0JW{@KB)LB|[F 2LzW-=^԰eGkI)&ٗUVA;4[Yqew~raNO ?xdC9W=/RQ{j/*g4\~W 8;:n1# /֕eW:InpS7vjxYhrإoC)DC3fW"#=^FXFkͷXMbݔ wvv Ah㹴WhY}@6G'׏3E^Àc&yR,\˓Jgʿ't=Wpޏ-%ޥ. n`2[2q z>~+u>0$stg:@ {y4Gi qlyigAmU9fF>A+(?{bP}5X# _2iz}Y~5cQ,DA$p$݆{5F`QJosK5| L ;D[Țҝ^Y2^O=ˡk]}kcJ?8 w==^\nJ r`+)'$u<3il"= Tw\IRON1J؇=vqU&@Չ38X6a.ח!P#!9ז<fdOx }l6et*rZ5ʿއi4?CP?|;}QF+gHf~yp|F~x+Vٓvmr1W@hpnjxk-/[D tx8#) *K!#gƭ3$X26Lj?t-u#lq&t`Kq^;>&꽆Dcb %+9؆HS :4Z-\ͦN=a$R.. wًy%r<N3 K?Y`@Ma7TSjo44|?,^G,$ muY风ŰRb/`P~V6(Bl9SF %}9>0 cKx<.~򾞁hHŶ89[3!gk*~wnFL?ᯬTO3BzFK<;~ISoBXSuO{6ګNW 4rV9:uy(O0LSGLJ+aa*j:_¦ XR+\ 熕 F6o~UQѩ:ȅf>1Ƀ,ol?:{ٷv 9 2P}8‚*n2Cu|<2^k7)/9 9XQT o`ϊ3:m@2"qS|j+0]*kLfRq8  ̡h$S/h ržpPqs 2N^]ozT11L"`4Ĉ٥#ΏPVFA^gU!x/;醣̈u]0W@d0K3Gi "ꗮ!!ڜ| y=FD!͕t+;4qQn(hx#]:+}{Jc@fB떲yGq 2J lɾ8I|\][ q(a]ZѪ˴lWWjl% vp{H3{hL BXUb[ ZI_XRZ[0=QV\ hSQ!6I-ne{s'p+_JY h U@GCV' w: `ա0.!}U*(i\%jziܴ!?ٚz &kFbZ\jV} .ťV>K3"*u~9<"GChOM!Z$>/AqLcȲ0+Un^1~o!M㞒m $wƤ\vWt^ ai `܆ZA]WD2-nUlN}Wr{5a 3(JW:<RŬ eBݳ X풥klȏ!KTJ0ҎaA >Vy1Ioe eSHjL?ɺb)N2^4Hr%rX)$wz6,{p;.t捔^Y.XȈuQ Zq,+Q79s'Q 9'RJעN_ z T2zL{(۷ӂ#JV[.(2?S+!Ukɹҗҁh˽n{S)1{17\eA qq; [mc0Ru"|: %NQ+ObD Qo,[M0>L$^+9kJx]y4#RE |+)LMlqx1 FX3Bݿ${V6uY)A@(h~ҞϮJiCWŧ(x*Xq)|(/s"&0͹%5v 8y 880Y$ƛ[p=:͇ AY Y6p}($)h89h KFمX[ZztZ[V%}=Z}{# `/v˟ey>D-J ]i;>x肂4cj-RV7)O7rpC0;(SڻJ_F_ T N$&xbn(J- BG}iҾ^}4U@ҋ{c TomX5}-EfMcP Sa^IC*]tP$:f6E"StrV!YkdiWBV*E)k'{;i(-wN==ڲ]j?9VX$0eϧ 0ϖ@'N(I !6Y+C Gj#zaJvw3<)lj4E*C ި@J$q޿%6a؛E3O%7U|2"GJ[͔5cqyYB\f'?5u9v0$-Q#13{lS?*~gY6Qls? ~Bv;c労'8Ny$و<:}wn=\qa=E Ww08Vr(FA+D/i3@1!?$a25.j(FwPZI tP O)s&'E^&o8/t~\ЀLI"dyn_c!^Xzˏߛ/ng؁SǕXeVCtPgH6g! xp.XQ[y$J/ԢJ۔EmFv@Uח㈳G.f:LO٘dKhĦ̡<:5];cԬqwIQHne,lӔp5Os֫>OL WT2Z9%E;'$%`xK|(n A Z T=?ZƝ'p4x^ 7opd]ZL\_IxVn %݂UqZZ.|tD;impP3;f 3ܿl{ HnЍNgi"໒zW3:i&=YNCͺKӻ _PZ.)v0dj(gV-ŏcnf a9AҟdgȐ%"lXc].TEh5`jaiA_ Av'ך iHgK,IvtHu!U5tts//~E:Á 8P8fo[`|.M?6+T/BCpl~V>;>CzW*}9]&5 L =e'>ͷ%~ F^M|OOen|Lz^?c%kY@2掄ݕ;9>y?<">2OP[ ALK9 :0v , EEm#2bέaK$]5_`s- 󕖾yIJlU;։ Q~1E#Z qnN6V#0O,u?\xluZXݭЂ #~JSsQu>|#rem6?sCAZZ$)"]PP_GX[}(X^6}Ha3!yu-f^[O"N%%-&2x^0zc=Nas̿:qCJ}S c o>U20cHI?}[+<5&>x̌TFҾJ Ȩ{ n ̒# cL:UsGZ~7ծƝ=@ ^Kz\H8l\*{894*p鞕,䢼>]X =[P , ؘ/_CΎѧU=;?oI:d4f6?nB\OqJ6%ؚ&/ R [TϿ,8O |MFT)LjjXD<¥ڣ-EZ3h~|$'dEaRfgdR>,"&|yYWXgqe\Eh;ann9J]uo *g7?Kq֖A%4k S-93lHs`-hw`Z} E+vմG}৚eץ_TJID)F5u\Z'L`fu2$T8 |r,auP2Ķ5Xtrw y=NM *)˜ȎCm)b$Lfˇx W:MAקzcPߜLs5;UG@L%oon-{Xx Kzw('9&ZTI{T6ROg3S[ҢVNC1ܹ;PލCI1c%E×36fstB+HYXԍ}TTٴD;NÄճTW?\[ptMSPx +\Z`-&j=3FU@:uRC^wIy-%}m u̸NSn~v  KMn(삯"}?Hu ^|n"4[ڜmf/ TA ?@ ME$L*W.5TΟ@w 'J[@k2^1Irʃ:Dn@a\P9سVujCb#PBZbO~M3s01x^\c&z&FLu3#F4(n$k 9R ׂF " B:Z<8%gIvٖ['UC@2Sl_Nx-EzzN"vlGH"0B׀84h:Qb% ^$ŎQ WP^)kOI=u}E} L:)PH4zރr{M] k7ۀ6 M,ܹ0V)S5۩ZKAra\D_F8|M\VHNO~?v5[~絬AH9OslwX揃[,-b8.svT);<lG >|%g^MĿDF*S-:MEY0DpϳDid#C丶'I/ܗv,gZ`gFB|o$N ]$ Nyp܏raI{I0k;Tۻ^\O$H8(Y51fWu*[HtV3e$QٯшM56>d]LOjy(q.ϱ[֤*\A]|W֐a@Q6 W>m9+UO*_b3I}Φ+,Zn·Oy!z\k|Wr >3f/7=Dl-;l}1eȇqj},2 KUډɢ{T[U866.r@i;}\0܄?SeI6*oYUmE])S2YK5uq>6Y;GQ/$fݜt]@7e3JefNSQZ!i,߃yiAnYH~~fQkJJziBZis@4E)MqnN`ۀѾA# UClihy0ٹi,7f mI*.!Hd=&Ɲ|'fws5[m0>FiоjOp|wQ3^:K{7Z#MGg%8mbR֢,-| x'Z}5Tz3v{iT: ?3uȶX)'#5 rE9?ayS ?Fw߭f}sVu6fOm&. ;^۷15"E5n K]T*L&-,ISFkMz`fGmݪ^$ *N~ۖw*Vځ߂q&n~d=W@V %MP3N!:y Yi״$K mPTeHI8)l\$π&~m+ t Ɯҍh=}೑fj$3Zd sV883qP@WvW_+~)INqx1[4_ݻ*<.`gf,C0EԲlw7keq kmq c?Toznnu^H&|6Fi^{%wFu"g \ a!X*mܢ8)t[`MZ(Aܡ,;MUHj(&29;zRLr' h % @`٣yP|\;T]4;v.X7*JeOR/D֗q ?$Yځv1)ddTOc}8j rhF+|4d23!<&'S^)䍵. 0""柆b5f.⁹1~l\3m#n$gC #Y(t-.{e)[BJ0F2OA~$Eo_fD,k 25GVTkʔd+5:atMLn{+ cwFƨ ~jTv4}JNtvH_GǓH"N&QC=4 Pk':aT&w}C@,B_wNGZpHT-bq넹6o_*1LFQ[̼ I)¥S !m?Y@j6E9";e u)74|=J!>},޽.>Sh=vз. 5A$tp&ff?ekoM#ẑ@np3RQM/ [~Z?KBFdɻh౲d< H,56g.쾧VnR?,Ggu#%gg;]\?%!Os0e$PG-3h Bۨl2R9bA` ;gCDT̮k*6jj[ < 11z1d`]mi&DrE36aAkޠRӴݙT4,hm8H< {=6O32"n0)ˡyRW bPoF:Ta j 5̧n"ίPֺg8z"F9{JvݱP1 0mpL3RymB]k˸tĮ'XeWc'z: l`|[,'ZǗS ,}8Bh~%O{es7[h3،Ǟe}OI%"a@oݲY>͆i5uuQx /'Rc?DžıE)& F3퀴zV,ho LdH"H##X_+odˁ&xXhPN zUB*s=Nto 2콸C?Y&ݓnU!'CX?*R3vEWA8?J oˠ$򝋱!Q}`c*b7,c>gm/ l^cw}oPKs]Vm*c "![kLzN} wahBi )#E!2apabA6)V=5 i!Noۯoyd?=;-PnnsW:?룎p3;`1e-.$\^ ~ ʯ* &@G;ʡTv)T6+uh[նߝr-r3ӞOHgks-Bg8KC,`^L7L8uQGGKAT׋Ř Sks x?{YD:A/v39ղi%\!Yg,Fr5H#K܄7/hAmB ث Ŋ* |2u r$[DpRyn@C>. {H xB-,ζ1l0< u50WKsNJvG>Gţ6)(c̴ 1o#U k}X74zz5 zƱ ݮ5=VH#;h o8MK:3%?tL1E%.D`^ YCit`eOdI`ĭ-8ƌlma^:K^5}^ \2/pb ny:#\tbC2ڸlJ[`g3dABųൻ btutuoGӥm\Ljɫ 9. k:w2FGý s"8F*+mJ-)<*qS!A3;\Ux{rO| Jk|AV}򗍝oR~3gZE+ l8$_V³q53Ɏ-~܍ɭc[+Yč' :c Jz3O11C8!BH0^9Un `ƐOVaDEXv]C8b<^i,r~fUTeDkhG9(3W͊=c0 zCTKW(l[[qKBKf؟Xf`Q=0u`_C鐜Ƙt"'"x.T<#Ju/Q/Hت42hQV9D1X/x,9T 퍼s?6 K*ȝʎqeyKn[۱+L hbiu]c%8q׶fy?]Y_ԁ{AD/` 0zfM6tIrN[T6&>3df7\bQwҋZ~ubnp>2gsaFN٤8[Nq*h¬:ᇙb[K}Je]\WC;yn=J|oUsSa3f$D07jK)cK.v5=;tv1<s]#4wƇAj~Dmȅ0 amQD|A[ EMohtR,;3R\fy|pbb^ by_hfXbоE{>0\tw U;z< :!@iP:5 n0nF148;j# M{޲Q@ ~Z+ϙ;S!M]O[uEgwQׯ!| K@^A~9XBaᗥWK0%6пUkˌzs`4c[l?0#'0j~l*ApR~XX:^`^rZ pɤCM'5#eɺhHnBȿW~\|i6Ub\ 4 }Wb2C4~ :U.gp=e2Mܯ rmR<6-ǁ#^%JـՀbkTX[nMkoIׯMB9X 6/߄8%52'P Hƶ&O Fj,}⒲l!v7Nų|swѮ*[ 2m33`Q!QqlzrJ6/yo~w&h'~l([NxL15",ʵBbPDJa{ElcV 3ijaEFANCнõ.n1]z'.HaT?h rlmgזR%''ഖ aކPi<O0Xm3}o$93{.Қ[>(pL_kjV$DyzPI.%uAZw3:roNԠ[ ;XJG x ě.ءhZvIgEѡ5qA鯟JBGjA|y!ĒA̱n|Prʒߺ_Vrsg]_UNȣQȈxV^oa&v5HLSH!o翆*y|Δ(~T3L:>'JvAZ:+BƯxGx&T6Pȴȭw+ OX Ug,}Ov;ax9\IkfR!Eo%z`_TИ0%kd&к>DwMđuCLcҠ&nJNԆE'܍(r{C/  1"8`tR|9"yǞX Y9ՇQ>/dHB(l˘>}0ePhHTK4,ol.Hb5Vz&8?`$ X!9. hz{M;|rn.i'4  "FwcS4Mo49"}y*,Bcό./ [YZ587Wc9hV%N7"B~'6GxH Z<-kx.,I\%b(?ʡX69!{u)K'6<վV+birY^xD"x+RO"]ehQ(W_ChQy:X U*yv,ۏ<^M(!+%R WӒ :&!Gu-@~V'z(TGn@YL4fI{+m,hBnL&RŢRyi?LSW$D jHT*E/{?Ib{QV_8<uu/1v֢ZcPxp;eЅ}lȃ apz.e;BRPV@f)WE㿕*ѿ Bye - t]|ZXS/Rt'GFiҚ4(bS2%L@_7-oyՙȦP⬥z!g d:(&cK w.oh[&1!v}tN%>0 YZspam/R/0000755000176000001440000000000012403543116011442 5ustar ripleyusersspam/R/diff.R0000644000176000001440000000137312401066100012470 0ustar ripleyusers# This is file ../spam/R/diff.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] ######################################################################## diff.spam <- function (x, lag = 1, differences = 1, ...) { xlen <- dim(x)[1L] if (length(lag) > 1L || length(differences) > 1L || lag < 1L || differences < 1L) stop("'lag' and 'differences' must be integers >= 1") if (lag * differences >= xlen) return( numeric(0)) for (i in 1L:differences){ x <- x[(1L+lag):xlen,, drop = FALSE] - x[1L:(xlen-lag),, drop = FALSE] xlen <- xlen - lag } return( x) } setMethod("diff","spam",diff.spam) spam/R/plotting.R0000644000176000001440000001410012372657772013444 0ustar ripleyusers# This is file ../spam/R/plotting.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # Similar to misc3D if(! exists(".bincode", envir = .BaseNamespaceEnv)) .bincode <- function(v, breaks, ...) { .C("bincode", as.double(v), length(v), as.double(breaks), length(breaks), code = integer(length(v)), as.logical(TRUE), as.logical(TRUE), nok = TRUE, NAOK = TRUE, DUP = FALSE, PACKAGE = "base")$code } image.spam <- function (x = seq(0, 1, len = nrow(z)), y = seq(0, 1, len = ncol(z)), z, zlim = range(z), xlim = range(x), ylim = range(y), col = heat.colors(12), add = FALSE, xaxs = "i", yaxs = "i", xlab, ylab, breaks, oldstyle = FALSE,cex=NULL, ...) { if (missing(z)) { if (!missing(x)) { if (is.list(x)) { z <- x$z y <- x$y x <- x$x } else { if (is.null(dim(x))) stop("argument must be matrix-like") z <- x x <- seq(0, 1, len = nrow(z)) } if (missing(xlab)) xlab <- "" if (missing(ylab)) ylab <- "" } else stop("no 'z' matrix specified") } else if (is.list(x)) { xn <- deparse(substitute(x)) if (missing(xlab)) xlab <- paste(xn, "x", sep = "$") if (missing(ylab)) ylab <- paste(xn, "y", sep = "$") y <- x$y x <- x$x } else { if (missing(xlab)) xlab <- if (missing(x)) "" else deparse(substitute(x)) if (missing(ylab)) ylab <- if (missing(y)) "" else deparse(substitute(y)) } if (any(!is.finite(x)) || any(!is.finite(y))) stop("'x' and 'y' values must be finite and non-missing") if (any(diff(x) <= 0) || any(diff(y) <= 0)) stop("increasing 'x' and 'y' values expected") spamversion <- (prod(z@dimension) > .Spam$imagesize) if (!spamversion){ image.default(x, y, as.matrix(z),...) } else { if (!is.spam(z)) stop("'z' must be a matrix") xx <- x yy <- y if (length(x) > 1 && length(x) == nrow(z)) { dx <- 0.5 * diff(x) x <- c(x[1] - dx[1], x[-length(x)] + dx, x[length(x)] + dx[length(x) - 1]) } if (length(y) > 1 && length(y) == ncol(z)) { dy <- 0.5 * diff(y) y <- c(y[1] - dy[1], y[-length(y)] + dy, y[length(y)] + dy[length(y) - 1]) } zvals <- z@entries if (missing(breaks)) { nc <- length(col) if (!missing(zlim) && (any(!is.finite(zlim)) || diff(zlim) < 0)) stop("invalid z limits") if (diff(zlim) == 0) zlim <- if (zlim[1] == 0) { c(-1, 1) } else zlim[1] + c(-0.4, 0.4) * abs(zlim[1]) zvals <- (zvals - zlim[1])/diff(zlim) zi <- if (oldstyle) { floor((nc - 1) * zvals + 0.5) } else floor((nc - 1e-05) * zvals + 1e-07) zi[zi < 0 | zi >= nc] <- NA } else { if (length(breaks) != length(col) + 1) stop("must have one more break than colour") if (any(!is.finite(breaks))) stop("breaks must all be finite") # Patch proposed by BR see email. zi <- .bincode(zvals, breaks, TRUE, TRUE) - 1 } if (!add) plot(NA, NA, xlim = xlim, ylim = ylim, type = "n", xaxs = xaxs, yaxs = yaxs, xlab = xlab, ylab = ylab, ...) if (length(xx) != nrow(z) || length(yy) != ncol(z)) stop("dimensions of z are not length(x) times length(y)") if (missing(cex)) { warning("default value for 'cex' in 'image' might be a bad choice", call.=FALSE) cex <- 1 } points( xx[rep.int((1:nrow(z)),diff(z@rowpointers))], yy[z@colindices], pch='.', cex=cex*.Spam$cex/sum(z@dimension), col=col[zi+1]) } box() } display.spam <- function(x,col=c("gray","white"),xlab="column",ylab="row", cex=NULL, main="",...) { nrow <- x@dimension[1] ncol <- x@dimension[2] # For small matrices, we transform them into regular ones and use the image.default # routine. if (prod(nrow,ncol) < .Spam$imagesize) { z <- vector("double", prod(nrow,ncol)) dim(z) <- c(nrow,ncol) z[cbind(rep.int(nrow:1,diff(x@rowpointers)),x@colindices)] <- -1 image.default(x=1:ncol,y=-(nrow:1),t(z), axes=FALSE, col=col, xlab=xlab, ylab=ylab, ...) } else { if (missing(cex)) { warning("default value for 'cex' in 'display' might not be the optimal choice", call.=FALSE) cex <- 1 } plot( x@colindices, rep.int(-(1:nrow),diff(x@rowpointers)), pch='.', cex=cex*.Spam$cex/(ncol+nrow), col=col[1],xlab=xlab,ylab=ylab,axes=FALSE, ylim=c(-nrow,-0)-.5,xlim=c(0,ncol)+.5,xaxs = "i", yaxs = "i",...) } # Adjust axes labels. axis(1,pretty(1:ncol), ...) axis(2,pretty(-(nrow:1)),labels=rev(pretty(1:nrow)), ...) box() } plot.spam <- function(x,y,xlab=NULL,ylab=NULL,...) { lab <- deparse(substitute(x)) #only a few cases are considered # 1st case, a colum vector only if (ncol(x)==1) { x <- c(x) return( plot(x,...)) } # 2nd case a matrix tmp <- x[,1:2, drop=FALSE] # extract the first two columns plot(c( tmp[,1]), c(tmp[,2]), xlab=ifelse(missing(xlab),paste(lab,'[,1]',sep=''),xlab), ylab=ifelse(missing(ylab),paste(lab,'[,2]',sep=''),ylab),...) } #setGeneric("image", function(x, ...) standardGeneric("image")) setMethod("image","spam",function(x,cex=NULL,...){image.spam(x,cex=cex,...)}) # the following is unfortunately not possible #setMethod("image",signature(x="numeric",y="numeric",z="spam"),function(x,y,z,cex=NULL,...){image.spam(x,cex=cex,...)}) setGeneric("display",function(x,...)standardGeneric("display")) setMethod("display","spam",display.spam) setMethod("plot", signature(x="spam",y="missing"), plot.spam) setMethod("plot", signature(x="spam",y="spam"), function(x,y,...) { warning("'plot' with two 'spam' objects is not implemented",call.=FALSE) }) spam/R/subset.R0000644000176000001440000003146312374672415013115 0ustar ripleyusers# This is file ../spam/R/subset.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # SUBSETTING ########################################################################################## # notice the drop catch... # I don't know the best and official way, but it works as it is here... setMethod("[", signature(x = "spam", i = "missing", j = "missing", drop = "ANY"), function (x, i, j,..., drop) { # cat("missmiss") x}) setMethod("[",signature(x="spam",i="vector",j="missing", drop = "logical"), function (x, i, j,..., drop) { #cat(" log call was", deparse(match.call()), "\n") if (nargs()==3) { subset.rows.spam(x, i,drop=drop) } else { subset.rows.spam(x, i,,drop=drop) }} ) setMethod("[",signature(x="spam",i="vector",j="missing", drop = "missing"), function (x, i, j,..., drop) { #cat(" mis call was", deparse(match.call()), "\n") if (nargs()==2) { subset.rows.spam(x, i) } else { subset.rows.spam(x, i,) }}) setMethod("[",signature(x="spam",i="vector",j="vector", drop = "ANY"), function (x, i, j,..., drop) { # cat("vecvec") subset.spam(x,rw=i,cl=j,drop=drop)} ) setMethod("[",signature(x="spam",i="missing",j="vector", drop = "ANY"), function (x, i, j,...,drop) { # cat("missvec") subset.spam(x,rw=1:x@dimension[1],cl=j,drop=drop)} ) setMethod("[",signature(x="spam",i="matrix",j="missing", drop = "missing"), function (x, i, j,..., drop) {subset.spam(x,rw=i) }) setMethod("[",signature(x="spam",i="matrix",j="missing", drop = "logical"), function (x, i, j,..., drop) {subset.spam(x,rw=i,drop=drop) }) setMethod("[",signature(x="spam",i="matrix",j="matrix", drop = "ANY"), function (x, i, j,..., drop) {subset.spam(x,rw=cbind(c(i),c(j)),drop=drop) }) setMethod("[",signature(x="spam",i="spam",j="missing", drop = "ANY"), function (x, i, j,..., drop=.Spam$drop) { # drop is not implemented yet dimx <- x@dimension nrow <- dimx[1] ncol <- dimx[2] if ( i@dimension[1]>nrow | i@dimension[2]>ncol) stop("subscript out of bounds",call.=FALSE) z <- .Fortran("amask", nrow=nrow, ncol=ncol, a=as.double(x@entries), colindices=as.integer(x@colindices), rowpointers=as.integer(x@rowpointers), jmask=i@colindices, imask=c(i@rowpointers,rep(i@rowpointers[length(i@rowpointers)],nrow+1-length(i@rowpointers))), c=as.double(x@entries), jc=as.integer(x@colindices), ic=as.integer(x@rowpointers), iw=logical(ncol), nzmax=length(i@colindices) , ierr=0L, NAOK=.Spam$NAOK,DUP=TRUE,PACKAGE="spam") # some copying is required!!!! nz <- z$ic[nrow+1]-1 if (nz==0) return( numeric(0)) if (drop) { ic <- unique( z$ic[1:(z$nrow+1)]) dimx <- as.integer(c(length(ic)-1,max(z$jc[1:nz]))) } else { ic <-z$ic[1:(z$nrow+1)] } return(new("spam",entries=z$c[1:nz],colindices=z$jc[1:nz],rowpointers=ic, dimension=dimx)) } ) setMethod("[", signature(x = "spam", i = "ANY", j = "ANY", drop = "ANY"), function(x,i,j, drop) stop("Invalid or not-yet-implemented 'spam' subsetting")) # the proper S3 subsetting causes problems... # "[.spam" <- function (x, rw, cl,drop=.Spam$drop) {subset.spam(x,rw=rw,cl=cl,drop) } "subset.rows.spam" <- function (x, i, ..., drop=.Spam$drop) # approach: we extract rows (nargs=2) or elements (nargs=3) # i is a vector of integers or logical! # nargs idea from Matrix! { nA <- nargs()+missing(drop) # cat("subset.rows.spam call was", deparse(match.call()),' ',nargs(), ' ' , nA, "\n") dimx <- x@dimension nrow <- dimx[1] ncol <- dimx[2] mini <- min(i, na.rm=TRUE) maxi <- max(i, na.rm=TRUE) if (mini<0 & maxi>0) stop("Negative and positive subscripts mixed") if(nA==3) { # extract elements if (is.logical(i)) { inefficiencywarning( "Logical subsetting may be inefficient, is this really what you want?", prod(dimx)) return(.Fortran("spamcsrdns", nrow, entries=as.double(x@entries), colindices=x@colindices, rowpointers=x@rowpointers, res=vector("double",prod(dimx)), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$res[i]) } if (mini<0) { inefficiencywarning( "Negative subsetting may be inefficient, is this really what you want?", prod(dimx)) return(.Fortran("spamcsrdns", nrow, entries=as.double(x@entries), colindices=x@colindices, rowpointers=x@rowpointers, res=vector("double",prod(dimx)), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$res[i]) } # eliminate zeros, # force too large to NA, keep NAs i <- i[i>0] ind <- !(is.na(i)|(i> (nrow*ncol))) ii <- i[ind]-1 i <- ii %% nrow+1 j <- ii %/% nrow+1 nir <- length(i) z <- vector("double",length(ind)) z[!ind] <- NA z[ind] <- .Fortran("getallelem", nir, as.integer(i), as.integer(j), as.double(x@entries),as.integer(x@colindices),as.integer(x@rowpointers), iadd=vector("integer",nir), allelem=vector("double",nir), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE="spam")$allelem # getallelem(nir,ir,jr,a,ja,ia,alliadd,allelem) return(z) } if(nA==4) { if (is.logical(i)) { # logical if( length(i) > nrow) stop("(subscript) logical subscript too long",call.=FALSE) i <- seq_len( nrow)[i] } else { i <- i[i!=0] # eliminate zero lines if (maxi>x@dimension[1]) stop("subscript out of bounds",call.=FALSE) # negative values: if ( maxi <= 0 ) i <- seq_len( nrow)[i] } ni <- as.integer( length(i)) if (ni==0) return(numeric(0)) # zero elements... if (any(is.na(i))) { stop("'NA's in subsetting vector have been eliminated.") # i <- i[!is.na(i)] } nz <- as.integer(sum(x@rowpointers[i+1]-x@rowpointers[i])) if (nz==0) {#trap zero matrix if (drop==TRUE && (ni==1 || ncol==1)) return( vector("double",max(ni,ncol))) else return(new("spam",rowpointers=c(1L,rep.int(2L,ni )), dimension = c(ni,ncol))) } else { # subroutine getlines(a,ja,ia, ni, i, bnz, b,jb,ib) z <- .Fortran("getlines", as.double(x@entries),as.integer(x@colindices),as.integer(x@rowpointers), ni, as.integer(i), newnz=nz, entries=vector("double",nz), colindices=vector("integer",nz),rowpointers=vector("integer",ni+1), NAOK=.Spam$NAOK,DUP=DUPFALSE, PACKAGE="spam") # print(c(nz,z$newni,is.integer(nz), is.integer(z$newni),z$newni!=ni)) if(z$newnz!=nz) stop(gettextf("Subsetting error, please report %d, %d",z$newnz,nz)) } # print(c(drop,ni,ncol,(drop==TRUE && (ni==1 || ncol==1) ))) if (drop==TRUE && (ni==1 || ncol==1)) # this is essentially a c() call return(.Fortran("spamcsrdns", nrow=ni, entries=z$entries, colindices=z$colindices, rowpointers=z$rowpointers, res=vector("double",prod(ni,ncol)), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$res) else { newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries slot(newx,"colindices",check=FALSE) <- z$colindices slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- c(ni,ncol) return(newx) } } stop("incorrect number of dimensions") } "subset.spam" <- function (x,rw,cl,...,drop=.Spam$drop) { # we separate into cases where: # (A) rw matrix: # 1: logical: transformation to spam and extract structure # 2: two column matrix: extract (i,j) as given by the lines. # 3: all else extract x[ c( rw)] # (B) rw and cl one element: ((i,j) # (C) rw and cl vectors: (i1:i2,j1:j2) [i1<=i2, j1<=j2] # (c(i1,...,ii),c(j1,...,jj)) [arbitrary block] # if (missing(drop)) drop <- .Spam$drop # print(drop) dimx <- x@dimension nrow <- dimx[1] ncol <- dimx[2] if (is.matrix(rw)) { if (is.logical(rw)) { return( x[as.spam.matrix(rw)] ) } if (dim(rw)[2]==2) { ir <- rw[,1] jr <- rw[,2] } else { ir <- c(rw-1) %% nrow + 1 jr <- c(rw-1) %/% nrow + 1 } if ( (min(ir)<1)|(max(ir)>x@dimension[1])|(min(jr)<1)|(max(jr)>x@dimension[2])) stop("subscript out of bounds",call.=FALSE) nir <- length(ir) return(.Fortran("getallelem", nir, as.integer(ir), as.integer(jr), as.double(x@entries),as.integer(x@colindices),as.integer(x@rowpointers), integer(nir), allelem=vector("double",nir), NAOK=.Spam$NAOK,DUP=DUPFALSE, PACKAGE="spam")$allelem) } # negative values: if ( max(rw)<0 ) rw <- seq_len( nrow)[rw] if ( max(cl)<0 ) cl <- seq_len( ncol)[cl] # logical if (is.logical(rw)) rw <- seq_len( nrow)[rw] if (is.logical(cl)) cl <- seq_len( ncol)[cl] if (length(cl)==0) stop("You should subset at least one element for the columns",call.=FALSE) if (length(rw)==0) stop("You should subset at least one element for the rows",call.=FALSE) if ( (min(rw)<1)|(max(rw)>x@dimension[1])|(min(cl)<1)|(max(cl)>x@dimension[2])) stop("subscript out of bounds",call.=FALSE) if (length(rw)==1 & length(cl)==1){ # function to extract only one element return(.Fortran("getelem", as.integer(rw), as.integer(cl), as.double(x@entries),as.integer(x@colindices),as.integer(x@rowpointers), iadd=0L, elem=as.double(0), PACKAGE="spam")$elem) } if (is.vector(rw) && is.vector(cl)) { nrw <- length(rw) # length returns an integer, so is a product therof ncl <- length(cl) diffrw <- diff(rw) diffcl <- diff(cl) nz <- as.integer( min( (1+sum(diff(sort(rw))==0))*(1+sum(diff(sort(cl))==0))* length(x@entries), prod(nrw,ncl))) # very pessimistic if (all(diffrw==1) & all(diffcl==1)) { z <- .Fortran("submat", nrow, job=1L, # need values as well i1=as.integer(rw[1]), i2=as.integer(rw[nrw]), j1=as.integer(cl[1]), j2=as.integer(cl[ncl]), as.double(x@entries),x@colindices,x@rowpointers, nr=0L, nc=0L, entries=vector("double",nz), colindices=vector("integer",nz),rowpointers=vector("integer",nrw+1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") nz <- z$rowpointers[z$nr+1]-1 } else { z <- .Fortran("getblock", as.double(x@entries),x@colindices,x@rowpointers, nr=nrw,as.integer(rw), nc=ncl,as.integer(cl), nz=nz, entries=vector("double",nz), colindices=vector("integer",nz),rowpointers=vector("integer",nrw+1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") nz <- z$nz } if (nz==0) {#trap zero matrix if (drop==TRUE && (z$nr==1 || z$nc==1)) return( vector("double",max(z$nr,z$nc))) else return(new("spam",rowpointers=c(1L,rep.int(2L,z$nr )), dimension = c(z$nr,z$nc))) } if (drop==TRUE && (z$nr==1 || z$nc==1)) # this is essentially a c() call return(.Fortran("spamcsrdns", nrow=z$nr, entries=z$entries[1:nz], colindices=z$colindices[1:nz], rowpointers=z$rowpointers[1:(z$nr+1)], res=vector("double",prod(z$nr,z$nc)), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$res) else { newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:nz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:nz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers[1:(z$nr+1)] slot(newx,"dimension",check=FALSE) <- c(z$nr,z$nc) return(newx) } } stop("invalid or not-yet-implemented 'spam' subsetting") } spam/R/xybind.R0000644000176000001440000001770212372657772013114 0ustar ripleyusers# This is file ../spam/R/xybind.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] ######################################################################## "rbind.spam" <- function(...,deparse.level=0) { if (deparse.level!=0) warning("Only 'deparse.level=0' implemented, coerced to zero,") addnargs <- ifelse(missing(deparse.level),0,1) nargs <- nargs()-addnargs if (nargs == 0) return( NULL) args <- list(...) if (!is.null( names( args))) { warning("Names of arguments are ignored") names( args) <- NULL } args[which(sapply(args, is.null))] <- NULL # nargs needs an update nargs <- length(args) - addnargs if (nargs == 0) return( NULL) if (nargs == 1) return( args[[1]]) if (nargs == 2) { # we distinguish between the cases: # 1 spam, spam # 2 spam, numeric (scalar, vector, matrix) # 3 numeric, spam # 4 numeric, numeric # Case 1: this is the quick way if( is.spam(args[[1]]) & is.spam(args[[2]])) { if(ncol(args[[1]])!=ncol(args[[2]])) stop("Arguments have differing numbers of columns, in rbind.spam()",call.=FALSE) nrow1 <- args[[1]]@dimension[1] newx <- new("spam") newx@entries <- c(args[[1]]@entries, args[[2]]@entries) newx@colindices <- c(args[[1]]@colindices, args[[2]]@colindices) newx@rowpointers <- c(args[[1]]@rowpointers, args[[2]]@rowpointers[-1]+args[[1]]@rowpointers[nrow1+1]-as.integer(1)) newx@dimension <- c(nrow1+args[[2]]@dimension[1],args[[1]]@dimension[2]) return(newx) } # Case 2: spam, numeric (scalar, vector, matrix) # if scalar, coherce it first to vector of appropriate length, # if vector, attach dimension. if( is.spam(args[[1]]) & is.numeric(args[[2]])) { Xdim <- args[[1]]@dimension Ylen <- length(args[[2]]) if (Ylen==1) { Xlen <- Xdim[2] args[[2]] <- rep( args[[2]], Xlen) dim( args[[2]]) <- c(1,Ylen) } else if (is.vector(args[[2]])) dim(args[[2]]) <- if( Xdim[1]==1) c(Ylen,1) else c(1,Ylen) Ydim <- dim(args[[2]]) if(Xdim[2]!=Ydim[2]) stop("Arguments have differing numbers of columns, in rbind.spam()",call.=FALSE) newx <- new("spam") newx@entries <- c(args[[1]]@entries, as.double(t(args[[2]]))) newx@colindices <- c(args[[1]]@colindices, rep.int(as.integer(1:Ydim[2]),Ydim[1])) newx@rowpointers <- c(args[[1]]@rowpointers, seq.int(args[[1]]@rowpointers[Xdim[1]+1], by=Ydim[2], length.out=Ydim[1]+1)[-1]) newx@dimension <- c(Xdim[1]+Ydim[1],Ydim[2]) return(newx) } # Case 3: numeric (scalar, vector, matrix), spam # similar as above if( is.numeric(args[[1]]) & is.spam(args[[2]])) { Xlen <- length( args[[1]]) Ydim <- args[[2]]@dimension if (Xlen==1) { Xlen <- Ydim[2] args[[1]] <- rep( args[[1]], Xlen) dim( args[[1]]) <- c(1,Xlen) } else if (is.vector(args[[1]])) dim(args[[1]]) <- if ( Ydim[1]==1) c(Xlen,1) else c(1,Xlen) Xdim <- dim(args[[1]]) if(ncol(args[[2]])!=Xdim[2]) stop("Arguments have differing numbers of columns, in rbind.spam()",call.=FALSE) newx <- new("spam") newx@entries <- c(as.double(t(args[[1]])), args[[2]]@entries ) newx@colindices <- c(rep.int(as.integer(1:Xdim[2]),Xdim[1]), args[[2]]@colindices) newx@rowpointers <- c(seq.int(1, by=Xdim[2], length.out=Xdim[1]), args[[2]]@rowpointers + Xlen) newx@dimension <- c(Ydim[1]+Xdim[1],Ydim[2]) return(newx) } # Case 4: numeric,numeric # result is a cleaned spam object. if( is.numeric(args[[1]]) & is.numeric(args[[2]])) return( as.spam.matrix( rbind(args[[1]],args[[2]])) ) stop("Not all argument are of class 'spam' and 'numeric', in rbind.spam()", call.=FALSE) } else { # "recursive" approach only, e.g. no checking tmp <- rbind.spam( args[[1]],args[[2]]) for ( i in 3:nargs) tmp <- rbind.spam( tmp,args[[i]]) return( tmp) } } "cbind.spam" <- function(...,deparse.level=0) { if (deparse.level!=0) warning("Only 'deparse.level=0' implemented, coerced to zero,") addnargs <- ifelse(missing(deparse.level),0,1) nargs <- nargs()-addnargs if (nargs == 0) return( NULL) args <- list(...) if (!is.null( names( args))) { warning("Names of arguments are ignored") names( args) <- NULL } args[which(sapply(args, is.null))] <- NULL nargs <- length(args) - addnargs if (nargs == 0) return( NULL) if (nargs == 1) return( args[[1]]) if (nargs == 2) { Ydim <- if (is.spam(args[[2]])) args[[2]]@dimension else dim(args[[2]]) if (is.numeric(args[[1]])) { # we do _not_ have a spam object if (is.vector(args[[1]])) { if (is.null(Ydim)) { # if Ydim is NULL, then Y is a vector as well and we need special treatment. args[[1]] <- spam.numeric( args[[1]], max( length(args[[1]]),length(args[[2]]))) } else { # "standard" case, a vector (scalar) with a matrix args[[1]] <- spam.numeric( args[[1]], Ydim[1]) # scalar } } else { # we have a regular matrix args[[1]] <- as.spam.matrix(args[[1]]) } } else if (!is.spam(args[[1]])) { # we have anything stop("Not all argument are of class 'spam' and 'numeric', in cbind.spam()", call.=FALSE) } Xdim <- args[[1]]@dimension # now, X=args[[1]] is a spam, the treatment of Y is easier: if (is.numeric(args[[2]])) { # we do _not_ have a spam object if (is.vector(args[[2]])) args[[2]] <- spam.numeric( args[[2]], Xdim[1]) else args[[2]] <- as.spam.matrix(args[[2]]) } else if (!is.spam(args[[2]])) { stop("Not all argument are of class 'spam' and 'numeric', in cbind.spam()", call.=FALSE) } Ydim <- args[[2]]@dimension if(Xdim[1]!=Ydim[1]) stop("Arguments have differing numbers of rows, in cbind.spam()",call.=FALSE) XYlen <- args[[1]]@rowpointers[Xdim[1]+1]+args[[2]]@rowpointers[Xdim[1]+1]-2L z <- .Fortran("cbind", Xdim[2], Xdim[1], Ydim[2], XYlen, args[[1]]@entries, args[[1]]@colindices, args[[1]]@rowpointers, args[[2]]@entries, args[[2]]@colindices, args[[2]]@rowpointers, entries=vector( "double", XYlen), colindices=vector( "integer", XYlen), rowpointers=vector( "integer", Xdim[1]+1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") if (FALSE) { # a loop would be (in R...): for (i in 1:nrow) { if (args[[1]]@rowpointers[i]1) stop("Internal error in 'update.spam.chol.NgPeyton' code ", u$ierr,call.=FALSE) if(u$ierr == 1) { if (.Spam$cholupdatesingular == "null") return(NULL) else if (.Spam$cholupdatesingular == "error") stop("Singularity problem when updating a Cholesky Factor.") else if (.Spam$cholupdatesingular == "warning") warning("Singularity problem when updating a Cholesky Factor.\n'object' not updated.") else stop("'cholupdatesingular' should be 'error', 'null' or 'warning'.") } else { slot(object, "entries", check = FALSE) <- u$entries } invisible(object) } chol.spam <- function(x, pivot = "MMD", method="NgPeyton", memory=list(), eps = .Spam$eps, ...){ if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) nrow <- x@dimension[1] nnzA <- as.integer( x@rowpointers[nrow+1]-1) if(nrow!=x@dimension[2]) stop("non-square matrix in 'chol'",call.=FALSE) if (any( diag.of.spam(x, nrow, nrow) < .Spam$eps)) stop("Input matrix to 'chol' not positive definite (up to eps)",call.=FALSE) if(.Spam$cholsymmetrycheck) { test <- isSymmetric.spam(x, tol = eps*100) if (!isTRUE(test)) stop("Input matrix to 'chol' not symmetric (up to 100*eps)",call.=FALSE) } if (method != "NgPeyton") warning(gettextf("method = '%s' is not supported. Using 'NgPeyton'", method), domain = NA) if (length(pivot)==1) { if (pivot==FALSE) { doperm <- 0L pivot <- seq_len(nrow) } else if(pivot==TRUE) { doperm <- 1L pivot <- vector("integer",nrow) } else { doperm <- as.integer( switch(match.arg(pivot,c("MMD","RCM")),MMD=1,RCM=2)) pivot <- vector("integer",nrow) } } else if (length(pivot)==nrow) { doperm <- 0L if (!is.integer(pivot[1])) pivot <- as.vector(pivot,"integer") if (.Spam$cholpivotcheck) { checkpivot(pivot,nrow) } } else stop("'pivot' should be 'MMD', 'RCM' or a valid permutation") ### IMPROVEME get better parameter values nnzcfact <- c(5,1,5) nnzRfact <- c(5,1,2) # nnzcolindices = length of array holding the colindices if(is.null(memory$nnzcolindices)) { nnzcolindices <- ifelse((nnzA/nrow < 5), # very sparse matrix max(1000,nnzA*(1.05*nnzA/nrow-3.8)), nnzA)*nnzcfact[doperm+1] nnzcolindices <- max(nnzcolindices,nnzA) }else { nnzcolindices <- max(memory$nnzcolindices,nnzA) memory$nnzcolindices <- NULL } # nnzR = length of array holding the nonzero values of the factor if(is.null(memory$nnzR)) nnzR <- min(max(4*nnzA,floor(.4*nnzA^1.2))*nnzRfact[doperm+1],nrow*(nrow+1)/2) else { nnzR <- memory$nnzR memory$nnzR <- NULL } if(is.null(memory$cache)) cache <- 512 else { cache <- memory$cache memory$cache <- NULL } if (length( memory)>0 ) warning("The component(s) ", paste("'",names(memory),"'",sep='',collapse=","), " of the argument 'memory'\npassed to function 'chol' not meaningful and hence ignored.",call.=FALSE) nnzR <- as.integer(nnzR) nnzcolindices <- as.integer(nnzcolindices) z <- .Fortran("cholstepwise", nrow = nrow,nnzA = nnzA, d = as.double(x@entries),jd = x@colindices,id = x@rowpointers, doperm = doperm,invp = vector("integer",nrow), perm = pivot, nnzlindx = vector("integer",1), nnzcolindices = as.integer(nnzcolindices), lindx = vector("integer",nnzcolindices), xlindx = vector("integer",nrow+1), # nsuper = vector("integer",1), # nnzR = as.integer(nnzR),# lnz = vector("double",nnzR), # xlnz = vector("integer",nrow+1), # snode = vector("integer",nrow), xsuper = vector("integer",nrow+1), cachesize = as.integer(cache), ierr = 0L, NAOK = .Spam$NAOK,DUP=DUPFALSE,PACKAGE="spam") if(z$ierr == 1) stop("Singularity problem when calculating the Cholesky factor.") if(z$ierr == 6) stop("Inconsitency in the input",call.=FALSE) while( z$ierr>1) { if(z$ierr == 4) { tmp <- ceiling(nnzR*.Spam$cholincreasefactor[1]) warning("Increased 'nnzR' with 'NgPeyton' method\n", "(currently set to ",tmp," from ",nnzR,")",call.=FALSE) nnzR <- tmp } if(z$ierr == 5) { tmp <- ceiling(nnzcolindices*.Spam$cholincreasefactor[2]) warning("Increased 'nnzcolindices' with 'NgPeyton' method\n", "(currently set to ",tmp," from ",nnzcolindices,")",call.=FALSE) nnzcolindices <- tmp } z <- .Fortran("cholstepwise", nrow = nrow,nnzA = as.integer(x@rowpointers[nrow+1]-1), d = as.double(x@entries),jd = x@colindices,id = x@rowpointers, doperm = doperm,invp = vector("integer",nrow), perm = pivot, nnzlindx = vector("integer",1), nnzcolindices = as.integer(nnzcolindices), lindx = vector("integer",nnzcolindices), xlindx = vector("integer",nrow+1), # nsuper = vector("integer",1), # nnzR = as.integer(nnzR),# lnz = vector("double",nnzR), # xlnz = vector("integer",nrow+1), # snode = vector("integer",nrow), xsuper = vector("integer",nrow+1), cachesize = as.integer(cache), ierr = 0L, NAOK = .Spam$NAOK,DUP=DUPFALSE,PACKAGE="spam") if(z$ierr == 1) stop("Singularity problem when calculating the Cholesky factor.") } nnzR <- as.integer(z$xlnz[length(z$xlnz)]-1) newx <- new("spam.chol.NgPeyton") slot(newx,"entries",check=FALSE) <- z$lnz[1:nnzR] slot(newx,"colindices",check=FALSE) <- z$lindx[1:z$nnzlindx] slot(newx,"colpointers",check=FALSE) <- z$xlindx[1:(z$nsuper+1)] ########!!!!!!! slot(newx,"rowpointers",check=FALSE) <- z$xlnz slot(newx,"dimension",check=FALSE) <- c(nrow,nrow) slot(newx,"pivot",check=FALSE) <- z$perm slot(newx,"invpivot",check=FALSE) <- z$invp slot(newx,"supernodes",check=FALSE) <- z$xsuper[1:(z$nsuper+1)] slot(newx,"snmember",check=FALSE) <- z$snode slot(newx,"memory",check=FALSE) <- as.integer(c(nnzcolindices,z$nnzR,cache)) slot(newx,"nnzA",check=FALSE) <- nnzA invisible(newx) } solve.spam <- function (a, b, Rstruct = NULL, ...) { nrow <- a@dimension[1] ncol <- a@dimension[2] if (ncol != nrow) stop("only square matrices can be inverted") if (missing(b)) { b <- diag(1, ncol) } else { if(!is.matrix(b)) b <- as.matrix(b) } p <- dim(b)[2] if(nrow!=dim(b)[1])stop("'b' must be compatible with 'a'") # if we have a spam matrix, we calculate the Cholesky factor if (is(a,"spam")) if (is(Rstruct, "spam.chol.NgPeyton")) a <- update.spam.chol.NgPeyton(Rstruct, a, ...) else a <- chol.spam(a, ...) if (is(a,"spam.chol.NgPeyton")) { # The following is a fast way to perform: # z <- backsolve(a,forwardsolve( t(a),b)) nsuper <- as.integer( length(a@supernodes)-1) z <- .Fortran("backsolves", m = nrow, nsuper, p, a@colindices, a@colpointers, as.double(a@entries), a@rowpointers, a@invpivot, a@pivot, a@supernodes, vector("double",nrow), sol = vector("double",nrow*p), as.vector(b,"double"), DUP=DUPFALSE,NAOK = .Spam$NAOK,PACKAGE = "spam")$sol } else z <- backsolve(a, forwardsolve( t(a),b)) # see the helpfile for a comment about the 't(a)' construct. if ( p!=1) dim(z) <- c(nrow,p) return( z) } chol2inv.spam <- function (x, ...) { nrow <- x@dimension[1] if (is(x,"spam.chol.NgPeyton")) { y <- vector("double",nrow*nrow) y[1L + 0L:(nrow - 1L) * (nrow + 1L)] <- 1.0 z <- .Fortran("backsolves", m = nrow, as.integer( length(x@supernodes)-1), nrow, x@colindices, x@colpointers, as.double(x@entries), x@rowpointers, x@invpivot, x@pivot, x@supernodes, vector("double",nrow), sol = vector("double",nrow*nrow), y, DUP=DUPFALSE,NAOK = .Spam$NAOK,PACKAGE = "spam")$sol dim(z) <- c(nrow,nrow) } else z <- backsolve.spam(x, forwardsolve.spam( t(x), diag(nrow))) return( z) } backsolve.spam <- function(r, x,...){#, k = NULL, upper.tri = NULL, transpose = NULL){ # r: spam.chol.NgPeyton structure as returned by chol.spam or a spam object # x: rhs a vector or a matrix in dense form # dimensions: ( m x n) ( n x p) m <- r@dimension[1] if(is.vector(x)) { n <- length(x) p <- 1L } else { if(!is.matrix(x)) x <- as.matrix(x) n <- nrow(x) p <- ncol(x) } # we separate between "spam.chol.NgPeyton" and "spam" if (is(r,"spam.chol.NgPeyton")) { if (n!=m) stop("Cholesky factor 'r' not compatible with 'x'") nsuper <- as.integer( length(r@supernodes)-1) if (!.Spam$dopivoting) { z <- .Fortran("backsolve", m, nsuper, p, r@colindices, r@colpointers, as.double(r@entries), r@rowpointers, r@supernodes, sol = vector("double",m*p), DUP=DUPFALSE,NAOK = .Spam$NAOK, PACKAGE="spam")$sol }else{ z <- .Fortran("pivotbacksolve", m, nsuper, p, r@colindices, r@colpointers, as.double(r@entries), r@rowpointers, r@invpivot, r@pivot, r@supernodes, vector("double",m), sol = vector("double",m*p), as.double(x), DUP=DUPFALSE,NAOK = .Spam$NAOK,PACKAGE="spam")$sol } } else { if (n!=m) stop("Triangular matrix 'r' not compatible with 'x'") # solve R sol = x z <- .Fortran("spamback", m=m,p,sol = vector("double",m*p),x=as.vector(x,"double"), al=as.double(r@entries),jal=r@colindices, ial=r@rowpointers, DUP=DUPFALSE,NAOK = .Spam$NAOK,PACKAGE="spam") if (z$m<0) stop(gettextf("singular matrix in 'backsolve'. Last zero in diagonal [%d]", -z$m), domain = NA) else z <- z$sol } if (p>1) dim(z) <- c(m,p) return(z) } forwardsolve.spam <- function(l, x,...){#, k = NULL, upper.tri = NULL, transpose = NULL){ # l: spam.chol.NgPeyton structure as returned by chol.spam # or an ordinary lower triangular spam matrix # x: rhs a vector a matrix in dense form # dimensions: ( m x n) ( n x p) # if (!any(is.null(c(upper.tri,k,transpose )))) # warning("'k', 'upper.tri' and 'transpose' argument do not have any effect here") m <- l@dimension[1] if(is.vector(x)) { n <- length(x) p <- 1L } else { if(!is.matrix(x)) x <- as.matrix(x) n <- nrow(x) p <- ncol(x) } # we separate between "spam.chol.NgPeyton" and "spam" if (is(l,"spam.chol.NgPeyton")) { if(n!=m) stop("Cholesky factor 'l' not compatible with 'x'") nsuper <- as.integer( length(l@supernodes)-1) if (!.Spam$dopivoting) { z <- .Fortran("forwardsolve", m, nsuper, p, l@colindices, l@colpointers, as.double(l@entries), l@rowpointers, l@supernodes, sol = vector("double",m*p), DUP=DUPFALSE,NAOK = .Spam$NAOK,PACKAGE="spam")$sol }else{ z <- .Fortran("pivotforwardsolve", m, nsuper, p, l@colindices, l@colpointers, as.double(l@entries), l@rowpointers, l@invpivot, l@pivot, l@supernodes, vector("double",m), sol = vector("double",m*p), as.double(x), DUP=DUPFALSE,NAOK = .Spam$NAOK,PACKAGE="spam")$sol } } else { if (n!=m) stop("Triangular matrix 'l' not compatible with 'x'") # solve L sol = x z <- .Fortran("spamforward", m=m,p,sol = vector("double",m*p),x=as.vector(x,"double"), al=as.double(l@entries),jal=l@colindices, ial=l@rowpointers, DUP=DUPFALSE,NAOK = .Spam$NAOK,PACKAGE="spam") if (z$m<0) stop(gettextf("singular matrix in 'forwardsolve'. First zero in diagonal [%d]", -z$m), domain = NA) else z <- z$sol } if (p>1) dim(z) <- c(m,p) return(z) } setMethod("chol","spam", chol.spam) setMethod("solve","spam",solve.spam) setMethod("chol2inv","spam", chol2inv.spam) setMethod("chol2inv","spam.chol.NgPeyton", chol2inv.spam) setMethod("backsolve","spam",#signature(r="spam",x='ANY'), backsolve.spam) setMethod("backsolve","spam.chol.NgPeyton",#signature(r="spam.chol.NgPeyton",x='ANY'), backsolve.spam,sealed=TRUE) #setMethod("backsolve","spam.chol.NgPeyton", backsolve.spam) setMethod("forwardsolve","spam", forwardsolve.spam) setMethod("forwardsolve","spam.chol.NgPeyton", forwardsolve.spam) ###################################################################### ###################################################################### determinant.spam <- function(x, logarithm = TRUE, pivot = "MMD",method="NgPeyton", memory=list(),eps = .Spam$eps, ...){ if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) logdet <- list() #### start from above nrow <- x@dimension[1] nnzA <- as.integer( x@rowpointers[nrow+1]-1) if(nrow!=x@dimension[2]) stop("non-square matrix in 'chol'",call.=FALSE) if(.Spam$cholsymmetrycheck) { test <- isSymmetric.spam(x, tol = eps*100) if (!isTRUE(test)) stop("Input matrix to 'chol' not symmetric (up to 100*eps)",call.=FALSE) } if (method != "NgPeyton") warning(gettextf("method = '%s' is not supported. Using 'NgPeyton'", method), domain = NA) if (length(pivot)==nrow) { doperm <- 0L pivot <- as.vector(pivot,"integer") if (.Spam$cholpivotcheck) { checkpivot(pivot,nrow) } } else if (length(pivot)==1) { if (pivot==FALSE) { doperm <- 0L pivot <- seq_len(nrow) } else if(pivot==TRUE) { doperm <- 1L pivot <- vector("integer",nrow) } else { doperm <- as.integer( switch(match.arg(pivot,c("MMD","RCM")),MMD=1,RCM=2)) pivot <- vector("integer",nrow) } } else stop("'pivot' should be 'MMD', 'RCM' or a permutation") ### IMPROVEME get better parameter values nnzcfact <- c(5,1,5) nnzRfact <- c(5,1,2) # nnzcolindices = length of array holding the colindices if(is.null(memory$nnzcolindices)) { nnzcolindices <- ifelse((nnzA/nrow < 5), # very sparse matrix max(1000,nnzA*(1.05*nnzA/nrow-3.8)), nnzA)*nnzcfact[doperm+1] nnzcolindices <- max(nnzcolindices,nnzA) }else { nnzcolindices <- max(memory$nnzcolindices,nnzA) memory$nnzcolindices <- NULL } # nnzR = length of array holding the nonzero values of the factor if(is.null(memory$nnzR)) nnzR <- min(max(4*nnzA,floor(.4*nnzA^1.2))*nnzRfact[doperm+1],nrow*(nrow+1)/2) else { nnzR <- memory$nnzR memory$nnzR <- NULL } if(is.null(memory$cache)) cache <- 64 else { cache <- memory$cache memory$cache <- NULL } if (length( memory)>0 ) warning("The component(s) ", paste("'",names(memory),"'",sep='',collapse=","), " of the argument 'memory'\npassed to function 'chol' not meaningful and hence ignored.",call.=FALSE) z <- .Fortran("cholstepwise", nrow = nrow,nnzA = as.integer(x@rowpointers[nrow+1]-1), d = as.double(x@entries),jd = x@colindices,id = x@rowpointers, doperm = doperm,invp = vector("integer",nrow), perm = pivot, nnzlindx = vector("integer",1), nnzcolindices = as.integer(nnzcolindices), lindx = vector("integer",nnzcolindices), xlindx = vector("integer",nrow+1), # nsuper = vector("integer",1), # nnzR = as.integer(nnzR),# lnz = vector("double",nnzR), # xlnz = vector("integer",nrow+1), # snode = vector("integer",nrow), xsuper = vector("integer",nrow+1), cachesize = as.integer(cache), ierr = 0L, NAOK = .Spam$NAOK,DUP=DUPFALSE, PACKAGE = "spam") if(z$ierr == 1) stop("Singularity problem when calculating the Cholesky factor.") if(z$ierr == 6) stop("Inconsitency in the input",call.=FALSE) while( z$ierr>1) { if(z$ierr == 4) { warning("Increased 'nnzR' with 'NgPeyton' method\n", "(currently set to ",nnzR," from ",ceiling(nnzR*.Spam$cholpar[1]),")",call.=FALSE) nnzR <- ceiling(nnzR*.Spam$nnzRinc) } if(z$ierr == 5) { warning("Increased 'nnzcolindices' with 'NgPeyton' method\n", "(currently set to ",nnzcolindices," from ",ceiling(nnzcolindices*.Spam$cholpar[2]),")",call.=FALSE) nnzcolindices <- ceiling(nnzcolindices*.Spam$cholpar[2]) } z <- .Fortran("cholstepwise", nrow = nrow,nnzA = as.integer(x@rowpointers[nrow+1]-1), d = as.double(x@entries),jd = x@colindices,id = x@rowpointers, doperm = doperm,invp = vector("integer",nrow), perm = pivot, nnzlindx = vector("integer",1), nnzcolindices = as.integer(nnzcolindices), lindx = vector("integer",nnzcolindices), xlindx = vector("integer",nrow+1), # nsuper = vector("integer",1), # nnzR = as.integer(nnzR),# lnz = vector("double",nnzR), # xlnz = vector("integer",nrow+1), # snode = vector("integer",nrow), xsuper = vector("integer",nrow+1), cachesize = as.integer(cache), ierr = 0L, NAOK = .Spam$NAOK,DUP=DUPFALSE, PACKAGE = "spam") } #### end from above if(z$ierr == 1) { # all other errors trapped warning("singularity problem or matrix not positive definite",call.=FALSE) logdet$modulus <- NA } else{ tmp <- 2* sum( log( z$lnz[ z$xlnz[ -(z$nrow+1)]])) if (logarithm) logdet$modulus <- tmp else logdet$modulus <- exp(tmp) } attr(logdet$modulus,"logarithm") <- logarithm logdet$sign <- ifelse(z$ierr == 1,NA,1) attr(logdet,"class") <- "det" return(logdet) } determinant.spam.chol.NgPeyton <- function(x, logarithm = TRUE,...) { logdet <- list() tmp <- sum( log(x@entries[ x@rowpointers[-(x@dimension[1]+1)]])) if (logarithm) logdet$modulus <- tmp else logdet$modulus <- exp(tmp) attr(logdet$modulus,"logarithm") <- logarithm logdet$sign <- 1 attr(logdet,"class") <- "det" return(logdet) } setMethod("determinant","spam", determinant.spam) setMethod("determinant","spam.chol.NgPeyton", determinant.spam.chol.NgPeyton) ###################################################################### ######################################################################## "as.matrix.spam.chol.NgPeyton" <- function(x,...){ nrow <- x@dimension[1] nnzR <- x@rowpointers[nrow+1]-1 newx <- new("spam") nsuper <- as.integer( length(x@supernodes)-1) xcolindices <- .Fortran('calcja', nrow, nsuper, x@supernodes, x@colindices, x@colpointers, x@rowpointers, xja=vector("integer",nnzR), NAOK = .Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$xja return(array(.Fortran("spamcsrdns", nrow=nrow, entries=as.double(x@entries), colindices=xcolindices, rowpointers=x@rowpointers, res=vector("double",nrow*nrow), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$res, c(nrow,nrow)) # we preserve dimensions ) } setMethod("as.matrix","spam.chol.NgPeyton",as.matrix.spam.chol.NgPeyton) setMethod("as.vector","spam.chol.NgPeyton", function(x){ as.vector.spam(as.spam.chol.NgPeyton(x)) }) ######################################################################## # force to spam matrices. Would not be required with inheritance setMethod("image","spam.chol.NgPeyton", function(x,cex=NULL,...){ image.spam(as.spam.chol.NgPeyton(x),cex=cex,...) }) setMethod("display","spam.chol.NgPeyton", function(x,...){ display.spam(as.spam.chol.NgPeyton(x),...) }) setMethod("t","spam.chol.NgPeyton", function(x){ t.spam(as.spam.chol.NgPeyton(x)) }) setMethod("chol","spam.chol.NgPeyton", function(x){ x }) ######################################################################## ### system.time({ for (i in 1:1000) x=1:1000000}) # 8.820 ### system.time({ for (i in 1:1000) x=seq(length=1000000)}) # 8.397 ### system.time({ for (i in 1:1000) x=seq_len(1000000)}) # 8.628 ### system.time({ for (i in 1:1000) x=seq.int(1000000)}) # 8.944 ### system.time({ for (i in 1:100000) x=1:10000}) # 2.161 ### system.time({ for (i in 1:100000) x=seq(length=10000)}) # 3.288 ### system.time({ for (i in 1:100000) x=seq_len(10000)}) # 2.060 ### system.time({ for (i in 1:100000) x=seq.int(10000)}) # 2.249 spam/R/dim.R0000644000176000001440000000750012374453614012352 0ustar ripleyusers # This is the actual dim... "dim<-.spam" <- function(x, value) { if (is.spam(x)) { dimx <- x@dimension pdim <- prod(dimx) vlen <- prod(value) if( !identical(pdim,vlen)) stop( sprintf("dims [product %d] do not match the length of object [%d]. Do you want `pad`", pdim,vlen)) if (length(value)>2) stop("dims should be of length 1 or 2") if (identical(length(value),1L)) return( c(x) ) if(any(dimx<1)) stop("the dims contain negative values") tmp <- cbind(st=rep(1:dim(x)[1],diff(x@rowpointers)), nd=x@colindices) ind <- tmp[,1]+(tmp[,2]-1)*dimx[1] - 1 slist <- list(i = ind%%value[1] +1, j = ind%/%value[1] +1, x@entries) return( spam.list( slist, nrow=value[1], ncol=value[2], eps = .Machine$double.eps)) } else { dim(x) <- value x } } ######################################################################## # dim and derivatives "pad<-.spam" <- function(x,value) { if ( (min(value)<1 ) || any(!is.finite(value))) stop("dims should be postive integers.") if (!identical( length(value), 2L)) stop("dims should be of length 2.") dimx <- x@dimension last <- value[1]+1 # In three steps: # 1) Address col truncation # to safe time, we also take into account if we have fewer or equal rows # 2) Augment rows # 3) if fewer rows and more columns, truncate # In any case, dimensions are fixed at the end. # If fewer cols required, we run reducedim if (dimx[2]>value[2]){ # subroutine reducedim(a,ja,ia,eps,bnrow,bncol,k,b,jb,ib) z <- .Fortran("reducedim", oldra=as.double(x@entries), oldja=x@colindices, oldia=x@rowpointers, eps=.Spam$eps, as.integer(min(value[1],dimx[1])),as.integer(value[2]), nz=1L, entries=vector("double",length(x@entries)), colindices=vector("integer",length(x@entries)), rowpointers=vector("integer",last), NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") if (identical(z$nz,1L) ) return(new("spam",rowpointers=c(1L,rep.int(2L,as.integer(value[1]))), dimension=as.integer(value))) nz <- z$nz-1 slot(x,"entries",check=FALSE) <- z$entries[1:nz] slot(x,"colindices",check=FALSE) <- z$colindices[1:nz] slot(x,"rowpointers",check=FALSE) <- z$rowpointers[1:min(last,dimx[1]+1)] } # augment rows if (dimx[1]value[1])&(dimx[2]="’, ‘">"’ # ‘Math’ ‘"abs"’, ‘"sign"’, ‘"sqrt"’, ‘"ceiling"’, ‘"floor"’, # ‘"trunc"’, ‘"cummax"’, ‘"cummin"’, ‘"cumprod"’, ‘"cumsum"’, # ‘"log"’, ‘"log10"’, ‘"log2"’, ‘"log1p"’, ‘"acos"’, ‘"acosh"’, # ‘"asin"’, ‘"asinh"’, ‘"atan"’, ‘"atanh"’, ‘"exp"’, ‘"expm1"’, # ‘"cos"’, ‘"cosh"’, ‘"cospi"’, ‘"sin"’, ‘"sinh"’, ‘"sinpi"’, # ‘"tan"’, ‘"tanh"’, ‘"tanpi"’, ‘"gamma"’, ‘"lgamma"’, # ‘"digamma"’, ‘"trigamma"’ # ‘Math2’ ‘"round"’, ‘"signif"’ # ‘Summary’ ‘"max"’, ‘"min"’, ‘"range"’, ‘"prod"’, ‘"sum"’, ‘"any"’, ‘"all"’ ############## # Unary operators "+", "-" and "!" are handled with e2 missing... # # Currently, "+", "-" are handled... setMethod("!",signature(x="spam"), function(x){ if(.Spam$structurebased) { x@entries <- as.double(callGeneric(x@entries)) x } else { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(x))) spam(as.double( callGeneric(as.matrix(x))), nrow=nrow(x)) } }) setMethod("+",signature(e1="spam",e2="missing"), function(e1) e1 ) setMethod("-",signature(e1="spam",e2="missing"), function(e1) { e1@entries <- -e1@entries; e1} ) # ‘Math2’ : setMethod("Math2",signature(x = "spam", digits = "ANY"), function(x, digits){ x@entries <- callGeneric(x@entries, digits = digits); x }) # ‘Math’ : setMethod("Math","spam", function(x){ if(.Spam$structurebased) { x@entries <- callGeneric(x@entries) x }else{ x@entries <- callGeneric(x@entries) as.spam.spam( x) } }) # ‘Math’, where we pass to matrix first... spam_Math <- function(x) { if(.Spam$structurebased) { x@entries <- callGeneric(x@entries) x }else{ inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(x))) as.spam(callGeneric(as.matrix(x))) }} setMethod("exp","spam", spam_Math ) setMethod("log10","spam", spam_Math ) setMethod("log2","spam", spam_Math ) # from ?log: Do not set S4 methods on ‘logb’ itself. # special case to set base... setMethod("log","spam", function(x,...) { if(.Spam$structurebased) { x@entries <- callGeneric(x@entries,...) x }else{ inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(x))) as.spam(callGeneric(as.matrix(x),...)) }} ) setMethod("cos","spam", spam_Math ) #setMethod("cospi","spam", spam_Math ) setMethod("cosh","spam", spam_Math ) setMethod("acosh","spam", spam_Math ) setMethod("acos","spam", spam_Math ) setMethod("gamma","spam", spam_Math ) setMethod("digamma","spam", spam_Math ) setMethod("trigamma","spam", spam_Math ) setMethod("lgamma","spam", spam_Math ) setMethod("cummax","spam", spam_Math ) setMethod("cummin","spam", spam_Math ) setMethod("cumprod","spam", spam_Math ) setMethod("cumsum","spam", spam_Math ) # ‘Summary’ : setMethod("Summary","spam", function(x,...,na.rm=FALSE){ if(.Spam$structurebased) { callGeneric(x@entries,...,na.rm=na.rm) }else{ if ( prod( x@dimension) == length( x@entries)) { callGeneric(x@entries,...,na.rm=na.rm) } else { callGeneric(c(0,x@entries),...,na.rm=na.rm) } } } ) logical_Summary <- function( x,...,na.rm=FALSE){ if(.Spam$structurebased) { callGeneric(as.logical(x@entries),...,na.rm=na.rm) }else{ if ( prod( x@dimension) == length( x@entries)) { callGeneric(as.logical(x@entries),...,na.rm=na.rm) } else { callGeneric(as.logical(c(0,x@entries)),...,na.rm=na.rm) } } } setMethod("any","spam", logical_Summary) setMethod("all","spam", logical_Summary) ################################################################################################################################################################################################################################################################################################ # ‘Ops’ ‘"Arith"’, ‘"Compare"’, ‘"Logic"’ # ‘Logic’ ‘"&"’, ‘"|"’. "spam_Logic_vectorspam" <- function(e1, e2) { if(.Spam$structurebased) { if(identical(length(e1),1L) | identical(length(e1), length(e2@entries))) { e2@entries <- as.double( callGeneric(e1, e2@entries)) return(e2) } if( length(e1) == prod(e2@dimension)) return( as.spam( callGeneric(e1, as.matrix(e2))) ) stop(gettextf("incompatible lengths for %s operation.", sQuote(.Generic))) } else { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(e2))) return( as.spam( callGeneric(e1, as.matrix(e2))) ) } } "spam_Logic_spamvector" <- function(e1, e2) { if(.Spam$structurebased) { if(identical(length(e2),1L) | identical(length(e2), length(e1@entries))) { e1@entries <- as.double( callGeneric(e1@entries, e2)) return(e1) } if( length(e2)== prod(e1@dimension)) return( as.spam( callGeneric(as.matrix(e1), e2)) ) stop(gettextf("incompatible lengths for %s operation.", sQuote(.Generic))) } else { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(e1))) return( as.spam( callGeneric(as.matrix(e1), e2)) ) } } setMethod("|",signature(e1="spam",e2="spam"), function(e1,e2){ z <- spam_add(e1,e2);z@entries <- rep(1,length(z@colindices));z}) setMethod("&",signature(e1="spam",e2="spam"), function(e1,e2){ z <- spam_mult(e1,e2); z@entries <- rep(1,length(z@colindices));z}) setMethod("Logic",signature(e1="spam",e2="vector"), spam_Logic_spamvector) setMethod("Logic",signature(e1="vector",e2="spam"), spam_Logic_vectorspam) ################################################################################################## # ‘Compare’ ‘"=="’, ‘">"’, ‘"<"’, ‘"!="’, ‘"<="’, ‘">="’ "spam_Compare" <- function(e1,e2) { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), max(prod(dim(e1)), prod(dim(e2)))) as.spam( callGeneric( as.matrix(e1), as.matrix(e2)) ) } "spam_Compare_spamvector" <- function(e1, e2){ if(.Spam$structurebased) { if(identical(length(e2),1L) | identical(length(e2), length(e1@entries))) { e1@entries <- as.double(callGeneric(e1@entries, e2)) return(e1) } if( length(e2)== prod(e1@dimension)) return( as.spam( callGeneric(as.matrix(e1), e2)) ) stop(gettextf("incompatible lengths for %s operation.", sQuote(.Generic))) } else { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(e1))) return( as.spam( callGeneric(as.matrix(e1), e2)) ) } } "spam_Compare_vectorspam" <- function(e1, e2) { if(.Spam$structurebased) { if(identical(length(e1),1L) | identical(length(e1), length(e2@entries))) { e2@entries <- as.double( callGeneric(e1, e2@entries)) return(e2) } if( length(e1) == prod(e2@dimension)) return( as.spam( callGeneric(e1, as.matrix(e2))) ) stop(gettextf("incompatible lengths for %s operation.", sQuote(.Generic))) } else { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(e2))) return( as.spam( callGeneric(e1, as.matrix(e2))) ) } } setMethod("Compare",signature(e1="spam",e2="spam"), spam_Compare ) setMethod("Compare",signature(e1="spam",e2="vector"), spam_Compare_spamvector ) setMethod("Compare",signature(e1="vector",e2="spam"), spam_Compare_vectorspam ) ################################################################################################## # ‘Arith’: ‘"+"’, ‘"-"’, ‘"*"’, ‘"^"’, ‘"%%"’, ‘"%/%"’, ‘"/"’ "spam_Arith_vectorspam" <- function(e1, e2){ if(.Spam$structurebased) { if(identical(length(e1),1L) | identical(length(e1), length(e2@entries))) { e2@entries <- callGeneric(e1, e2@entries) return(e2) } if( length(e1) == prod(e2@dimension)) return( as.spam( callGeneric(e1, as.matrix(e2))) ) stop(gettextf("incompatible lengths for %s operation.", sQuote(.Generic))) } else { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(e1))) return( as.spam( callGeneric(e1, as.matrix(e2))) ) } } "spam_Arith_spamvector" <- function(e1, e2){ if(.Spam$structurebased) { if(identical(length(e2),1L) | identical(length(e2), length(e1@entries))) { e1@entries <- callGeneric(e1@entries, e2) return(e1) } if( length(e2)== prod(e1@dimension)) return( as.spam( callGeneric(as.matrix(e1), e2)) ) stop(gettextf("incompatible lengths for %s operation.", sQuote(.Generic))) } else { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), prod(dim(e1))) return( as.spam( callGeneric(as.matrix(e1), e2)) ) } } spam_Arith <- function(e1,e2) { inefficiencywarning( gettextf("This %s operation may be inefficient",sQuote(.Generic)), max(prod(dim(e1)), prod(dim(e2)))) as.spam( callGeneric( as.matrix(e1), as.matrix(e2))) } setMethod("Arith",signature(e1="spam",e2="spam"), spam_Arith ) setMethod("Arith",signature(e1="spam",e2="vector"), spam_Arith_spamvector) setMethod("Arith",signature(e1="vector",e2="spam"), spam_Arith_vectorspam) setMethod("/",signature(e1="spam",e2="spam"), function(e1,e2){ "/"(e1,as.matrix(e2)) } ) setMethod("^",signature(e1="spam",e2="spam"), function(e1,e2){ "^"(e1,as.matrix(e2)) } ) ###################################################################### # nz <- 128; ln <- nz^2; A <- spam(0,ln,ln); is <- sample(ln,nz); js <- sample(ln,nz);A[cbind(is,js)] <- 1:nz # nz <- 128; ln <- nz^2; A <- spam(0,ln,ln); is <- sample(ln,ln); js <- sample(ln,ln);A[cbind(is,js)] <- 1:ln # system.time( spam:::.spam.addsparsefull(A,1)) ; system.time( as.matrix.spam(A)+1.5) ####################################################################### "spam_add" <- function(A, B, s=1) { nrow <- A@dimension[1] ncol <- A@dimension[2] if(ncol != B@dimension[2] || nrow != B@dimension[1]) stop("non-conformable matrices") nzmax <- .Fortran("aplbdg", nrow, ncol, A@colindices, A@rowpointers, B@colindices, B@rowpointers, vector("integer",nrow),nnz=vector("integer",1),vector("integer",ncol), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$nnz z <- .Fortran("aplsb1", nrow, ncol, as.double(A@entries), A@colindices, A@rowpointers, as.double(s), as.double(B@entries), B@colindices, B@rowpointers, entries = vector("double",nzmax), colindices = vector("integer",nzmax), rowpointers = vector("integer",nrow+1), as.integer(nzmax+1), ierr = vector("integer",1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") if(z$ierr != 0) stop("insufficient space for sparse matrix addition") nz <- z$rowpointers[nrow+1]-1 newz <- new("spam") slot(newz,"entries", check=FALSE) <- z$entries[1:nz] slot(newz,"colindices", check=FALSE) <- z$colindices[1:nz] slot(newz,"rowpointers", check=FALSE) <- z$rowpointers slot(newz,"dimension", check=FALSE) <- c(nrow,ncol) return(newz) } setMethod("+",signature(e1="spam",e2="spam"), function(e1,e2){ spam_add(e1, e2) }) setMethod("-",signature(e1="spam",e2="spam"), function(e1,e2){ spam_add(e1, e2, -1)}) ############################################################################### "spam_mult" <- function(e1,e2) { # if(is.vector(e1)) { # if(length(e1) == 1){ # if(e1==0) return( spam(0,nrow(e2),ncol(e2))) # else{ # just a scalar # e2@entries <- e1*e2@entries # return(e2) # } # } else if(length(e1) == nrow(e2)) # return(diag.spam(e1) %*% e2) # else # length(e1) == ncol(e2) is not required # stop("e1 and e2 not conformable for efficient element-by-element multiplication") # } # else if(is.vector(e2)) { # if(length(e2) == 1){ # if(e2==0) return( spam(0,nrow(e1),ncol(e1))) # else { # e1@entries <- e2*e1@entries # return(e1) # } # } # else if(length(e2) == nrow(e1)) # return(diag.spam(e2) %*% e1) # else # stop("e1 and e2 not conformable for efficient element-by-element multiplication") # } # if(is.matrix(e1)) # e1 <- as.spam(e1) # else if(is.matrix(e2)) # e2 <- as.spam(e2) # if(!(is.spam(e1) && is.spam(e2))) # stop("Arguments must be of class: vector, matrix or spam") e1row <- e1@dimension[1] e1col <- e1@dimension[2] if(e1col != e2@dimension[2] | e1row != e2@dimension[1]) stop("non-conformable matrices") nnzmax <- length(intersect(e1@colindices+e1col*(rep(1:e1row,diff(e1@rowpointers))-1), e2@colindices+e2@dimension[2]*(rep(1:e2@dimension[1],diff(e2@rowpointers))-1)))+1 z <- .Fortran("aemub", e1row, e1col, as.double(e1@entries), e1@colindices, e1@rowpointers, as.double(e2@entries), e2@colindices, e2@rowpointers, entries = vector("double",nnzmax), colindices = vector("integer",nnzmax), rowpointers = vector("integer",e1row+1), integer(e1col), double(e1col), as.integer(nnzmax), ierr = vector("integer",1), NAOK=.Spam$NAOK,DUP=DUPFALSE, PACKAGE = "spam") if(z$ierr != 0) stop("insufficient space for element-wise sparse matrix multiplication") nnz <- z$rowpointers[e1row+1]-1 if(identical(z$entries,0L)){#trap zero matrix z$colindices <- 1L z$rowpointers <- c(1L,rep(2L,e1row)) } return(new("spam",entries=z$entries[1:nnz],colindices=z$colindices[1:nnz],rowpointers=z$rowpointers, dimension=c(e1row,e1col))) } setMethod("*",signature(e1="spam",e2="spam"), spam_mult) ########################################################################################################################################################################################################################################################################################################################################################################################################################################################################################################## #".spam.addsparsefull" <- function(A,B){ # # A is sparse, B is full # if (missing(B)) return(A) # if (!is.numeric(B)) stop("numeric argument expected") # nrow <- A@dimension[1] # ncol <- A@dimension[2] # pdim <- prod(nrow,ncol) # if (is.matrix(B)) { # if(ncol != dim(B)[2] || nrow != dim(B)[1]) # stop("non-conformable matrices") # } else { # if(pdim%%length(B)!=0) { # stop("longer object length # is not a multiple of shorter object length") # } else B <- rep(B,pdim %/% length(B)) # } # return(array( .Fortran("addsparsefull", # nrow,as.double(A@entries),A@colindices, # A@rowpointers,b=as.double(B),NAOK=.Spam$NAOK,PACKAGE = "spam" # )$b,c(nrow,ncol))) # } # #".spam.subfullsparse" <- function(A,B){ # # A is sparse, B is full # if (missing(B)) { # A@entries <- -A@entries # return(A) # } # if (!is.numeric(B)) stop("numeric argument expected") # nrow <- A@dimension[1] # ncol <- A@dimension[2] # pdim <- prod(nrow,ncol) # if (is.matrix(B)) { # if(ncol != dim(B)[2] || nrow != dim(B)[1]) # stop("non-conformable matrices") # } else { # if(pdim %% length(B)!=0) { # stop("longer object length # is not a multiple of shorter object length") # } else B <- rep(B,pdim %/% length(B)) # } # if (!is.double(B[1])) B <- as.double(B) # return(array( .Fortran("subfullsparse", # nrow,ncol,as.double(A@entries),A@colindices, # A@rowpointers,b=as.double(B),NAOK=.Spam$NAOK,PACKAGE = "spam" # )$b,c(nrow,ncol))) #} # #".spam.subsparsefull" <- function(B,A){ # # A is sparse, B is full # if (!is.numeric(B)) stop("numeric argument expected") # nrow <- A@dimension[1] # ncol <- A@dimension[2] # pdim <- prod(nrow,ncol) # if (is.matrix(B)) { # if(ncol != dim(B)[2] || nrow != dim(B)[1]) # stop("non-conformable matrices") # } else { # if(pdim %% length(B)!=0) { # stop("longer object length # is not a multiple of shorter object length") # } else B <- rep(B,pdim %/% length(B)) # } # if (!is.double(B[1])) B <- as.double(B) # return(array( .Fortran("subsparsefull", # nrow,as.double(A@entries),A@colindices, # A@rowpointers,b=as.double(B),NAOK=.Spam$NAOK,PACKAGE = "spam" # )$b,c(nrow,ncol))) #} # #setMethod("+",signature(e1="spam", e2="ANY"), # function(e1,e2){ .spam.addsparsefull(e1,e2)}) #setMethod("+",signature(e1="ANY", e2="spam"), # function(e1,e2){ .spam.addsparsefull(e2,e1)}) # # #setMethod("-",signature(e1="spam", e2="ANY"), # function(e1,e2){ .spam.subfullsparse(e1,e2)}) #setMethod("-",signature(e1="ANY", e2="spam"), # function(e1,e2){ .spam.subsparsefull(e1,e2)}) # #"spam_division" <- function(e1,e2) { # Element-wise matrix division of two spams # if(is.numeric(e1) && length(e1) == 1) # { e2@entries <- e1/e2@entries # return(e2) # } else if(is.numeric(e2) && length(e2) == 1) { # e1@entries <- e1@entries/e2 # return(e1) # } # else if(is.spam(e1) || is.spam(e2) || is.matrix(e1) || is.matrix(e2)){ # if(is.matrix(e1)) e1 <- as.spam(e1) # if(is.matrix(e2)) e2 <- as.spam(e2) # nrow <- e1@dimension[1] # ncol <- e1@dimension[2] # if(ncol != e2@dimension[2] | nrow != e2@dimension[1]) # stop("matrices not conformable for element-by-element division") # nzmax <- length(unique(c(e1@colindices+ncol*(rep(1:nrow,diff(e1@rowpointers))-1), # e2@colindices+e2@dimension[2]*(rep(1:e2@dimension[1],diff(e2@rowpointers))-1))))+1 # z <- .Fortran("_aedib_", # does not order the colindicies upon return! # nrow, # ncol, # as.integer(1), # as.double(e1@entries), e1@colindices, e1@rowpointers, # as.double(e2@entries), e2@colindices, e2@rowpointers, # entries = vector("double",nzmax), # colindices = vector("integer",nzmax), # rowpointers = vector("integer",nrow+1), # as.integer(nzmax), # integer(ncol), # double(ncol), # ierr = vector("integer",1), # NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam" # ) # if(z$ierr != 0) stop("insufficient space for element-wise sparse matrix division") # nz <- z$rowpointers[nrow+1]-1 # return(new("spam",entries=z$entries[1:nz],colindices=z$colindices[1:nz],rowpointers=z$rowpointers, # dimension=c(nrow,ncol))) # } ##"spam_exponent" <- function(e1, e2) #{ # nrow <- e1@dimension[1] # ncol <- e1@dimension[2] # if(ncol != e2@dimension[2] | nrow != e2@dimension[1]) # stop("matrices not conformable for element-wise exponentiation ") # nzmax <- length(unique(c(e1@colindices+ncol*(rep(1:nrow,diff(e1@rowpointers))-1), # e2@colindices+e2@dimension[2]*(rep(1:e2@dimension[1],diff(e2@rowpointers))-1))))+1 # z <- .Fortran("_aeexpb_", does not reorder col indices! # as.integer(nrow), as.integer(ncol), # 1L, # as.double(e1@entries), as.integer(e1@colindices), as.integer(e1@rowpointers), # as.double(e2@entries), as.integer(e2@colindices), as.integer(e2@rowpointers), # entries = vector("double",nzmax), # colindices = vector("integer",nzmax), # rowpointers = vector("integer",nrow+1), # as.integer(nzmax), # integer(ncol), double(ncol), # ierr = vector("integer",1), # NAOK=.Spam$NAOK,PACKAGE = "spam" # ) # if(z$ierr != 0) stop("insufficient space for element-wise exponentiation") # nz <- z$rowpointers[nrow+1]-1 # return(new("spam",entries=z$entries[1:nz],colindices=z$colindices[1:nz],rowpointers=z$rowpointers, # dimension=c(nrow,ncol))) #} ############################# #getClass("numeric") # Extends: "vector" #getClass("matrix") #Extends: Class "vector", by class "array", distance 3, with explicit coerce # Hence we use use vector, especially, to include the NA case that is not of type numeric! spam/R/foreign.R0000644000176000001440000002530712372657772013250 0ustar ripleyusers# This is file ../spam/R/foreign.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # Contains two sections: # 1) Routines to transform spam objects to SparseM and Matrix # 2) Functions to read (and write) MM and HB formats. # 1a) spam <-> SparseM as.spam.matrix.csr <- function(x) { # if (is.matrix.csr(x)) { newx <- new("spam") slot(newx,"entries",check=FALSE) <- as.double( x@ra) slot(newx,"colindices",check=FALSE) <- x@ja slot(newx,"rowpointers",check=FALSE) <- x@ia slot(newx,"dimension",check=FALSE) <- x@dimension return(newx) # } else stop("Wrong object passed to 'as.spam.matrix.csr'") } # The following should not be necessary because it is # as."matrix.csr".spam and not "as.matrix".csr.spam. # Is there anyway around this? as.matrix.csr.spam <- function(x,...) { # if (require('SparseM')){ newx <- new("matrix.csr") slot(newx,"ra",check=FALSE) <- x@entries slot(newx,"ja",check=FALSE) <- x@colindices slot(newx,"ia",check=FALSE) <- x@rowpointers slot(newx,"dimension",check=FALSE) <- x@dimension return(newx) # } } # 1b) spam <-> Matrix as.dgRMatrix.spam <- function(x) { if (require('Matrix')) { newx <- new(p=0:0,'dgRMatrix') slot(newx,"x",check=FALSE) <- x@entries slot(newx,"j",check=FALSE) <- x@colindices-1L slot(newx,"p",check=FALSE) <- x@rowpointers-1L slot(newx,"Dim",check=FALSE) <- x@dimension return(newx) } } as.dgCMatrix.spam <- function(x) { if (require('Matrix')) { dimx <- x@dimension nz <- x@rowpointers[dimx[1] + 1] - 1 z <- .Fortran("transpose", n = dimx[1], m = dimx[2], a = as.double(x@entries),ja = x@colindices, ia = x@rowpointers, entries = vector("double",nz), colindices = vector("integer", nz), rowpointers = vector("integer", dimx[2] + 1), NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") newx <- new(p=0:0,'dgCMatrix') slot(newx,"x",check=FALSE) <- z$entries slot(newx,"i",check=FALSE) <- z$colindices-1L slot(newx,"p",check=FALSE) <- z$rowpointers-1L slot(newx,"Dim",check=FALSE) <- dimx return(newx) } } as.spam.dgRMatrix <- function(x) { if (is(x,'dgRMatrix')){ if (identical(length(x@x),0L)) # zero matrix return(new("spam",rowpointers=c(1L,rep.int(2L,x@Dim[1])), dimension=x@Dim)) newx <- new('spam') slot(newx,"entries",check=FALSE) <- x@x slot(newx,"colindices",check=FALSE) <- x@j+1L slot(newx,"rowpointers",check=FALSE) <- x@p+1L slot(newx,"dimension",check=FALSE) <- x@Dim return(newx) } stop("Wrong object passed to 'as.spam.dgRMatrix'") } as.spam.dgCMatrix <- function(x) { if (is(x,'dgCMatrix')){ if (identical(length(x@x),0L)) # zero matrix return(new("spam",rowpointers=c(1L,rep.int(2L,x@Dim[1])), dimension=x@Dim)) nz <- x@p[x@Dim[2] + 1] z <- .Fortran("transpose", n = x@Dim[2], m = x@Dim[1], a = as.double(x@x),ja = x@i+1L, ia = x@p+1L, entries = vector("double",nz), colindices = vector("integer", nz), rowpointers = vector("integer", x@Dim[1] + 1), NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") newx <- new('spam') slot(newx,"entries",check=FALSE) <- z$entries slot(newx,"colindices",check=FALSE) <- z$colindices slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- x@Dim return(newx) } stop("Wrong object passed to 'as.spam.dgCMatrix'") } # 2) Import and export # taken from Matrix 0.999375-10 and adapted for spam ## Utilities for the Harwell-Boeing and MatrixMarket formats readone <- function(ln, iwd, nper, conv) # By Bates/Maechler from Matrix 0.999375-10 { ln <- gsub("D", "E", ln) inds <- seq(0, by = iwd, length = nper + 1) (conv)(substring(ln, 1 + inds[-length(inds)], inds[-1])) } readmany <- function(conn, nlines, nvals, fmt, conv) # By Bates/Maechler from Matrix 0.999375-10 { if (!grep("[[:digit:]]+[DEFGI][[:digit:]]+", fmt)) stop("Not a valid format") Iind <- regexpr('[DEFGI]', fmt) nper <- as.integer(substr(fmt, regexpr('[[:digit:]]+[DEFGI]', fmt), Iind - 1)) iwd <- as.integer(substr(fmt, Iind + 1, regexpr('[\\.\\)]', fmt) - 1)) rem <- nvals %% nper full <- nvals %/% nper ans <- vector("list", nvals %/% nper) for (i in seq_len(full)) ans[[i]] <- readone(readLines(conn, 1, ok = FALSE), iwd, nper, conv) if (!rem) return(unlist(ans)) c(unlist(ans), readone(readLines(conn, 1, ok = FALSE), iwd, rem, conv)) } read.HB <- function(file) # Adapted from Bates/Maechler Matrix 0.999375-10 version { if (is.character(file)) file <- if (file == "") stdin() else file(file) if (!inherits(file, "connection")) stop("'file' must be a character string or connection") if (!isOpen(file)) { open(file) on.exit(close(file)) } hdr <- readLines(file, 4, ok = FALSE) Title <- sub('[[:space:]]+$', '', substr(hdr[1], 1, 72)) Key <- sub('[[:space:]]+$', '', substr(hdr[1], 73, 80)) totln <- as.integer(substr(hdr[2], 1, 14)) ptrln <- as.integer(substr(hdr[2], 15, 28)) indln <- as.integer(substr(hdr[2], 29, 42)) valln <- as.integer(substr(hdr[2], 43, 56)) rhsln <- as.integer(substr(hdr[2], 57, 70)) if (!(t1 <- substr(hdr[3], 1, 1)) %in% c('C', 'R', 'P')) stop(paste("Invalid storage type:", t1)) if (t1 != 'R') stop("Only numeric sparse matrices allowed") ## _FIXME: Patterns should also be allowed if (!(t2 <- substr(hdr[3], 2, 2)) %in% c('H', 'R', 'S', 'U', 'Z')) stop(paste("Invalid storage format:", t2)) if (!(t3 <- substr(hdr[3], 3, 3)) %in% c('A', 'E')) stop(paste("Invalid assembled indicator:", t3)) nr <- as.integer(substr(hdr[3], 15, 28)) nc <- as.integer(substr(hdr[3], 29, 42)) nz <- as.integer(substr(hdr[3], 43, 56)) nel <- as.integer(substr(hdr[3], 57, 70)) ptrfmt <- toupper(sub('[[:space:]]+$', '', substr(hdr[4], 1, 16))) indfmt <- toupper(sub('[[:space:]]+$', '', substr(hdr[4], 17, 32))) valfmt <- toupper(sub('[[:space:]]+$', '', substr(hdr[4], 33, 52))) rhsfmt <- toupper(sub('[[:space:]]+$', '', substr(hdr[4], 53, 72))) if (!is.na(rhsln) && rhsln > 0) { h5 <- readLines(file, 1, ok = FALSE) } ptr <- readmany(file, ptrln, nc + 1, ptrfmt, as.integer) ind <- readmany(file, indln, nz, indfmt, as.integer) vals <- readmany(file, valln, nz, valfmt, as.numeric) # Spam related changes: if (t3 =="E") stop("Only assembled Harwell-Boeing formats implemented") z <- .Fortran("transpose", n = nc, m = nr, a = vals,ja = ind, ia = ptr, entries = vector("double",nz), colindices = vector("integer", nz), rowpointers = vector("integer", nr + 1), NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") newx <- new('spam') slot(newx,"entries",check=FALSE) <- z$entries slot(newx,"colindices",check=FALSE) <- z$colindices slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- c(nr, nc) if (t2 %in% c('H', 'S')) newx <- newx+t.spam(newx)-diag.spam(spam(newx)) if (t2 =="Z") newx <- newx-t.spam(newx) return(newx) } # alternatives are implementing # http://math.nist.gov/MatrixMarket/mmio/f/mmiof77.html read.MM <- function(file) { if (is.character(file)) file <- if(file == "") stdin() else file(file) if (!inherits(file, "connection")) stop("'file' must be a character string or connection") if (!isOpen(file)) { open(file) on.exit(close(file)) } scan1 <- function(what, ...) scan(file, nmax = 1, what = what, quiet = TRUE, ...) if ((hdr <- tolower(scan1(character()))) != "%%matrixmarket") # RF: added a to lower stop("file is not a MatrixMarket file") if (!(typ <- tolower(scan1(character()))) %in% "matrix") stop("type '", typ, "' not recognized") if (!(repr <- tolower(scan1(character()))) %in% c("coordinate", "array")) stop("representation '", repr, "' not recognized") elt <- tolower(scan1(character())) if (!elt %in% c("real", "complex", "integer", "pattern")) stop("element type '", elt, "' not recognized") sym <- tolower(scan1(character())) if (!sym %in% c("general", "symmetric", "skew-symmetric", "hermitian")) stop("symmetry form '", sym, "' not recognized") nr <- scan1(integer(), comment.char = "%") nc <- scan1(integer()) # code from now on differs from Matrix one... if (repr == "coordinate") { nz <- scan1(integer()) switch(elt, "real" = { what <- list(i= integer(), j= integer(), x= numeric())}, "integer" = { what <- list(i= integer(), j= integer(), x= numeric()) warning("'integer' format coerced to 'double'", call. = FALSE) }, "pattern" = { what <- list(i= integer(), j= integer()) warning("matrix elements assumed as 1 ('pattern' format)", call. = FALSE) }, "complex" = { what <- list(i= integer(), j= integer(), x= numeric(), y= numeric()) warning("retaining only real part of 'complex' format", call. = FALSE) } ) z <- scan(file, nmax = nz, quiet = TRUE, what= what) newx <- spam.list(list(ind=cbind(z$i,z$j),x= if(elt=="pattern") rep.int(1,nz) else z$x ), nr,nc) if (sym %in% c("symmetric", "hermitian")) { dim(newx) <- rep(max(nr,nc),2) newx <- newx+t.spam(newx)-diag.spam(diag(newx)) } if (sym=="skew-symmetric") { dim(newx) <- rep(max(nr,nc),2) newx <- newx-t.spam(newx) } } else { nz <- nr*nc x <- scan(file, nmax = nz, quiet = TRUE, what=numeric()) z <- .Fortran("spamdnscsr", nrow = nr, ncol = nc, x = x, nr, entries = vector("double",nz), colindices = vector("integer", nz), rowpointers = vector("integer",nr + 1), eps = spam.options('eps'), NAOK = TRUE, DUP=DUPFALSE, PACKAGE = "spam") warning("returning a (possibly) dense 'spam' object", call. = FALSE) nz <- z$rowpointers[nr+1]-1 if (identical(nz, 0L)) return(new("spam",rowpointers=c(1L,rep.int(2L,nr)), dimension=c(nr,nc))) newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:nz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:nz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- c(nr,nc) } return(newx) } spam/R/makeprec.R0000644000176000001440000000326412372657772013404 0ustar ripleyusers# This is file ../spam/R/makeprec.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] "precmat.GMRFreglat" <- function(n,m, par=.1, model = "m1p1", eps = .Spam$eps){ if((n<2)|(m<2)) stop("n and m need to be >1") dims <- c(n,m) if (model=="m1p1"){ x <- numeric(dims[1]) x[1:2] <- c(1,-par[1]) y <- numeric(prod(dims)) y[dims[1]+1] <- -par[1] return( kronecker(diag.spam(dims[2]), toeplitz.spam(x,eps=eps))+toeplitz.spam(y,eps=eps)) } if (model=="m1p2"){ x <- numeric(dims[1]) x[1:2] <- c(1,-par[1]) y <- numeric(prod(dims)) y[dims[1]+1] <- -par[2] return( kronecker(diag.spam(dims[2]), toeplitz.spam(x,eps=eps))+toeplitz.spam(y,eps=eps)) } if (model=="m2p3"){ x <- numeric(dims[1]) x[1:2] <- c(1,-par[1]) y <- numeric(dims[1]) y[1:2] <- c(-par[2],-par[3]) z <- numeric(dims[2]) z[2] <- 1 p1 <- kronecker( diag.spam(dims[2]), toeplitz.spam(x,eps=eps)) p2 <- kronecker( toeplitz.spam(z,eps=eps), toeplitz.spam(y,eps=eps)) return( p1 + p2) } if (model=="m2p4"){ x <- numeric(dims[1]) x[1:2] <- c(1,-par[1]) y <- numeric(dims[1]) y[1:2] <- c(-par[2],-par[3]) w <- numeric(dims[1]) w[1:2] <- c(-par[2],-par[4]) z <- numeric(dims[2]) z[2] <- 1 p1 <- kronecker( diag.spam(dims[2]), toeplitz.spam(x,eps=eps)) p2 <- kronecker( toeplitz.spam(z,rep(0,dims[2]),eps=eps), toeplitz.spam(y,w,eps=eps)) p3 <- kronecker( toeplitz.spam(rep(0,dims[2]),z,eps=eps), toeplitz.spam(w,y,eps=eps)) return( p1 + p2 + p3) } stop("Model not implemented yet!") } spam/R/rmvnorm.R0000644000176000001440000001006412375156664013306 0ustar ripleyusers# This is file ../spam/R/rmvnorm.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # Draw from a multivariate normal: # (Algorithm 2.3 from Rue and Held, 2005) rmvnorm.spam <- function(n,mu=rep(0, nrow(Sigma)), Sigma, Rstruct=NULL, ...) { # taken from ?chol.spam if (is(Rstruct,"spam.chol.NgPeyton")) cholS <- update.spam.chol.NgPeyton( Rstruct, Sigma, ...) else cholS <- chol.spam( Sigma,...) # cholS is the upper triangular part of the permutated matrix Sigma iord <- ordering(cholS, inv=TRUE) N <- dim(Sigma)[1] R <- as.spam(cholS) retval <- as.matrix( ( array(rnorm(n*N),c(n,N)) %*% R)[,iord,drop=F]) # It is often better to order the sample than the matrix # R itself. return(sweep(retval, 2, mu, "+")) } # Draw from a multivariate normal given a precision matrix: # (Algorithm 2.4 from Rue and Held, 2005) rmvnorm.prec <- function(n,mu=rep(0, nrow(Q)), Q, Rstruct=NULL, ...) { if (is(Rstruct,"spam.chol.NgPeyton")) R <- update.spam.chol.NgPeyton( Rstruct, Q, ...) else R <- chol(Q,...) # R is the upper triangular part of the permutated matrix Sigma N <- dim(Q)[1] nu <- backsolve(R, array(rnorm(n*N),c(N,n)), k=N) return(t(nu+mu)) } # Draw from the canonical representation of a multivariate normal: # (Algorithm 2.5 from Rue and Held, 2005) rmvnorm.canonical <- function(n, b, Q, Rstruct=NULL, ...) { N=dim(Q)[1] if (is(Rstruct,"spam.chol.NgPeyton")) R <- update.spam.chol.NgPeyton( Rstruct, Q, ...) else R <- chol(Q,...) if(is(R,"spam.chol.NgPeyton")){ mu <- drop(solve.spam( R, b)) } else { mu <- backsolve( R, forwardsolve( t(R), b), k=N) } nu <- backsolve(R, array( rnorm(n*N), c(N, n)), k=N) return(t(nu+mu)) } rmvnorm.const <- function (n, mu = rep(0, nrow(Sigma)), Sigma, Rstruct = NULL, A = array(1, c(1,nrow(Sigma))), a=0, U=NULL, ...) { N <- dim(Sigma)[1] if (!identical(ncol(A), N)) stop("Incorrect constraint specification") if (is(Rstruct, "spam.chol.NgPeyton")) cholS <- update.spam.chol.NgPeyton(Rstruct, Sigma, ...) else cholS <- chol.spam(Sigma, ...) iord <- ordering(cholS, inv = TRUE) N <- dim(Sigma)[1] R <- as.spam(cholS) x <- sweep( (array(rnorm(n * N), c(n, N)) %*% R)[, iord, drop = F], 2, mu, "+") if (is.null(U)){ V <- backsolve( R, forwardsolve( R, t(A)), k=N) W <- A %*% V U <- solve(W, t(V)) } correct <- A %*% t(x) - a return(x - t( t(U)%*% correct)) } rmvnorm.prec.const <- function (n, mu = rep(0, nrow(Q)), Q, Rstruct = NULL, A = array(1, c(1,nrow(Q))), a=0, U=NULL, ...) { N = dim(Q)[1] if (!identical(ncol(A), N)) stop("Incorrect constraint specification") if (is(Rstruct, "spam.chol.NgPeyton")) R <- update.spam.chol.NgPeyton(Rstruct, Q, ...) else R <- chol(Q, ...) x <- backsolve(R, array(rnorm(n * N), c(N, n)), k=N) + mu if (is.null(U)){ tV <- t( backsolve( R, forwardsolve( R, t(A)), k=N)) W <- tcrossprod(A, tV) U <- solve(W, tV) } correct <- A %*% x - a return(t(x- t(U) %*% correct)) } rmvnorm.canonical.const <- function (n, b, Q, Rstruct = NULL, A = array(1, c(1,nrow(Q))), a=0, U=NULL, ...) { N = dim(Q)[1] if (!identical(ncol(A), N)) stop("Incorrect constraint specification") if (is(Rstruct, "spam.chol.NgPeyton")) R <- update.spam.chol.NgPeyton(Rstruct, Q, ...) else R <- chol(Q, ...) if (is(R, "spam.chol.NgPeyton")) { mu <- drop(solve.spam(R, b)) } else { mu <- backsolve(R, forwardsolve(t(R), b)) } x <- backsolve(R, array(rnorm(n * N), c(N, n)), k=N) + mu if (is.null(U)){ tV <- t( backsolve( R, forwardsolve( R, t(A)), k=N)) W <- tcrossprod(A, tV) U <- solve(W, tV) } correct <- A %*% x - a return(t(x- t(U) %*% correct)) } spam/R/profile.R0000644000176000001440000001123012375274544013240 0ustar ripleyusers# This is file ../spam/R/profile.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] ".onLoad" <- function (lib, pkg) { # if (R.version$minormaxsize) warning(msg, call. = FALSE) } ".onAttach" <- function (lib, pkg) { packageStartupMessage( spam.version$version.string," is loaded.", # "\nType demo( spam) for some demos,", # " help( Spam) for an overview\nof this package.", # "\nHelp for individual functions is obtained by ", # "adding the\nsuffix '.spam' to the function name, e.g. 'help(chol.spam)'.") "\nType 'help( Spam)' or 'demo( spam)' for a short introduction ", "\nand overview of this package.", "\nHelp for individual functions is also obtained by ", "adding the\nsuffix '.spam' to the function name, e.g. 'help( chol.spam)'.") unlockBinding(".Spam", asNamespace("spam")) } "spam.getOption" <- function (x) spam.options(x)[[1]] "spam.options" <- function (...) { if (nargs() == 0) return(.Spam) current <- .Spam temp <- list(...) if (length(temp) == 1L && is.null(names(temp))) { arg <- temp[[1]] switch(mode(arg), list = temp <- arg, character = return(.Spam[arg]), stop("invalid argument: ", sQuote(arg))) } if (length(temp) == 0) return(current) n <- names(temp) if (is.null(n)) stop("options must be given by name") # changed <- current[n] #rf current[n] <- temp if (sys.parent() == 0) env <- asNamespace("spam") else env <- parent.frame() assign(".Spam", current, envir = env) invisible(current) } powerboost <- function(flag="on") { if (sys.parent() == 0) env <- asNamespace("spam") else env <- parent.frame() current <- spam.options() current[c("NAOK","safemodevalidity","cholsymmetrycheck","cholpivotcheck","eps")] <- if (tolower(flag) %in% c("true","on","an","ein")) { list(!FALSE,FALSE,FALSE,FALSE,1e-8) } else { list(!TRUE,TRUE,TRUE,TRUE,.Machine$double.eps) } assign(".Spam", current, envir = env) invisible( current) } DUPFALSE <- FALSE spam/R/kronecker.R0000644000176000001440000000561112372657772013576 0ustar ripleyusers# This is file ../spam/R/kronecker.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] kronecker.spam <- function(X,Y,FUN = "*", make.dimnames = FALSE, ...) { if (make.dimnames) warning("dimnames not supported within sparse matrices") lenx <- length(X) leny <- length(Y) kronlen <- lenx*leny if(is.spam(X)){ Xdim <- X@dimension Xentries <- X@entries Xcol <- X@colindices Xrow <- X@rowpointers }else if (is.vector(X)){ Xentries <- X Xcol <- rep.int(as.integer(1),lenx) Xdim <- as.integer(c(lenx,1)) Xrow <- seq_len(lenx+1) } else { Xentries <- as.double(t(X)) Xdim <- dim(X) Xcol <- rep.int(as.integer(1:Xdim[2]),Xdim[1]) Xrow <- seq.int(1, by=Xdim[2], length.out=Xdim[1]+1) } if(is.spam(Y)){ Ydim <- Y@dimension Yentries <- Y@entries Ycol <- Y@colindices Yrow <- Y@rowpointers } else if (is.vector(Y)){ Yentries <- Y Ycol <- rep.int(as.integer(1),leny) Ydim <- as.integer(c(leny,1)) Yrow <- seq_len(leny+1) } else { Yentries <- as.double(t(Y)) Ydim <- dim(Y) Ycol <- rep.int(as.integer(1:Ydim[2]),Ydim[1]) Yrow <- seq.int(1, by=Ydim[2], length.out=Ydim[1]+1) } kronxy <- new("spam") if (FUN=="*") { z <- .Fortran("kroneckermult",Xdim[1],Xentries,Xcol,Xrow, Ydim[1],Ydim[2],Yentries,Ycol,Yrow, entries=vector( "double", kronlen), colindices=vector( "integer", kronlen), rowpointers=vector( "integer",Xdim[1]*Ydim[1]+1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") slot(kronxy, "entries", check=FALSE) <- z$entries }else { z <- .Fortran("kronecker",Xdim[1],Xentries,Xcol,Xrow, Ydim[1],Ydim[2],Yentries,Ycol,Yrow, ent1=vector( "double",kronlen),ent2=vector( "double",kronlen), colindices=vector( "integer",kronlen), rowpointers=vector( "integer",Xdim[1]*Ydim[1]+1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") FUN <- match.fun(FUN) slot(kronxy, "entries", check=FALSE) <- FUN(z$ent1,z$ent2,...) if (z$rowpointers[Xdim[1]*Ydim[1]+1]-1 < prod(Xdim,Ydim)) warning("Sparseness structure of 'kronecker(X,Y)' preseved when applying 'FUN'.", call. = FALSE) } slot(kronxy, "colindices", check=FALSE) <- z$colindices slot(kronxy, "rowpointers", check=FALSE) <- z$rowpointers slot(kronxy, "dimension", check=FALSE) <- Xdim*Ydim # no need to use prod return(kronxy) } "kronecker.default" <- base::kronecker setGeneric("kronecker") setMethod("kronecker","spam", kronecker.spam) setMethod("kronecker",signature(X="spam",Y="spam"), kronecker.spam) setMethod("kronecker",signature(X="spam",Y="ANY"), kronecker.spam) setMethod("kronecker",signature(X="ANY",Y="spam"), kronecker.spam) spam/R/mle.R0000644000176000001440000001173712372657772012376 0ustar ripleyusers# This is file ../spam/R/mle.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] neg2loglikelihood.spam <- function(y, X, distmat, Covariance, beta, theta, Rstruct = NULL,...) { Sigma <- do.call(Covariance,list(distmat,theta)) if (!is.spam(Sigma)){ warning("'Covariance' should return a spam object. Forced to spam.") Sigma <- as.spam(Sigma) } if (is(Rstruct, "spam.chol.NgPeyton")) cholS <- update.spam.chol.NgPeyton(Rstruct, Sigma, ...) else cholS <- chol.spam(Sigma, ...) n <- length(y) resid <- y-X%*%beta return( n * log(2*pi) + 2*c(determinant.spam.chol.NgPeyton(cholS)$modulus) + sum(resid * solve.spam( cholS, resid)) ) } neg2loglikelihood <- function(y, X, distmat, Covariance, beta, theta, ...) { Sigma <- do.call(Covariance,list(distmat,theta)) cholS <- chol(Sigma, ...) logdet <- sum(log(diag(cholS))) n <- length(y) resid <- y-X%*%beta return( n * log(2*pi) + 2*logdet + sum(resid * backsolve(cholS, forwardsolve(cholS, resid, transpose=TRUE, upper.tri=TRUE),n)) ) } mle.spam <- function(y, X, distmat, Covariance, beta0, theta0, thetalower, thetaupper, optim.control=NULL, Rstruct = NULL, hessian = FALSE,...) { if (!is(Rstruct, "spam.chol.NgPeyton")) { Sigma <- do.call(Covariance, list(distmat,c(thetaupper[1],theta0[-1]))) if (!is.spam(Sigma)) stop("'Covariance' should return a spam object.") Rstruct <- chol.spam(Sigma, ...) } p <- dim(X)[2] n <- length(y) neg2loglikelihood <- function(fulltheta,...) { Sigma <- do.call(Covariance,list(distmat,fulltheta[-(1:p)])) cholS <- update.spam.chol.NgPeyton(Rstruct, Sigma, ...) resid <- y-X%*%fulltheta[1:p] return( n * log(2*pi) + 2*c(determinant.spam.chol.NgPeyton(cholS)$modulus) + sum(resid * solve.spam( cholS, resid)) ) } return(optim(c(beta0,theta0),neg2loglikelihood, method = "L-BFGS-B",control = optim.control, lower=c(rep(-Inf,p),thetalower), upper=c(rep(Inf,p),thetaupper), hessian = hessian)) } mle <- function(y, X, distmat, Covariance, beta0, theta0, thetalower, thetaupper, optim.control=NULL, hessian = FALSE, ...) { p <- dim(X)[2] n <- length(y) neg2loglikelihood <- function(fulltheta,...) { Sigma <- do.call(Covariance,list(distmat,fulltheta[-(1:p)])) cholS <- chol(Sigma, ...) logdet <- sum(log(diag(cholS))) resid <- y-X%*%fulltheta[1:p] return( n * log(2*pi) + 2*logdet + sum(resid * backsolve(cholS, forwardsolve(cholS, resid, transpose=TRUE, upper.tri=TRUE),n)) ) } return(optim(c(beta0,theta0),neg2loglikelihood, method = "L-BFGS-B",control = optim.control, lower=c(rep(-Inf,p),thetalower), upper=c(rep(Inf,p),thetaupper), hessian = hessian)) } mle.nomean.spam <- function(y, distmat, Covariance, theta0, thetalower, thetaupper, optim.control = NULL, Rstruct = NULL, hessian = FALSE,...) { if (!is(Rstruct, "spam.chol.NgPeyton")) { Sigma <- do.call(Covariance, list(distmat,c(thetaupper[1],theta0[-1]))) if (!is.spam(Sigma)) stop("'Covariance' should return a spam object.") Rstruct <- chol.spam(Sigma, ...) } n <- length(y) neg2loglikelihood <- function(theta,...) { Sigma <- do.call(Covariance,list(distmat,theta)) cholS <- update.spam.chol.NgPeyton(Rstruct, Sigma, ...) return( n * log(2*pi) + 2*c(determinant.spam.chol.NgPeyton(cholS)$modulus) + sum(y * solve.spam( cholS, y)) ) } return(optim(theta0,neg2loglikelihood, method = "L-BFGS-B",control = optim.control, lower=thetalower, upper=thetaupper, hessian = hessian)) } mle.nomean <- function(y, distmat, Covariance, theta0, thetalower, thetaupper, optim.control=NULL, hessian = FALSE, ...) { n <- length(y) neg2loglikelihood <- function(theta,...) { Sigma <- do.call(Covariance,list(distmat,theta)) cholS <- chol(Sigma, ...) logdet <- sum(log(diag(cholS))) return( n * log(2*pi) + 2*logdet + sum(y * backsolve(cholS, forwardsolve(cholS, y, transpose=TRUE, upper.tri=TRUE),n)) ) } return(optim(theta0,neg2loglikelihood, method = "L-BFGS-B",control = optim.control, lower=thetalower, upper=thetaupper, hessian = hessian)) } spam/R/toepliz.R0000644000176000001440000000556412372660136013274 0ustar ripleyusers# This is file ../spam/R/toepliz.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] ######################################################################## "circulant.spam" <- function(x, n=NULL, eps = .Spam$eps) { if (!(is.vector(x)|is.list(x)) ) stop("'x' is not a vector or a list") if( is.list(x)) { if (!identical(length(x),2L)) stop("Argument 'x' needs to be a list with two elements") if (is.null(n)) stop("'n' needs to be given") ind <- x[[1]] x <- x[[2]] sel <- (ind <= n)&(abs(x)>eps) ind <- ind[sel] x <- x[sel] }else{ n <- length(x) ind <- (1:n)[abs(x) > eps] x <- x[ind] } n <- as.integer(n) len <- as.integer(length( ind)[1]) # see ?length@value if(identical(len,0L)) return(new("spam", rowpointers = c(1L, rep.int(2L, n)), dimension = as.integer(c(n, n)))) # subroutine circulant(nrow,len, x,j, a,ja,ia) nz <- n*len z <- .Fortran('circulant',n, len, as.double(x), as.integer(ind), entries= vector("double", nz), colindices = vector("integer", nz), rowpointers = vector("integer", n + 1), NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") newx <- new("spam") slot(newx, "entries", check = FALSE) <- z$entries slot(newx, "colindices", check = FALSE) <- z$colindices slot(newx, "rowpointers", check = FALSE) <- z$rowpointers slot(newx, "dimension", check = FALSE) <- c(n, n) return(newx) } toeplitz.spam <- function(x,y=NULL, eps = .Spam$eps) { if (!is.vector(x)) stop("'x' is not a vector") n <- length(x) if (!is.null(y)){ if (!identical(length(y),n)) stop("Length of 'y' and 'x' do not match") fullx <- c(rev(y[-1]),x) } else { fullx <- c(rev(x[-1]),x) } ind <- (1:(2*n-1))[abs(fullx) > eps] fullx <- fullx[ind] n <- as.integer(n) len <- as.integer(length( ind)[1]) # see ?length@value if(identical(len,0L)) return(new("spam", rowpointers = c(1L, rep.int(2L, n)), dimension = as.integer(c(n, n)))) # subroutine toeplitz(nrow,len, x,j, a,ja,ia,kk) nz <- n*len z <- .Fortran('toeplitz',n, len, as.double(fullx), as.integer(ind), entries= vector("double", nz), colindices = vector("integer", nz), rowpointers = vector("integer", n + 1), nnz=as.integer(1), NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") newx <- new("spam") slot(newx, "entries", check = FALSE) <- z$entries[1:z$nnz] slot(newx, "colindices", check = FALSE) <- z$colindices[1:z$nnz] slot(newx, "rowpointers", check = FALSE) <- z$rowpointers slot(newx, "dimension", check = FALSE) <- c(n, n) return(newx) } # spam/R/rowcolstats.R0000644000176000001440000000342412372657772014177 0ustar ripleyusers# This is file ../spam/R/rowcolstats.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] rowSums.spam <- function(x,...) { return( .Fortran("rowsums", as.double(x@entries), as.integer(x@colindices), as.integer(x@rowpointers), x@dimension[1], rs=vector("double",x@dimension[1]), NAOK=.Spam$NAOK, DUP=DUPFALSE, PACKAGE="spam")$rs) } colSums.spam <- function(x,...) { return( .Fortran("colsums", as.double(x@entries), as.integer(x@colindices), as.integer(x@rowpointers), x@dimension[1], cs=vector("double",x@dimension[2]), NAOK=.Spam$NAOK, DUP=DUPFALSE, PACKAGE="spam")$cs) } rowMeans.spam <- function(x,...) { return( .Fortran("rowmeans", as.double(x@entries), as.integer(x@colindices), as.integer(x@rowpointers), x@dimension[1],x@dimension[2], as.logical(.Spam$structurebased), rm=vector("double",x@dimension[1]), NAOK=.Spam$NAOK, DUP=DUPFALSE, PACKAGE="spam")$rm) } colMeans.spam <- function(x,...) { return( .Fortran("colmeans", as.double(x@entries), as.integer(x@colindices), as.integer(x@rowpointers), x@dimension[1],x@dimension[2], as.logical(.Spam$structurebased), cm=vector("double",x@dimension[2]),vector("integer",x@dimension[2]), NAOK=.Spam$NAOK, DUP=DUPFALSE, PACKAGE="spam")$cm) } setMethod("rowSums","spam",rowSums.spam) setMethod("colSums","spam",colSums.spam) setMethod("rowMeans","spam",rowMeans.spam) setMethod("colMeans","spam",colMeans.spam) spam/R/apply.R0000644000176000001440000000366712372657772012751 0ustar ripleyusers# This is file ../spam/R/apply.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # primitive apply function. apply.spam <- function(X, MARGIN=NULL, FUN, ...){ if (!is.spam(X)) stop("'X' must be of type 'spam'") if (!is.null(dimnames(X))) warning("dimnames are stripped") FUN <- match.fun(FUN) d <- dim(X) d.ans <- d[MARGIN] dn.ans <- NULL if (is.null(MARGIN)|| length(MARGIN)==2){ ans <- FUN(X@entries,...) if (length( ans)!=length( X@entries)) stop("'FUN' does not return an appropriate vector") if (any(!is.finite(ans))) { warning("'NA/NaN/Inf' coerced to zero") ans[!is.finite(ans)] <- 0 } X@entries <- ans return(X) } ans <- vector("list",d.ans) if (MARGIN==1) { for (i in 1:d[1]) ans[[i]] <- FUN(X[i,,drop=F]@entries,...) } else if (MARGIN==2) { for (i in 1:d[2]) ans[[i]] <- FUN(X[,i,drop=F]@entries,...) } else stop("'MARGIN' must be 1, 2 or c(1,2)") # Block very similar to 'apply' d2 <- prod(d.ans) ans.list <- is.recursive(ans[[1]]) l.ans <- length(ans[[1]]) ans.names <- names(ans[[1]]) if (!ans.list){ ans.list <- any(unlist(lapply(ans, length)) != l.ans) } if (!ans.list && length(ans.names)) { all.same <- sapply(ans, function(x) identical(names(x), ans.names)) if (!all(all.same)) ans.names <- NULL } len.a <- if (ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) if (length(MARGIN) == 1 && len.a == d2) return(ans) if (len.a == d2) return(array(ans, d.ans)) if (len.a > 0 && len.a%%d2 == 0) { dn.ans <- vector(mode = "list", length(d.ans)) dn.ans <- c(list(ans.names), dn.ans) return(array(ans, c(len.a%/%d2, d.ans), if (!all(sapply(dn.ans, is.null))) dn.ans)) } return(ans) } spam/R/image_spam.R0000644000176000001440000000030112372657772013704 0ustar ripleyusers# This is file ../spam/R/image_spam.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] spam/R/tailhead.R0000644000176000001440000000313312372657772013363 0ustar ripleyusers# This is file ../spam/R/headtail.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] head.spam <- function(x, n = 6L, m = n, ...) { stopifnot(length(n) == 1L, length(m) == 1L) n <- if (n < 0L) max(nrow(x) + n, 0L) else min(n, nrow(x)) m <- if (m < 0L) max(ncol(x) + m, 0L) else min(m, ncol(x)) as.matrix(x[seq_len(n), seq_len(m), drop = FALSE]) } tail.spam <- function (x, n = 6L, m = n, addrownums = TRUE, ...) { stopifnot(length(n) == 1L, length(m) == 1L) nrx <- nrow(x) ncx <- ncol(x) n <- if (n < 0L) max(nrx + n, 0L) else min(n, nrx) m <- if (m < 0L) max(ncx + m, 0L) else min(m, ncx) selr <- seq.int(to = nrx, length.out = n) selc <- seq.int(to = ncx, length.out = n) ans <- as.matrix( x[selr, selc, drop = FALSE]) if (addrownums) { # if (addrownums && is.null(rownames(x))) { # rownames is null by default # rownames(ans) <- paste0("[", selr, ",]") # can be used from R2.15 # colnames(ans) <- paste0("[,", selc, "]") rownames(ans) <- paste("[", selr, ",]", sep = "") colnames(ans) <- paste("[,", selc, "]", sep = "") } ans } setMethod("head","spam",head.spam) setMethod("tail","spam",tail.spam) setMethod("head","spam.chol.NgPeyton", function(x, n = 6L, m = n, ...) head.spam(as.spam(x), n = 6L, m = n, ...)) setMethod("tail","spam.chol.NgPeyton", function(x, n = 6L, m = n, addrownums = TRUE, ...) tail.spam(as.spam(x), n = 6L, m = n, addrownums = TRUE, ...)) spam/R/precmat.R0000644000176000001440000000726012402106212013214 0ustar ripleyusers# This is file ../spam/R/precmat.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # construct various precision matrices precmat <- function(n, season=12, m=n, A=NULL, order=1, ... , type="RW1") { avtype <- c("rw1", "rw2", "rwn", "season","igmrfreglat","igmrfirreglat","gmrfreglat") method <- pmatch(tolower(type), avtype) if (is.na(method)) stop("Precision matrix type not implemented yet. Please ask for.") switch(method, return(precmat.RW1(n)), return(precmat.RW2(n)), return(precmat.RWn(n, order)), return(precmat.season(n,season)), return(precmat.IGMRFreglat(n,m,...)), return(precmat.IGMRFirreglat(A,...)), return(precmat.GMRFreglat(n,m,...))) } precmat.IGMRFreglat <- function (n, m, order=1, anisotropy = 1) { if((n<2)|(m<2)) stop("n and m need to be >1") if(order==1) { if (anisotropy < 0 | anisotropy > 2) stop("anisotropy parameter needs to be in [0,2]") return(kronecker(precmat.RW1(m), diag.spam(2-anisotropy, n)) + kronecker(diag.spam(anisotropy, m), precmat.RW1(n))) } else if (order==2) { return(kronecker(precmat.RW2(m), diag.spam(n)) + kronecker(diag.spam( m), precmat.RW2(n))) } if( (order<1)|(order>=min(n,m))) stop("order needs to be between 1 and min(n,m)-1") Dn <- diff.spam(diag.spam(n), lag = 1, differences = order) Dm <- diff.spam(diag.spam(m), lag = 1, differences = order) return(kronecker(t(Dm)%*%Dm, diag.spam(n)) + kronecker(diag.spam( m), t(Dn)%*%Dn)) } precmat.IGMRFirreglat <- function(A, eps= .Spam$eps) { if(!is.spam(A)) A <- as.spam(A, eps) A@entries <- rep.int(1, length(A)) test <- isSymmetric.spam(A, tol = eps * 100) if (!isTRUE(test)) stop("Input matrix not symmetric (up to 100*eps)",call. = FALSE) return(diag.spam( diff(A@rowpointers)) - A) } precmat.RW1 <- function(n) { if(n<2) stop("Dimension 'n' should be larger than two") Q <- spam(0,n,n) Q@entries <- rep(-1,n-1) Q@colindices <- as.integer( seq.int(2, to=n,by=1)) Q@rowpointers <- as.integer(c(seq.int(1,to=n,by=1),n)) return(Q + t(Q) + diag.spam(c(1, rep.int(2, n-2), 1))) } precmat.RW2<- function(n) { if(n<4) stop("Dimension 'n' should be larger than three") Q <- spam(0,n,n) Q@entries <- c(-2,1,rep(c(-4,1),n-3),-2) Q@colindices <- as.integer( c(rep(2:(n-1),each=2)+c(0,1),n)) Q@rowpointers <- as.integer(c(seq.int(1,to=2*(n-1),by=2),2*(n-1),2*(n-1))) return(Q + t(Q) + diag.spam(c(1,5, rep.int(6, n-4), 5,1))) } precmat.RWn <- function(n, order=3) { if( (order<1)|(order>=n)) stop("order needs to be between 1 and n-1") D <- diff.spam(diag.spam(n), lag=1, differences=order) return( t(D)%*%D ) } precmat.season <- function(n, season=12) { if(n<2*season) stop("Dimension 'n' should be larger than twice the season") Q <- spam(0,n,n) m <- season first <- rev( outer(1:(m-1), (m-1):1, "pmin")) mid <- rep.int((m-1):1, n-2*m+2) tmp <- outer(1:(m-1), 1:(m-1), "pmin") last <- rev( tmp[upper.tri(tmp)]) Q@entries <- c( first, mid, last) Q@rowpointers <- as.integer( c( seq.int( 1, length.out=n-m+1, by=m-1), # first and mid (n-m)*(m-1)+1+cumsum((m-1):1), (m-1)*(n-m/2)+1) # last ) Q@colindices <- as.integer( c( rep.int(1:(m-1), n-m+1) + rep.int(1:(n-m+1), rep.int(m-1, n-m+1)), # first and mid n-last+1 ) # last ) return(Q + t(Q) + diag.spam(c(1:m, rep.int(m, n-2*m), m:1))) } spam/R/dist.R0000644000176000001440000001237412377632615012554 0ustar ripleyusers# This is file ../spam/R/dist.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] ### in base: # dist(x, method = "euclidean", diag = FALSE, upper = FALSE, p=2) # ### in fields # rdist( x1, x2) # rdist.earth(x1, x2, miles = TRUE, R = NULL) # fields.rdist.near( x1, x2, delta, max.points= NULL) # ### in sp # spDistsN1(pts, pt, longlat=FALSE) # ### in amap ### nbproc integer, Number of subprocess for parallelization # Dist(x, method = "euclidean", nbproc = 1, diag = FALSE, upper = FALSE) # ### in argosfilter # distance(lat1, lat2, lon1, lon2) # gc between two pts in km # distanceTrack(lat,lon) # gc between pts in km # ### in proxy # dist(x, y = NULL, method = NULL, ..., diag = FALSE, upper = FALSE, # pairwise = FALSE, by_rows = TRUE, convert_similarities = TRUE, # auto_convert_data_frames = TRUE) # ### in RFOC # GreatDist(LON1, LAT1, LON2, LAT2, EARTHRAD= 6371) # nearest.dist <- function( x, y=NULL, method = "euclidean", delta = 1, upper = if(is.null(y)) FALSE else NULL, p = 2, miles=TRUE, R=NULL # eps = NULL, diag = NULL ) { # see help for exact parameter meaning # We always include all small distances. Hence, this function # works different than any other spam functions. An addititonal # call to an as.spam would eliminate the small values. # if (!is.null(diag)) warning("Argument 'diag' is deprecated") # if (!is.null(eps)) warning("Argument 'eps' is deprecated") if (!is.na(pmatch(method, "euclidian"))) method <- "euclidean" METHODS <- c("euclidean", "maximum", "minkowski", "greatcircle") method <- pmatch(method, METHODS) # result is integer if (is.na(method)) stop("invalid distance method") if (method == 4) { if (is.null(R)) p <- ifelse( miles,3963.34,6378.388) else { if (R <= 0) stop("'R' should be postiive") p <- R } if (abs(delta)>180.1) stop("'delta' should be smaller than 180 degrees.") } if (is.null(upper)) part <- 0L else part <- ifelse(upper, 1L ,-1L) if (is.data.frame(x)) x <- as.matrix(x) if (is.list(x)) stop("'x' should be an array or matrix") # as.matrix( list() ) does not work if (!is.matrix(x)) x <- as.matrix(x) nd <- dim(x)[2] n1 <- dim(x)[1] if (!is.null(y)) { # we specify x and y: if (is.data.frame(y)) y <- as.matrix(y) if (is.list(x)) stop("'x' should be an array or matrix") if (!is.matrix(y)) y <- as.matrix(y) if (nd!=dim(y)[2]) stop("'x' and 'y' should have the same number of columns.") n2 <- dim(y)[1] mi <- min(n1,n2) ma <- max(n1,n2) nnz <- min(max(.Spam$nearestdistnnz[1], ma*.Spam$nearestdistnnz[2]), (as.double(mi)*(mi+1)+(ma-mi)^2)/ ifelse( is.null(upper), 1, 2), 2^31-2) # there is an as.double just in case that mi (and n1 below) is > 2^16 } else { # x = y, i.e. proper distance matrix if (n1==1) stop("More than a single point in 'x' is required.") if (method == 4) { p <- -p # we save one variable... } y <- x n2 <- n1 nnz <- min(max(.Spam$nearestdistnnz[1], n1*.Spam$nearestdistnnz[2]), (as.double(n1)*(n1+1))/ ifelse( is.null(upper), 1, 2), 2^31-2) } repeat { d <- .Fortran("closestdist", nd, as.double(x), n1, as.double(y), n2, part, as.double(p[1]), method, as.double(abs( delta[1])), colindices=vector("integer",nnz), rowpointers=vector("integer",n1+1), entries=vector("double",nnz), nnz=as.integer(nnz), iflag=as.integer(0),DUP=DUPFALSE,NAOK=.Spam$NAOK, PACKAGE="spam") if (d$iflag==0) break else { if (nnz==2^31-2) stop("distance matrix is too dense (more than 2^31 entries).") nnz <- min(2^31-2,nnz*.Spam$nearestdistincreasefactor*n1/(d$iflag-1)) madens <- d$iflag on.exit( warning(paste("You ask for a 'dense' spase distance matrix, I require one more iteration.", "\nTo avoid the iteration, increase 'nearestdistnnz' option to something like\n", "'spam.options(nearestdistnnz=c(",d$nnz,",400))'\n(constructed ",madens, " lines out of ",n1,").\n",sep=""), call. = TRUE) ) } } dmat <- new("spam") slot(dmat,"entries",check=FALSE) <- d$entries[1:d$nnz] slot(dmat,"colindices",check=FALSE) <- d$colindices[1:d$nnz] slot(dmat,"rowpointers",check=FALSE) <- d$rowpointers slot(dmat,"dimension",check=FALSE) <- as.integer(c(n1,n2)) return( dmat) } # in fields: # rdist <- function (x1, x2) spam_rdist <- function(x1, x2, delta = 1) nearest.dist(x1, y=x2, delta = delta, upper = NULL) # in fields: # rdist.earth <- function (x1, x2, miles = TRUE, R = NULL) spam_rdist.earth <- function(x1, x2, delta=1, miles = TRUE, R = NULL) nearest.dist( x1, y=x2, method = "greatcircle", delta = delta, miles=miles, R=R, upper = NULL) spam/R/s3only.R0000644000176000001440000000074012375327014013022 0ustar ripleyusers# This is file ../spam/R/s3only.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] eigen.spam <- function(x, ...) { inefficiencywarning( "This 'eigen' operation may be inefficient", prod(dim(x))) eigen(as.matrix(x), ...) } var.spam <- function(x, ...) { inefficiencywarning( "This 'var' operation may be inefficient", prod(dim(x))) var(as.matrix(x), ...) } spam/R/helper.R0000644000176000001440000003536312403543116013056 0ustar ripleyusers# This is file ../spam/R/helper.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] ######################################################################## ######################################################################## # a few nice helper functions: bandwidth <- function(A) { if (!is.spam(A)) { warning("Matrix not 'spam' object. Coerced to one") A <- as.spam(A) } ret <- .Fortran("getbwd",A@dimension[1],A@entries,A@colindices, A@rowpointers,low=integer(1),upp=integer(1), NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") return(c(ret$low,ret$upp)) } bdiag.spam <- function(...){ nargs <- nargs() if (nargs == 0) return( NULL) args <- list(...) args[which(sapply(args, is.null))] <- NULL if (nargs == 1) return( args[[1]]) if (nargs == 2) { # Classical case, concatenate two matrices A <- args[[1]] B <- args[[2]] if(!is.spam(A)) A <- as.spam(A) if(!is.spam(B)) B <- as.spam(B) dimA <- A@dimension lenA <- length(A@entries) A@entries <- c(A@entries,B@entries) A@colindices <- c(A@colindices,B@colindices+dimA[2]) A@rowpointers <- c(A@rowpointers,B@rowpointers[-1]+lenA) A@dimension <- dimA+B@dimension return(A) } else { # "recursive" approach only, e.g. no checking tmp <- bdiag.spam( args[[1]], args[[2]]) for ( i in 3:nargs) tmp <- bdiag.spam( tmp, args[[i]]) return( tmp) } } adjacency.landkreis <- function(loc) # this reads the germany graph file provide by # loc <- "http://www.math.ntnu.no/~hrue/GMRF-book/germany.graph" # or # loc <- system.file("demodata/germany.graph", package="INLA") # { n <- as.numeric( readLines(loc, n=1)) nnodes <- nodes <- numeric( n) adj <- list() for (i in 1:n) { tmp <- as.numeric(scan(loc, skip=i, nlines=1, quiet=T, what=list(rep("",13)))[[1]]) nodes[i] <- tmp[1] nnodes[i] <- tmp[2] adj[[i]] <- tmp[-c(1:2)] } adj <- adj[ order(nodes)] nnodes <- nnodes[ order(nodes)] A <- spam(0) A@colindices <- as.integer( unlist(adj)+1) A@rowpointers <- as.integer( c(1,cumsum(lapply(adj, length))+1)) A@entries <- rep(1, length(unlist(adj))) A@dimension <- as.integer( c(n, n)) return(A) } map.landkreis <- function(data, col=NULL, zlim=range(data), add=FALSE, legendpos=c( 0.88,0.9,0.05,0.4)) # This is a stripped-down version of the function provided by the INLA package. # Added color argument, changed 'append' to 'add'. # Legend is tuned for a mai=rep(0,4) call { npoly <- length(spam::germany) ymax <- ymin <- xmax <- xmin <- 1:npoly if (length(data)!=npoly) stop('data has wrong length') if (is.null(col)) { if (requireNamespace("fields", quietly = TRUE)) { col <- fields::tim.colors(64) } else { col <- gray(seq(.05,to=0.95,length=64)) } } ncol <- length(col) polycol <- col[round(((data-zlim[1])/diff(zlim)+1e-6)*(ncol-1))+1] for(i in 1:length(spam::germany)) { xmin[i] <- min(spam::germany[[i]][,2],na.rm=T) xmax[i] <- max(spam::germany[[i]][,2],na.rm=T) ymin[i] <- min(spam::germany[[i]][,3],na.rm=T) ymax[i] <- max(spam::germany[[i]][,3],na.rm=T) } if (!add) plot(c(min(xmin),max(xmax)),c(min(ymin),max(ymax)), type="n", axes=F, xlab="", ylab="") for(k in npoly:1) polygon(spam::germany[[k]][,2],spam::germany[[k]][,3],col=polycol[k]) if (requireNamespace("fields", quietly = TRUE)) fields::image.plot(as.matrix(data), zlim=zlim, legend.only=T, smallplot=legendpos, cex=.2, col=col) invisible() } germany.plot <- function(vect, col=NULL, zlim=range(vect), legend=TRUE, main=NULL, cex.axis=1, add=FALSE, ... ) { if (length(vect) != spam::germany.info$n) stop("data has wrong length") if (!add) { par(mai=c(.1,.1,.1,.3)) plot(0,0, xlim=spam::germany.info$xlim, ylim=spam::germany.info$ylim, type = "n", axes = F, xlab = "", ylab = "") } if (is.null(col)) { ## from: require(RColorBrewer); col <- colorRampPalette(brewer.pal(9,"Blues"))(100) col <- c("#F7FBFF", "#F4F9FE", "#F2F8FD", "#F0F7FD", "#EEF5FC", "#ECF4FB", "#EAF3FB", "#E8F1FA", "#E6F0F9", "#E4EFF9", "#E2EEF8", "#E0ECF7", "#DEEBF7", "#DCEAF6", "#DAE8F5", "#D8E7F5", "#D6E6F4", "#D5E5F4", "#D3E3F3", "#D1E2F2", "#CFE1F2", "#CDDFF1", "#CBDEF0", "#C9DDF0", "#C7DBEF", "#C5DAEE", "#C1D9ED", "#BED7EC", "#BBD6EB", "#B8D5EA", "#B5D3E9", "#B1D2E7", "#AED1E6", "#ABCFE5", "#A8CEE4", "#A4CCE3", "#A1CBE2", "#9ECAE1", "#9AC8E0", "#96C5DF", "#92C3DE", "#8EC1DD", "#89BEDC", "#85BCDB", "#81BADA", "#7DB8DA", "#79B5D9", "#75B3D8", "#71B1D7", "#6DAFD6", "#69ACD5", "#66AAD4", "#62A8D2", "#5FA6D1", "#5CA3D0", "#58A1CE", "#559FCD", "#529DCC", "#4E9ACB", "#4B98C9", "#4896C8", "#4493C7", "#4191C5", "#3E8EC4", "#3C8CC3", "#3989C1", "#3686C0", "#3484BE", "#3181BD", "#2E7EBC", "#2C7CBA", "#2979B9", "#2776B8", "#2474B6", "#2171B5", "#1F6FB3", "#1D6CB1", "#1B69AF", "#1967AD", "#1764AB", "#1562A9", "#135FA7", "#115CA5", "#0F5AA3", "#0D57A1", "#0B559F", "#09529D", "#084F9A", "#084D96", "#084A92", "#08478E", "#08458A", "#084286", "#083F82", "#083D7E", "#083A7A", "#083776", "#083572", "#08326E", "#08306B") } ncol <- length(col) polycol <- (col)[round((((vect) - zlim[1])/diff(zlim) + 1e-06) * (ncol - 1)) + 1] polygon( spam::germany.poly[17965L:1L,], col = (polycol[spam::germany.info$polyid])[599L:1L], ...) if (legend&&requireNamespace("fields", quietly = TRUE)){ legendpos <- c(0.845, 0.89, 0.05, 0.4) fields::image.plot(as.matrix(vect), zlim = zlim, legend.only = TRUE, smallplot = legendpos, axis.args=list(cex.axis=cex.axis,lwd=0, lwd.ticks=1.3), col = col) } if(!is.null(main)) text( min(spam::germany.info$xlim), max(spam::germany.info$ylim), main, cex=1.5, adj=c(0,1)) invisible() } grid_zoom <- function(inputGrob = pointsGrob(runif(200),runif(200)), inputViewport = viewport(name='main'), x = 'topleft', y, just, ratio = c(.3,.4), zoom_xlim, zoom_ylim, rect = TRUE, rect_lwd = 1, rect_fill = 'gray92', draw =TRUE, zoom_fill = 'white', zoom_frame_gp = gpar(lwd = 1), zoom_gp = NULL, zoom_xaxis = xaxisGrob(main = FALSE), zoom_yaxis = NULL) { ## inputGrob <- pointsGrob(runif(100), runif(100), pch='.', gp=gpar(cex=4),default.units='native',name='cc') ## inputViewort <- viewport(name='main') ## x <- 'topleft' ## ratio <- unit(c(.3,.3), 'npc') ## zoom_xlim <- c(0.1,.5) ## zoom_ylim <- c(0.1,.5) ## rect <- TRUE ## rect_lwd = 1 ## rect_fill = 'gray92' ## zoom_fill = 'white' ## zoom_frame_gp = gpar(lwd = 1) ## draw = TRUE ## zoom_gp = NULL # cat('may not work if other units than \'native\' and if the inputGrob has a complex structure. \n') if (!identical(length(ratio), 1)) ratio <- c(ratio, ratio) if(class(x) == 'character') switch(x, topleft = {x = 0; y = 1; just = c(0, 1)}, topright = {x = 1; y = 1 ; just = c(1, 1)}, bottomright = {x = 1; y = 0; just = c(1, 0)}, bottomleft = {x = 0; y = 0; just = c(0, 0)}) inputViewport$name <- 'main' vp <- vpStack(inputViewport, vpList(viewport(name='zoom', x = unit(x,'npc'), y = unit(y,'npc'), width=unit(ratio[1],'npc'), height=unit(ratio[2],'npc'), just = just, xscale=zoom_xlim, yscale=zoom_ylim, default.units='native', clip = 'on'), viewport(name='zoom_noClip', x = unit(x,'npc'), y = unit(y,'npc'), width=unit(ratio[1],'npc'), height=unit(ratio[2],'npc'), just = just, xscale=zoom_xlim, yscale=zoom_ylim, default.units='native', clip = 'off'))) inputGrob <- editGrob(inputGrob, name='main', vp='main') zoom_grob <- editGrob(inputGrob, name='zoom', vp='main::zoom') if(!is.null(zoom_gp)) zoom_grob <- editGrob(inputGrob, name='zoom', vp='main::zoom', gp=zoom_gp) if(!is.null(zoom_xaxis)) zoom_xaxis <- editGrob(zoom_xaxis, vp='main::zoom_noClip', name = 'xaxis') if(!is.null(zoom_yaxis)) zoom_yaxis <- editGrob(zoom_yaxis, vp='main::zoom_noClip', name = 'yaxis') rect <- rectGrob(x = zoom_xlim[1], y = zoom_ylim[1], just = c(0,0), width = diff(zoom_xlim), height = diff(zoom_ylim), default.units = 'native', vp = 'main', gp = gpar(lwd = rect_lwd, fill=rect_fill)) rect_frame <- rectGrob(x = zoom_xlim[1], y = zoom_ylim[1], just = c(0,0), width = diff(zoom_xlim), height = diff(zoom_ylim), default.units = 'native', vp = 'main', gp = gpar(lwd = rect_lwd)) gr <- gList(rect, inputGrob, rectGrob(vp='main::zoom', gp=gpar(fill=zoom_fill)), zoom_grob, rectGrob(vp='main::zoom_noClip', gp=zoom_frame_gp), zoom_xaxis, zoom_yaxis, rect_frame) out <- gTree(children=gr, childrenvp = vp) if (draw) grid.draw(out) invisible(out) } grid_trace2 <- function (chain1, chain2 = NULL, xlim = NULL, ylim1 = NULL, ylim2=NULL, chain1_lab = "", chain2_lab = "", main = "", chain1_yaxis_at = NULL, chain2_yaxis_at = NULL, log = FALSE, cex_points = unit(.2, "mm"), cex_main = unit(1.2, "mm"), lwd_lines = unit(.1, "mm"), lwd_frame = unit(.8, "mm"), draw = TRUE) { if (is.null(chain2)) { chain2 <- chain1[, 2] chain1 <- chain1[, 1] } if (log) { chain1 <- log(chain1) chain2 <- log(chain2) } stopifnot(identical(length(chain1), length(chain2))) n <- length(chain1) if(!is.null(xlim)){ stopifnot(length(xlim)==2) chain1.sub <- chain1[xlim[1]:xlim[2]] chain2.sub <- chain2[xlim[1]:xlim[2]] }else{ chain1.sub <- chain1 chain2.sub <- chain2 } if(!is.null(ylim1)) stopifnot(length(ylim1)==2) if(!is.null(ylim2)) stopifnot(length(ylim2)==2) vp1 <- plotViewport(unit(c(2.5, 3, 2.5, 2), "cm"), name = "frame") vp2 <- viewport(layout = grid.layout(nrow = 1, ncol = 3, respect = rbind(c(0, 0, 1)), widths = unit(c(1, 0.3, 1), c("null", "cm", "null"))), name = "lay1") vp3 <- viewport(layout.pos.col = 1, name = "traces") vp4 <- viewport(layout = grid.layout(nrow = 2, ncol = 1), name = "lay2") vp5 <- viewport(layout.pos.row = 1, name = "trace1") vp5data <- dataViewport(xData = 1L:n, yData = chain1, xscale = xlim, yscale = ylim1, extension = c(0.02, 0.03), name = "trace1data", clip="off") vp5data_clip <- dataViewport(xData = 1L:n, yData = chain1, xscale = xlim, yscale = ylim1, extension = c(0.02, 0.03), name = "trace1data_clip", clip="on") vp6 <- viewport(layout.pos.row = 2, name = "trace2") vp6data_clip <- dataViewport(xData = 1L:n, yData = chain2, xscale = xlim, yscale = ylim2, extension = c(0.02, 0.03), name = "trace2data_clip", clip="on") vp6data <- dataViewport(xData = 1L:n, yData = chain2, xscale = xlim, yscale = ylim2, extension = c(0.02, 0.03), name = "trace2data", clip="off") vp7 <- viewport(layout.pos.col = 3, name = "scatter") vp7data_clip <- dataViewport(xData = chain1, yData = chain2, xscale = ylim1, yscale = ylim2, extension = 0.03, name = "scatterData_clip", clip="on") vp7data <- dataViewport(xData = chain1, yData = chain2, xscale = ylim1, yscale = ylim2, extension = 0.03, name = "scatterData", clip="off") vps <- vpStack(vp1, vp2, vpList(vpStack(vp3, vp4, vpList(vpStack(vp5, vp5data, vp5data_clip), vpStack(vp6, vp6data, vp6data_clip))), vpStack(vp7, vp7data, vp7data_clip))) grs <- gList(rectGrob(vp = "frame::lay1::traces::lay2::trace1", gp = gpar(lwd = lwd_frame), name = "rect_trace1"), linesGrob(x = 1L:n, y = chain1, gp = gpar(lty = 1, lwd = lwd_lines), default.units = "native", vp = "frame::lay1::traces::lay2::trace1::trace1data::trace1data_clip", name = "lines_chain1"), yaxisGrob(at = chain1_yaxis_at, vp = "frame::lay1::traces::lay2::trace1::trace1data", name = "yaxis_chain1"), rectGrob(vp = "frame::lay1::traces::lay2::trace2", gp = gpar(lwd = lwd_frame), name = "rect_trace2"), linesGrob(x = 1L:n, y = chain2, gp = gpar(lty = 1, lwd = lwd_lines), default.units = "native", vp = "frame::lay1::traces::lay2::trace2::trace2data::trace2data_clip", name = "lines_chain2"), yaxisGrob(at = chain2_yaxis_at, vp = "frame::lay1::traces::lay2::trace2::trace2data", name = "yaxis_chain2"), xaxisGrob(vp = "frame::lay1::traces::lay2::trace2::trace2data", name = "xaxis_chains"), pointsGrob(x = chain1.sub, y = chain2.sub, pch = 20, gp = gpar(cex = cex_points), default.units = "native", vp = "frame::lay1::scatter::scatterData::scatterData_clip", name = "points_scatter"), rectGrob(vp = "frame::lay1::scatter::scatterData", gp = gpar(lwd = lwd_frame), name = "rect_scatter"), textGrob(chain1_lab, y = unit(-1, "line") - unit(0.2, "cm"), vp = "frame::lay1::scatter", name = "text_scatter_lab1"), textGrob(chain2_lab, x = unit(1, "npc") + unit(0.5, "cm"), rot = 90, vp = "frame::lay1::scatter", name = "text_scatter_lab2"), textGrob(main, x = unit(.5, "npc") + grobHeight(rectGrob())*.5, y = unit(1, "npc") + max(stringHeight("Fg"),unit(.6, "cm")), vp = "frame::lay1::traces", name = "title", just=c(.5, .5), gp=gpar(cex=cex_main)) ) out <- gTree(childrenvp = vps, children = grs) if (draw) grid.draw(out) invisible(out) } spam/R/spamlist.R0000644000176000001440000000555312372657772013454 0ustar ripleyusers# This is file ../spam/R/spamlist.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] "spam.list" <- function(x, nrow = 1, ncol = 1,eps = .Spam$eps) { if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) if (!is.list(x)|(length(x)<2)|(length(x)>3)) stop("Argument 'x' needs to be a list with two or three elements") # two cases: list of length # - two (matrix with two columns called ind* and the elements) # - three (each one column called i*, j*. if (identical(length(x),2L)) { indnr <- pmatch("ind",names(x)) if (is.na(indnr)) stop("Argument 'x' needs an element called 'indices'") elenr <- ifelse( identical( indnr,1L), 2L, 1L) nz <- length( x[[elenr]]) dimx <- dim(x[[indnr]]) if (is.null(dimx)||(dimx[2] != 2)) stop("Indices should have two columns") if (dimx[1] != nz) stop("Number of indices does not match with number of elements") ir <- as.integer(x[[indnr]][,1]) jc <- as.integer(x[[indnr]][,2]) } else { inr <- pmatch("i",names(x)) jnr <- pmatch("j",names(x)) if (is.na(inr)||is.na(jnr)) stop("Argument 'x' needs elements called 'i' and 'j'") elenr <- c(1:3)[-c(inr,jnr)] nz <- length( x[[elenr]]) ir <- as.integer(x[[inr]]) jc <- as.integer(x[[jnr]]) if ((length(ir) != nz)||(length(jc) != nz)) stop("Number of indices does not match with number of elements") } if (identical(nz, 0L)) return(new("spam",rowpointers=c(1L,rep.int(2L,as.integer(nrow))), dimension=as.integer(c(nrow,ncol)))) if (any( ir <= 0) || any( jc <= 0)) stop("Indices need to be positive") if (any(!is.finite(x[[elenr]]))) { warning("'NA/NaN/Inf' coerced to zero") x[[elenr]][!is.finite(x[[elenr]])] <- 0 } nrow <- as.integer(ifelse(missing(nrow),max(ir),nrow)) ncol <- as.integer(ifelse(missing(ncol),max(jc),ncol)) z <- .Fortran(ifelse(toupper(.Spam$listmethod=='PE'),"triplet3csr","triplet2csr"), nrow=nrow, ncol=ncol, nz=nz, as.double(x[[elenr]]),ir,jc, entries=vector("double",nz), colindices=vector("integer",nz), rowpointers=vector("integer",nrow+1),eps, NAOK=TRUE, DUP=DUPFALSE, PACKAGE = "spam" ) # print(z) if (identical(z$nz, 0L)) return(new("spam",rowpointers=c(1L,rep.int(2L,nrow)), dimension=c(nrow,ncol))) newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:z$nz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:z$nz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- c(nrow,ncol) return(newx) } setMethod("as.spam","list", { function(x,eps) spam.list(x,eps=eps)}) setMethod("spam","list",spam.list) spam/R/permutation.R0000644000176000001440000001020612372657772014156 0ustar ripleyusers# This is file ../spam/R/permutation.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] checkpivot <- function(pivot, len, type="Pivot") { if(is.null(pivot)) return() if(!is.vector(pivot)) stop(paste(type,"is not a vector.")) pivot <- as.vector(pivot,"integer") if (!identical(length(pivot),len)) stop(paste(type,"of wrong length.")) tmp <- sort.int(pivot) if(tmp[1]!=1 || any(tmp-seq_len(len)!=0)) stop(paste("Invalid",type)) return() } "permutation.spam" <- function(A, P=NULL, Q=NULL, ind=FALSE, check=TRUE){ # eliminated .Internal calls as this creates a 'Note' on CRAN checks. # Only 1-2% timing loss, see end of the file. nrow <- A@dimension[1] ncol <- A@dimension[2] if (is.null(P)&is.null(Q)) stop("At least one permutation should be specified") nz <- A@rowpointers[nrow+1]-1 if (check){ checkpivot(P,nrow,"Permutation") checkpivot(Q,ncol,"Permutation") } if (is.null(Q)) { # subroutine rperm (nrow,a,ja,ia,ao,jao,iao,perm) # B = P A P <- as.integer(P) if(ind) P <- order(P) # if(ind) P <- .Internal(order(T,F,P)) z <- .Fortran("rperm", nrow, A@entries,A@colindices,A@rowpointers, entries = vector("double",nz), colindices = vector("integer", nz), rowpointers = vector("integer", nrow + 1),P, NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") } else { if (is.null(P)){ # subroutine cperm (nrow,a,ja,ia,ao,jao,iao,perm,iwork) # integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(*), iwork(*) # double precision a(*), ao(*) # B = A Q Q <- as.integer(Q) if(ind) Q <- order(Q) # if(ind) Q <- .Internal(order(T,F,Q)) z <- .Fortran("cperm", nrow, A@entries,A@colindices,A@rowpointers, entries = vector("double",nz), colindices = vector("integer", nz), rowpointers = vector("integer", nrow + 1), Q, NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") } else { # subroutine dperm (nrow,a,ja,ia,ao,jao,iao,pperm,qperm,iwork) # B = P A Q Q <- as.integer(Q) # if(ind) Q <- .Internal(order(T,F,Q)) if(ind) Q <- order(Q) P <- as.integer(P) # if(ind) P <- .Internal(order(T,F,P)) if(ind) P <- order(P) z <- .Fortran("dperm", nrow, A@entries,A@colindices,A@rowpointers, entries = vector("double",nz), colindices = vector("integer", nz), rowpointers = vector("integer", nrow + 1), P,Q, NAOK = .Spam$NAOK, DUP=DUPFALSE, PACKAGE = "spam") } } newx <- new("spam") slot(newx, "entries", check = FALSE) <- z$entries slot(newx, "colindices", check = FALSE) <- z$colindices slot(newx, "rowpointers", check = FALSE) <- z$rowpointers slot(newx, "dimension", check = FALSE) <- c(nrow,ncol) return(newx) } permutation.matrix <- function(A, P=NULL, Q=NULL, ind=FALSE, check=TRUE){ nrow <- dim(A)[1] ncol <- dim(A)[1] if (is.null(P)&is.null(Q)) stop("At least one permutation should be specified") if (check){ checkpivot(P,nrow,"Permutation") checkpivot(Q,ncol,"Permutation") } if (ind) { if (is.null(Q)) return(A[P,]) if (is.null(P)) return(A[,Q]) return(A[P,Q]) } else { if (is.null(Q)) return(A[order(P),]) if (is.null(P)) return(A[,order(Q)]) return(A[order(P),order(Q)]) } } setGeneric("permutation",function(A, P=NULL, Q=NULL, ind=FALSE, check=TRUE)standardGeneric("permutation")) setMethod("permutation","matrix",permutation.matrix) setMethod("permutation","spam",permutation.spam) ### ss <- sample(1:100000) ### system.time( for( i in 1:1000) tt<-order(ss)) ### system.time( for( i in 1:1000) tt<-.Internal(order(T,F,ss))) spam/R/s4coerce.R0000644000176000001440000000250012377115711013277 0ustar ripleyusers# This is file ../spam/R/definitions.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # a few coercions that make sense... # showMethods(coerce) setAs("spam","logical", def=function(from) { if(.Spam$structurebased) { return( as.logical(from@entries)) }else{ inefficiencywarning( gettextf("This operation may be inefficient"), prod(dim(from))) return( as.logical(as.matrix(from))) }}) setAs("spam","vector", def=function(from) { if(.Spam$structurebased) { return( as.vector(from@entries)) }else{ inefficiencywarning( gettextf("This operation may be inefficient"), prod(dim(from))) return( as.vector(as.matrix(from))) }}) setAs("spam","integer", def=function(from) { if(.Spam$structurebased) { return( as.integer(from@entries)) }else{ inefficiencywarning( gettextf("This operation may be inefficient"), prod(dim(from))) return( as.integer(as.matrix(from))) }}) setAs("spam","matrix", def=function(from) { inefficiencywarning( gettextf("This operation may be inefficient"), prod(dim(from))) return( as.logical(as.matrix(from))) }) setAs("spam","list", def=function(from) { return( triplet(from)) }) spam/R/covmat.R0000644000176000001440000001312212372657772013100 0ustar ripleyusers# This is file ../spam/R/covmat.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] # construct various precision matrices covmat <- function(h, theta, ... , type="sph") { avtype <- c("exponential", "spherical", "nugget", "wu1","wu2","wu3","wendland1","wendland2", "matern") method <- pmatch(tolower(type), avtype) if (is.na(method)) stop("Covariance function not implemented yet. Please ask for.") switch(method, return(cov.exp(h, theta, ...)), return(cov.sph(h, theta, ...)), return(cov.nug(h, theta, ...)), return(cov.wu1(h, theta, ...)), return(cov.wu2(h, theta, ...)), return(cov.wu3(h, theta, ...)), return(cov.wend1(h, theta, ...)), return(cov.wend2(h, theta, ...)), return(cov.mat(h, theta, ...))) } .par.check.cov <- function(theta,nr=2){ if (any(theta<0)) { warning('Parameters coerced to positive values') theta <- abs(theta) } nt <- length(theta) if (nt < nr) return( c( theta, rep(1, nr-nt), 0)) return( c( theta, 0)[1:(nr+1)]) } cov.sph <- function(h, theta, ... , eps= .Spam$eps) { theta <- .par.check.cov(theta) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[3], ifelse(tmp < 1, theta[2] * (1 - 1.5 * tmp + 0.5 * tmp^3), 0)) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[3], ifelse(h < 1, theta[2] * (1 - 1.5 * h + 0.5 * h^3), 0)) } } cov.wend1 <- function(h, theta, ... , eps= .Spam$eps) { # is \phi_{3,1} in the 98 paper and \psi_{3,1} in the 95 paper theta <- .par.check.cov(theta) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[3], ifelse(tmp < 1, theta[2] * ((1 - tmp)^4*(4*tmp+1)), 0)) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[3], ifelse(h < 1, theta[2] * ((1 - h)^4*(4*h+1)), 0)) } } cov.wend2 <- function(h, theta, ... , eps= .Spam$eps) { # is \phi_{3,2} in the 98 paper and \psi_{4,2} in the 95 paper theta <- .par.check.cov(theta) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[3], ifelse(tmp < 1, theta[2] * ((1 - tmp)^6*(35*tmp^2+18*tmp+3))/3, 0)) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[3], ifelse(h < 1, theta[2] * ((1 - h)^6*(35*h^2+18*h+3))/3, 0)) } } cov.wu1 <- function(h, theta, ... , eps= .Spam$eps) { theta <- .par.check.cov(theta) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[3], ifelse(tmp < 1, theta[2] * ((1 - tmp)^3*(1+3*tmp+tmp^2)), 0)) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[3], ifelse(h < 1, theta[2] * ((1 - h)^3*(1+3*h+h^2)), 0)) } } cov.wu2 <- function(h, theta, ... , eps= .Spam$eps) { theta <- .par.check.cov(theta) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[3], ifelse(tmp < 1, theta[2] * ((1 - tmp)^4*(4+16*tmp+12*tmp^2+3*tmp^3))/4, 0)) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[3], ifelse(h < 1, theta[2] * ((1 - h)^4*(4+16*h+12*h^2+3*h^3))/4, 0)) } } cov.wu3 <- function(h, theta, ... , eps= .Spam$eps) { theta <- .par.check.cov(theta) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[3], ifelse(tmp < 1, theta[2] * ((1 - tmp)^6*(1+6*tmp+41/3*tmp^2+12*tmp^3+5*tmp^4+5/6*tmp^5)), 0)) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[3], ifelse(h < 1, theta[2] * ((1 - h)^6*(1+6*h+41/3*h^2+12*h^3+5*h^4+5/6*h^5)), 0)) } } cov.mat <- function(h, theta, ... , eps= .Spam$eps) { theta <- .par.check.cov(theta,3) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[4], theta[2] * (((2^(-(theta[3] - 1)))/gamma(theta[3])) * (tmp^theta[3]) * besselK(tmp, nu = theta[3]))) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[4], theta[2] * (((2^(-(theta[3] - 1)))/gamma(theta[3])) * (h^theta[3]) * besselK(h, nu = theta[3]))) } } cov.exp <- function(h, theta, ... , eps= .Spam$eps) { theta <- .par.check.cov(theta,2) if (is.spam(h)) { tmp <- h@entries/theta[1] h@entries <- ifelse(tmp < eps, theta[2] + theta[3], theta[2] * exp( -tmp)) return( h) } else { h <- h/theta[1] ifelse(h < eps, theta[2] + theta[3], theta[2] * exp( -h)) } } cov.nug <- function(h, theta, ... , eps= .Spam$eps) { theta <- .par.check.cov(theta,0) if (is.spam(h)) { h@entries <- ifelse(h@entries < eps, theta[1], 0) return( h) } else { ifelse(h < eps, theta[1], 0) } } spam/R/tcrossprod.R0000644000176000001440000000171312372657772014014 0ustar ripleyuserscrossprod.spam <- function(x, y=NULL) { dimx <- dim(x) if( is.null(y)) { if(!is.spam(x)) return(crossprod(x)) if(dimx[2]==1L) return(matrix( sum(x@entries^2))) return( .spam.matmul(t.spam(x),x)) } if( (!is.spam(x)) & (!is.spam(y))) return(crossprod(x,y)) return( .spam.matmul(t(x),y)) } tcrossprod.spam <- function(x, y=NULL) { dimx <- dim(x) if( is.null(y)) { if(!is.spam(x)) return(tcrossprod(x)) if(dimx[2]==1L) return(matrix( sum(x@entries^2))) return( .spam.matmul(x,t.spam(x))) } if( (!is.spam(x)) & (!is.spam(y))) return(tcrossprod(x,y)) return( .spam.matmul(x,t(y))) } setMethod("crossprod",signature(x="spam",y="missing"), crossprod.spam) setMethod("crossprod",signature(x="ANY",y="spam"), crossprod.spam) setMethod("tcrossprod",signature(x="spam",y="missing"), tcrossprod.spam) setMethod("tcrossprod",signature(x="ANY",y="spam"), tcrossprod.spam) spam/R/definitions.R0000644000176000001440000012106712377563723014127 0ustar ripleyusers# This is file ../spam/R/definitions.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] todo <- function() help( "todo.spam") spam.history <- function() help("spam.history") validspamobject <- function(object) { if (.Spam$safemodevalidity){ if(!identical(length(object@dimension), 2L) ){ print(object@dimension) return("invalid dimension attribute") } else{ nrow <- object@dimension[1] ncol <- object@dimension[2] } if (!.Spam$NAOK) { if (any(!is.finite(object@entries))) return("'NA/NaN/Inf' not allowed") } if (any(!is.double(object@entries))) return("matrix entries need to be of double mode") if(!identical(length(object@entries),length(object@colindices))) return("entries and column indices don't have equal lengths") if(any(object@colindices < 1) || any(object@colindices > ncol)) return("column indices exceeds dimension bounds") if(any(object@rowpointers < 1)) return("some elements of row pointes are <= 0") if(any(diff(object@rowpointers)<0)) return("row pointers are not monotone increasing") diffcolindices <- diff(object@colindices) # positive values within each row if (all(diff(object@rowpointers)>1) && length(diffcolindices)>0) # only if we have multiple values if (identical( nrow, 1L)) { if ( any(diffcolindices<1)) return("column indices are not ordered") } else { if ( any(diffcolindices[-(object@rowpointers[2:nrow]-1)]<1)) return("column indices are not ordered") } if(object@rowpointers[length(object@rowpointers)] != length(object@entries)+1) return("last element of row pointers doesn't conform") if(length(object@rowpointers) != nrow+1) return("row pointers has wrong number of elements") if(length(object@entries) < 1 || length(object@entries) > prod(object@dimension)) return("too few or too many entries") } TRUE } setClass("spam",representation(entries="numeric", colindices="integer", rowpointers="integer", dimension="integer"), prototype = prototype(entries=as.double( 0), colindices=1L, rowpointers=c(1L,2L), dimension=c(1L,1L)), validity = validspamobject) # in the future use representation as slots=c(...) see help setClass setMethod("initialize", "spam", function(.Object, entries = 0, # by default a 1x1 zero matrix. colindices = as.integer( rep(1, length( entries ))), # or a nx1 matrix rowpointers= as.integer( 1:(length( entries )+1)), # with n=length(ra) dimension = as.integer( c(length( rowpointers )-1,max( 1,colindices )))) { # a specific "degenerate" case: if (identical(length(entries),0L)) { # e.g., induced by rep(1,0) warning("While initializing, empty 'spam' object coerced to zero 'spam' matrix", call.=FALSE) entries <- 0 colindices <- 1L rowpointers <- c(1L,2L) dimension <- c(1L,1L) } # if (rowpointers[ length(rowpointers)] ==1) { # e.g., zero matrix # rowpointers[-1] <- as.integer(2) # colindices <- as.integer(1) # } .Object@entries <- entries .Object@colindices <- colindices .Object@rowpointers <- rowpointers .Object@dimension <- dimension validObject(.Object) .Object }) print.spam <- function(x,...) { if (prod(x@dimension) < .Spam$printsize) { print(as.matrix.spam(x),...) } else { if ( (length(x@entries)==1) & (x@entries[1]==0)) { cat('Zero matrix of dimension ',x@dimension[1],'x', x@dimension[2],'.\n',sep='', fill=TRUE) }else { cat('Matrix of dimension ',x@dimension[1],'x', x@dimension[2],' with (row-wise) nonzero elements:\n',sep='', fill=TRUE) print(x@entries,...) } } cat("Class 'spam'\n") invisible(NULL) } summary.spam <- function(object,...) { nz <- length(object@entries) dens <- nz/prod(object@dimension)*100 cat("Matrix object of class 'spam' of dimension ",object@dimension[1],'x', object@dimension[2],',\n',sep='') cat(' with ',nz,' (row-wise) nonzero elements.\n',sep='') cat(' Density of the matrix is ',signif(dens,3),'%.\n',sep='') cat("Class 'spam'\n") invisible(list(nnz=nz, density=dens)) } setMethod("show","spam", function(object) { if (prod(object@dimension) < .Spam$printsize) { print(as.matrix.spam(object)) } else { if ( identical(length(object@entries),1L) & identical(object@entries[1],0L)) { cat('Zero matrix of dimension ',object@dimension[1],'x', object@dimension[2],'.\n',sep='') }else { cat('Matrix of dimension ',object@dimension[1],'x', object@dimension[2],' with (row-wise) nonzero elements:\n',sep='') print(object@entries) } } cat("Class 'spam'\n") invisible(object) }) setMethod("print","spam", print.spam) setMethod("summary","spam",summary.spam) setMethod("length<-","spam",function(x,value) stop("operation not allowed on 'spam' object") ) setMethod("length","spam",function(x) x@rowpointers[x@dimension[1]+1]-1 ) # equivalent to length(x@entries) setMethod("c","spam", function(x,...,recursive=TRUE){ dimx <- x@dimension cx <- .Fortran("spamcsrdns", nrow=dimx[1], entries=as.double(x@entries), colindices=x@colindices, rowpointers=x@rowpointers, res=vector("double",prod(dimx)), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$res if (length( list(...)) < 1) return( cx) else c( cx,c(...,recursive),recursive) }) ######################################################################## # diag and derivatives "diag.spam" <- function(x=1, nrow, ncol) { if (is.spam(x)) return( diag.of.spam( x, nrow, ncol)) if (is.array(x) && length(dim(x)) != 1) stop("first argument is array, but not matrix.") if (missing(x)) n <- as.integer(nrow) else if (length(x) == 1 && missing(nrow) && missing(ncol)) { n <- as.integer(x) x <- 1 } else n <- length(x) if (!missing(nrow)) n <- as.integer(nrow) if(missing(ncol)) ncol <- n p <- as.integer(ncol) m <- min(n, p) newx <- new("spam") slot(newx,"entries",check=FALSE) <- vector("double", m) newx@entries[1:m] <- as.double(x) slot(newx,"colindices",check=FALSE) <- 1:m slot(newx,"rowpointers",check=FALSE) <- as.integer(c(1:m,rep(m+1,n+1-m))) slot(newx,"dimension",check=FALSE) <- c(n,p) return(newx) } "diag<-.spam" <- function(x,value) { nrow <- x@dimension[1] minrc <- min( x@dimension) if (length(value)==1) value <- rep(value,minrc) else if (length(value)!=minrc) stop("replacement diagonal has wrong length") z <- .Fortran("setdiagmat", nrow = nrow, n = minrc, a = c(x@entries,double(minrc)), ja = c(x@colindices,integer(minrc)), ia = x@rowpointers, diag = as.double(value), iw = vector("integer",nrow), # just to be sure info = vector("integer",nrow+1), NAOK = .Spam$NAOK, PACKAGE = "spam") nz <- z$ia[nrow+1]-1 newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$a[1:nz] slot(newx,"colindices",check=FALSE) <- z$ja[1:nz] slot(newx,"rowpointers",check=FALSE) <- z$ia slot(newx,"dimension",check=FALSE) <- x@dimension return(newx) } "diag.spam<-" <- get("diag<-.spam") "diag.of.spam" <- function(x, nrow, ncol) { len <- min(x@dimension) return(.Fortran("getdiag", a = as.double(x@entries), colindices = x@colindices, rowpointers = x@rowpointers, len = len, diag = vector("double",len), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam" )$diag) } setMethod("diag","spam",diag.of.spam) setMethod("diag<-","spam",get("diag<-.spam")) ######################################################################## "t.spam" <- function(x){ dimx <- x@dimension nz <- x@rowpointers[dimx[1]+1]-1 z <- .Fortran("transpose", n=dimx[1],m=dimx[2], a=as.double(x@entries),ja=x@colindices,ia=x@rowpointers, entries=vector("double",nz),colindices=vector("integer",nz), rowpointers=vector("integer",dimx[2]+1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") t.x <- new("spam") slot(t.x,"entries",check=FALSE) <- z$entries[1:nz] slot(t.x,"colindices",check=FALSE) <- z$colindices[1:nz] slot(t.x,"rowpointers",check=FALSE) <- z$rowpointers slot(t.x,"dimension",check=FALSE) <- dimx[2:1] return( t.x) } setMethod("t","spam",t.spam) ######################################################################## "is.spam" <- function(x) is(x,"spam") "as.spam" <- function(x, eps = .Spam$eps) stop('coercion not defined form this class') "spam" <- function(x, nrow = 1, ncol = 1, eps = .Spam$eps) stop("argument 'x' should be of mode 'numeric' (or 'spam')") "as.spam.spam" <- function(x, eps = .Spam$eps) { if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) dimx <- x@dimension z <- .Fortran("cleanspam", nrow=dimx[1], entries=as.double(x@entries), colindices=x@colindices, rowpointers=x@rowpointers, eps=as.double(eps), NAOK=.Spam$NAOK, PACKAGE = "spam" ) nz <- z$rowpointers[dimx[1]+1]-1 if(nz==0) return(new("spam",rowpointers=c(1L,rep(2L,dimx[1])), dimension=dimx)) newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:nz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:nz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers[1:(dimx[1]+1)] slot(newx,"dimension",check=FALSE) <- dimx return(newx) } "cleanup" <- function(x, eps = .Spam$eps) { if (is.spam(x)) as.spam.spam(x,eps) else x } "as.spam.matrix" <- function(x, eps = .Spam$eps) { if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) dimx <- dim(x) nz <- length(x) z <- .Fortran("spamdnscsr", nrow=dimx[1], ncol=dimx[2], x=as.double(x), dimx[1], entries=vector("double",nz), colindices=vector("integer",nz), rowpointers=vector("integer",dimx[1]+1), eps=as.double(eps), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam" ) nz <- z$rowpointers[dimx[1]+1]-1 if(nz==0) return(new("spam",rowpointers=c(1L,rep(2L,dimx[1])), dimension=dimx)) # no nonzero values. We preserve the dimension of x newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:nz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:nz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- dimx return(newx) } "as.spam.numeric" <- function(x, eps = .Spam$eps) { if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) # if (any(!is.finite(x))) { # warning("'NA/NaN/Inf' coerced to zero") # x[!is.finite(x)] <- 0 # } poselements <- (abs(x)>eps) if (any(!is.finite(x))) { poselements[!is.finite(x)] <- TRUE } lx <- length(x) nz <- sum(poselements) if (identical(nz,0)) # empty matrix return(new("spam",rowpointers=c(1L,rep.int(2L,lx)), dimension=c(lx,1L))) newx <- new("spam") slot(newx,"entries",check=FALSE) <- as.double(x[poselements]) slot(newx,"colindices",check=FALSE) <- rep.int(1L, nz) slot(newx,"rowpointers",check=FALSE) <- as.integer(cumsum(c(1, poselements))) slot(newx,"dimension",check=FALSE) <- c(lx,1L) return(newx) } "as.spam.dist" <- function(x, eps = .Spam$eps) { if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) if (any(!is.finite(x))) { warning("'NA/NaN/Inf' coerced to zero") x[!is.finite(x)] <- 0 } dimx <- attr(x,"Size") size <- dimx*(dimx-1)/2 z <- .Fortran("disttospam", nrow=dimx, x=as.vector(x,'double'), entries=vector('double',size), colindices=vector('integer',size), rowpointers=vector('integer',dimx+1), eps=as.double(eps), NAOK=.Spam$NAOK, PACKAGE = "spam" ) nz <- z$rowpointers[dimx+1]-1 if(nz==0) return(new("spam",rowpointers=c(1L,rep(2L,dimx)), dimension=c(dimx,dimx))) newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:nz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:nz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers[1:(dimx+1)] slot(newx,"dimension",check=FALSE) <- c(dimx,dimx) return(newx) } "as.spam.list" <- function(x, eps = .Spam$eps) spam.list(x,eps) "spam.numeric" <- function(x, nrow = 1, ncol = 1, eps = .Spam$eps) { if (eps<.Machine$double.eps) stop("'eps' should not be smaller than machine precision",call.=FALSE) if (any(!is.finite(x))) { warning("'NA/NaN/Inf' coerced to zero") x[!is.finite(x)] <- 0 } lenx <- length( x) if (missing(nrow)) nrow <- ceiling( lenx/ncol) else if (missing(ncol)) ncol <- ceiling( lenx/nrow) dimx <- as.integer( c(nrow, ncol)) if (lenx != prod(nrow, ncol)) { if(lenx==1 && abs(x)nrow | i@dimension[2]>ncol) stop("subscript out of bounds",call.=FALSE) if ( ( (i@rowpointers[i@dimension[1]+1]-1) %%length(value))!= 0) stop("number of items to replace is not a multiple of replacement length") nzmax <- as.integer(min(prod(nrow,ncol), i@rowpointers[i@dimension[1]+1]+x@rowpointers[nrow+1]-2)) if (length(value)!= (i@rowpointers[i@dimension[1]+1]-1) ) value <- rep(value, (i@rowpointers[i@dimension[1]+1]-1) %/%length(value)) # cat(length(value))#@@# z <- .Fortran("subass", nrow,ncol, as.double(x@entries), x@colindices, x@rowpointers, b=as.double(value), bj=i@colindices, bi=i@rowpointers, c=vector("double",nzmax),jc=vector("integer",nzmax),ic=vector("integer",nrow+1), nzmax=nzmax, PACKAGE="spam") cnz <- z$ic[nrow+1]-1 return(new("spam",entries=z$c[1:cnz],colindices=z$jc[1:cnz], rowpointers=z$ic[1:(nrow+1)],dimension=c(nrow,ncol))) } ) setMethod("[<-", signature(x = "spam", i = "ANY", j = "ANY", value = "ANY"), function(x,i,j, value){# cat(value,class(value)) stop("invalid or not-yet-implemented 'spam' subassigning")}) "assign.spam" <- function (x, rw, cl,value) { # we separate into cases where: # (A) rw matrix: # 1: logical: transformation to spam and extract structure # 2: two column matrix: extract (i,j) as given by the lines. # 3: all else extract x[ c( rw)] # (B) rw and cl one element: ((i,j) # (C) rw and cl vectors: (i1:i2,j1:j2) [i1<=i2, j1<=j2] # (c(i1,...,ii),c(j1,...,jj)) [arbitrary block] # print(rw) # print(cl) # print(value) if (!is.numeric(value)) stop(paste("Assignment of numeric structures only, here",class(value))) dimx <- x@dimension nrow <- dimx[1] ncol <- dimx[2] if (is.matrix(rw)) { if (is.logical(rw)) { return( x[as.spam(rw)] <- value) } if (dim(rw)[2]==2) { ir <- rw[,1] jr <- rw[,2] } else { ir <- c(rw-1) %% nrow + 1 jr <- c(rw-1) %/% nrow + 1 rw <- cbind(ir,jr) } if ( (min(ir)<1)|(max(ir)>x@dimension[1])|(min(jr)<1)|(max(jr)>x@dimension[2])) stop("subscript out of bounds",call.=FALSE) if (any(duplicated(cbind(ir,jr)))) stop("only unique index for subassigning",call.=FALSE) nir <- length(ir) if ( (nir%%length(value))!= 0) stop("number of items to replace is not a multiple of replacement length") value <- rep(value, nir%/%length(value)) ord <- order(ir,jr) rw <- rw[ord,,drop=F] bia <- .Fortran("constructia", nrow,as.integer(nir), rowpointers=vector("integer",nrow+1), ir=as.integer(c(rw[,1],0)), PACKAGE="spam")$rowpointers nzmax <- as.integer(min(prod(nrow,ncol), nir+x@rowpointers[nrow+1])+2) z <- .Fortran("subass", nrow,ncol, as.double(x@entries), x@colindices, x@rowpointers, b=as.vector(value[ord],"double"), bj=as.vector(rw[,2],"integer"), bi=bia, entries=vector("double",nzmax), colindices=vector("integer",nzmax), rowpointers=vector("integer",nrow+1), nzmax=nzmax, NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE="spam") cnz <- z$rowpointers[nrow+1]-1 if (cnz<0) { cat('Negative cnz in subassigning, forced to one. Please report.') return( spam(0)) } newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:cnz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:cnz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- c(nrow,ncol) return(newx) } # negative subsetting: if ( max(rw)<0 ) rw <- seq_len( nrow)[rw] if ( max(cl)<0 ) cl <- seq_len( ncol)[cl] # logical if (is.logical(rw)) rw <- seq_len( nrow)[rw] if (is.logical(cl)) cl <- seq_len( ncol)[cl] # sanity check if (length(rw)==0) stop("You should assign at least one element for the rows",call.=FALSE) if (length(cl)==0) stop("You should assign at least one element for the columns",call.=FALSE) if ( (min(rw)<1)|(max(rw)>x@dimension[1])|(min(cl)<1)|(max(cl)>x@dimension[2])) stop("subscript out of bounds",call.=FALSE) if (is.vector(rw) && is.vector(cl)) { if (any(duplicated(rw))||any(duplicated(cl))) stop("only unique index for subassigning",call.=FALSE) nrw <- length(rw) # length returns an integer, so is a product therof ncl <- length(cl) bnz <- nrw*ncl if ( (bnz%%length(value))!= 0) stop("number of items to replace is not a multiple of replacement length") # we pack the value into a vector _row by row_ value <- c(t(array(as.double(value),c(nrw,ncl))[order(rw),order(cl)])) bia <- vector("integer",nrow) # bia has size of nrow + 1 bia[rw] <- ncl # in each row we have ncl new objects bia <- as.integer(c(1,cumsum(bia)+1)) # we construct now a sparse matrix containing the "value" at positions rw and cl. # then we use the subassign function. nzmax <- as.integer(min(prod(nrow,ncol), bnz+x@rowpointers[nrow+1])+2) # new("spam",entries=value,colindices=rep(sort(as.integer(cl)),nrw),rowpointers=bia,c(nrow,ncol)) z <- .Fortran("subass", nrow,ncol, as.double(x@entries), x@colindices ,x@rowpointers, b=value, bj=rep(sort(as.integer(cl)),nrw), bi=bia, entries=vector("double",nzmax),colindices=vector("integer",nzmax), rowpointers=vector("integer",nrow+1), nzmax=nzmax, NAOK=.Spam$NAOK,PACKAGE="spam") cnz <- z$rowpointers[nrow+1]-1 newx <- new("spam") slot(newx,"entries",check=FALSE) <- z$entries[1:cnz] slot(newx,"colindices",check=FALSE) <- z$colindices[1:cnz] slot(newx,"rowpointers",check=FALSE) <- z$rowpointers slot(newx,"dimension",check=FALSE) <- c(nrow,ncol) return(newx) } stop("invalid or not-yet-implemented 'spam' subsetting") } ".spam.matmul.mat" <- function(x,y) { nrow <- x@dimension[1] ncol <- x@dimension[2] yrow <- dim(y)[1] ycol <- dim(y)[2] if(yrow != ncol)stop("not conformable for multiplication") z <- .Fortran("amuxmat", nrow, yrow, ycol, as.double(y), y=vector("double",nrow*ycol), as.double(x@entries), x@colindices, x@rowpointers, NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$y dim(z) <- c(nrow,ycol) return(z) } ".spam.matmul" <- function(x,y) { if (is.vector(x)) { y <- t(y) nrow <- y@dimension[1] ncol <- y@dimension[2] if(length(x) != ncol) stop("not conformable for multiplication") z <- .Fortran("amux", nrow, as.double(x), y=vector("double",nrow), as.double(y@entries), y@colindices, y@rowpointers, NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$y dim(z) <- c(1,nrow) return(z) } if (is.vector(y)) { nrow <- x@dimension[1] ncol <- x@dimension[2] if(length(y) != ncol)stop("not conformable for multiplication") z <- .Fortran("amux", nrow, as.double(y), y=vector("double",nrow), as.double(x@entries), x@colindices, x@rowpointers, NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam")$y dim(z) <- c(nrow,1) return(z) } if (is.matrix(y)) y <- as.spam(y) if (is.matrix(x)) x <- as.spam(x) #matrix multiply two sparse spam matrices xn <- x@dimension[1] xm <- x@dimension[2] yl <- y@dimension[2] if(xm != y@dimension[1]) stop("matrices not conformable for multiplication") z <- .Fortran("amubdg", xn,xm,yl, x@colindices,x@rowpointers, y@colindices,y@rowpointers, integer(xn), nz = vector("integer",1), integer(yl), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") nzmax <- z$nz z <- .Fortran("amub", xn,yl, 1L, as.double(x@entries), x@colindices, x@rowpointers, as.double(y@entries), y@colindices, y@rowpointers, entries = vector("double",nzmax), colindices = vector("integer",nzmax), rowpointers = vector("integer",xn+1), as.integer(nzmax), integer(yl), ierr = vector("integer",1), NAOK=.Spam$NAOK,DUP=DUPFALSE,PACKAGE = "spam") nz <- z$rowpointers[xn+1]-1 if(z$ierr != 0) stop("insufficient space for sparse matrix multiplication") if(nz==0){#trap zero matrix z$entries <- 0 z$colindices <- 1L z$rowpointers <- as.integer(c(1,rep(2,xn))) } else z <- .Fortran("sortrows", xn,entries=z$entries[1:nz],colindices=z$colindices[1:nz],rowpointers=z$rowpointers, NAOK=.Spam$NAOK,PACKAGE = "spam") newz <- new("spam") slot(newz,"entries",check=FALSE) <- z$entries slot(newz,"colindices",check=FALSE) <- z$colindices[1:nz] slot(newz,"rowpointers",check=FALSE) <- z$rowpointers slot(newz,"dimension",check=FALSE) <- as.integer(c(xn,yl)) return(newz) } setMethod("%*%",signature(x="spam",y="spam"), .spam.matmul) setMethod("%*%",signature(x="spam",y="matrix"), .spam.matmul.mat) setMethod("%*%",signature(x="spam",y="numeric"), .spam.matmul) setMethod("%*%",signature(x="matrix",y="spam"), .spam.matmul) setMethod("%*%",signature(x="numeric",y="spam"), .spam.matmul) ##################################################################################### upper.tri.spam <- function(x,diag=FALSE) { dimx <- x@dimension nrow <- dimx[1] z <- .Fortran("getu", nrow, as.double(x@entries),x@colindices,x@rowpointers, entries=as.double(x@entries),colindices=x@colindices,rowpointers=x@rowpointers, NAOK = .Spam$NAOK,PACKAGE="spam") nz <- z$rowpointers[dimx[1]+1]-1 if (!diag) { z <- .Fortran("getdia", n=nrow, m=nrow, job=1L, entries=z$entries[1:nz], colindices=z$colindices[1:nz], rowpointers=z$rowpointers, len=nrow, diag=vector("double",nrow), idiag=vector("integer",nrow), ioff=0L, NAOK = .Spam$NAOK,PACKAGE = "spam" ) nz <- z$rowpointers[nrow+1]-1 } if(.Spam$trivalues) return(new("spam",entries=z$entries[1:nz],colindices=z$colindices[1:nz],rowpointers=z$rowpointers,dimension=dimx)) else return(new("spam",entries=rep(1,nz),colindices=z$colindices[1:nz],rowpointers=z$rowpointers,dimension=dimx)) } lower.tri.spam <- function(x,diag=FALSE) { dimx <- x@dimension nrow <- dimx[1] z <- .Fortran("getl", nrow, as.double(x@entries),x@colindices,x@rowpointers, entries=as.double(x@entries),colindices=x@colindices,rowpointers=x@rowpointers, NAOK=.Spam$NAOK,PACKAGE="spam") nz <- z$rowpointers[nrow+1]-1 if (!diag) { z <- .Fortran("getdia", n=nrow, m=nrow, job=1L, entries=z$entries[1:nz], colindices=z$colindices[1:nz], rowpointers=z$rowpointers, len=nrow, diag=vector("double",nrow), idiag=vector("integer",nrow), ioff=0L, NAOK=.Spam$NAOK,PACKAGE = "spam" ) nz <- z$rowpointers[nrow+1]-1 } if(.Spam$trivalues) return(new("spam",entries=z$entries[1:nz],colindices=z$colindices[1:nz],rowpointers=z$rowpointers,dimension=dimx)) else return(new("spam",entries=rep(1,nz),colindices=z$colindices[1:nz],rowpointers=z$rowpointers,dimension=dimx)) } setGeneric("upper.tri") setMethod("upper.tri","spam",upper.tri.spam) setGeneric("lower.tri") setMethod("lower.tri","spam",lower.tri.spam) # fields uses the construct of vector representation for a diagonal matrix. # Create a special matrix multiply for diagonal matrices. # Diagonal matrix assumed to be just a vector. # NOTE: this is not a symmetric operation: # when a left vector is given it is a diagonal matrix # when a right vector is given it is a vector. # .spam.diagmulmat <- function(x,y){ nrow <- y@dimension[1] if(length(x) != nrow) stop("not conformable for multiplication") z <- .Fortran("diagmua", nrow, entries=as.double(y@entries), y@rowpointers, as.vector(x,"double"), NAOK=.Spam$NAOK,PACKAGE = "spam")$entries y@entries <- z return(y) } .spam.diagaddmat <- function(x,y){ # subroutine diagaddmat (nrow, a, ja, ia, diag, b, jb, ib, iw) nrow <- y@dimension[1] minrc <- min( y@dimension) if(length(x) != minrc) stop("not conformable for addition") z <- .Fortran("diagaddmat", nrow = nrow, n = minrc, a = c(y@entries,double(minrc)), ja = c(y@colindices,integer(minrc)), ia = y@rowpointers, diag = as.double(x), iw = vector("integer",nrow), # just to be sure info = vector("integer",nrow+1), NAOK=.Spam$NAOK,PACKAGE = "spam") nz <- z$ia[nrow+1]-1 return(new("spam",entries=z$a[1:nz],colindices=z$ja[1:nz], rowpointers=z$ia,dimension=y@dimension)) } setGeneric("%d*%",function(x,y,...)standardGeneric("%d*%")) setMethod("%d*%",signature(x="matrix",y="ANY"), function(x,y){x%*%y} ) setMethod("%d*%",signature(x="numeric",y="matrix"), function(x,y){x*y} ) setMethod("%d*%",signature(x="numeric",y="numeric"), function(x,y){cbind(x*y)} ) setMethod("%d*%",signature(x="spam",y="spam"), .spam.matmul ) setMethod("%d*%",signature(x="spam",y="ANY"), .spam.matmul ) setMethod("%d*%",signature(x="numeric",y="spam"), .spam.diagmulmat ) setGeneric("%d+%",function(x,y,...)standardGeneric("%d+%")) setMethod("%d+%",signature(x="matrix",y="ANY"), function(x,y){ x+y } ) setMethod("%d+%",signature(x="numeric",y="matrix"), function(x,y){ diag(x)+y} ) setMethod("%d+%",signature(x="numeric",y="numeric"), function(x,y){ diag(x)+y} ) setMethod("%d+%",signature(x="spam",y="spam"), function(x,y){ .spam.addsubsparsesparse(e1,e2,1)}) setMethod("%d+%",signature(x="spam",y="ANY"), function(x,y){ .spam.addsparsefull(e1,e2)}) setMethod("%d+%",signature(x="numeric",y="spam"), .spam.diagaddmat ) ##################################################################### # # a bit of matrix handling all.equal.spam <- function (target, current, tolerance = .Machine$double.eps^0.5, scale = NULL, check.attributes = FALSE,...) { if (check.attributes) warning("attributes are not supported for 'spam' objects. Ignoring 'check.attributes' argument") if (!is.spam(target)) stop("'target' should be of class 'spam'") if (!is.spam(current)) { return(paste("target is spam, current is ", data.class(current), sep = "")) } msg <- NULL lt <- length(target) lc <- length(current) if (lt != lc) { return(paste("Lengths (", lt, ", ", lc, ") differ", sep = "")) } dt <- target@dimension dc <- current@dimension if ( !all( dt == dc )) return(paste("Dimensions ([",dt[1],",",dt[2],"], [", dc[1],",",dc[2], "]) differ", sep = "")) tmp <- sum(target@colindices != current@colindices) if ( tmp>0) msg <- c(msg,paste("Column-sparsity structure differ (at least", tmp,"instance(s))")) tmp <- sum(target@rowpointers != current@rowpointers) if ( tmp>0) msg <- c(msg,paste("Row-sparsity structure differ (at least", tmp,"instance(s))")) xy <- mean(abs(target@entries - current@entries)) what <- if (is.null(scale)) { xn <- mean(abs(target@entries)) if (is.finite(xn) && xn > tolerance) { xy <- xy/xn "relative" } else "absolute" } else { xy <- xy/scale "scaled" } if (is.na(xy) || xy > tolerance) msg <- c(msg,paste("Mean", what, "difference:", format(xy))) if (is.null(msg)) TRUE else msg } isSymmetric.spam <- function(object, tol = 100 * .Machine$double.eps, ...) { # very similar to is.Symmetric.matrix test <- all.equal.spam(object, t.spam(object), tolerance = tol, ...) # Possibility that structure is different but not contents if (!isTRUE(test)) { object <- as.spam.spam(object) test <- all.equal.spam(object, t.spam(object), tolerance = tol, ...) } isTRUE(test) } setMethod("all.equal",signature(target="spam",current="spam"), all.equal.spam ) setMethod("all.equal",signature(target="matrix",current="spam"), function (target, current, tolerance = .Machine$double.eps^0.5, scale = NULL, check.attributes = FALSE,eps = .Spam$eps,...) { if (check.attributes) warning("attributes are not supported for 'spam' objects. Ignoring 'check.attributes' argument") msg <- NULL dimx <- dim(target) nz <- length(target) z <- .Fortran("spamdnscsr", nrow = dimx[1], ncol = dimx[2], x = as.double(target), dimx[1], entries = vector("double", nz), colindices = vector("integer", nz), rowpointers = vector("integer", dimx[1] + 1), eps = as.double(eps), NAOK = .Spam$NAOK,DUP=DUPFALSE, PACKAGE = "spam") lt <- z$rowpointers[dimx[1] + 1] - 1 lc <- length(current) if (lt != lc) { return(paste("Lengths (", lt, ", ", lc, ") differ", sep = "")) } dt <- dim(target) dc <- current@dimension if ( !all( dt == dc )) return(paste("Dimensions ([",dt[1],",",dt[2],"], [", dc[1],",",dc[2], "]) differ", sep = "")) tmp <- sum(z$colindices[1:lt] != current@colindices) if ( tmp>0) msg <- c(msg,paste("Column-sparsity structure differ (at least", tmp,"instance(s))")) tmp <- sum(z$rowpointers != current@rowpointers) if ( tmp>0) msg <- c(msg,paste("Row-sparsity structure differ (at least", tmp,"instance(s))")) xy <- mean(abs(z$entries[1:lt] - current@entries)) what <- if (is.null(scale)) { xn <- mean(abs(z$entries)) if (is.finite(xn) && xn > tolerance) { xy <- xy/xn "relative" } else "absolute" } else { xy <- xy/scale "scaled" } if (is.na(xy) || xy > tolerance) msg <- c(msg,paste("Mean", what, "difference:", format(xy))) if (is.null(msg)) TRUE else msg } ) setMethod("isSymmetric","spam", isSymmetric.spam) spam/R/norm.R0000644000176000001440000000321312372657772012562 0ustar ripleyusers# This is file ../spam/R/norm.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] ######################################################################## #norm <- function(x, type = "sup", ...){ # typ <- charmatch(tolower(type), c("sup",'l1',"frobenius","hs")) # if (is.na(typ)) stop("undefined norm '",type,"'.",call.=FALSE) # switch(typ, # max(abs(x)), # sum(abs(x)), # sqrt(sum(x^2)),sqrt(sum(x^2)) # ) #} norm.spam <- function(x, type = "m", ...){ typ <- substr(tolower(type),1,1) if (typ %in% c("o", "1")) { return( max( colSums(abs(x)))) } if (typ %in% c("i")) { return( max( rowSums(abs(x)))) } if (typ %in% c("f", "h")) { return( sqrt(sum(x@entries^2))) } if (typ %in% c("m","s")) { return( max(abs(x@entries)) ) } stop("undefined norm '",type,"'.",call.=FALSE) } setMethod("norm",signature(x="spam",type="character"), function(x, type, ...) norm.spam(x, type)) setMethod("norm",signature(x="spam",type="missing"), function(x, type, ...) norm.spam(x, type="O")) setMethod("norm", signature(x = "numeric", type = "character"), function(x, type, ...) base::norm(as.matrix(x), type)) setMethod("norm", signature(x = "numeric", type = "missing"), function(x, type, ...) base::norm(as.matrix(x), type="O")) setMethod("norm", signature(x = "matrix", type = "character"), function(x, type, ...) base::norm(x, type)) setMethod("norm", signature(x = "matrix", type = "missing"), function(x, type, ...) base::norm(x, type='o')) spam/R/constructors.R0000644000176000001440000000467712375442136014363 0ustar ripleyusers# This is file ../spam/R/foreign.R # This file is part of the spam package, # http://www.math.uzh.ch/furrer/software/spam/ # by Reinhard Furrer [aut, cre], Florian Gerber [ctb] "rowpointers<-" <- function(x, value) { dimx <- x@dimension nnz1 <- x@rowpointers[dimx[1]+1] diffvalue <- diff(value) if ( any(!is.finite(value))) stop("row pointers should be postive integers.") if (!identical( length(x@rowpointers), length(value))) stop("wrong length of row pointers in `rowpointers<-`.", call.=FALSE) if (any(diffvalue<0)) stop("row pointers are not monotone increasing in `rowpointers<-`.", call.=FALSE) if (any(diffvalue>dimx[2])) stop("row pointers have too large leaps in `rowpointers<-`.", call.=FALSE) if (value[1]<1) stop("first element of row pointers is < 1 in `rowpointers<-`.", call.=FALSE) if(value[dimx[1]+1] != nnz1) stop("last element of row pointers does not conform in `rowpointers<-`.", call.=FALSE) x@rowpointers <- as.integer(value) x } "colindices<-" <- function(x, value) { dimx <- x@dimension if ( any(!is.finite(value))) stop("column indices should be postive integers in `colindices<-`.", call.=FALSE) if ( any(value<1) | any(value> dimx[2])) stop("column indices exceed dimension `colindices<-`.", call.=FALSE) diffcolindices <- diff(value) # positive values within each row if (all(diff(x@rowpointers)>1) && length(diffcolindices)>0) # only if we have multiple values if (identical( dimx[1], 1L)) { if ( any(diffcolindices<1)) stop("column indices are not ordered `colindices<-`.", call.=FALSE) } else { if ( any(diffcolindices[-(x@rowpointers[2:dimx[1]]-1)]<1)) stop("column indices are not ordered `colindices<-`.", call.=FALSE) } x@colindices <- as.integer(value) x } "entries<-" <- function(x, value) { if (!identical( length(x@entries), length(value))) stop("wrong length in `entries<-`.", call.=FALSE) if (!.Spam$NAOK) { if (any(!is.finite(value))) stop("'NA/NaN/Inf' not allowed in `entries<-`.", call.=FALSE) } if (!is.numeric( value)) stop("numerical required in `entries<-`.", call.=FALSE) x@entries <- as.double(value) x } "dimension<-" <- function(x, value) { stop("modification through `dim' or `pad`", call.=FALSE) } spam/MD50000644000176000001440000002233712403575207011566 0ustar ripleyusers732c090f1093e49656850579b4a93b69 *ChangeLog 14fae9256524c2158eece6f033b320f2 *DESCRIPTION 7f1cb8e283914490c2fd765a556b24d4 *NAMESPACE 4d216ae47c8f31b78c0d32015fba0b35 *R/apply.R 66c1a28134edc23a94cf00cecea1e799 *R/constructors.R d2f2f05464bb44b6cc96e85ca498cb5c *R/covmat.R 41bb619971fb0da08468f16dbab385fb *R/definitions.R 78dcf7b77851f1a1f3b83e9d832130b2 *R/diff.R f2c915fade4722f11eb55bb0daa1df66 *R/dim.R 3a6bf12651fbe07d16fc4238b3717832 *R/dist.R 4789ac525aed0df577a067c3543aaa23 *R/foreign.R 8fdd13615295209d2fc32e12c30c8e8b *R/helper.R 9157c19d43f1291fb7a926fed7d4414a *R/image_spam.R 905e1e4c64f1b78294ddd7c8042e3d00 *R/kronecker.R ea6c379d782049832ea2defd06cae6f9 *R/makeprec.R 24d3f41302086cb8b9aef2a3fb4feb17 *R/math.R b1283ade83489726b70fb3c8836ce9c6 *R/mle.R 2eb83ba6f803ce88943c07741921464e *R/norm.R 172e85e0ae6d54db0d7deb531225d076 *R/permutation.R 5513c54ef33ec301c4ffcf67ca583744 *R/plotting.R c0c777f62f90672b6cb36d25c086d6c0 *R/precmat.R 0876e38619bdfe4a36373ebd7df82b66 *R/profile.R 2806684b4d021d9a2f2f72d84574f5f9 *R/rmvnorm.R 7a92b64b0873709a6aec0f6cb09fe691 *R/rowcolstats.R a5da7c16284ceb6b64d3568339f16534 *R/s3only.R 73c854d3f886154ce50252d4951e562f *R/s4coerce.R 256504ebd0392b7efd3c96cc97d21b5c *R/spam_solve.R ae2393b05261dfe61d020d3db908dcc0 *R/spamlist.R c989b719eb63d3de1171c78fa8c81faf *R/subset.R 8c0bd810c708863389f6213bf5a13f4b *R/tailhead.R 47847ec1b4977f921da195fe06f5f160 *R/tcrossprod.R d6aa38b910a3b86d5cf8e6b1bf9faa91 *R/toepliz.R 59e38f3d99c34d90fc7e23c86c505b6e *R/xybind.R 239f312af7e1e1f7cbbb00fc3191994b *README c50879b823669ba5e0427e9ced418d04 *data/Oral.rda 10fc8c5f9967a56a1527166c4695de3e *data/UScounties.ndorder.rda fc4338a95e61a96e87a52a2b81586e03 *data/UScounties.storder.rda 489f6da5e1ae79ec9036948db29af479 *data/USprecip.rda 9065b4d1e091328000e7270771a227be *data/germany.rda 7f167a8cb2260d098dced53bf9d33362 *demo/00Index ca08f6157c298cfaf663459da1206f14 *demo/article-jss-example1.R 92387df84476d7846cd3e2262e459987 *demo/article-jss-example2.R d4fe111ed3266b057eb95472f558709b *demo/article-jss.R 6e96786f8ec763abbb412a53b3e6108e *demo/cholesky.R a7bee1644416a21e4f78a254683b949a *demo/spam.R b21ed11314af2f8b71d2009a1802b876 *demo/timing.R 5f7f87e4c51dff4df09d6ae1972735eb *inst/0ChangeLog a8073fc0e9c667b814bcf0e5ea35cf96 *inst/0LICENSE 512c41e65e4afe45afa7c4e54e753367 *inst/0NEWS ad9df746e8d6572b91988611ab4fad17 *inst/CITATION 4e28764fe501fe0b586e8cd0f644f8a5 *inst/NEWS 0f7ff8c0275da9085576b25fa7437bfd *inst/demodata/germany.adjacency e1581d4d8b6059ea47f824bd8110a659 *man/Oral.Rd 3f8b93ed4aabb166f0b48659063bb917 *man/UScounties.Rd 61128f2df7026bbdc0a54d04a6be4a68 *man/USprecip.Rd 51115daad03805513583e331e4c11869 *man/adjacency.Rd 15182be19c04232077d9b07754ab4817 *man/allequal.Rd c3eb6e4c56ff5901dde13fdd89fd72bc *man/apply.Rd e9c53aa40e0b1ba29d97d89c85eaa9aa *man/bandwidth.Rd a18aa35a3a765ae94874bf3f3af3db6c *man/bdiag.Rd 5baf08ffde5ec68173c03de3dfc54e6d *man/chol.Rd 0d765873857778a91c2b03c0933038b6 *man/circulant.Rd 546919791914969f40b1ab3930d18279 *man/cleanup.Rd 38ce08f57bdc5d427e7a06c890f34878 *man/coerce.Rd 3c294fa2df752e5dfcc1ca2220eea571 *man/coercion.Rd 5d02c6193ccbb281f180f1fccdf2d403 *man/complexity.Rd f67ee8b541d8fcece89b42576e08f9f7 *man/constructors.Rd 01da7fa8c716a34b3546d53985581f11 *man/cov.Rd b1966ede8318c8c4e93b295732c7e1f7 *man/crossprod.Rd ab2be44f082c00426eb7565fc7a6fd3b *man/det.Rd a01ed4d4381dfaa2e033982496b0a0e3 *man/diag.Rd d0e5cbabdc709630ed256fe39fc2ef1e *man/diff.Rd 22349d524fea1e54c12b8ca91132a4cf *man/dim.Rd 3d60d3551356088601e091f624f77b82 *man/display.Rd 6a5f93f942330bdd4988ac44fba007e0 *man/foreign.Rd 0242a8d4517b1d0adb963057aa879fb7 *man/germany.Rd f2c04ce61291b2579b0022fdfb8c4c5c *man/germanydata.Rd 76881d7d0b5f80b114296e2ff9afb63c *man/grid_trace2.Rd becdcb5f52ceba7673b7aa25d0437c74 *man/grid_zoom.Rd 5014112a1a839b21eabe116bceb7cc55 *man/headtail.Rd 19f869795633b2c9705eeff456099920 *man/history.spam.Rd 5cafb3a16f61bc0974d9769c2d0379f0 *man/image.Rd 281de72550e7d749253a83b6b43bf4be *man/import.Rd a2d2793b40d44d5a505fc01cdd463924 *man/isSymmetric.Rd b84c5b17dcd08c32a84fa70b37ea97de *man/kronecker.Rd 85d8fbe64a2b6e67992ae223e4c6fbbc *man/landkreis.Rd 37ba22ed7e4a01a1ce1c4a9849613b03 *man/lu.tri.Rd 57665ac3a08d534d369e6f2499764789 *man/makeprec.Rd f4680b9a35ff673c7d8566b4703134a5 *man/math.Rd 5f787267add233af16ed622259e14f90 *man/math2.Rd b5aaa1d7212122da367fe43a3d3e4a1e *man/methods.Rd b0c0c37c70270170cad6628b7927144f *man/mle.Rd 4dfcb7b3f0119dc46f8518920efd72d6 *man/nearestdist.Rd 2dd21682385b9fd73b005167c4bd80a8 *man/operations.Rd 9d2fbe5664c386879a4bab95b5e64c3a *man/options.Rd 7f35ae41893dccca348e0aeb96cd86f3 *man/ordering.Rd 4354a8477eba43c2839a67ccd2e10077 *man/pad.Rd d12f343babbd167c35413a6764612a95 *man/permutation.Rd c382cf63b908eef22e76e7240a4981e9 *man/powerboost.Rd be2094a0bb9d4dac645736613e0feb55 *man/precmat.Rd 6d9bc701800139c92ce6febb0b7f4e96 *man/print.Rd 3b22ffe46a8f7d72088fdd9c2c60faad *man/rdist.Rd c1758e53d3a2860fe48b32c9b3ffe942 *man/rmvnorm.Rd 05f85233ca788121f9d8ac9f51cb23de *man/rmvnorm.const.Rd 0c5a23d457250234cd368c82fbbe2beb *man/rowcolstats.Rd 0424949c0f54cba0ab620ed91a4e9e56 *man/s3only.Rd 3c5cc86a19320b34e853172303168e00 *man/solve.Rd 74cc0c06573033a4f1d49eee38016e27 *man/spam-class.Rd ebe41288526adae2dd7e806859a31b27 *man/spam-package.Rd 71944ba5fdd774836cdd088bba374cab *man/spam.chol.NgPeyton-class.Rd 6decbdbadf362ee42d680d6ec9224d62 *man/spam.creation.Rd 1158c857bfe8867443142599e94b9d79 *man/spam.internal.Rd e807a810c785f20fdf383099ee29ecf1 *man/summary.Rd fa5d9bc885433d045f1462335843833b *man/todo.Rd 8647edc00fccb58b38fe9e6af2589ea3 *man/toeplitz.Rd e928b1473fb0d8f14a6c1ff2cd23d6e3 *man/triplet.Rd 680d8cd11e5e46d4bcf210dd30c62d66 *man/version.Rd 21dff8fdac428731959bda0e38eed384 *man/xybind.Rd 434ab528cf3a1f59268f5acb01e23ed2 *src/bckslvmodified.f a3c82eacaf71ad4a020aa99d6c1adaaf *src/cholmodified.f 93fdbd909719a19e717347dcdc6a9739 *src/dist.f f8ab4af093398e7ccb2deead0e48f01e *src/fromsparsekit.f 84ad6d36837eaab39954369215fe718c *src/kronecker.f 3e5016181c25e3315ec27fa9e5af846b *src/permutation.f 404b1cd7ded5b7a5774cbeb98436fa84 *src/rowcolstats.f 445b1d32315a3857dd6db569df614089 *src/spamown.f 5e7a92fa20c81cd1e6060217b55ceafb *src/spamown2.f f94aedee615ad962e1cb690e83e891d0 *src/xybind.f c7ebecd8e54f38b6465bbe242a2aee95 *tests/constructors.R 9b1094dc06cc5eac9ba34fd7f5732468 *tests/constructors.Rout.save 71ca12306be6be717b041585481d36ae *tests/covmat.R afcb190a2915d5690c6b8615bde0e065 *tests/covmat.Rout.save 6664bb3e25a14dd13ca45c11021753d9 *tests/crossprod.R 5048a13ed53b3b3a16178bc95bd48333 *tests/crossprod.Rout.save 4c3038e38b5bd5b2633ddd4a75fbff3a *tests/demo_article-jss-example1.R c6e6a2d0a9ea146917a6d8c8bc228e47 *tests/demo_article-jss-example1.Rout.save ed4bcdee9264bdc7982c2316b2f65235 *tests/demo_article-jss-example2.R ef1873ffbc1db105193ea63e5e9764ab *tests/demo_article-jss-example2.Rout.save baf5b96695e6df94fec955626c10c478 *tests/demo_article-jss.R bac2d78b65334709d2db630feb98a1bf *tests/demo_article-jss.Rout.save e930ee41420939cf416ad0ff4f564f1e *tests/demo_cholesky.R 0153708d7a0d3e92deadde3e35b5d0b5 *tests/demo_cholesky.Rout.save fdb0da15d3872aab0631e853edbe592d *tests/demo_spam.R 6d9f41ee35029aa8381f1bc67d338c45 *tests/demo_spam.Rout.save 1d5e4408c20dd30ab21e6e32a41d2f87 *tests/demo_timing.R cdbb7a61933c0feefc3e687bf348149f *tests/demo_timing.Rout.save 86fddf478f237917d686e2a7fe55f3b5 *tests/diff.R e8bcf6a1a4e3eb8a881954657e41492a *tests/diff.Rout.save 8a35747cb98d90134f9b1a0833bc7b9b *tests/dim.R b240205f09bf65d4d823d9967e4c227f *tests/dim.Rout.save 404fd45ef91094ec2b848370b1e25341 *tests/displays.R 83dbe3920aae8656d731eceb2342f79d *tests/displays.Rout.save c2b4be2d73daf7cdb83b61fe09754a52 *tests/dist.R c799ead429026ab43ec871b5855b4764 *tests/dist.Rout.save 91fd5b6f1b85cbb5434c4fc10e7702d6 *tests/foreign.R 320f1e4f5d3b9b69bc90501584f320cc *tests/foreign.Rout.save 88a1aad5821e9413dfe45509a48828f4 *tests/helper.R a2c10cc5e5c9911f45762ce415cda240 *tests/helper.Rout.save da7d644f34babea7e5d691ad0d902272 *tests/jss_areal_counts.R ef85f9125c43121686871f54d70c38ed *tests/jss_areal_counts.Rout.save 91444de4c0cb37ea6d58a263db3b5378 *tests/kronecker.R 979e9e05a9a148b5d824e6eb9dec5f07 *tests/kronecker.Rout.save 1797667c1ad2704ef3f523d402a6a838 *tests/math.R aa02a768d283568f5467e3212726ae4f *tests/math.Rout.save 6f4dca2d3650da1dde96a29977e5356b *tests/mle.R bddd48c6191fbd8d3dbb67cc8d65a3ba *tests/mle.Rout.save eb0353c09fba7c7f6ebaa00a00d9a863 *tests/norm.R 274f87cb5a4019c78f6067052739ac92 *tests/norm.Rout.save 6c827608f95643a85992c55f26d6405a *tests/ops.R 55122408a38e864a0012387b053d23d4 *tests/ops.Rout.save 6c981b2225581f271030b4c8ca47d083 *tests/overall.R e0068c2aa05ba4de4fb582e4afbade6e *tests/overall.Rout.save 9a29fd944a5f3dc8ed6860651cec4f9f *tests/permutation.R 2e9cf559de409af9b3caf3fb726a3f76 *tests/permutation.Rout.save f1da426ffac952d71fdeb8f8ca713b14 *tests/rowcolstats.R 167ee24d38a930bec39481ad479c4463 *tests/rowcolstats.Rout.save 5540e9cc3882bbdb34990dcea1703fe3 *tests/solve.R c4594c20d7aa73f286cdc6371c9a2e7d *tests/solve.Rout.save 6f5f9cab9eab74f6fd61a685499fbe07 *tests/spamlist.R 7d6c76ab5a2745fbdaf7ac7c27b0bd46 *tests/spamlist.Rout.save 80123d1d37b79aa2b32cf0784be710f5 *tests/subsetting.R a073629adf9cc4ed5fe73abaff12c58c *tests/subsetting.Rout.save 1f7f7fd939179e8c5f4569cb0216cc3a *tests/xybind.R 8b72f30293cf697654613c869e3167fe *tests/xybind.Rout.save spam/README0000644000176000001440000000161112402015710012111 0ustar ripleyusersVersions of `spam` prior to 1.00 included a LICENSE file that described the license of some Fortran routines incompatible with the general R philosophy. The routines are in src/cholmodified.f. For the packages `SparseM` and `spam`, Esmond Ng and Barry Peyton have very kindly given permission to use their routines under an open source license (2012/03/09 and 2014/08/29). They have requested that their code be credited via the following two publications: Esmond G. Ng and Barry W. Peyton, "Block sparse Cholesky algorithms on advanced uniprocessor computers". SIAM J. Sci. Stat. Comput. 14 (1993), pp. 1034-1056. John R. Gilbert, Esmond G. Ng, and Barry W. Peyton, "An efficient algorithm to compute row and column counts for sparse Cholesky factorization". SIAM J. Matrix Anal. Appl. 15 (1994), pp. 1075-1091. The old license file of `spam` versions <1.0 is in ./inst/0LICENCE spam/DESCRIPTION0000644000176000001440000000176712403575207012770 0ustar ripleyusersPackage: spam Version: 1.0-1 Date: 2014-09-09 Authors@R: c(person("Reinhard", "Furrer", role = c("aut", "cre"), email = "reinhard.furrer@math.uzh.ch"), person("Florian", "Gerber", role = "ctb", email = "florian.gerber@math.uzh.ch")) Author: Reinhard Furrer [aut, cre], Florian Gerber [ctb] Maintainer: Reinhard Furrer Depends: R (>= 2.15), methods, grid Suggests: fields, Matrix Description: Set of functions for sparse matrix algebra. Differences with SparseM/Matrix are: (1) we only support (essentially) one sparse matrix format, (2) based on transparent and simple structure(s), (3) tailored for MCMC calculations within GMRF. (4) S3 and S4 like-"compatible" ... and it is fast. LazyLoad: Yes LazyData: Yes License: LGPL-2 Title: SPArse Matrix URL: http://www.math.uzh.ch/furrer/software/spam/ Packaged: 2014-09-09 10:53:35 UTC; furrer NeedsCompilation: yes Repository: CRAN Date/Publication: 2014-09-09 15:03:03 spam/ChangeLog0000644000176000001440000001001712403556057013022 0ustar ripleyuserscommit 3823eb2a93ac5466ec368de81a294c63fd9c8ddd Author: Reinhard Furrer Date: Tue Sep 9 12:53:07 2014 +0200 Addressing approach commit fcc8e87858c7b77b3ef038b30b229bbeb2bafeca Author: Reinhard Furrer Date: Sat Sep 6 22:15:47 2014 +0200 Getting towards CRAN release commit 4f7ddb20efaf89efea79eaf03dfb411f293c36c4 Merge: 55a7ace 764935f Author: Reinhard Furrer Date: Sat Sep 6 21:32:58 2014 +0200 Merge remote-tracking branch 'origin/tests_jss_areal_mapping' commit 55a7acee168a7bb260e90a32a60107c21e306f67 Author: Reinhard Furrer Date: Sat Sep 6 14:35:30 2014 +0200 Help adjusts commit 764935f9f09336c07b316b3ccce923c94ca4d214 Author: Florian Gerber Date: Thu Sep 4 10:55:54 2014 +0200 test script for BYM sampler of JSS-disease paper - inclusion of Leroux sampler not possible. depends on package:trucdist new file: tests/jss_areal_counts.R commit 9bf9597b6440aa40575d37544fad1a79e3546e0e Author: Reinhard Furrer Date: Wed Sep 3 23:43:33 2014 +0200 corrected update commit 8ad11ea5c7eaddc8595716bdb5906eebd0cdec58 Author: Reinhard Furrer Date: Thu Aug 28 12:32:09 2014 +0200 Coercion and Wrappers... set to 0.80 commit 7fc3c8aa594195a11f0002a9bf73f5ebf0ec8452 Author: Reinhard Furrer Date: Tue Aug 26 16:57:09 2014 +0200 coerce functions, ifelse works! commit a7177a6dce0d3c4e4642c303ec8c21040462d7ee Author: Reinhard Furrer Date: Thu Aug 21 21:21:10 2014 +0200 first version of 0.60-0 commit 0cd661154bc24ce7c05a25b87d1781bfd99ac5bc Author: Reinhard Furrer Date: Wed Aug 13 16:06:28 2014 +0200 final fixes for freeze of version 0.50-0 commit d85f2d2f4f181ae066c248774081edb0de4f7d96 Author: Reinhard Furrer Date: Wed Aug 13 13:33:25 2014 +0200 Test to pass non finite numbers through some fortran routines commit 55391e836d2f467b013b781fdddc2b97c281a837 Author: Reinhard Furrer Date: Wed Aug 13 10:11:48 2014 +0200 First stab at coherent 'Math' group handling commit 408115340155aac74e07501243eb27b34bdfc6eb Author: Reinhard Furrer Date: Tue Aug 12 21:32:26 2014 +0200 first stab at coherent 'dim' and structure based operators commit 005135896e0f4f516fdbaa0d22f3e8580b24c808 Author: Reinhard Furrer Date: Tue Aug 12 10:47:37 2014 +0200 Bugfix assignment commit 36024017dfc777baf510c6780fe5aecbf230c4e6 Author: Reinhard Furrer Date: Tue Aug 12 10:35:47 2014 +0200 constructor: rowpointers part II commit 308101b2ee6311f33e783f6c6f09c2b4f444984d Author: Reinhard Furrer Date: Tue Aug 12 10:34:55 2014 +0200 constructor: rowpointers commit 869bf80ef88bc93e343f99bc062a6bc5aa59b258 Author: Reinhard Furrer Date: Tue Aug 12 07:15:16 2014 +0200 crossprod help file and additional todo commit cdab58b0a625eacff0c4d9e3855b41349016324c Author: Reinhard Furrer Date: Tue Aug 12 07:09:44 2014 +0200 News and Rd adjustment commit 775bf4c3ba574f8a0d89669eb0eaebfd8c06069f Author: Reinhard Furrer Date: Mon Aug 11 21:24:23 2014 +0200 added crossprod and eliminated [d,i]check commit 78b101b99739be585f2c4c27e37733df32b7b088 Author: Reinhard Furrer Date: Wed Jun 11 20:35:48 2014 +0200 Fixed version number commit f21c8dfed9903a761c8306ba1cbe7db56a137136 Author: Reinhard Furrer Date: Wed Jun 11 20:33:13 2014 +0200 Eliminating nested structure commit 95fcaf89166c0029f3933bdcce27fa25eeb80b4e Author: Reinhard Furrer Date: Wed Jun 11 20:27:33 2014 +0200 first commit spam/man/0000755000176000001440000000000012402107170012007 5ustar ripleyusersspam/man/diag.Rd0000644000176000001440000000424412346261543013222 0ustar ripleyusers% This is file ../spam/man/diag.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{diag} \alias{diag} \alias{diag.of.spam} \alias{diag.spam} \alias{diag,spam-method} \alias{diag,ANY-method} \alias{diag<-} \alias{diag<-,ANY-method} \alias{diag<-,spam-method} \alias{diag<-.spam} \alias{diag.spam<-} \alias{diag.assign,spam-method} \title{Sparse Matrix diagonals} \description{Extract or replace the diagonal of a matrix, or construct a diagonal matrix. } \usage{ # diag(x) diag(x=1, nrow, ncol) diag(x) <- value diag.spam(x=1, nrow, ncol) diag.spam(x) <- value } \arguments{ \item{x}{a \code{spam} matrix, a vector or a scalar.} \item{nrow, ncol}{Optional dimensions for the result.} \item{value}{either a single value or a vector of length equal to that of the current diagonal.} } \value{ If \code{x} is a spam matrix then \code{diag(x)} returns the diagonal of \code{x}. The assignment form sets the diagonal of the sparse matrix \code{x} to the given value(s).\cr \code{diag.spam} works as \code{diag} for spam matrices: If \code{x} is a vector (or 1D array) of length two or more, then \code{diag.spam(x)} returns a diagonal matrix whose diagonal is \code{x}. If \code{x} is a vector of length one then \code{diag.spam(x)} returns an identity matrix of order the nearest integer to \code{x}. The dimension of the returned matrix can be specified by \code{nrow} and \code{ncol} (the default is square). The assignment form sets the diagonal of the matrix \code{x} to the given value(s). } \details{Using \code{diag(x)} can have unexpected effects if \code{x} is a vector that could be of length one. Use \code{diag(x, nrow = length(x))} for consistent behaviour. } %\references{} \seealso{\code{\link{upper.tri}}, \code{\link{lower.tri}}. } \examples{ diag.spam(2, 4) # 2*I4 smat <- diag.spam(1:5) diag( smat) diag( smat) <- 5:1 # The last line is equivalent to diag.spam( smat) <- 5:1 # Note that diag.spam( 1:5) <- 5:1 not work of course. } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/adjacency.Rd0000644000176000001440000000230712346261543014235 0ustar ripleyusers% This is file ../spam/man/adjacency.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{adjacency} \alias{adjacency} \alias{adjacency.spam} \alias{adjacency.landkreis} \alias{germany.graph} \title{Administrative districts of Germany} \description{Constructing the adjacency graph of the administrative districts of Germany} \usage{ adjacency.landkreis( loc) } \arguments{ \item{loc}{location of the graph structure, can be an URL.} } \details{The function is included as an example on how to construct adjacency matrices form a (common) adjacency structure. For the particular example, note that the nodes are not numbered consecutively and that they start from zero.} \value{a sparse matrix in \code{spam} format.} \references{The adjacency data has been provided by Havard Rue and is also available in \pkg{INLA}.} \seealso{\code{\link{germany.plot}} super-seeding \code{map.landkreis} for plotting.\cr \code{\link{Oral}}.} \examples{ \dontrun{ loc <- system.file("demodata/germany.adjacency", package="spam") display( adjacency.landkreis( loc)) } } \author{Reinhard Furrer} \keyword{hplot} spam/man/diff.Rd0000644000176000001440000000210112401700351013177 0ustar ripleyusers% This is file ../spam/man/diff.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{diff} \alias{diff.spam} \alias{diff,spam-method} \title{Lagged Differences} \description{Returns suitably lagged and iterated differences.} \usage{ # diff.spam(x, lag = 1, differences = 1, ...) \S4method{diff}{spam}(x, lag = 1, differences = 1, ...) } \arguments{ \item{x}{a \code{spam} matrix containing the values to be differenced.} \item{lag}{an integer indicating which lag to use.} \item{differences}{an integer indicating the order of the difference.} \item{...}{further arguments to be passed to or from methods.} } \value{A \code{spam} matrix with elements similar to \code{as.spam(diff(as.matrix(x), ...))}. } %\details{ } %\references{} \seealso{\code{diff} in \code{base}, \code{\link{precmat}}.} \examples{ # incidence matrix for a RW(3) model D <- diff.spam(diag.spam(10), lag=1, differences=3) t(D)%*%D } \author{Reinhard Furrer} \keyword{array} \keyword{manip} spam/man/rmvnorm.Rd0000644000176000001440000000476512346261543014026 0ustar ripleyusers% This is file ../spam/man/rmvnorm.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{rmvnorm} \alias{rmvnorm.spam} \alias{rmvnorm.prec} \alias{rmvnorm.canonical} \title{Draw Multivariate Normals} \description{ Fast ways to draw multivariate normals when the variance or precision matrix is sparse.} \usage{ rmvnorm.spam(n,mu=rep(0, nrow(Sigma)), Sigma, Rstruct=NULL, ...) rmvnorm.prec(n,mu=rep(0, nrow(Q)), Q, Rstruct=NULL, ...) rmvnorm.canonical(n, b, Q, Rstruct=NULL, ...) } \arguments{ \item{n}{number of observations.} \item{mu}{mean vector.} \item{Sigma}{covariance matrix of class \code{spam}.} \item{Q}{precision matrix.} \item{b}{vector determining the mean.} \item{Rstruct}{the Cholesky structure of \code{Sigma} or \code{Q}.} \item{\dots}{arguments passed to \code{chol}.} } \details{The functions \code{rmvnorm.prec} and \code{rmvnorm.canonical} do not require sparse precision matrices. For \code{rmvnorm.spam}, the differences between regular and sparse covariance matrices are too significant to be implemented here. \cr Often (e.g., in a Gibbs sampler setting), the sparsity structure of the covariance/precision does not change. In such setting, the Cholesky factor can be passed via \code{Rstruct} in which only updates are performed (i.e., \code{update.spam.chol.NgPeyton} instead of a full \code{chol}). } %\note{There is intentionally no \acronym{S3} distinction between the classes % \code{spam} and \code{spam.chol.}\emph{method}.} \references{See references in \code{\link{chol}}. } \seealso{\code{\link{chol}} and \code{\link{ordering}}. } \examples{ # Generate multivariate from a covariance inverse: # (usefull for GRMF) set.seed(13) n <- 25 # dimension N <- 1000 # sample size Sigmainv <- .25^abs(outer(1:n,1:n,"-")) Sigmainv <- as.spam( Sigmainv, eps=1e-4) Sigma <- solve( Sigmainv) # for verification iidsample <- array(rnorm(N*n),c(n,N)) mvsample <- backsolve( chol(Sigmainv), iidsample) norm( var(t(mvsample)) - Sigma, type="m") # compare with: mvsample <- backsolve( chol(as.matrix( Sigmainv)), iidsample, n) #### ,n as patch norm( var(t(mvsample)) - Sigma, type="m") # 'solve' step by step: b <- rnorm( n) R <- chol(Sigmainv) norm( backsolve( R, forwardsolve( R, b))- solve( Sigmainv, b) ) norm( backsolve( R, forwardsolve( R, diag(n)))- Sigma ) } % backsolve( chol(as.matrix(V)[ord,ord]),iidsample)[iord,] % \author{Reinhard Furrer} \keyword{algebra} spam/man/chol.Rd0000644000176000001440000001352212402016145013227 0ustar ripleyusers% This is file ../spam/man/chol.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{chol} \alias{chol.spam} \alias{chol,ANY-method} \alias{chol,matrix-method} \alias{chol,spam-method} \alias{update.spam} \alias{update,spam.chol.NgPeyton-method} \alias{update.spam.chol.NgPeyton} \title{Cholesky Factorization for Sparse Matrices} \description{ \code{chol} performs a Cholesky decomposition of a symmetric positive definite sparse matrix \code{x} of class \code{spam}.} \usage{ # chol(x, \dots) \S4method{chol}{spam}(x, pivot = "MMD", method = "NgPeyton", memory = list(), eps = .Spam$eps, \dots) # update.spam.chol.NgPeyton(object, x,...) \S4method{update}{spam.chol.NgPeyton}(object, x,...) %chol(x, method, ordering, memory, \dots) } \arguments{ \item{x}{symmetric positive definite matrix of class \code{spam}.} \item{pivot}{should the matrix be permuted, and if, with what algorithm, see \sQuote{Details} below.} \item{method}{Currently, only \code{NgPeyton} is implemented.} \item{memory}{Parameters specific to the method, see \sQuote{Details} below.} \item{eps}{threshold to test symmetry. Defaults to \code{.Spam$eps}.} \item{\dots}{further arguments passed to or from other methods.} \item{object}{an object from a previous call to \code{chol}.} } \value{The function returns the Cholesky factor in an object of class \code{spam.chol.}\emph{method}. Recall that the latter is the Cholesky factor of a reordered matrix \code{x}, see also \code{\link{ordering}}. } \details{\code{chol} performs a Cholesky decomposition of a symmetric positive definite sparse matrix \code{x} of class \code{spam}. Currently, there is only the block sparse Cholesky algorithm of Ng and Peyton (1993) implemented (\code{method="NgPeyton"}). To pivot/permute the matrix, you can choose between the multiple minimum degree (\code{pivot="MMD"}) or reverse Cuthill-Mckee (\code{pivot="RCM"}) from George and Lui (1981). It is also possible to furnish a specific permutation in which case \code{pivot} is a vector. For compatibility reasons, \code{pivot} can also take a logical in which for \code{FALSE} no permutation is done and for \code{TRUE} is equivalent to \code{MMD}.\cr Often the sparsity structure is fixed and does not change, but the entries do. In those cases, we can update the Cholesky factor with \code{update.spam.chol.NgPeyton} by suppling a Cholesky factor and the updated matrix. Notice that the structure is effectively \code{object <- update(object, x)}. The update feature without assignement has been disabled. The option \code{cholupdatesingular} determines how singular matrices are handled by \code{update}. The function hands back an error (\code{"error"}), a warning (\code{"warning"}) or the value \code{NULL} (\code{"null"}).\cr The Cholesky decompositions requires parameters, linked to memory allocation. If the default values are too small the Fortran routine returns an error to \R, which allocates more space and calls the Fortran routine again. The user can also pass better estimates of the allocation sizes to \code{chol} with the argument \code{memory=list(nnzR=..., nnzcolindices=...)}. The minimal sizes for a fixed sparsity structure can be obtained from a \code{summary} call, see \sQuote{Examples}.\cr The output of \code{chol} can be used with \code{forwardsolve} and \code{backsolve} to solve a system of linear equations.\cr Notice that the Cholesky factorization of the package \code{SparseM} is also based on the algorithm of Ng and Peyton (1993). Whereas the Cholesky routine of the package \code{Matrix} are based on \code{CHOLMOD} by Timothy A. Davis (\code{C} code). } \references{ Ng, E. G. and Peyton, B. W. (1993) Block sparse Cholesky algorithms on advanced uniprocessor computers, \emph{SIAM J. Sci. Comput.}, \bold{14}, 1034--1056. Gilbert, J. R., Ng, E. G. and Peyton, B. W. (1994) An efficient algorithm to compute row and column counts for sparse Cholesky factorization, \emph{SIAM J. Matrix Anal. Appl.}, \bold{15}, 1075--1091. George, A. and Liu, J. (1981) \emph{Computer Solution of Large Sparse Positive Definite Systems}, Prentice Hall. } \note{ Although the symmetric structure of \code{x} is needed, only the upper diagonal entries are used. By default, the code does check for symmetry (contrarily to \code{base:::chol}). However, depending on the matrix size, this is a time consuming test. A test is ignored if \code{spam.options( "cholsymmetrycheck")} is set to \code{FALSE}. If a permutation is supplied with \code{pivot}, \code{spam.options( "cholpivotcheck")} determines if the permutation is tested for validity (defaults to \code{TRUE}). } \seealso{\code{\link{det.spam}}, \code{\link{solve.spam}}, \code{\link{forwardsolve.spam}}, \code{\link{backsolve.spam}} and \code{\link{ordering}}. } \examples{ # generate multivariate normals: set.seed(13) n <- 25 # dimension N <- 1000 # sample size Sigma <- .25^abs(outer(1:n,1:n,"-")) Sigma <- as.spam( Sigma, eps=1e-4) cholS <- chol( Sigma) # cholS is the upper triangular part of the permutated matrix Sigma iord <- ordering(cholS, inv=TRUE) R <- as.spam(cholS) mvsample <- ( array(rnorm(N*n),c(N,n)) \%*\% R)[,iord] # It is often better to order the sample than the matrix # R itself. # 'mvsample' is of class 'spam'. We need to transform it to a # regular matrix, as there is no method 'var' for 'spam' (should there?). norm( var( as.matrix( mvsample)) - Sigma, type='m') norm( t(R) \%*\% R - Sigma) # To speed up factorizations, memory allocations can be optimized: opt <- summary(cholS) # here, some elements of Sigma may be changed... cholS <- chol( Sigma, memory=list(nnzR=opt$nnzR,nnzcolindices=opt$nnzc)) } % backsolve( chol(as.matrix(V)[ord,ord]),iidsample)[iord,] % \author{Reinhard Furrer, based on Ng and Peyton (1993) Fortran routines} \keyword{algebra} spam/man/makeprec.Rd0000644000176000001440000000325512402107170014072 0ustar ripleyusers% This is file ../spam/man/makeprec.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{makeprec} \alias{precmat.GMRFreglat} \title{Create Precision Matrices} \description{Creates precision matrices for gridded GMRF.} \usage{ precmat.GMRFreglat(n,m, par, model = "m1p1", eps = .Spam$eps) } \arguments{ \item{n}{first dimension of the grid.} \item{m}{second dimension of the grid.} \item{par}{parameters used to construct the matrix.} \item{model}{see details and examples.} \item{eps}{A tolerance parameter: elements of \code{x} such that \code{abs(x) <= eps} set to zero. Defaults to \code{eps = .Spam$eps}} } \value{A \code{spam} matrix of dimension \code{prod(dims)}x\code{prod(dims)}.} \details{The function should be illustrative on how to create precision matrices for gridded GMRF. Hence, no testing (positive definiteness is done). The model specification \code{"m"} determines the complexity and \code{"p"} the number of parameters. Please see the examples on the meaning of the different models. } %\references{} \seealso{\code{\link{precmat}}, \code{\link{toeplitz.spam}}, \code{\link{kronecker.spam}}} \examples{ as.matrix(precmat.GMRFreglat(4, 3, c(.4), 'm1p1')) as.matrix(precmat.GMRFreglat(4, 3, c(.4,.3), 'm1p2')) as.matrix(precmat.GMRFreglat(4, 3, c(.4,.3,.2), 'm2p3')) as.matrix(precmat.GMRFreglat(4, 3, c(.4,.3,.2,.1),'m2p4')) # up to the diagonal, the following are equivalent: cleanup( precmat.IGMRFreglat(3,4) - precmat.GMRFreglat(3,4,1, 'm1p1')) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/spam.chol.NgPeyton-class.Rd0000644000176000001440000001040012346261543017036 0ustar ripleyusers% This is file ../spam/man/spam.chol.NgPeyton-class.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{spam.chol.NgPeyton-class} \docType{class} \alias{spam.chol.NgPeyton-class} \alias{as.matrix,spam.chol.NgPeyton-method} \alias{as.spam,spam.chol.NgPeyton-method} \alias{backsolve,spam.chol.NgPeyton-method} \alias{c,spam.chol.NgPeyton-method} \alias{determinant,spam.chol.NgPeyton-method} \alias{diag,spam.chol.NgPeyton-method} \alias{dim<-,spam.chol.NgPeyton-method} \alias{dim,spam.chol.NgPeyton-method} \alias{display,spam.chol.NgPeyton-method} \alias{forwardsolve,spam.chol.NgPeyton-method} \alias{image,spam.chol.NgPeyton-method} \alias{length<-,spam.chol.NgPeyton-method} \alias{length,spam.chol.NgPeyton-method} \alias{ordering,spam.chol.NgPeyton-method} \alias{print,spam.chol.NgPeyton-method} \alias{show,spam.chol.NgPeyton-method} \alias{summary,spam.chol.NgPeyton-method} \alias{t,spam.chol.NgPeyton-method} \alias{chol,spam.chol.NgPeyton-method} \title{Class "spam.chol.NgPeyton"} \description{Result of a Cholesky decomposition with the \code{NgPeyton} method} \section{Objects from the Class}{ Objects are created by calls of the form \code{chol(x,method="NgPeyton", ...)} and should not be created directly with a \code{new("spam.chol.NgPeyton", ...)} call.\cr At present, no proper print method is defined. However, the factor can be transformed into a \code{spam} object. } \section{Methods}{ \describe{ \item{as.matrix}{\code{signature(x = "spam.chol.NgPeyton")}: Transform the factor into a regular matrix. } \item{as.spam}{\code{signature(x = "spam.chol.NgPeyton")}: Transform the factor into a \code{spam} object.} \item{backsolve}{\code{signature(r = "spam.chol.NgPeyton")}: solving a triangular system, see \code{\link{solve}}. } \item{forwardsolve}{\code{signature(l = "spam.chol.NgPeyton")}: solving a triangular system, see \code{\link{solve}}. } \item{c}{\code{signature(x = "spam.chol.NgPeyton")}: Coerce the factor into a vector. } \item{determinant}{\code{signature(x = "spam.chol.NgPeyton")}: Calculates the determinant from the factor, see also \code{\link{det}}. } \item{diag}{\code{signature(x = "spam.chol.NgPeyton")}: Extracts the diagonal entries.} % \item{dim<-}{\code{signature(x = "spam.chol.NgPeyton")}: ... } \item{dim}{\code{signature(x = "spam.chol.NgPeyton")}: Retrieve the dimension. Note that \code{"dim<-"} is not implemented.} \item{display}{\code{signature(x = "spam.chol.NgPeyton")}: Transformation to a \code{spam} object and display, see also \code{\link{display}}. } \item{image}{\code{signature(x = "spam.chol.NgPeyton")}: Transformation to a \code{spam} object and display, see also \code{\link{image}}. } % \item{length<-}{\code{signature(x = "spam.chol.NgPeyton")}: ... } \item{length}{\code{signature(x = "spam.chol.NgPeyton")}: Retrieve the dimension. Note that \code{"length<-"} is not implemented. } \item{ordering}{\code{signature(x = "spam.chol.NgPeyton")}: Retrieves the ordering, in \code{\link{ordering}}. } \item{print}{\code{signature(x = "spam.chol.NgPeyton")}: Short description. } \item{show}{\code{signature(object = "spam.chol.NgPeyton")}: Short description. } \item{summary}{\code{signature(object = "spam.chol.NgPeyton")}: Description of the factor, returns (as a list) \code{nnzR}, \code{nnzcolindices}, the density of the factor \code{density}, and fill-in ratio \code{fillin}. For the use of the first two, see \sQuote{Examples} in \code{\link{chol}}.} \item{t}{\code{signature(x = "spam.chol.NgPeyton")}: Transformation to a \code{spam} object and transposition. } \item{chol}{\code{signature(x = "spam.chol.NgPeyton")}: Returns \code{x} unchanged. } } } \references{Ng, E. G. and B. W. Peyton (1993), "Block sparse Cholesky algorithms on advanced uniprocessor computers", \emph{SIAM J. Sci. Comput.}, \bold{14}, pp. 1034-1056. } \author{Reinhard Furrer} \seealso{\code{\link{print.spam}} \code{\link{ordering}} and \code{\link{chol}}} \examples{ x <- spam( c(4,3,0,3,5,1,0,1,4),3) cf <- chol( x) cf as.spam( cf) # Modify at own risk... slotNames(cf) } \keyword{classes} spam/man/precmat.Rd0000644000176000001440000000434512346261543013753 0ustar ripleyusers% This is file ../spam/man/precmat.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{precmat} \alias{precmat} \alias{precmat.RW1} \alias{precmat.RW2} \alias{precmat.RWn} \alias{precmat.season} \alias{precmat.IGMRFreglat} \alias{precmat.IGMRFirreglat} \title{IGMRF Precision Matrices} \description{ Fast ways to create sparse precision matrices for various IGMRF.} \usage{ precmat(n, season=12, m=n, A=NULL, order=1, ... , type="RW1") precmat.RW1(n) precmat.RW2(n) precmat.RWn(n, order=3) precmat.season(n, season=12) precmat.IGMRFreglat(n, m, order=1, anisotropy=1) precmat.IGMRFirreglat(A, eps=.Spam$eps) } \arguments{ \item{n}{dimension of the field.} \item{type}{the type of the IGMRF.} \item{season}{length of season.} \item{m}{second dimension (in case of a regular lattice).} \item{A}{adjacency matrix (see below).} \item{order}{order for higher order RWs.} \item{anisotropy}{anisotropy factor, between 0 and 2.} \item{eps}{tolerance level.} \item{\dots}{arguments passed to individual functions.} } \details{\code{precmat} is a wrapper that calls the other functions according to the argument \code{type}. \cr Implements many of the precision matrices discussed in Chapter 3 of Rue and Held (2005). For example, \code{precmat.RW1}, \code{precmat.RW2} and \code{precmat.season} are given in equations (3.22), (3.40) and (3.59); \code{precmat.IGMRFreglat} on page 107. Note that for the latter we reverse the order of the dimension here! \cr If adjacency matrix is a regular matrix, it is coerced to a \code{spam} object. Only the structure is used. Make sure, that the diagonal is empty. } \value{A sparse precision matrix.} %\note{There is intentionally no \acronym{S3} distinction between the classes % \code{spam} and \code{spam.chol.}\emph{method}.} \references{Rue and Held (2005). } \seealso{\code{\link{precmat.GMRFreglat}}, \code{\link{rmvnorm.prec}}, \code{\link{adjacency.landkreis}}. } \examples{ n <- 10 Q <- precmat.RW2( n) # rmvnorm.prec(1, Q=Q) # does not work, because the matrix is singular. Q%*%cbind(1,1:n) } % backsolve( chol(as.matrix(V)[ord,ord]),iidsample)[iord,] % \author{Reinhard Furrer} \keyword{algebra} spam/man/kronecker.Rd0000644000176000001440000000272412375330263014300 0ustar ripleyusers% This is file ../spam/man/kronecker.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{kronecker} \alias{kronecker.default} \alias{kronecker.spam} \title{Kronecker Products on Sparse Matrices} \description{Computes the generalised kronecker product of two arrays, \code{X} and \code{Y}.} \usage{ kronecker.spam(X, Y, FUN = "*", make.dimnames = FALSE, ...) } \arguments{ \item{X}{sparse matrix of class \code{spam}, a vector or a matrix.} \item{Y}{sparse matrix of class \code{spam}, a vector or a matrix.} \item{FUN}{a function; it may be a quoted string. See details} \item{make.dimnames}{Provide dimnames that are the product of the dimnames of \code{X} and \code{Y}. } \item{ ...}{optional arguments to be passed to \code{FUN}.} } \value{An array \code{A} with dimensions \code{dim(X) * dim(Y)}.} \details{The sparsity structure is determined by the ordinary \code{\%x\%}. Hence, the result of \code{kronecker(X, Y, FUN = "+")} is different depending on the input. } %\references{} %\seealso{\code{\link{chol}}} \examples{ # Starting with non-spam objects, we get a spam matrix kronecker.spam( diag(2), array(1:4, c(2, 2))) kronecker( diag.spam(2), array(1:4, c(2, 2))) # Notice the preservation of sparsity structure: kronecker( diag.spam(2), array(1:4, c(2, 2)), FUN="+") } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/math.Rd0000644000176000001440000000532612377434727013263 0ustar ripleyusers% This is file ../spam/man/math.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{Math} \alias{Math.spam} \alias{Math,spam-method} \alias{ceiling.spam} \alias{ceiling,spam-method} \alias{floor.spam} \alias{floor,spam-method} \alias{trunc.spam} \alias{trunc,spam-method} \alias{exp.spam} \alias{exp,spam-method} \alias{log.spam} \alias{log,spam-method} \alias{log2.spam} \alias{log2,spam-method} \alias{log10.spam} \alias{log10,spam-method} \alias{sqrt.spam} \alias{sqrt,spam-method} \alias{gamma.spam} \alias{gamma,spam-method} \alias{digamma.spam} \alias{digamma,spam-method} \alias{trigamma.spam} \alias{trigamma,spam-method} \alias{lgamma.spam} \alias{lgamma,spam-method} \alias{abs.spam} \alias{abs,spam-method} \alias{cumprod.spam} \alias{cumprod,spam-method} \alias{cumsum.spam} \alias{cumsum,spam-method} \alias{cummax.spam} \alias{cummax,spam-method} \alias{cummin.spam} \alias{cummin,spam-method} \alias{cos.spam} \alias{cos,spam-method} %\alias{cospi.spam} %\alias{cospi,spam-method} \alias{cosh.spam} \alias{cosh,spam-method} \alias{acos.spam} \alias{acos,spam-method} \alias{acosh.spam} \alias{acosh,spam-method} \alias{sin.spam} \alias{sin,spam-method} \alias{asin.spam} \alias{asin,spam-method} \alias{asinh.spam} \alias{asinh,spam-method} \alias{tan.spam} \alias{tan,spam-method} \alias{atan.spam} \alias{atan,spam-method} \alias{atanh.spam} \alias{atanh,spam-method} \title{Mathematical functions} \description{Applies the \code{Math} group functions to \code{spam} objects } \usage{# ceiling(x) # floor(x) # exp(x, base = exp(1)) # log(x, base = exp(1)) # sqrt(x) # abs(x) # cumprod(x) # cumsum(x) # cos(x) # sin(x) # tan(x) # acosh(x) ... } \arguments{\item{x}{spam object.} \item{base}{positive number. The base with respect to which logarithms are computed. Defaults to \code{e=exp(1)}.} } \value{If \code{structurebased=TRUE}, all functions operate on the vector \code{x@entries} and return the result thereof.\cr Conversely, if \code{structurebased=FALSE}, the result is identical to one with \code{as.matrix(x)} input and an \code{as.spam} purger. } \details{ It is important to note that the zero entries do not enter the evaluation when \code{structurebased=FALSE}. The operations are performed on the stored non-zero elements. This may lead to differences if compared with the same operation on a full matrix. } %\references{ %} \seealso{\code{\link{Summary.spam}}, \code{\link{Ops.spam}} and \code{\link{Math2.spam}} } \examples{ getGroupMembers("Math") mat <- matrix(c( 1,2,0,3,0,0,0,4,5),3) smat <- as.spam( mat) cos( mat) cos( smat) spam.options(structurebased=FALSE) cos( smat) sqrt( smat) } \author{Reinhard Furrer} \keyword{manip} spam/man/cleanup.Rd0000644000176000001440000000176112346261543013746 0ustar ripleyusers% This is file ../spam/man/cleanup.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{cleanup} \alias{cleanup} \title{Cleaning up sparse matrices} \description{ Eliminates an zeros in a sparse matrix.} \usage{ cleanup(x, eps = .Spam$eps) } \arguments{ \item{x}{a sparse matrix of class \code{spam}.} \item{eps}{numeric scalar > 0. Smaller entries are coerced to zero.} } \details{A sparse matrix may still contain zeros. This function (aliased to \code{as.spam}) filters these values.\cr This often causes confusion when testing such matrices for symmetry or comparing apparently equal matrices with \code{all.equal} (see \sQuote{Examples} below. } \seealso{\code{\link{isSymmetric.spam}} and \code{\link{all.equal.spam}}. } \examples{ A <- diag.spam(2) A[1,2] <- 0 all.equal(A, t(A)) isSymmetric.spam(A) all.equal(cleanup(A), diag.spam(2)) } \author{Reinhard Furrer} \keyword{algebra} spam/man/solve.Rd0000644000176000001440000001130512402102337013426 0ustar ripleyusers% This is file ../spam/man/solve.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{spam solve} \alias{backsolve} \alias{forwardsolve} \alias{backsolve-methods} \alias{backsolve,ANY-method} \alias{backsolve,spam-method} \alias{backsolve,matrix-method} \alias{backsolve.spam} \alias{forwardsolve-methods} \alias{forwardsolve,ANY-method} \alias{forwardsolve,spam-method} \alias{forwardsolve,matrix-method} \alias{forwardsolve.spam} \alias{chol2inv.spam} \alias{chol2inv,spam-method} \alias{chol2inv,spam.chol.NgPeyton-method} \alias{solve.spam} \alias{solve,ANY-method} \alias{solve,spam-method} \title{Linear Equation Solving for Sparse Matrices} \description{ \code{backsolve} and \code{forwardsolve} solve a system of linear equations where the coefficient matrix is upper or lower triangular. \cr \code{solve} solves a linear system or computes the inverse of a matrix if the right-hand-side is missing. } \usage{ \S4method{solve}{spam}(a, b, Rstruct=NULL, \dots) \S4method{backsolve}{spam}(r, x, \dots) \S4method{forwardsolve}{spam}(l, x, \dots) \S4method{chol2inv}{spam}(x, \dots) } \arguments{ \item{a}{symmetric positive definite matrix of class \code{spam} or a Cholesky factor as the result of a \code{chol} call.} \item{l,r}{object of class \code{spam} or \code{spam.chol.}\emph{method} returned by the function \code{chol}.} \item{x,b}{vector or regular matrix of right-hand-side(s) of a system of linear equations.} \item{Rstruct}{the Cholesky structure of \code{a}.} \item{\dots}{further arguments passed to or from other methods, see \sQuote{Details} below.} } \details{ We can solve \code{A \%*\% x = b} by first computing the Cholesky decomposition \code{A = t(R)\%*\%R)}, then solving \code{t(R)\%*\%y = b} for \code{y}, and finally solving \code{R\%*\%x = y} for \code{x}. \code{solve} combines \code{chol}, a Cholesky decomposition of a symmetric positive definite sparse matrix, with \code{forwardsolve} and then \code{backsolve}.\cr In case \code{a} is from a \code{chol} call, then \code{solve} is an efficient way to calculate \code{backsolve(a, forwardsolve( t(a), b))}. However, for \code{a.spam} and \code{a.mat} from a \code{chol} call with a sparse and ordinary matrix, note that \code{forwardsolve( a.mat, b, transpose=T, upper.tri=T)} is equivalent to \code{forwardsolve( t(a.mat), b)} and \code{backsolve(a.spam, forwardsolve(a.spam, b, transpose=T, upper.tri=T))} yields the desired result. But \code{backsolve(a.spam,forwardsolve(t(a.spam), resid))} is wrong because \code{t(a.spam)} is a \code{spam} and not a \code{spam.chol.NgPeyton} object. \code{forwardsolve} and \code{backsolve} solve a system of linear equations where the coefficient matrix is lower (\code{forwardsolve}) or upper (\code{backsolve}) triangular. Usually, the triangular matrix is result from a \code{chol} call and it is not required to transpose it for \code{forwardsolve}. Note that arguments of the default methods \code{k}, \code{upper.tri} and \code{transpose} do not have any effects here. Notice that it is more efficient to solve successively the linear equations (both triangular solves) than to implement these in the Fortran code. If the right-hand-side in \code{solve} is missing it will compute the inverse of a matrix. For details about the specific Cholsesky decomposition, see \code{\link{chol}}. Recall that the Cholesky factors are from ordered matrices. \code{chol2inv(x)} is a faster way to \code{solve(x)}. } \note{There is intentionally no \acronym{S3} distinction between the classes \code{spam} and \code{spam.chol.}\emph{method}.} \references{See references in \code{\link{chol}}. } \seealso{\code{\link{chol.spam}} and \code{\link{ordering}}. } \examples{ # Generate multivariate form a covariance inverse: # (usefull for GRMF) set.seed(13) n <- 25 # dimension N <- 1000 # sample size Sigmainv <- .25^abs(outer(1:n,1:n,"-")) Sigmainv <- as.spam( Sigmainv, eps=1e-4) Sigma <- solve( Sigmainv) # for verification iidsample <- array(rnorm(N*n),c(n,N)) mvsample <- backsolve( chol(Sigmainv), iidsample) norm( var(t(mvsample)) - Sigma) # compare with: mvsample <- backsolve( chol(as.matrix( Sigmainv)), iidsample, n) #### ,n as patch norm( var(t(mvsample)) - Sigma) # 'solve' step by step: b <- rnorm( n) R <- chol(Sigmainv) norm( backsolve( R, forwardsolve( R, b))- solve( Sigmainv, b) ) norm( backsolve( R, forwardsolve( R, diag(n)))- Sigma ) # 'update': R1 <- update( R, Sigmainv + diag.spam( n)) } % backsolve( chol(as.matrix(V)[ord,ord]),iidsample)[iord,] % \author{Reinhard Furrer, based on Ng and Peyton (1993) Fortran routines} \keyword{algebra} spam/man/coerce.Rd0000644000176000001440000000227612377117300013554 0ustar ripleyusers\name{coerce-methods} \docType{methods} \alias{coerce.spam} \alias{coerce,spam,logical-method} \alias{coerce,spam,matrix-method} \alias{coerce,spam,vector-method} \alias{coerce,spam,list-method} \alias{coerce,spam,integer-method} \title{Force a \code{spam} Object to Belong to a Class} \description{ These functions manage the relations that allow coercing a \code{spam} object to a given class. } \section{Methods}{ \describe{ \item{\code{signature(from = "spam", to = "matrix")}}{ this is essentially equivalent to \code{as.matrix(object)}. } \item{\code{signature(from = "spam", to = "list")}}{ this is essentially equivalent to \code{triplet(object)}. } \item{\code{signature(from = "spam", to = "vector")}}{ this is essentially equivalent to \code{object@entries} (\code{structurebased=TRUE}) or \code{c(object)}. } \item{\code{signature(from = "spam", to = "logical")}}{ the entries are forced to logicals (nonzeros only in case of \code{structurebased=TRUE}). } \item{\code{signature(from = "spam", to = "integer")}}{ the entries are forced to integers (nonzeros only in case of \code{structurebased=TRUE}). } }} \examples{ ifelse( diag.spam(2)*c(0,1), TRUE, FALSE) } \keyword{methods} spam/man/det.Rd0000644000176000001440000000470012375330047013065 0ustar ripleyusers% This is file ../spam/man/det.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{det} \alias{det,spam-method} \alias{det,spam.chol.NgPeyton-method} \alias{det.spam} \alias{determinant} %\alias{determinant,spam.chol.NgPeyton-method} \alias{determinant,spam-method} \alias{determinant.spam} \alias{determinant.spam.chol} \alias{determinant.spam.chol.NgPeyton} \title{Calculate the determinant of a positive definite Sparse Matrix} \description{\code{det} and \code{determinant} calculate the determinant of a positive definite sparse matrix. \code{determinant} returns separately the modulus of the determinant, optionally on the logarithm scale, and the sign of the determinant. } \usage{ # det(x, ...) determinant(x, logarithm = TRUE, ...) } \arguments{ \item{x}{sparse matrix of class \code{spam} or a Cholesky factor of class \code{spam.chol.NgPeyton}.} \item{logarithm}{logical; if \code{TRUE} (default) return the logarithm of the modulus of the determinant.} \item{...}{Optional arguments. Examples include \code{method} argument and additional parameters used by the method.} } \value{For \code{det}, the determinant of \code{x}. For \code{determinant}, a list with components \item{modulus}{a numeric value. The modulus (absolute value) of the determinant if \code{logarithm} is \code{FALSE}; otherwise the logarithm of the modulus.} \item{sign}{integer; either +1 or -1 according to whether the determinant is positive or negative.} } \details{If the matrix is not positive definite, the function issues a warning and returns \code{NA}. The determinant is based on the product of the diagonal entries of a Cholesky factor, i.e. internally, a Cholesky decomposition is performed. By default, the NgPeyton algorithm with minimal degree ordering us used. To change the methods or supply additonal parameters to the Cholesky factorization function, see the help for \code{\link{chol}}. The determinant of a Cholesky factor is also defined. } \references{ Ng, E. G. and B. W. Peyton (1993) Block sparse Cholesky algorithms on advanced uniprocessor computers, \emph{SIAM J. Sci. Comput.}, \bold{14}, 1034--1056. } \seealso{\code{\link{chol.spam}} } \examples{ x <- spam( c(4,3,0,3,5,1,0,1,4),3) det( x) determinant( x) det( chol( x)) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/foreign.Rd0000644000176000001440000000342712346261543013751 0ustar ripleyusers% This is file ../spam/man/foreign.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{foreign} \alias{foreign} \alias{as.spam.matrix.csr} \alias{as.matrix.csr.spam} \alias{as.dgRMatrix.spam} \alias{as.dgCMatrix.spam} \alias{as.spam.dgRMatrix} \alias{as.spam.dgCMatrix} \title{Transformation to other sparse formats} \description{Transform between the \code{spam} sparse format to the \code{matrix.csr} format of \code{SparseM} and \code{dgRMatrix} format of \code{Matrix}} \usage{ as.spam.matrix.csr(x) # as.matrix.csr.spam(x) as.dgRMatrix.spam(x) as.dgCMatrix.spam(x) as.spam.dgRMatrix(x) as.spam.dgCMatrix(x) } \arguments{ \item{x}{sparse matrix of class \code{spam}, \code{matrix.csr}, \code{dgRMatrix} or \code{dgCMatrix}.} } \value{According to the call, a sparse matrix of class \code{spam}, \code{matrix.csr}, \code{dgRMatrix} or \code{dgCMatrix}.} \details{ We do not provide any \code{S4} methods and because of the existing mechanism a standard \code{S3} does not work.\cr The functions are based on \code{require}.\cr Notice that \code{as.matrix.csr.spam} should read as \code{as."matrix.csr".spam}. } %\references{} \seealso{ \code{\link{triplet}}, \code{\link[Matrix]{Matrix}} or \code{\link[SparseM]{matrix.csr}}} \examples{ \dontrun{ S <- diag.spam(4) U <- as.matrix.csr.spam( S) R <- as.dgRMatrix.spam( S) C <- as.dgCMatrix.spam( S) as.spam.dgCMatrix(C) slotNames(U) slotNames(R) # For column oriented sparse formats a transpose does not the job, # as the slot names change. # as.spam(R) does not work. } \dontrun{ # a dataset contained in Matrix data(KNex) as.spam.dgCMatrix(KNex$mm) } } \author{Reinhard Furrer} \keyword{array} \keyword{manip} spam/man/cov.Rd0000644000176000001440000000473012346261543013105 0ustar ripleyusers% This is file ../spam/man/cov.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{covmat} \alias{covmat} \alias{cov.exp} \alias{cov.sph} \alias{cov.nug} \alias{cov.wu1} \alias{cov.wu2} \alias{cov.wu3} \alias{cov.wend1} \alias{cov.wend2} \alias{cov.mat} \title{Covariance functions} \description{ Evaluate a covariance function.} \usage{ covmat(h, theta, ... , type="sph") cov.exp(h, theta, ... , eps= .Spam$eps) cov.sph(h, theta, ... , eps= .Spam$eps) cov.nug(h, theta, ... , eps= .Spam$eps) cov.wu1(h, theta, ... , eps= .Spam$eps) cov.wu2(h, theta, ... , eps= .Spam$eps) cov.wu3(h, theta, ... , eps= .Spam$eps) cov.wend1(h, theta, ... , eps= .Spam$eps) cov.wend2(h, theta, ... , eps= .Spam$eps) cov.mat(h, theta, ... , eps= .Spam$eps) } \arguments{ \item{h}{object containing the lags.} \item{theta}{parameter of the covariance function, see \sQuote{Details}.} \item{type}{covariance function specification.} \item{\dots}{arguments passed from other methods.} \item{eps}{tolerance level.} } \details{\code{covmat} is a wrapper that calls the other functions according to the argument \code{type}. The nomenclature is similar to \code{premat} \cr The parametrization is (range, sill, [smoothness], nugget), where only the range needs to be specified. Default values are (1,[1],0). In case of negative parameter values, a warning is issued and the absolute value is retained. Although more cryptic, having all arguments as a single vector simplifies optimization with \code{optim}. \cr Currently, the functions distinguish between a sparse \code{spam} object \code{h} and any other numeric type. In the future, this might change and appropriate methods will be implemented. } \value{Covariance function evaluated on \code{h}.} %\note{There is intentionally no \acronym{S3} distinction between the classes % \code{spam} and \code{spam.chol.}\emph{method}.} \references{Any classical book about geostatistics.} \seealso{\code{\link{precmat}}.} \examples{ locs <- cbind(runif(10),runif(10)) h <- nearest.dist(locs, delta=.3) Sigma <- cov.sph(h, c(.3, 1, .1)) \dontrun{ h <- seq(0, to=1, length.out=100) plot( h, cov.exp(h, c(1/3,1)), type='l', ylim=c(0,1)) type <- c("sph","wendland1","wendland2","wu1","wu2","wu3") for (i in 1:6) lines( h, covmat(h, 1, type=type[i]), col=i+1) legend('topright',legend=type, col=2:7, lty=1) } } \author{Reinhard Furrer} \keyword{algebra} spam/man/mle.Rd0000644000176000001440000001055712346261543013077 0ustar ripleyusers% This is file ../spam/man/mle.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{mle} \alias{neg2loglikelihood.spam} \alias{mle.spam} \alias{mle.nomean.spam} \alias{neg2loglikelihood} \alias{mle} \alias{mle.nomean} \title{Maximum likelihood estimates} \description{Maximum likelihood estimates of a simple spatial model} \usage{ neg2loglikelihood.spam(y, X, distmat, Covariance, beta, theta, Rstruct = NULL, ...) neg2loglikelihood(y, X, distmat, Covariance, beta, theta, ...) mle.spam(y, X, distmat, Covariance, beta0, theta0, thetalower, thetaupper, optim.control=NULL, Rstruct = NULL, hessian = FALSE,...) mle(y, X, distmat, Covariance, beta0, theta0, thetalower, thetaupper, optim.control=NULL, hessian = FALSE, ...) mle.nomean.spam(y, distmat, Covariance, theta0, thetalower, thetaupper, optim.control=NULL, Rstruct = NULL, hessian = FALSE, ...) mle.nomean(y, distmat, Covariance, theta0, thetalower, thetaupper, optim.control=NULL, hessian = FALSE, ...) } \arguments{ \item{y}{data vector of length n.} \item{X}{the design matrix of dimension n x p.} \item{distmat}{a distance matrix. Usually the result of a call to \code{nearest.dist}.} \item{Covariance}{function defining the covariance. See example.} \item{beta}{parameters of the trend (fixed effects).} \item{theta}{parameters of the covariance structure.} \item{Rstruct}{the Cholesky structure of the covariance matrix.} \item{beta0,theta0}{inital values.} \item{thetalower,thetaupper}{lower and upper bounds of the parameter \code{theta}.} \item{optim.control}{arguments passed to \code{optim}.} \item{hessian}{Logical. Should a numerically differentiated Hessian matrix be returned?} \item{...}{additional arguments passed to \code{chol}.} } \value{The negative-2-loglikelihood or the output from the function \code{optim}. } \details{ We provide functions to calculate the negative-2-log-likelihood and maximum likelihood estimates for the model y ~ N_n( X beta, Sigma(h;theta) ) in the case of a sparse or ordinary covariance matrices. In the case of the \code{*.spam} versions, the covariance function has to return a \code{spam} object. In the other case, the methods are correctly overloaded and work either way, slightly slower than the \code{*.spam} counterparts though. When working on the sphere, the distance matrix has to be transformed by h -> R / 2 sin(h/2) where R is the radius of the sphere. The covariance function requires that the first argument is the distance matrix and the second the parameters. One can image cases in which the covariance function does not take the entire distance matrix but only some partial information thereof. (An example is the use of a kronecker type covariance structure.) In case of a sparse covariance construction where the argument \code{Rstruct} is not given, the first parameter element needs to be the range parameter. (This results from the fact, that a sparse structure is constructed that is independent of the parameter values to exploit the fast Choleski decomposition.) In the zero-mean case, the \code{neg2loglikelihood} is calculated by setting the parameters \code{X} or \code{beta} to zero. } %\references{} \seealso{\code{\link{covmat}} } \examples{ # True parameter values: truebeta <- c(1,2,.2) # beta = (intercept, linear in x, linear in y) truetheta <- c(.5,2,.02) # theta = (range, sill, nugget) # We now define a grid, distance matrix, and a sample: x <- seq(0,1,l=5) locs <- expand.grid( x, x) X <- as.matrix( cbind(1,locs)) # design matrix distmat <- nearest.dist( locs, upper=NULL) # distance matrix Sigma <- cov.sph( distmat, truetheta) # true covariance matrix set.seed(15) y <- c(rmvnorm.spam(1,X \%*\% truebeta,Sigma)) # construct sample # Here is the negative 2 log likelihood: neg2loglikelihood.spam( y, X, distmat, cov.sph, truebeta, truetheta) # We pass now to the mle: res <- mle.spam(y, X, distmat, cov.sph, truebeta, truetheta,thetalower=c(0,0,0),thetaupper=c(1,Inf,Inf)) # Similar parameter estimates here, of course: mle.nomean.spam(y-X\%*\%res$par[1:3], distmat, cov.sph, truetheta, thetalower=c(0,0,0), thetaupper=c(1,Inf,Inf)) } \author{Reinhard Furrer } \keyword{algebra} spam/man/spam-class.Rd0000644000176000001440000001657712377433510014374 0ustar ripleyusers% This is file ../spam/man/spam-class.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{spam-class} \docType{class} \alias{spam.class} \alias{spam-class} \alias{as.matrix,spam-method} \alias{as.matrix.spam} \alias{[<-,spam,ANY,ANY,ANY-method} \alias{[<-,spam,matrix,matrix,ANY-method} \alias{[<-,spam,matrix,missing,ANY-method} \alias{[<-,spam,missing,missing,ANY-method} \alias{[<-,spam,missing,vector,ANY-method} \alias{[<-,spam,missing,vector,spam-method} \alias{[<-,spam,spam,missing,ANY-method} \alias{[<-,spam,vector,missing,ANY-method} \alias{[<-,spam,vector,missing,spam-method} \alias{[<-,spam,vector,vector,ANY-method} \alias{[<-,spam,vector,vector,spam-method} \alias{[<-,spam,missing,missing,numeric-method} \alias{[<-,spam,missing,vector,numeric-method} \alias{[<-,spam,vector,missing,numeric-method} \alias{[<-,spam,vector,vector,numeric-method} \alias{[<-,spam,matrix,missing,numeric-method} \alias{[<-,spam,matrix,matrix,numeric-method} \alias{[<-,spam,spam,missing,numeric-method} \alias{[<-,spam,ANY-method} \alias{[,spam,missing,missing,ANY-method} \alias{[,spam,missing,vector,ANY-method} \alias{[,spam,vector,missing,logical-method} \alias{[,spam,vector,missing,missing-method} \alias{[,spam,vector,vector,ANY-method} \alias{[,spam,matrix,missing,missing-method} \alias{[,spam,matrix,missing,logical-method} \alias{[,spam,matrix,matrix,ANY-method} \alias{[,spam,spam,missing,ANY-method} \alias{[,spam,ANY,ANY,ANY-method} \alias{Arith,spam,spam-method} \alias{Arith,spam,ANY-method} \alias{Arith,ANY,spam-method} \alias{Compare,ANY,spam-method} \alias{Compare,spam,ANY-method} \alias{Compare,spam,spam-method} \alias{!,spam-method} \alias{+,spam,missing-method} \alias{-,spam,missing-method} \alias{c,spam-method} \alias{t,spam-method} \alias{length<-,spam-method} \alias{length,spam-method} \alias{lower.tri,spam-method} \alias{kronecker,spam,ANY-method} \alias{kronecker,ANY,spam-method} \alias{kronecker,spam,spam-method} \alias{crossprod,spam,missing-method} \alias{tcrossprod,spam,missing-method} \alias{crossprod,ANY,spam-method} \alias{tcrossprod,ANY,spam-method} \alias{plot,spam,missing-method} \alias{plot,spam,spam-method} \alias{show,spam-method} \alias{upper.tri,spam-method} \title{Class "spam"} \description{The \code{spam} class is a representation of sparse matrices.} \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("spam", entries, colindices, rowpointes, dimension)}. The standard "old Yale sparse format" is used to store sparse matrices.\cr The matrix \code{x} is stored in row form. The first element of row \code{i} is \code{x@rowpointers[i]}. The length of row \code{i} is determined by \code{x@rowpointers[i+1]-x@rowpointers[i]}. The column indices of \code{x} are stored in the \code{x@colindices} vector. The column index for element \code{x@entries[k]} is \code{x@colindices[k]}.} \section{Slots}{ \describe{ \item{\code{entries}:}{Object of class \code{"numeric"} contains the nonzero values. } \item{\code{colindices}:}{Object of class \code{"integer"} ordered indices of the nonzero values. } \item{\code{rowpointers}:}{Object of class \code{"integer"} pointer to the beginning of each row in the arrays \code{entries} and \code{colindices}.} \item{\code{dimension}:}{Object of class \code{"integer"} specifying the dimension of the matrix.} } } \section{Methods}{ \describe{ \item{as.matrix}{\code{signature(x = "spam")}: transforming a sparse matrix into a regular matrix.} \item{as.vector}{\code{signature(x = "spam")}: transforming a sparse matrix into a vector (dependings on \code{structurebased}) see \code{\link{as.vector.spam}} for details.} \item{as.spam}{\code{signature(x = "spam")}: cleaning of a sparse matrix.} \item{[<-}{\code{signature(x = "spam", i,j, value)}: assigning a sparse matrix. The negative vectors are not implemented yet. } \item{[}{\code{signature(x = "spam", i, j)}: subsetting a sparse matrix. The negative vectors are not implemented yet. } \item{\%*\%}{\code{signature(x, y)}: matrix multiplication, all combinations of sparse with full matrices or vectors are implemented.} \item{c}{\code{signature(x = "spam")}: vectorizes the sparse matrix and takes account of the zeros. Hence the lenght of the result is \code{prod(dim(x))}.} \item{cbind}{\code{signature(x = "spam")}: binds sparse matrices, see \code{\link{cbind}} for details.} \item{chol}{\code{signature(x = "spam")}: see \code{\link{chol}} for details.} \item{diag}{\code{signature(x = "spam")}: see \code{\link{diag}} for details.} \item{dim<-}{\code{signature(x = "spam")}: rearranges the matrix to reflect a new dimension.} \item{dim}{\code{signature(x = "spam")}: gives the dimension of the sparse matrix.} \item{pad<-}{\code{signature(x = "spam")}: truncates or augments the matrix see \code{\link{dim}} for details.} \item{image}{\code{signature(x = "spam")}: see \code{\link{image}} for details.} \item{display}{\code{signature(x = "spam")}: see \code{\link{display}} for details.} % \item{initialize}{\code{signature(.Object = "spam")}: ... } \item{length<-}{\code{signature(x = "spam")}: Is not implemented and causes an error.} \item{length}{\code{signature(x = "spam")}: gives the number of non-zero elements.} \item{lower.tri}{\code{signature(x = "spam")}: see \code{\link{lower.tri}} for details. } \item{Math}{\code{signature(x = "spam")}: see \code{\link{Math}} for details.} \item{Math2}{\code{signature(x = "spam")}: see \code{\link{Math2}} for details. } \item{norm}{\code{signature(x = "spam")}: calculates the norm of a matrix.} \item{plot}{\code{signature(x = "spam", y)}: same functionality as the ordinary \code{plot}. } \item{print}{\code{signature(x = "spam")}: see \code{\link{print}} for details.} \item{rbind}{\code{signature(x = "spam")}: binds sparse matrices, see \code{\link{cbind}} for details.} % \item{show}{\code{signature(object = "spam")}: ... } \item{solve}{\code{signature(a = "spam")}: see \code{\link{solve}} for details.} \item{summary}{\code{signature(object = "spam")}: small summary statement of the sparse matrix.} \item{Summary}{\code{signature(x = "spam")}: All functions of the \code{Summary} class (like \code{min}, \code{max}, \code{range}...) operate on the vector \code{x@entries} and return the result thereof. See Examples or \code{\link{Summary}} for details. } \item{t}{\code{signature(x = "spam")}: transpose of a sparse matrix.} \item{upper.tri}{\code{signature(x = "spam")}: see \code{\link{lower.tri}} for details.} } } \section{Details}{ The compressed sparse row (CSR) format is often described with the vectors \code{a}, \code{ia}, \code{ja}. To be a bit more comprehensive, we have chosen longer slot names. } \section{Note}{The slots \code{colindices} and \code{rowpointers} are tested for proper integer assignments. This is not true for \code{entries}. } %\references{} \author{Reinhard Furrer, some of the Fortran code is based on A. George, J. Liu, E. S. Ng, B.W Peyton and Y. Saad (alphabetical)} %\note{} %\seealso{} \examples{ showMethods("as.spam") smat <- diag.spam(runif(15)) range(smat) cos(smat) } \keyword{classes} spam/man/version.Rd0000644000176000001440000000254512346261543014005 0ustar ripleyusers% This is file ../spam/man/version.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{version} \alias{version} \alias{spam.version} \alias{spam.Version} \title{Spam Version Information} \description{ \code{spam.version} is a variable (\code{list}) holding detailed information about the version of \code{spam} loaded. \code{spam.Version()} provides detailed information about the version of \code{spam} running. } \usage{ spam.version } \value{\code{spam.version} is a list with character-string components \item{status}{the status of the version (e.g., \code{"beta"})} \item{major}{the major version number} \item{minor}{the minor version number} \item{year}{the year the version was released} \item{month}{the month the version was released} \item{day}{the day the version was released} \item{version.string}{a \code{character} string concatenating the info above, useful for plotting, etc.} \code{spam.version} is a list of class \code{"simple.list"} which has a \code{print} method. } % \references{} \seealso{See the R counterparts \code{\link[base]{R.version}}. } \author{Reinhard Furrer} \examples{ spam.version$version.string } \keyword{environment} \keyword{sysdata} \keyword{programming} spam/man/math2.Rd0000644000176000001440000000221712375441741013331 0ustar ripleyusers% This is file ../spam/man/math2.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{Math2} \alias{Math2.spam} \alias{Math2,spam-method} \alias{Math2,spam,numeric-method} \alias{round,spam-method} \alias{signif,spam-method} \alias{round.spam} \alias{signif.spam} \title{Rounding of Numbers} \description{Applies the \code{Math2} group functions to '\code{spam}' objects } \usage{\S4method{round}{spam}(x, digits = 0) \S4method{signif}{spam}(x, digits = 6) } \arguments{\item{x}{spam object.} \item{digits}{integer indicating the precision to be used.} } \value{All functions operate on the vector \code{x@entries} and return the result thereof. } %\details{% Is implemented for R>=2.3.x only. However, % it would be possible to use Martin's proposed workaround: % \url{http://tolstoy.newcastle.edu.au/R/help/05/12/18192.html} %\references{ %} \seealso{\code{\link{Ops.spam}} and \code{\link{Math.spam}}} \examples{ getGroupMembers("Math2") smat <- diag.spam( rnorm(15)) round(smat, 3) } \author{Reinhard Furrer} \keyword{manip} % "round" "signif" spam/man/ordering.Rd0000644000176000001440000000404612375331002014115 0ustar ripleyusers% This is file ../spam/man/ordering.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{ordering} \docType{methods} \alias{ordering} \alias{ordering.spam} \alias{ordering-methods} %\alias{ordering,spam.chol.NgPeyton-method} \alias{ordering.spam.chol} \alias{ordering.spam.chol.NgPeyton} \alias{ordering,spam-method} \alias{ordering,matrix-method} \title{Extract the permutation} \description{Extract the (inverse) permutation used by the Cholesky decomposition} \usage{ ordering( x, inv=FALSE) } \arguments{ \item{x}{object of class \code{spam.chol.}\emph{method} returned by the function \code{chol}.} \item{inv}{Return the permutation (default) or inverse thereof.} } \details{ Recall that calculating a Cholesky factor from a sparse matrix consists of finding a permutation first, then calculating the factors of the permuted matrix. The ordering is important when working with the factors themselves.\cr The ordering from a full/regular matrix is \code{1:n}.\cr Note that there exists many different algorithms to find orderings. \cr See the examples, they speak more than 10 lines. } \seealso{\code{\link{chol.spam}}, \code{\link{solve.spam}}. } \examples{ # Construct a pd matrix S to work with (size n) n <- 100 # dimension S <- .25^abs(outer(1:n,1:n,"-")) S <- as.spam( S, eps=1e-4) I <- diag(n) # Identity matrix cholS <- chol( S) ord <- ordering(cholS) iord <- ordering(cholS, inv=TRUE) R <- as.spam( cholS ) # R'R = P S P', with P=I[ord,], # a permutation matrix (rows permuted). RtR <- t(R) \%*\% R # the following are equivalent: as.spam( RtR - S[ord,ord] ) as.spam( RtR[iord,iord] - S ) as.spam( t(R[,iord]) \%*\% R[,iord] - S ) # trivially: as.spam( t(I[iord,]) - I[ord,]) # (P^-1)' = P as.spam( t(I[ord,]) - I[,ord]) # as.spam( I[iord,] - I[,ord]) as.spam( I[ord,]\%*\%S\%*\%I[,ord] - S[ord,ord] ) # pre and post multiplication with P and P' is ordering } \author{Reinhard Furrer} \keyword{algebra} spam/man/pad.Rd0000644000176000001440000000250412375330614013055 0ustar ripleyusers% This is file ../spam/man/dim.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{pad} \alias{pad} \alias{pad.spam} \alias{pad<-} \alias{pad<-.spam} \alias{pad<-,spam-method} \alias{pad<-,matrix-method} \title{Padding a (sparse) matrix} \description{ Resets the dimension of a (\code{spam}) matrix by truncation or zero padding. } \usage{ pad(x) <- value %"pad<-.spam"(x,value) } \arguments{ \item{x}{a \code{spam} matrix} \item{value}{A numeric two-vector.} } \value{ A (\code{spam}) matrix of dimension \code{value} where trunction or padding has been used. } \details{ It is important to notice the different behavior of the replacement method for ordinary arrays and \code{spam} objects (see \sQuote{Examples}). Here, the elements are not simply rearranged but an entirely new matrix is constructed. If the new column dimension is smaller than the original, the matrix is also cleaned (with \code{spam.option("eps")} as filter). } %\references{} \seealso{\code{\link{dim.spam}}. } \examples{ x <- diag(4) dim(x)<-c(2,8) x s <- diag.spam(4) pad(s) <- c(7,3) # any positive value can be used s <- diag.spam(4) pad(s) <- c(2,8) # result is different than x } \author{Reinhard Furrer} \keyword{array} spam/man/spam.creation.Rd0000644000176000001440000000664412402337566015071 0ustar ripleyusers% This is file ../spam/man/spam.creation.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{spam} \alias{spam.creation} \alias{initialize,spam-method} \alias{spam} \alias{spam.list} \alias{spam.numeric} \alias{spam,list-method} \alias{spam,numeric-method} %\alias{spam.spam} %\alias{spam,spam-method} \alias{as.spam,matrix-method} \alias{as.spam,numeric-method} \alias{as.spam,spam-method} \alias{as.spam,dist-method} \alias{as.spam,list-method} \alias{as.spam} \alias{as.spam.spam} \alias{as.spam.numeric} \alias{as.spam.matrix} \alias{as.spam.chol.NgPeyton} \alias{as.spam.dist} \alias{as.spam.list} \alias{is.spam} \alias{validspamobject} \title{Sparse Matrix Class} \description{ This group of functions evaluates and coerces changes in class structure. } \usage{ spam(x, nrow = 1, ncol = 1, eps = .Spam$eps) as.spam(x, eps = .Spam$eps) is.spam(x) } \value{ A valid \code{spam} object.\cr \code{is.spam} returns \code{TRUE} if \code{x} is a \code{spam} object.} \arguments{ \item{x}{is a matrix (of either dense or sparse form), a list, vector object or a distance object} \item{nrow}{number of rows of matrix } \item{ncol}{number of columns of matrix } \item{eps}{A tolerance parameter: elements of \code{x} such that \code{abs(x) < eps} set to zero. Defaults to \code{eps = .Spam$eps} } } \details{ The functions \code{spam} and \code{as.spam} act like \code{matrix} and \code{as.matrix} to coerce an object to a sparse matrix object of class \code{spam}. If \code{x} is a list, it should contain either two or three elements. In case of the former, the list should contain a \code{n} by two matrix of indicies (called \code{ind}) and the values. In case of the latter, the list should contain three vectors containing the row, column indices (called \code{i} and \code{j}) and the values. In both cases partial matching is done. In case there are several triplets with the same \code{i}, \code{j}, the values are added. \code{eps} should be at least as large as \code{.Machine$double.eps}. } \note{The zero matrix has the element zero stored in (1,1).\cr The functions do not test the presence of \code{NA/NaN/Inf}. Virtually all call a Fortran routine with the \code{NAOK=NAOK} argument, which defaults to \code{FALSE} resulting in an error. Hence, the \code{NaN} do not always properly propagate through (i.e. \code{spam} is not IEEE-754 compliant). } \references{Reinhard Furrer, Stephan R. Sain (2010). "spam: A Sparse Matrix R Package with Emphasis on MCMC Methods for Gaussian Markov Random Fields.", \emph{Journal of Statistical Software}, 36(10), 1-25, \url{http://www.jstatsoft.org/v36/i10/.} } \seealso{ \code{\link{SPAM}} for a general overview of the package; \code{\link{spam.options}} for details about the \code{safemode} flag; \code{\link{read.MM}} and \code{\link{foreign}} to create \code{spam} matrices from MatrixMarket files and from certain \pkg{Matrix} or \pkg{SparseM} formats. } \examples{ # old message, do not loop, when you create a large sparse matrix set.seed(13) nz <- 128 ln <- nz^2 smat <- spam(0,ln,ln) is <- sample(ln,nz) js <- sample(ln,nz) system.time(for (i in 1:nz) smat[is[i], js[i]] <- i) system.time(smat[cbind(is,js)] <- 1:nz) getClass("spam") spam.options(NAOK=TRUE) as.spam( c(1, NA)) } \author{Reinhard Furrer} \keyword{algebra} spam/man/bandwidth.Rd0000644000176000001440000000151312346261543014256 0ustar ripleyusers% This is file ../spam/man/bandwidth.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{bandwidth} \alias{bandwidth} \title{Bandwidth of a Sparse Matrix} \description{Returns the lower and upper bandwidth of a sparse matrix} \usage{ bandwidth(A) } \arguments{ \item{A}{spam object} } \details{The matrix does not need to be diagonal. Values can be negative indicating the the matrix contains a band cinfined in the upper or lower triangular part. } \value{Integer vector containing the lower and upper bandwidth} %\references{} \seealso{ \code{\link{diag.spam}}. } \examples{ bandwidth(spam(c(0, 1), 3, 2)) bandwidth(spam(c(0, 0, 1, rep(0, 9)), 4, 3)) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/complexity.Rd0000644000176000001440000000355612346261543014520 0ustar ripleyusers% This is file ../spam/man/complexity.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{complexity} \alias{complexity} \alias{complexities} \title{Complexity for Sparse Matrices} \description{A few results of computational complexities for selected sparse algoritms in \code{spam} } \details{A Cholesky factorization of an n-matrix requires n^3/3 flops. In case of banded matrices (bandwidth p, p<} \keyword{plot} \keyword{trace plot} \keyword{grid} spam/man/options.Rd0000644000176000001440000001300012375340506013776 0ustar ripleyusers% This is file ../spam/man/options.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{options} \alias{options.spam} \alias{spam.options} \alias{spam.getOption} \alias{.Spam} \title{Options Settings} \description{ Allow the user to set and examine a variety of \emph{options} which affect the way in which \R computes and displays sparse matrix results. } \usage{ spam.options(\dots) spam.getOption(x) } \arguments{ \item{\dots}{any options can be defined, using \code{name = value} or by passing a list of such tagged values. However, only the ones below are used in \code{spam}.\cr Further, \code{spam.options('name') == spam.options()['name']}, see the example. } \item{x}{a character string holding an option name.} } \details{ Invoking \code{spam.options()} with no arguments returns a list with the current values of the options. To access the value of a single option, one should use \code{spam.getOption("eps")}, e.g., rather than \code{spam.options("eps")} which is a \emph{list} of length one.\cr Internally, the options are kept in the list \code{.Spam}.\cr Of course, printing is still subordinate to \code{getOption("max.print")} or similar options. } \value{ For \code{spam.getOption}, the current value set for option \code{x}, or \code{NULL} if the option is unset. For \code{spam.options()}, a list of all set options sorted by category. For \code{spam.options(name)}, a list of length one containing the set value, or \code{NULL} if it is unset. For uses setting one or more options, a list with the previous values of the options changed (returned invisibly). } \section{Options used}{ A short description with the default values follows. \describe{ \item{\code{eps=.Machine$double.eps}:}{values smaller than this are considered as zero. This is only used when creating spam objects.} \item{\code{drop=FALSE}:}{default parameter for \code{drop} when subsetting} \item{\code{printsize=100}:}{the max number of elements of a matrix which we display as regular matrix.} \item{\code{imagesize=10000}:}{the max number of elements of a matrix we display as regular matrix with \code{image} or \code{display}. Larger matrices are represented as dots only.} \item{\code{cex=1200}:}{default dot size for \code{image} or \code{display}.} \item{\code{structurebased=FALSE}:}{should operations be carried out on the nonzero entries (the structure) or including the zeros.} \item{\code{inefficiencywarning=1e6}:}{issue a warning when inefficient operations are performed and the matrix exceeds the specified size. Valid value is a postive integer or a logical. \code{TRUE} corresponds to 1 (always), \code{FALSE} to \code{Inf}.} \item{\code{trivalues=FALSE}:}{a flag whether to return the structure (\code{FALSE}) or the values themselves (\code{TRUE}) when returning the upper and lower triangular part of a matrix.} \item{\code{listmethod="PE"}:}{algorithm for \code{spam.list}. Default is suggestion by Paul Eilers (thanks). Any other specification uses a bubble sort algorithm which is only slightly faster for very sparse matrices. } \item{\code{dopivoting=TRUE}:}{default parameter for "solve" routines. \code{FALSE} would solve the system without using the permutation.} \item{\code{NAOK=FALSE}:}{logical determines if NA, NaN and Inf are allowed to Fortan. Setting to TRUE allows to work with these but full functionality has not been tested.} \item{\code{safemodevalidity=TRUE}:}{logical determines if sanity check is peformed when constructing sparse matrices. Default is safer but somewhat slower.} \item{\code{cholsymmetrycheck=TRUE}:}{for the Cholesky factorization, verify if the matrix is symmetric.} \item{\code{cholpivotcheck=TRUE}:}{for the Cholesky factorization, when passing a permutation, should a minimum set of checks be performed?} \item{\code{cholupdatesingular="warning"}:}{for a Cholesky update, what happens if the matrix is singular: \code{"warning"} only and returning the not updated factor, \code{"error"} or return simply \code{"NULL"}.} \item{\code{cholincreasefactor=c(1.25,1.25)}:}{If not enought memory could be allocated, these are the steps to increase it.} \item{\code{nnznearestdistnnz=c(400^2,400)}:}{Memory allocation parameters for \code{nearest.dist}.} \item{\code{nearestdistincreasefactor=1.25}:}{If not enought memory could be allocated, this is the step to increase it. } } } \seealso{Functions influenced by these options include: \code{\link{print.spam}}, \code{\link{display.spam}}, \code{\link{image.spam}}, \code{\link{upper.tri.spam}}, \code{\link{chol.spam}}, \code{\link{nearest.dist}}, etc.\cr \code{\link{powerboost}}\cr } \author{\code{spam.options} is essentially identical to \code{sm.options}.} \examples{ op <- spam.options() # two ways of representing the options nicely. utils::str(op) noquote(format(op) ) smat <- diag.spam( 1:8) smat spam.options( printsize=49) smat # Reset to default values: spam.options( eps=.Machine$double.eps, drop=FALSE, printsize=100, imagesize=10000, cex=1200, structurebased=FALSE, inefficiencywarning=1e6, trivalues=FALSE, listmethod="PE", NAOK=FALSE, safemodevalidity=TRUE, dopivoting=TRUE, cholsymmetrycheck=TRUE, cholpivotcheck=TRUE, cholupdatesingular="warning", cholincreasefactor=c(1.25,1.25), nearestdistincreasefactor=1.25, nearestdistnnz=c(400^2,400) ) } \keyword{IO} \keyword{environment} \keyword{error} \keyword{print} spam/man/grid_zoom.Rd0000644000176000001440000000645512346261543014315 0ustar ripleyusers% This is file ../spam/man/grid_zoom.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{grid_zoom} \alias{grid_zoom} \title{grid_zoom} \description{This function takes a grob object (e.g. created with package grid) and adds a zoom window. } \usage{ grid_zoom(inputGrob = pointsGrob(runif(200),runif(200)), inputViewport = viewport(name='main'), x = 'topleft', y, just, ratio = c(.3,.4), zoom_xlim, zoom_ylim, rect = TRUE, rect_lwd = 1, rect_fill = 'gray92', draw =TRUE, zoom_fill = 'white', zoom_frame_gp = gpar(lwd = 1), zoom_gp = NULL, zoom_xaxis = xaxisGrob(main = FALSE), zoom_yaxis = NULL) } \arguments{ \item{inputGrob}{A grob object, e.g created with package grid.} \item{inputViewport}{Viewport related to \code{inputGrob}.} \item{x}{Specifies the \code{x} coordinate of the zoom window. Alternatively it can be set to 'topleft', 'topright', 'bootmleft' or 'bootmright'} \item{y}{Specifies the \code{y} coordinate of the zoom window. } \item{just}{Specifies the justification of the zoom window. } \item{ratio}{Specifies size of the zoom window relative to the main window. } \item{zoom_xlim}{Specifies xlim value of the zoom window. } \item{zoom_ylim}{Specifies ylim value of the zoom window. } \item{rect}{Logical, if TRUE a rectangle of the zoom region is draw in the main window. } \item{rect_lwd}{lwd of the rectangle. } \item{rect_fill}{fill of the rectangle. } \item{draw}{logical, if TRUE the returned grob object is also drawn.} \item{zoom_fill}{fill color of the zoom window.} \item{zoom_frame_gp}{gpar() of the frame of the zoom window.} \item{zoom_gp}{gpar() of the inputGrob in the zoom viewport.} \item{zoom_xaxis}{xaxisGrob() to draw for the zoom window.} \item{zoom_yaxis}{yaxisGrob() to draw for the zoom window.} } \value{A grob object.} \details{ A zoom plot does only make sense if all objects of the \code{inputGrob} are specified in \code{native} units. Additional caution me be require for certain grobs: e.g. a zoom of a circleGrob() is problematic if the x and y axis are stretched by a different amount. } %\references{} \seealso{grid_trace2} \examples{ ## -- Example 1 -- set.seed(133) grid_zoom(inputGrob = pointsGrob(runif(200), runif(200)), inputViewport = viewport(name = 'main'), zoom_xlim = c(.2, .3), zoom_ylim = c(.2, .3)) ## -- Example 2 -- ## initial plot grid.newpage() vp <- viewport(width=.8, height=.8, clip='on') gt <- gTree(children=gList(polylineGrob(x=c((0:4)/10, rep(.5, 5), (10:6)/10, rep(.5, 5)), y=c(rep(.5, 5), (10:6/10), rep(.5, 5), (0:4)/10), id=rep(1:5, 4), default.units='native', gp=gpar(col=1:5, lwd=3)), pointsGrob(runif(1000), runif(1000),pch='.', gp=gpar(cex=3)), rectGrob(gp=gpar(lwd=3)))) pushViewport(vp) grid.draw(gt) ## plot with zoom window grid.newpage() grid_zoom(inputGrob = gt, inputViewport = vp, x='topright', zoom_xlim=c(.6,.73), zoom_ylim=c(.3,.43),ratio=.4, zoom_xaxis = NULL, zoom_gp = gpar(cex=3)) } \author{Florian Gerber } \keyword{zoom_grid} \keyword{zoom} \keyword{plot} \keyword{grid} spam/man/nearestdist.Rd0000644000176000001440000000771512377562062014655 0ustar ripleyusers% This is file ../spam/man/nearestdist.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{nearestdist} \alias{dist.spam} \alias{nearest.dist} \alias{distance} \title{Distance Matrix Computation} \description{This function computes and returns specific elements of distance matrix computed by using the specified distance measure.} \usage{ nearest.dist( x, y=NULL, method = "euclidean", delta = 1, upper = if (is.null(y)) FALSE else NULL, p=2, miles=TRUE, R=NULL) } \arguments{ \item{x}{Matrix of first set of locations where each row gives the coordinates of a particular point. See also \sQuote{Details}.} \item{y}{Matrix of second set of locations where each row gives the coordinates of a particular point. If this is missing \code{x} is used. See also \sQuote{Details}.} \item{method}{the distance measure to be used. This must be one of \code{"euclidean"}, \code{"maximum"}, \code{"minkowski"} or \code{"greatcircle"}. Any unambiguous substring can be given.} \item{delta}{only distances smaller than \code{delta} are recorded, see Details.} \item{upper}{Should the entire matrix (\code{NULL}) or only the upper-triagonal (\code{TRUE}) or lower-triagonal (\code{FALSE}) values be calculated.} \item{p}{The power of the Minkowski distance.} \item{miles}{For great circle distance: If true distances are in statute miles if false distances in kilometers.} \item{R}{For great circle distance: Radius to use for sphere to find spherical distances. If \code{NULL} the radius is either in miles or kilometers depending on the values of the miles argument. If \code{R=1} then distances are of course in radians.} % \item{eps}{deprecated. Left for backwards consistency.} % \item{diag}{deprecated. Left for backwards consistency. See \sQuote{Details}.} } \value{A \code{spam} object containing the distances spanned between zero and \code{delta}. The sparse matrix may contain many zeros (e.g., collocated data). However, to calculate covariances, these zeros are essential.} \details{For great circle distance, the by 2 matrices \code{x} and \code{y} contain the degrees longitudes in the first and the degrees latitudes in the second column. \code{eps} and \code{delta} are in degrees. Hence to restrict to distances smaller than \code{delta.km}, one has to specify \code{delta=delta.km*360/(6378.388*2*pi)}. The distance is in single precision (I am still not sure where I lose the double precision in the Fortran code) and if calculating the entire matrix \code{upper=NULL} (instead of adding its transpose) it may not pass the symmetry checks, for example.\cr Default value of Earth's radius is 3963.34miles (6378.388km).\cr The formerly depreciated arguments \code{eps} and \code{diag} are now eliminated. \code{x} and \code{y} can be any object with an existing \code{as.matrix} method.\cr A quick scan revealed distance functions in at least 7 packages (around 2008). The argument names should be as general as possible and be coherent with many (but not all) available distance functions.\cr The Fortran code is based on a idea of Doug Nychka. } %\references{} \seealso{\code{\link{spam_rdist}}} \examples{ # Note that upper=T and using t(X)+X is quicker than upper=NULL; # upper=T marginally slower than upper=F. # To compare nearest.dist with dist, use as.dist(...) nx <- 4 x <- expand.grid(as.double(1:nx),as.double(1:nx)) sum( ( as.dist(nearest.dist( x, delta=nx*2))- dist(x) )^2) # Create nearest neighbor structures: par(mfcol=c(1,2)) x <- expand.grid(1:nx,1:(2*nx)) display( nearest.dist( x, delta=1)) x <- expand.grid(1:(2*nx),1:nx) display( nearest.dist( x, delta=1)) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/operations.Rd0000644000176000001440000001255112374456106014503 0ustar ripleyusers% This is file ../spam/man/operations.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{spam operations} \alias{Ops.spam} \alias{spam.ops} \alias{\%*\%-methods} \alias{\%*\%,ANY,ANY-method} \alias{\%*\%,spam,spam-method} \alias{\%*\%,spam,matrix-method} \alias{\%*\%,spam,numeric-method} \alias{\%*\%,matrix,spam-method} \alias{\%*\%,numeric,spam-method} \alias{\%d*\%} \alias{\%d*\%,spam,spam-method} \alias{\%d*\%,spam,ANY-method} \alias{\%d*\%,matrix,spam-method} \alias{\%d*\%,matrix,ANY-method} \alias{\%d*\%,spam,numeric-method} \alias{\%d*\%,numeric,spam-method} \alias{\%d*\%,numeric,matrix-method} \alias{\%d*\%,numeric,numeric-method} \alias{\%d+\%} \alias{\%d+\%,spam,spam-method} \alias{\%d+\%,spam,ANY-method} \alias{\%d+\%,matrix,spam-method} \alias{\%d+\%,matrix,ANY-method} \alias{\%d+\%,spam,numeric-method} \alias{\%d+\%,numeric,matrix-method} \alias{\%d+\%,numeric,spam-method} \alias{\%d+\%,numeric,numeric-method} \alias{+,spam,spam-method} \alias{+,ANY,spam-method} \alias{+,spam,ANY-method} \alias{-,spam,spam-method} \alias{-,ANY,spam-method} \alias{-,spam,ANY-method} \alias{*,spam,spam-method} \alias{*,ANY,spam-method} \alias{*,spam,ANY-method} \alias{/,spam,spam-method} \alias{/,ANY,spam-method} \alias{/,spam,ANY-method} \alias{^,spam,spam-method} \alias{^,ANY,spam-method} \alias{^,spam,ANY-method} \alias{&,spam,ANY-method} \alias{&,spam,spam-method} \alias{&,ANY,spam-method} \alias{|,spam,ANY-method} \alias{|,ANY,spam-method} \alias{|,spam,spam-method} \alias{^,spam-method} \alias{\%\%,spam-method} \alias{\%/\%,spam-method} \alias{>,spam-method} \alias{>=,spam-method} \alias{<,spam-method} \alias{<=,spam-method} \alias{==,spam-method} \alias{!=,spam-method} \alias{norm} \alias{norm.spam} \alias{norm,ANY-method} \alias{norm,spam,character-method} \alias{norm,spam,missing-method} \alias{norm,numeric,missing-method} \alias{norm,numeric,character-method} \alias{norm,matrix,missing-method} \alias{norm,matrix,character-method} %\alias{t,ANY-method} %\alias{t,spam-method} \alias{t.spam} \alias{ncol,spam-method} \alias{nrow,spam-method} \alias{dim,ANY-method} \alias{dim,spam-method} \alias{[.spam} \alias{[<-.spam} \alias{[<-,spam,missing,missing-method} \alias{[<-,spam,missing,vector-method} \alias{[<-,spam,vector,missing-method} \alias{[<-,spam,vector,vector-method} \alias{[<-,spam,matrix,missing-method} \alias{[<-,spam,matrix,matrix-method} \alias{[<-,spam,spam,missing-method} \alias{[<-,spam,ANY,ANY-method} \alias{plot.spam} \alias{subset.spam} \alias{subset.rows.spam} \alias{assign.spam} \title{Basic Linear Algebra for Sparse Matrices} \description{Basic linear algebra operations for sparse matrices of class \code{spam}. } %\usage{x \%*\% y %y \%d*\% x %y \%d+\% x %x[i,] %... %} %\arguments{ %\item{x}{matrix of class \code{spam}.} %\item{y}{matrix of class \code{spam} or a dense matrix or vector.} %\item{value}{replacement values.} %\item{i,j}{vectors of elements to extract or replace.} %\item{nrow}{optional number of rows for the result.} %} \details{Linear algebra operations for matrices of class \code{spam} are designed to behave exactly as for regular matrices. In particular, matrix multiplication, transpose, addition, subtraction and various logical operations should work as with the conventional dense form of matrix storage, as does indexing, rbind, cbind, and diagonal assignment and extraction (see for example \code{\link{diag}}). Further functions with identical behavior are \code{dim} and thus \code{nrow}, \code{ncol}. The function \code{norm} calculates the (matrix-)norm of the argument. The argument \code{type} specifies the \code{l1} norm, \code{sup} or max norm (default), or the Frobenius or Hilbert-Schmidt (\code{frobenius/hs}) norm. Partial matching can be used. For example, \code{norm} is used to check for symmetry in the function \code{chol} by computing the norm of the difference between the matrix and its transpose The operator \code{\%d*\%} efficiently multiplies a diagonal matrix (in vector form) and a sparse matrix and is used for compatibility with the package fields. More specifically, this method is used in the internal functions of \code{Krig} to make the code more readable. It avoids having a branch in the source code to handle the diagonal or nondiagonal cases. Note that this operator is not symmetric: a vector in the left argument is interpreted as a diagonal matrix and a vector in the right argument is kept as a column vector. The operator \code{\%d+\%} efficiently adds a diagonal matrix (in vector form) and a sparse matrix, similarly to the operator \code{\%d+\%}. } \references{Some Fortran functions are based on \url{http://www-users.cs.umn.edu/~saad/software/SPARSKIT/sparskit.html} } \seealso{ \code{\link{spam}} for coercion and other class relations involving the sparse matrix classes. } \examples{ # create a weight matrix and scale it: \dontrun{ wij <- distmat # with distmat from a nearest.dist(..., upper=TRUE) call n <- dim(wij)[1] wij@entries <- kernel( wij@entries, h) # for some function kernel wij <- wij + t(wij) + diag.spam(n) # adjust from diag=FALSE, upper=TRUE sumwij <- wij \%*\% rep(1,n) # row scaling: # wij@entries <- wij@entries/sumwij[ wij@colindices] # col scaling: wij@entries <- wij@entries/sumwij[ rep(1:n, diff(wij@rowpointers))] } } \keyword{algebra} spam/man/circulant.Rd0000644000176000001440000000212412346261543014275 0ustar ripleyusers% This is file ../spam/man/circulant.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{circulant} \alias{circulant.spam} \title{Create Circulant Matrices} \description{Creates a circulant matrix in \code{spam} format.} \usage{ circulant.spam(x, n = NULL, eps = .Spam$eps) } \arguments{ \item{x}{the first row to form the circulant matrix or a list containing the indices and the nonzero values.} \item{n}{if \code{x} is a list, the dimension of the matrix.} \item{eps}{A tolerance parameter: elements of \code{x} such that \code{abs(x) <= eps} set to zero. Defaults to \code{eps = .Spam$eps}} } \value{The circulant matrix in \code{spam} format.} %\details{The vector \code{y} has to be of the same length as \code{x} % and its first element is discarded. % } %\references{} \seealso{\code{\link[magic]{circulant}} from package \pkg{magic}, \code{\link{toeplitz.spam}}} \examples{ circulant.spam(c(1,.25,0,0,0)) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/display.Rd0000644000176000001440000000322312346261543013757 0ustar ripleyusers% This is file ../spam/man/display.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{display} \alias{display} \alias{display.spam} \alias{display,spam-method} %\alias{display,spam.chol.NgPeyton-method} \title{Graphially Represent the Nonzero Entries} \description{The function represents the nonzero entries in a simple bicolor plot. } \usage{ display(x, ...) } \arguments{\item{x}{matrix of class \code{spam} or \code{spam.chol.NgPeyton}.} % \item{cex}{for very large matrices, the dot size may need to be scaled.} \item{...}{any other arguments passed to \code{image.default}/\code{plot}.} } %\value{} \details{\code{spam.getOption("imagesize")} determines if the sparse matrix is coerced into a matrix and the plotted with \code{image.default} or if the matrix is simply represented as a scatterplot with \code{pch="."}. The points are scaled according to \code{cex*spam.getOption("cex")/(nrow + ncol)}. For some devices or for non-square matrices, \code{cex} needs probably some adjustment. } %\references{} \seealso{\code{\link{image}}, \code{\link{spam.options}}} \examples{ set.seed(13) nz <- 8 ln <- nz smat <- spam(0, ln, ln) smat[cbind(sample(ln, nz), sample(ln, nz))] <- 1:nz par(mfcol=c(1,2), pty='s') spam.options(imagesize = 1000) display(smat) spam.options(imagesize = 10) display(smat) # very large but very sparse matrix nz <- 128 ln <- nz^2 smat <- spam(0, ln, ln) smat[cbind(sample(ln, nz), sample(ln, nz))] <- 1:nz par(mfcol=c(1, 1), pty='s') display(smat, cex = 100) } \author{Reinhard Furrer} \keyword{hplot} spam/man/history.spam.Rd0000644000176000001440000000271412346261543014756 0ustar ripleyusers% This is file ../spam/man/history.spam.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{history} \alias{history.spam} \alias{spam.history} \alias{history} \title{Brief Overview of the History} \description{Brief overview of \code{spam}s history} \usage{ spam.history() } \details{Many years ago, I required sparse matrix algebra capacities in \R for my research. The packages available at that time where not necessarily satisfying for my purpose. Hence, I started writing my own functions, somewhat inspired by the package \code{SparseM}. Over the years, I decided to write an \R package, called \code{spam}. In mean time, we have tree significant sparse matrix packages posted on CRAN. I believe that all three have their own niche of users. I believe that \code{spam} is stable, useful but definitely not fully matured. I appreciate all comments and remarks. There is no need to maintain here a complete list of changes. Older versions are available on CRAN (>0.11), each coming with a proper history file. } \references{See also a more detailed description at \url{http://www.math.uzh.ch/furrer/software/spam/history.shtml}.} \seealso{\code{\link{todo}}.} \examples{ \dontrun{ ## A complete history of changes file.show(system.file("NEWS", package = "spam")) file.show(system.file("0NEWS", package = "spam")) } } \keyword{internal} spam/man/germanydata.Rd0000644000176000001440000000344012346261543014607 0ustar ripleyusers% This is file ../spam/man/germanydata.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{germany.data} \alias{germany.data} \alias{germany.info} \alias{germany.poly} \alias{germany.spam} \alias{germany} \docType{data} \title{Meta-data about administrative districts of Germany} \description{Data for the display of data over the administrative districts of Germany} \format{\code{germany.info} is a list with elements \describe{ \item{n}{544 (number of districts around 1990).} \item{xrep,yrep}{representative coordinates of the districts (vectors of length 544)} \item{xlim,ylim}{2-vectors defining the limits of the districts.} \item{polyid}{linking the polygons to the districts (599 vector).} \item{id}{linking the districts to Community Identification Number.}} \code{germany.poly} defines the polygons. It is a 17965 by two matrix, each polygon separated by a row of \code{NA}s, each district by two rows.\cr \code{germany} defines the polygons in form of a list (backwards compatibility). } \references{The meta-data has been constructed based on (essentially) files from the package \pkg{INLA}, see \code{demo(Bym)}.\cr See also \url{http://de.wikipedia.org/wiki/Amtlicher_Gemeindeschl\%C3\%BCssel} and \url{http://de.wikipedia.org/wiki/Liste_der_Landkreise_in_Deutschland}} \details{The representative coordinates are calculated based on the mean value of the polygon coordinates. This creates sometimes strange values, e.g., district Leer.} \seealso{\code{\link{germany.plot}} \code{\link{Oral}}.} \examples{ # Plot the Bundeslaender: germany.plot(germany.info$id\%/\%1000,col=rep(2:8,3), legend=FALSE) } \author{Reinhard Furrer} \keyword{hplot} spam/man/landkreis.Rd0000644000176000001440000000323412346261543014270 0ustar ripleyusers% This is file ../spam/man/landkreis.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{map.landkreis} \alias{map.landkreis} \title{Administrative districts of Germany} \description{Displaying data over the administrative districts of Germany} \usage{ map.landkreis(data, col=NULL, zlim=range(data), add=FALSE, legendpos=c( 0.88,0.9,0.05,0.4)) } \arguments{ \item{data}{vector of length 544} \item{col}{color scheme to be used. By default uses \code{tim.colors} if available or a generic gray scale.} \item{zlim}{the minimum and maximum values for which colors should be plotted, defaulting to the range of \code{data}.} \item{add}{logical, if true adds to current plot.} \item{legendpos}{if package \pkg{fields} is loaded, puts a legend at that position.} } \references{The code of \code{map.landkreis} is very similar to \code{germany.map} from the package \pkg{INLA}.} \details{The function \code{\link{germany.plot}} super-seeds \code{map.landkreis} (it is several factors faster). \cr The perfect position of the legend is an art per se and depends on various \code{par} parameters. See also the source code of the function \code{image.plot} of \pkg{fields}.} \seealso{\code{\link{germany.plot}} super-seeding \code{map.landkreis}.} \examples{ \dontrun{ data( Oral) par( mfcol=c(1,2)) germany.plot( log( Oral$Y), legend=TRUE) map.landkreis( log( Oral$Y)) } } \author{Reinhard Furrer} \keyword{hplot} % dev.off() % dev.off();system.time( for (i in 1:20) map.landkreis(1:544)) % dev.off();system.time( for (i in 1:20) germany.plot(1:544)) spam/man/powerboost.Rd0000644000176000001440000000132012372657166014522 0ustar ripleyusers% This is file ../spam/man/powerboost.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{powerboost} \alias{powerboost} \title{Specific options Setting} \description{ Sets several options for speed-up. } \usage{ powerboost(flag) } \arguments{ \item{flag}{on or off} } \details{The options turn checking off (\code{"safemode"}, \code{"cholsymmetrycheck"} and \code{"cholpivotcheck"}) and switch to single precision for \code{"eps"}.} \value{ \code{NULL} in any case. } \seealso{\code{\link{spam.options}}. } \author{Reinhard Furrer, after receiving too much C.mc.st adds.} \keyword{environment} spam/man/headtail.Rd0000644000176000001440000000366612375336700014100 0ustar ripleyusers% This is file ../spam/man/headtail.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{head} \alias{head.spam} \alias{head,spam-method} \alias{head,spam.chol.NgPeyton-method} \alias{tail.spam} \alias{tail,spam-method} \alias{tail,spam.chol.NgPeyton-method} \title{ Return the First or Last Part of an Object } \description{ Returns the upper left or lower right part of a \code{\linkS4class{spam}} object. } \usage{ \S4method{head}{spam}(x, n = 6L, m = n, \dots) \S4method{tail}{spam}(x, n = 6L, m = n, addrownums = TRUE, \dots) } \arguments{ \item{x}{a \code{\linkS4class{spam}} object} \item{n}{a single integer. If positive, size for the resulting object: number of elements for a vector (including lists), rows for a matrix or data frame or lines for a function. If negative, all but the \code{n} last/first number of elements of \code{x}.} \item{m}{similar to \code{n} but for the number of columns.} \item{addrownums}{create row and column namves them from the selected elements.} \item{\dots}{arguments to be passed to or from other methods.} } \details{ For matrices, 2-dim tables and data frames, \code{head()} (\code{tail()}) returns the first (last) \code{n} rows and \code{m} columns when \code{n > 0} or all but the last (first) \code{n} rows when \code{n < 0} (with similar behavior for \code{m}). \code{tail()} will add row and column names of the form \code{"[n,]"} and \code{"[,n]"} to the result, so that it looks similar to the last lines and columns of \code{x} when printed. Setting \code{addrownums = FALSE} suppresses this behaviour. A method for \code{\linkS4class{spam.chol.NgPeyton}} objects is exported as well. } \value{ An regular matrix. } \author{ Reinhard Furrer } \examples{ head( precmat.RW2( 10)) tail( precmat.season(n=10, season=3), n=4, m=10) } \keyword{ manip } spam/man/s3only.Rd0000644000176000001440000000200612375335731013542 0ustar ripleyusers% This is file ../spam/man/s3only.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{s3only} \alias{var.spam} \alias{eigen.spam} \title{Wappers for Sparse Matrices} \description{ These functions are convenient wrappers for \code{spam} objects to classical matrix operations.} \usage{ var.spam(x, \dots) eigen.spam(x, \dots) \S3method{var}{spam}(x, \dots) \S3method{eigen}{spam}(x, \dots) } \arguments{ \item{x}{matrix of class \code{spam}.} \item{\dots}{further arguments passed to or from other methods.} } \value{Depends on function\dots } \details{There is probably no point in fully defining methods here. Typically, these functions do not exploit sparsity structures. Hence, for very large matrices, warnings may be posted.} %\references{} %\note{} \seealso{Option \code{"inefficiencywarning"} in \code{\link{spam.options}}. } \examples{ eigen( diag.spam(3)) } \author{Reinhard Furrer} \keyword{algebra} spam/man/triplet.Rd0000644000176000001440000000224312346261543013776 0ustar ripleyusers% This is file ../spam/man/triplet.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{triplet} \alias{triplet} \title{Transform a spam format to triplets} \description{Returns a list containing the indices and elements of a \code{spam} object.} \usage{ triplet(x, tri=FALSE) } \arguments{ \item{x}{sparse matrix of class \code{spam} or a matrix.} \item{tri}{Boolean indicating whether to create individual row and column indices vectors.} } \value{A list with elements \item{indices}{a by two matrix containing the indices if \code{tri=FALSE}.} \item{i,j}{vectors containing the row and column indices if \code{tri=TRUE}.} \item{values}{a vector containing the matrix elements.} } \details{ The elements are row (column) first if \code{x} is a \code{spam} object (matrix).\cr } %\references{} \seealso{ \code{\link{spam.list}} for the inverse operation and \code{foreign} for other transformations.} \examples{ x <- diag.spam(1:4) x[2,3] <- 5 triplet(x) all.equal( spam( triplet(x, tri=TRUE)), x) } \author{Reinhard Furrer} \keyword{array} spam/man/rmvnorm.const.Rd0000644000176000001440000000415512372215211015132 0ustar ripleyusers% This is file ../spam/man/rmvnorm.const.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{rmvnorm.const} \alias{rmvnorm.const} \alias{rmvnorm.prec.const} \alias{rmvnorm.canonical.const} \title{Draw Constrainted Multivariate Normals} \description{ Fast ways to draw multivariate normals with linear constrains when the variance or precision matrix is sparse.} \usage{ rmvnorm.const(n, mu = rep(0, nrow(Sigma)), Sigma, Rstruct = NULL, A = array(1, c(1,nrow(Sigma))), a=0, U=NULL, ...) rmvnorm.prec.const(n, mu = rep(0, nrow(Q)), Q, Rstruct = NULL, A = array(1, c(1,nrow(Q))), a=0, U=NULL, ...) rmvnorm.canonical.const(n, b, Q, Rstruct = NULL, A = array(1, c(1,nrow(Q))), a=0, U=NULL, ...) } \arguments{ \item{n}{number of observations.} \item{mu}{mean vector.} \item{Sigma}{covariance matrix of class \code{spam}.} \item{Q}{precision matrix.} \item{b}{vector determining the mean.} \item{Rstruct}{the Cholesky structure of \code{Sigma} or \code{Q}.} \item{A}{Constrain matrix.} \item{a}{Constrain vector.} \item{U}{see below.} \item{\dots}{arguments passed to \code{chol}.} } \details{The functions \code{rmvnorm.prec} and \code{rmvnorm.canonical} do not requrie sparse precision matrices. For \code{rmvnorm.spam}, the differences between regular and sparse covariance matrices are too significant to be implemented here. \cr Often (e.g., in a Gibbs sampler setting), the sparsity structure of the covariance/precision does not change. In such setting, the Cholesky factor can be passed via \code{Rstruct} in which only updates are performed (i.e., \code{update.spam.chol.NgPeyton} instead of a full \code{chol}). } %\note{There is intentionally no \acronym{S3} distinction between the classes % \code{spam} and \code{spam.chol.}\emph{method}.} \references{See references in \code{\link{chol}}. } \seealso{\code{\link{rmvnorm.spam}}. } \examples{ # to be filled in } % backsolve( chol(as.matrix(V)[ord,ord]),iidsample)[iord,] % \author{Reinhard Furrer} \keyword{algebra} spam/man/permutation.Rd0000644000176000001440000000257412375340524014670 0ustar ripleyusers% This is file ../spam/man/permutation.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{permutation} \alias{permutation} \alias{permutation.spam} \alias{permutation,spam-method} \alias{permutation,matrix-method} \title{Permute a matrix} \description{Row and/or column permutes a matrix. } \usage{ permutation.spam(A, P=NULL, Q=NULL, ind=FALSE, check=TRUE) } \arguments{ \item{A}{sparse matrix} \item{P}{vector giving the row permutation.} \item{Q}{vector giving the column permutation.} \item{ind}{are the indices given. See examples.} \item{check}{Should rudimentary checks be performed.} } \value{A permuted matrix. } \details{If P and Q are permutation matrices, the result is PAQ. However, it is also possible to specify the indices and to perform in a very efficient way \code{A[rowind, colind]}, see examples. A row permutation is much faster than a colum permutation. For very large matrices, a double transpose might be faster. The spam option \code{checkpivot} determines if the permutation is verified. } %\references{ %} \seealso{\code{\link{ordering}}, \code{\link{spam.options}}.} \examples{ A <- spam(1:12,3) P <- c(3,1,2) Q <- c(2,3,1,4) permutation(A,P,Q)-A[order(P),order(Q)] permutation(A,P,Q,ind=TRUE)-A[P,Q] } \author{Reinhard Furrer} \keyword{array}spam/man/constructors.Rd0000644000176000001440000000175112375412762015071 0ustar ripleyusers% This is file ../spam/man/constructors.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{constructors} \alias{rowpointers} \alias{rowpointers<-} \alias{colindices} \alias{colindices<-} \alias{entries} \alias{entries<-} \alias{dimension<-} \alias{constructors} \title{Slot modification} \description{Modify slots of \code{spam} objects } \usage{ rowpointers( x) <- value colindices( x) <- value entries( x) <- value} \arguments{ \item{x}{a \code{spam} matrix} \item{value}{vector of appropriate length.} } \value{Modified \code{spam} object.} \details{Various tests are performed. Thus much slower than direct assignment.\cr Slot \code{dimension} should be changed through \code{pad} or \code{dim} } \examples{ x <- diag.spam( 2) rowpointers( x) <- c(1,1,3) # The last line is equivalent to x@rowpointers <- as.integer( c(1,1,3)) } \author{Reinhard Furrer} \keyword{array} spam/man/Oral.Rd0000644000176000001440000000255012346261543013211 0ustar ripleyusers% This is file ../spam/man/Oral.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{Oral} \alias{Oral} \alias{Oral.spam} \alias{oral.spam} \docType{data} \title{Oral Cavity Cancer} \description{Oral cavity cancer counts in 544 districts in Germany over 1986-1990.} \format{\code{Oral} is a dataframe with 3 columns. \describe{ \item{Y}{observed counts} \item{E}{expected counts} \item{SMR}{standardized mortality ratios}} \code{germany} is a list of 544 elements, each describing an individual polygon of the district. } \details{The expected counts depend on the number of people in the region and their age distribution.\cr The regions are ordered according the supplied polygon description and adjacency graph.\cr There is a similar dataset \code{data(Germany)} with larynx cancer cases from the package \pkg{INLA} as well, with an additional smoking covariate. } \source{The data is available from the package \pkg{INLA} distributed from \url{www.r-inla.org} or from\cr \url{http://www.math.ntnu.no/~hrue/GMRF-book/oral.txt} } \references{ Knorr-Held, L. and Rasser, G. (2000) Bayesian Detection of Clusters and Discontinuities in Disease Maps, \emph{Biometrics}, 56, 13--21. } \seealso{\code{\link{germany.plot}}.} \keyword{datasets} spam/man/coercion.Rd0000644000176000001440000000246212377564173014130 0ustar ripleyusers% This is file ../spam/man/coercion.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{Coercion} \docType{class} \alias{as.vector.spam} \alias{as.vector,spam-method} \alias{as.vector,spam.chol.NgPeyton-method} \title{Coercion to a Vector} \description{Coercion of \code{spam} matrices to proper vector objects } \usage{\S4method{as.vector}{spam}(x, mode = "any") } \arguments{\item{x}{spam object.} \item{mode}{character string naming an atomic mode or \code{"any"}/\code{"list"}/\code{"expression"}.} } \value{If \code{structurebased=TRUE}, the vector \code{x@entries}.\cr Conversely, if \code{structurebased=FALSE}, the result is identical to one with \code{as.vector(as.matrix(x))}. } \details{This coercion allows smooth transitions between different matrix formats, see example below.\cr The Cholesky factors are first transformed to a \code{spam} object. } %\references{ %} \seealso{\code{\link{spam.options}}} \examples{ x <- diag(2) ifelse( x, x, 1-x) ifelse( x, as.vector(x), 1-as.vector(x)) x <- diag.spam(2) spam.options( structurebased=FALSE) ifelse( x, as.vector(x), 1-as.vector(x)) spam.options( structurebased=TRUE) ifelse( x, as.vector(x), 1-as.vector(x)) } \author{Reinhard Furrer} \keyword{manip} spam/man/rowcolstats.Rd0000644000176000001440000000243412346261543014701 0ustar ripleyusers% This is file ../spam/man/rowcolstats.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{rowSums} \alias{rowSums.spam} \alias{colSums.spam} \alias{rowMeans.spam} \alias{colMeans.spam} \alias{rowSums} \alias{colSums} \alias{rowMeans} \alias{colMeans} \alias{rowSums,spam-method} \alias{colSums,spam-method} \alias{rowMeans,spam-method} \alias{colMeans,spam-method} \title{ Form Row and Column Sums and Means } \description{ Form row and column sums and means for sparse \code{\linkS4class{spam}} matrices } \usage{ rowSums(x, na.rm = FALSE, dims = 1, \dots) colSums(x, na.rm = FALSE, dims = 1, \dots) rowMeans(x, na.rm = FALSE, dims = 1, \dots) colMeans(x, na.rm = FALSE, dims = 1, \dots) } \arguments{ \item{x}{a \code{\linkS4class{spam}} object} \item{na.rm}{currently ignored} \item{dims}{ignored as we have only two dimensions.} \item{\dots}{potentially further arguments from other methods.} } \details{ Depending on the flag \code{}. } \value{ Vector of appropriate length. } %\references{} \author{ Reinhard Furrer } %\note{} \seealso{ \code{\link{apply.spam}}, \code{\link{spam.options}}. } \examples{ x <- spam( rnorm(20), 5, 4) rowSums( x) c( x \%*\% rep(1,4)) } \keyword{manip} spam/man/todo.Rd0000644000176000001440000000260012346261543013255 0ustar ripleyusers% This is file ../spam/man/todo.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{todo} \alias{todo.spam} \alias{todo} \title{Small "ToDo" list} \description{List of what needs to be done within \code{spam} } \usage{ todo() } \details{This is a non exhaustive list of where we need to work on spam (of course the list is in random order):\cr - extend demo(s)\cr - write vignette\cr - complete help files\cr %Especially, there are still a few functions %commented in various 'usage' sections (to avoid warnings when checking %the library).\cr - extend basic matrix operatation, comparisons, etc: \cr \code{unique}, \code{duplicated}, ... - improve subsetting via row extraction, incorporate matrix permutation\cr % xtrows % - extend methods for \code{spam.chol.NgPeyton}: \cr % e.g., \code{diag} => done - implement other Cholesky routines (one eye glances to the LDL library). \cr - what about an LU/SVD decomposition?\cr % - implement \code{backsolve} and \code{forwardsolve} for \code{spam} class.\cr => done % - it might be useful to implement certain lines of code in Fortran: % say \code{rbind}, \code{cbind}, ...\cr => done Any other items are welcome (\email{reinhard.furrer@math.uzh.ch}).\cr } \keyword{internal} spam/man/toeplitz.Rd0000644000176000001440000000200312346261543014157 0ustar ripleyusers% This is file ../spam/man/toeplitz.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{toeplitz} \alias{toeplitz.spam} \title{Create Toeplitz Matrices} \description{Creates symmetric and asymmetric Toeplitz matrices.} \usage{ toeplitz.spam(x, y = NULL, eps = .Spam$eps) } \arguments{ \item{x}{the first row to form the Toeplitz matrix.} \item{y}{for asymmetric Toeplitz matrices, this contains the first column.} \item{eps}{A tolerance parameter: elements of \code{x} such that \code{abs(x) <= eps} set to zero. Defaults to \code{eps = .Spam$eps}.} } \value{The Toeplitz matrix in \code{spam} format.} \details{The vector \code{y} has to be of the same length as \code{x} and its first element is discarded. } %\references{} \seealso{\code{\link{toeplitz}}, \code{\link{circulant.spam}}} \examples{ toeplitz.spam(c(1,.25,0,0,0)) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/image.Rd0000644000176000001440000000373012375336631013402 0ustar ripleyusers% This is file ../spam/man/image.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{image} \alias{image.spam} \alias{image.spam.chol} \alias{image,spam-method} %\alias{image,spam.chol.NgPeyton-method} \title{Display a spam Object as Color Image} \description{The function creates a grid of colored rectangles with colors corresponding to the values in \code{z}. } \usage{ \S4method{image}{spam}(x, cex = NULL, ...) } \arguments{\item{x}{matrix of class \code{spam} or \code{spam.chol.NgPeyton}.} \item{cex}{for very large matrices, the dot size may need to be scaled.} \item{...}{any other arguments passed to \code{image.default} and \code{plot}.} } %\value{} \details{\code{getOption("imagesize")} determines if the sparse matrix is coerced into a matrix and the plotted similarly to \code{image.default} or if the matrix is simply represented as a scatterplot with \code{pch="."}. The points are scaled according to \code{cex*spam.getOption("cex")/(nrow+ncol)}. For some devices or for non-square matrices, \code{cex} needs probably some adjustment.\cr The a zero matrix in \code{spam} format has as (1,1) entry the value zero and only missing entries are interpreted as \code{NA} in the scatter plot. } %\references{} \seealso{\code{\link{display}} and \code{\link{spam.options}}.\cr The code is based on \code{\link[graphics]{image}} of \code{graphics}. } \examples{ set.seed(13) nz <- 8 ln <- nz smat <- spam(0, ln, ln) smat[ cbind(sample(ln,nz), sample(ln,nz))] <- 1:nz par(mfcol=c(1,2),pty='s') spam.options( imagesize=1000) image(smat) # better: col=tim.colors(nz)) spam.options( imagesize=10) image(smat) # better: col=tim.colors(nz)) nz <- 128 ln <- nz^2 smat <- spam(0,ln,ln) smat[cbind(sample(ln,nz), sample(ln,nz))] <- 1:nz par(mfcol=c(1,1), pty='s') image(smat,cex=100) # better:, col=tim.colors(nz)) } \author{Reinhard Furrer} \keyword{hplot} spam/man/bdiag.Rd0000644000176000001440000000274012346261543013363 0ustar ripleyusers% This is file ../spam/man/bdiag.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{bdiag} \alias{bdiag} \alias{bdiag.spam} \title{Binds Arrays Corner-to-Corner} \description{Creates a sparse block-diagonal matrix. } \usage{ bdiag.spam(...) } \arguments{ \item{...}{Arrays to be binded together} } \details{ This is a small helper function to create block diagonal sparse matrices. In the two matrix case, \code{bdiag.spam(A,B)}, this is equivalent to a complicated \code{rbind(cbind(A, null), cbind(B, t(null)))}, where \code{null} is a null matrix of appropriate dimension.\cr It is recursively defined. The arrays are coerced to sparse matrices first.\cr This function is similar to the function \code{bdiag} from the package \code{Matrix}. It is also similar to the function \code{adiag} from the package \code{magic}. However, here no padding is done and all the dimnames are stripped. } \value{ Returns a \code{spam} matrix as described above. } %\references{} \seealso{ \code{\link{diag.spam}}. } \examples{ A <- diag.spam(2, 4) # 2*I4 B <- matrix(1,3,3) AB <- bdiag.spam(A,B) # equivalent to: ABalt <- rbind(cbind( A, matrix(0,nrow(A),ncol(B))), cbind( matrix(0,nrow(B),ncol(A)), B)) norm(AB-ABalt) # Matrices do not need to be square: bdiag.spam(1,2:5,6) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/apply.Rd0000644000176000001440000000565512346261543013452 0ustar ripleyusers% This is file ../spam/man/apply.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{apply} \alias{apply.spam} \title{Apply Functions Over Sparse Matrix Margins} \description{Returns a vector or array or list of values obtained by applying a function to margins of a sparse matrix.} \usage{apply.spam(X, MARGIN=NULL, FUN, ...) } \arguments{ \item{X}{the \code{spam} matrix to be used.} \item{MARGIN}{a vector giving the subscripts which the function will be applied over. \code{1} indicates rows, \code{2} indicates columns, \code{NULL} or \code{c(1,2)} indicates rows and columns.} \item{FUN}{the function to be applied.} \item{...}{optional arguments to \code{FUN}.} } \details{This is a handy wrapper to apply a function to the (nonzero) elements of a sparse matrix. For example, it is possible to apply a covariance matrix to a distance matrix obtained by \code{nearest.dist}, see Examples.\cr A call to \code{apply} only coerces the sparse matrix to a regular one.\cr The basic principle is applying the function to \code{@entries}, or to the extracted columns or rows (\code{[,i,drop=F]} or \code{[i,,drop=F]}). It is important to note that an empty column contains at least one zero value and may lead to non intuitive results.\cr This function may evolve over the next few releases. } \value{Similar as a call to \code{apply} with a regular matrix. The most important cases are as follows. The result is a vector (\code{MARGIN} is length 1 and \code{FUN} is scalar) or a matrix (\code{MARGIN} is length 1 and \code{FUN} returns fixed length vectors, or \code{MARGIN} is length 2 and \code{FUN} is scalar) or a list (if \code{FUN} returns vectors of different lengths).} %\references{} \seealso{\code{base:apply} for more details on Value.} \examples{ S <- as.spam(dist(1:5)) S <- apply.spam(S/2, NULL, exp) # instead of # S@entries <- exp( S@entries/2) # Technical detail, a null matrix consists # of one zero element. apply.spam(S,c(1,2),pmax) apply.spam(S,1,range) # A similar example as for the base apply. # However, no dimnames else we would get warnings. x <- as.spam(cbind(x1 = 3, x2 = c(0,0,0, 5:2))) apply.spam(x, 2, mean, trim = .2) col.sums <- apply.spam(x, 2, sum) row.sums <- apply.spam(x, 1, sum) rbind(cbind(x, row.sums), c(col.sums, sum(col.sums))) apply.spam(x, 2, is.vector) # Sort the columns of a matrix # Notice that the result is a list due to the different # lengths induced by the nonzero elements apply.spam(x, 2, sort) # Function with extra args: cave <- function(x, c1, c2) c(mean(x[c1]), mean(x[c2])) apply(x,1, cave, c1=1, c2=c(1,2)) ma <- spam(c(1:4, 0, 0,0, 6), nrow = 2) ma apply.spam(ma, 1, table) #--> a list of length 2 apply.spam(ma, 1, stats::quantile)# 5 x n matrix with rownames } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/spam-package.Rd0000644000176000001440000000531412402354036014637 0ustar ripleyusers% This is file ../spam/man/spam-package.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{. SPAM .} \alias{overview} \alias{SPAM} \alias{Spam} \docType{package} \title{SPArse Matrix Package} \description{\code{spam} is a collection of functions for sparse matrix algebra. } \section{Gereral overview}{What is spam and what is it not:\cr While \code{Matrix} seems an overshoot of classes and \code{SparseM} focuses mainly on regression type problem, we provide a minimal set of sparse matrix functions fully functional for everyday spatial statistics life. There is however some emphasize on Markov chain Monte Carlo type calculations within the framework of (Gaussian) Markov random fields. \cr Emphasis is given on a comprehensive, simple, tutorial structure of the code. The code is S4 based but (in a tutorial spirit) the functions are in a S3 structure visible to the user (exported via \code{NAMESPACE}).\cr There exist many methods for sparse matrices that work identically as in the case of ordinary matrices. All the methods are discussed in the help and can be accessed directly via a \code{*.spam} concatenation to the function. For example, \code{help(chol.spam)} calls the help directly. We deliberately avoided aliases according to analogue helps from the base package.\cr Sparseness is used when handling large matrices. Hence, care has been used to provide efficient and fast routines. Essentially, the functions do not transform the sparse structure into full matrices to use standard (available) functionality, followed by a back transform. We agree, more operators, functions, etc. should eventually be implemented. The packages \code{fields} and \code{spam} are closely linked. \cr } \references{Reinhard Furrer, Stephan R. Sain (2010). "spam: A Sparse Matrix R Package with Emphasis on MCMC Methods for Gaussian Markov Random Fields.", \emph{Journal of Statistical Software}, 36(10), 1-25, \url{http://www.jstatsoft.org/v36/i10/.} } \seealso{See \code{\link{spam.class}} for a detailed class description, \code{\link{spam}} and \code{\link{spam.ops}} for creation, coercion and algebraic operations.%\cr% % %\code{demo(package='spam')} lists available demos.\cr% %Related packages are \code{\link[fields]{fields}}, % \code{\link[Matrix]{Matrix}} and % \code{\link[SparseM]{SparseM.ontology}}. } \examples{ \dontrun{ ## Citations: citation('spam') citation('spam',auto=TRUE) ## History of changes file.show(system.file("NEWS", package = "spam")) } } \author{Reinhard Furrer, with the help of Florian Gerber, Kaspar Moesinger and many others.} \keyword{documentation} \keyword{package} spam/man/methods.Rd0000644000176000001440000000130012401700261013732 0ustar ripleyusers% This is file ../spam/man/methods.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{spam methods} \alias{methods.spam} \title{Methods for sparse matrices} \description{Methods without any additional parameters for sparse matrices. } \details{If a method for \code{spam} objects takes the same arguments, produces the intuitive output. We do not provide additional help pages. However, such methods are usually linked to a \code{xzy.spam} function, that could also be called directly. } \seealso{Corresponding base help functions. } \author{Reinhard Furrer} \keyword{internal} spam/man/rdist.Rd0000644000176000001440000000353412377560567013460 0ustar ripleyusers% This is file ../spam/man/rdist.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{fields wrapper} \alias{spam_rdist} \alias{rdist.dist} \alias{spam_rdist.earth} \title{Wrapper for Distance Matrix Computation} \description{These functions are simple wrappers to \code{nearest.dist} to be used in \code{fields}.} \usage{ spam_rdist( x1, x2, delta = 1) spam_rdist.earth( x1, x2, delta = 1, miles=TRUE, R=NULL) } \arguments{ \item{x1}{Matrix of first set of locations where each row gives the coordinates of a particular point. } \item{x2}{Matrix of second set of locations where each row gives the coordinates of a particular point.} \item{delta}{only distances smaller than \code{delta} are recorded} \item{miles}{For great circle distance: If true distances are in statute miles if false distances in kilometers.} \item{R}{Radius to use for sphere to find spherical distances. If \code{NULL} the radius is either in miles or kilometers depending on the values of the miles argument. If \code{R=1} then distances are of course in radians.} } \value{A \code{spam} object containing the distances spanned between zero and \code{delta}. The sparse matrix may contain many zeros (e.g., collocated data). However, to calculate covariances, these zeros are essential.} \details{These functions are wrappers to \code{rdist} and \code{rdist.earth} in \code{fields}. They are used to simplify the use of sparse matrices in functions like \code{mKrig}. } %\references{} \seealso{\code{\link{nearest.dist}}} \examples{ \dontrun{ require(fields) look <- mKrig(x,Y, Covariance="Wendland", dimension=2, k=1, cov.args=list( Distance='spam_rdist')) } } \author{Reinhard Furrer} \keyword{array} spam/man/print.Rd0000644000176000001440000000362112375335233013450 0ustar ripleyusers% This is file ../spam/man/print.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{print} \docType{methods} \alias{print.spam} \alias{print,spam-method} %\alias{print,spam.chol.NgPeyton-method} \alias{print.spam.chol} \alias{print.spam.chol.NgPeyton} \alias{summary.spam} \alias{summary,spam-method} %\alias{summary,spam.chol.NgPeyton-method} \alias{summary.spam.chol} \alias{summary.spam.chol.NgPeyton} \title{Printing and summarizing sparse matrices} \description{Printing (non-zero elements) of sparse matrices and summarizing the sparsity structure thereof. } \usage{ \S4method{print}{spam}(x, ...) \S4method{summary}{spam}(object, ...) } \arguments{\item{x}{matrix of class \code{spam} or \code{spam.chol.}\emph{method}.} \item{object}{matrix of class \code{spam} or \code{spam.chol.}\emph{method}.} \item{...}{any other arguments passed to \code{print.default}.} } \value{\code{NULL} for \code{print}, because the information is printed with \code{cat} there is no real need to pass any object back. \cr % A list containing the non-zero elements and the density for \code{summary} for class \code{spam}.\cr % A list containing the non-zero elements of the factor, the density and the fill-in for \code{summary} for class \code{spam.chol.NgPeyton}.} \details{\code{spam.getOption('printsize')} determines if the sparse matrix is coerced into a matrix and the printed as an array or if only the non-zero elements of the matrix are given. } %\references{} \seealso{\code{\link{spam.options}}} \examples{ set.seed(13) nz <- 8 ln <- nz smat <- spam(0,ln,ln) smat[cbind(sample(ln,nz),sample(ln,nz))] <- 1:nz par(mfcol=c(1,2),pty='s') spam.options( printsize=1000) print(smat) spam.options( printsize=10) print(smat) summary(smat) (summary(smat)) } \author{Reinhard Furrer} \keyword{hplot} spam/man/isSymmetric.Rd0000644000176000001440000000237712346261543014633 0ustar ripleyusers% This is file ../spam/man/isSymmetric.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{isSymmetric} \alias{isSymmetric.spam} \alias{isSymmetric,spam-method} \title{Test if a spam matrix is Symmetric} \description{Efficient function to test if 'object' is symmetric or not.} \usage{ # isSymmetric.spam(object, ...) \S3method{isSymmetric}{spam}(object, tol = 100 * .Machine$double.eps, ...)} \arguments{ \item{object}{a \code{spam} matrix.} \item{tol}{numeric scalar >= 0. Smaller differences are not considered, see \code{all.equal.spam}.} \item{...}{further arguments passed to \code{all.equal.spam}.} } \details{symmetry is assessed by comparing the sparsity structure of \code{object} and \code{t(object)} via the function \code{all.equal.spam}. If a difference is detected, the matrix is cleaned with \code{cleanup} and compared again.} \value{ logical indicating if \code{object} is symmetric or not.} \seealso{\code{\link{all.equal.spam}}, \code{\link{cleanup}}.} \examples{ obj <- diag.spam(2) isSymmetric(obj) obj[1,2] <- .Machine$double.eps isSymmetric(obj) all.equal(obj, t(obj)) } \author{Reinhard Furrer} \keyword{array} spam/man/allequal.Rd0000644000176000001440000000527512346261543014123 0ustar ripleyusers% This is file ../spam/man/allequal.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{allequal} \alias{all.equal.spam} \alias{all.equal,matrix,spam-method} \alias{all.equal,spam,spam-method} \title{Test if Two 'spam' Objects are (Nearly) Equal} \description{Utility to compare two \code{spam} objects testing 'near equality'. Depending on the type of difference, comparison is still made to some extent, and a report of the differences is returned.} \usage{ \S3method{all.equal}{spam}(target, current, tolerance = .Machine$double.eps^0.5, scale = NULL, check.attributes = FALSE,...) } \arguments{ \item{target}{a \code{spam} object.} \item{current}{another \code{spam} object to be compared with \code{target}.} \item{tolerance}{numeric >= 0. Differences smaller than \code{tolerance} are not considered.} \item{scale}{numeric scalar > 0 (or \code{NULL}). See \sQuote{Details}.} \item{check.attributes}{currently not yet implemented.} \item{...}{Further arguments for different methods.} } \value{Either \code{TRUE} or a vector of 'mode' \code{"character"} describing the differences between \code{target} and \code{current}. } \details{ Numerical comparisons for \code{scale = NULL} (the default) are done by first computing the mean absolute difference of the two numerical vectors. If this is smaller than \code{tolerance} or not finite, absolute differences are used, otherwise relative differences scaled by the mean absolute difference. If \code{scale} is positive, absolute comparisons are made after scaling (dividing) by \code{scale}. Do not use \code{all.equal.spam} directly in \code{if} expressions: either use \code{isTRUE( all.equal.spam(...))} or \code{identical} if appropriate. Cholesky decomposition routines use this function to test for symmetry. A method for \code{matrix-spam} objects is defined as well. There is the additional catch of a zero matrix being represented by one zero element, see \sQuote{Examples} below. } \seealso{\code{\link{isSymmetric.spam}} and \code{\link{cleanup}}.} \examples{ obj <- diag.spam(2) obj[1,2] <- .Machine$double.eps all.equal( diag.spam(2), obj) all.equal( t(obj), obj) all.equal( t(obj), obj*1.1) # We can compare a spam to a matrix all.equal(diag(2),diag.spam(2)) # the opposite does often not make sense, # hence, it is not implemented. all.equal(diag.spam(2),diag(2)) # A zero matrix contains one element: str(spam(0)) # hence all.equal.spam(spam(0,3,3), diag.spam(0,3) ) norm(spam(0,3,3) - diag.spam(0,3) ) } \author{Reinhard Furrer} \keyword{array} spam/man/dim.Rd0000644000176000001440000000223512374455517013074 0ustar ripleyusers% This is file ../spam/man/dim.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{dim} \alias{dim.spam} \alias{dim<-.spam} \alias{dim<-,spam-method} \title{Dimensions of an Object} \description{ Retrieve or set the dimension of an \code{spam} object. } \usage{ # dim(x) # dim(x) <- value %"dim<-.spam"(x,value) } \arguments{ \item{x}{a \code{spam} matrix} \item{value}{A numeric two-vector, which is coerced to integer (by truncation).} } \value{ \code{dim} retrieves the \code{dimension} slot of the object. It is a vector of mode \code{integer}. The replacemnt method changes the dimension of the object by rearranging. } \details{ In older version of \code{spam}, the behavior of the replacement method was different and is now implemented in \code{\link{pad.spam}}. } %\references{} \seealso{\code{\link{pad.spam}}. } \examples{ x <- diag(4) dim(x)<-c(2,8) x s <- diag.spam(4) dim(s) <- c(2,8) # result is different than x s <- diag.spam(4) pad(s) <- c(7,3) # any positive value can be used } \author{Reinhard Furrer} \keyword{array} spam/man/crossprod.Rd0000644000176000001440000000223612372216504014327 0ustar ripleyusers% This is file ../spam/man/crossprod.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{crossprod} \alias{crossprod.default} \alias{crossprod.spam} \alias{tcrossprod.spam} \title{Spam Matrix Crossproduct} \description{ Given matrices \code{x} and \code{y} as arguments, return a matrix cross-product. This is formally equivalent to (but usually slightly faster than) the call \code{t(x) \%*\% y} (\code{crossprod.spam}) or \code{x \%*\% t(y)} (\code{tcrossprod.spam}).} \usage{ crossprod.spam(x, y = NULL) tcrossprod.spam(x, y = NULL) } \arguments{ \item{x, y}{matrices: \code{y = NULL} is taken to be the same matrix as \code{x}. Vectors are promoted to single-column or single-row matrices, depending on the context.} } \value{A double matrix} \note{ When \code{x} or \code{y} are not matrices, they are treated as column or row matrices. } %\references{} %\seealso{\code{\link{chol}}} \examples{ crossprod.spam(diag.spam(2),1:2) } \author{Reinhard Furrer} \keyword{array} \keyword{algebra} spam/man/UScounties.Rd0000644000176000001440000000251412346261543014415 0ustar ripleyusers% This is file ../spam/man/UScounties.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{UScounties} \alias{UScounties} \alias{UScounties.storder} \alias{UScounties.ndorder} \docType{data} \title{ Adjacency structure of the counties in the contiguous United States } \description{ First and second order adjacency structure of the counties in the contiguous United States. We consider that two counties are neighbors if they share at least one edge of their polygon description in \code{maps}. } \format{ Two matrices of class \code{spam} \describe{ \item{UScounties.storder}{ Contains a one in the \code{i} and \code{j} element if county \code{i} is a neighbor of county \code{j}. } \item{UScounties.ndorder}{ Contains a one in the \code{i} and \code{j} element if counties \code{i} and \code{j} are a neighbors of county \code{k} and counties \code{i} and \code{j} are not neighbors. } } } %\source{\url{ www.to somethin??}} \seealso{\code{map} from \pkg{maps}.} %\references{} \examples{ # number of counties: n <- nrow( UScounties.storder) \dontrun{ # make a precision matrix Q <- diag.spam( n) + .2 * UScounties.storder + .1 * UScounties.ndorder display( as.spam( chol( Q))) } } \keyword{datasets} spam/man/summary.Rd0000644000176000001440000000301412375134770014010 0ustar ripleyusers% This is file ../spam/man/summary.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{Summary} \alias{Summary.spam} \alias{Summary,spam-method} \alias{all.spam} \alias{any.spam} \alias{max.spam} \alias{min.spam} \alias{prod.spam} \alias{range.spam} \alias{sum.spam} \alias{all,spam-method} \alias{any,spam-method} \alias{max,spam-method} \alias{min,spam-method} \alias{prod,spam-method} \alias{range,spam-method} \alias{sum,spam-method} \title{Rounding of Numbers} \description{Applies the \code{Math2} group functions to \code{spam} objects } \usage{# max(x,..., na.rm = FALSE) } \arguments{\item{x}{spam object.} \item{na.rm}{a logical indicating whether missing values should be removed.} } \value{If \code{structurebased=TRUE}, all functions operate on the vector \code{x@entries} and return the result thereof.\cr Conversely, if \code{structurebased=FALSE}, the result is identical to one with \code{as.matrix(x)} input. } \details{The \code{na.rm} argument is only meaninful if \code{NAOK=TRUE}. } %\references{ %} \seealso{\code{\link{Math.spam}} and \code{\link{Math2}}.} \examples{ getGroupMembers("Summary") smat <- diag.spam( runif(15)) range(smat) spam.options(structurebased=FALSE) range(smat) \dontrun{ max( log(spam(c(1,-1))), na.rm=TRUE) } # allow 'NA's first: spam.options( NAOK=TRUE) max( log(spam(c(1,-1))), na.rm=TRUE) } \author{Reinhard Furrer} \keyword{manip} % all any max min prod range sum spam/man/germany.Rd0000644000176000001440000000345512346261543013763 0ustar ripleyusers% This is file ../spam/man/germany.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{germany.plot} \alias{germany.plot} \title{Plot administrative districts of Germany} \description{Displaying data over the administrative districts of Germany} \usage{ germany.plot(vect, col=NULL, zlim=range(vect), legend=TRUE, main=NULL, cex.axis=1, add=FALSE, ... ) } \arguments{ \item{vect}{vector of length 544} \item{col}{color scheme to be used. By default uses \code{colorRampPalette(brewer.pal(9,"Blues"))(100)}.} \item{zlim}{the minimum and maximum values for which colors should be plotted, defaulting to the range of \code{data}.} \item{legend}{Should the legend be added, see \sQuote{Details}.} \item{main}{an overall title for the plot.} \item{cex.axis}{label size of legend.} \item{add}{logical, if true adds to current plot.} \item{\dots}{additional arguments passed to \code{polygon}.} } \references{See also \url{http://de.wikipedia.org/wiki/Amtlicher_Gemeindeschl\%C3\%BCssel} and \url{http://de.wikipedia.org/wiki/Liste_der_Landkreise_in_Deutschland} %The code of \code{map.landkreis} is very similar to %\code{germany.map} from the package \pkg{INLA}.} } \details{The legend is only added, provided (a) function \code{image.plot} is available.\cr The perfect position of the legend is an art per se and depends on various \code{par} parameters. One possiblity for finer control is to not plot it and to manually call the function \code{image.plot} of \pkg{fields}.} \seealso{\code{\link{Oral}}.} \examples{ data( Oral) germany.plot( Oral$Y/Oral$E) # Plot the Bundeslaender: germany.plot(germany.info$id\%/\%1000,col=rep(2:8,3), legend=FALSE) } \author{Reinhard Furrer} \keyword{hplot} spam/man/USprecip.Rd0000644000176000001440000000267212346261543014053 0ustar ripleyusers% This is file ../spam/man/USprecip.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{USprecip} \alias{USprecip} \docType{data} \title{ Monthly total precipitation (mm) for April 1948 in the contiguous United States } \description{ This is a useful spatial data set of moderate to large size consisting of 11918 locations. See \url{www.image.ucar.edu/GSP/Data/US.monthly.met/} for the source of these data. } \format{ This data set is an array containing the following columns: \describe{ \item{lon,lat}{ Longitude-latitude position of monitoring stations } \item{raw}{ Monthly total precipitation in millimeters for April 1948 } \item{anomaly}{ Preipitation anomaly for April 1948. } \item{infill}{ Indicator, which station values were observed (5906 out of the 11918) compared to which were estimated. } } } \source{\url{www.image.ucar.edu/GSP/Data/US.monthly.met/}} \seealso{\code{\link[fields]{RMprecip}}} \references{ Johns, C., Nychka, D., Kittel, T., and Daly, C. (2003) Infilling sparse records of spatial fields. \emph{Journal of the American Statistical Association}, 98, 796--806. } \examples{ # plot \dontrun{ library(fields) data(USprecip) par(mfcol=c(2,1)) quilt.plot(USprecip[,1:2],USprecip[,3]) US( add=TRUE, col=2, lty=2) quilt.plot(USprecip[,1:2],USprecip[,4]) US( add=TRUE, col=2, lty=2) } } \keyword{datasets} spam/man/xybind.Rd0000644000176000001440000000334512375330454013614 0ustar ripleyusers% This is file ../spam/man/xybind.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{cbind} \alias{cbind.spam} \alias{rbind.spam} \alias{cbind,spam-method} \alias{rbind,spam-method} \title{Combine spam Matrices by Rows or Columns} \description{Take a sequence of vector, matrix or \code{spam} object arguments and combine by \emph{c}olumns or \emph{r}ows, respectively.} \usage{ cbind.spam(\dots, deparse.level = 0) rbind.spam(\dots, deparse.level = 0) } \arguments{ \item{...}{vectors, matrices or \code{spam} objects. See \sQuote{Details} and \sQuote{Value}} \item{deparse.level}{for compatibility reason here. Only \code{0} is implemented.} } \value{a \code{spam} object combining the \code{\dots} arguments column-wise or row-wise. (Exception: if there are no inputs or all the inputs are \code{NULL}, the value is \code{NULL}.)} \details{\code{rbind} and \code{cbind} are not exactly symmetric in how the objects are processed. The former is essentially an concatenation of the slots due to the sparse storage format. Different types of inputs are handled differently. The latter calls a Fortran routine after the input has been coerced to \code{spam} objects. \cr Only two objects at a time are processed. If more than two are present, a loop concatenates them successively. \cr A method is defined for a \code{spam} object as first argument. } %\references{} %\seealso{\code{\link{cbind,spam-method}}.} \examples{ x <- cbind.spam(1:5,6) y <- cbind(x, 7) rbind( x, x) # for some large matrices t( cbind( t(x), t(x))) # might be slightly faster: } \author{Reinhard Furrer} \keyword{array} \keyword{manip} spam/man/spam.internal.Rd0000644000176000001440000000170712346261543015072 0ustar ripleyusers% This is file ../spam/man/spam.internal.Rd % This file is part of the spam package, % http://www.math.uzh.ch/furrer/software/spam/ % by Reinhard Furrer [aut, cre], Florian Gerber [ctb] \name{spam internal} \alias{dcheck} \alias{icheck} \title{ Spam internal and auxiliary functions } \description{ The functions listed below are auxiliary functions but are exported by the NAMESPACE. The user should not require to call these directly. } \details{The functions are listed here for a better understanding of the code (to fulfill the tutorial style paradigm).\cr \code{validspamobject(object)} A few sanity checks if \code{object} is a proper \code{spam} object. \code{dcheck(x)}, \code{icheck(x)} testing and forcing of \code{x} to doubles and integers. These functions are used when calling Fortran routines. } %\note{The integers \code{int0}, \code{int1} and \code{int2} (0-2) are not % exported. %} \keyword{internal}