spatstat.sparse/0000755000176200001440000000000014157003222013405 5ustar liggesusersspatstat.sparse/NAMESPACE0000644000176200001440000000547714156763230014654 0ustar liggesusers## spatstat.sparse NAMESPACE file ## ................ Import packages .................. import(stats,graphics,grDevices,utils,methods) import(Matrix,abind,tensor) import(spatstat.utils) ## ................ Load dynamic library .............. ## (native routines are registered in init.c) ## (entry points are symbols with prefix "SP_") useDynLib(spatstat.sparse, .registration=TRUE, .fixes="SP_") ## ////////// DO NOT EDIT THE FOLLOWING /////////////// ## //////// it is generated automatically ///////////// # .................................................. # Automatically-generated list of documented objects # .................................................. export("anyNA.sparse3Darray") export("aperm.sparse3Darray") export("applySparseEntries") export("as.array.sparse3Darray") export("as.sparse3Darray") export("bilinearform") export("bind.sparse3Darray") export("check.anySparseVector") export("check.mat.mul") export("checksolve") export("Complex.sparse3Darray") export("dimnames.sparse3Darray") export("dimnames<-.sparse3Darray") export("dim.sparse3Darray") export("dim<-.sparse3Darray") export("EntriesToSparse") export("evalSparse3Dentrywise") export("expandSparse") export("gridadjacencymatrix") export("inside3Darray") export("mapSparseEntries") export("marginSumsSparse") export("Math.sparse3Darray") export("matrixinvsqrt") export("matrixpower") export("matrixsqrt") export("Ops.sparse3Darray") export("print.sparse3Darray") export("quadform") export("rbindCompatibleDataFrames") export("representativeRows") export("[.sparse3Darray") export("[<-.sparse3Darray") export("sparse3Darray") export("SparseEntries") export("SparseIndices") export("sparseVectorCumul") export("Summary.sparse3Darray") export("sumouter") export("sumsymouter") export("sumsymouterSparse") export("tensor1x1") export("tensorSparse") export("unionOfSparseIndices") # ....... Special cases ........... S3method("Complex", "sparse3Darray") S3method("Math", "sparse3Darray") S3method("Ops", "sparse3Darray") S3method("Summary", "sparse3Darray") # ....... End of special cases ... # ......................................... # Automatically generated list of S3 methods # ......................................... S3method("anyNA", "sparse3Darray") S3method("aperm", "sparse3Darray") S3method("as.array", "sparse3Darray") S3method("dimnames", "sparse3Darray") S3method("dim", "sparse3Darray") S3method("print", "sparse3Darray") S3method("[", "sparse3Darray") # ......................................... # Assignment methods # ......................................... S3method("dimnames<-", "sparse3Darray") S3method("dim<-", "sparse3Darray") S3method("[<-", "sparse3Darray") # ......................................... # End of methods # ......................................... spatstat.sparse/man/0000755000176200001440000000000014156765067014205 5ustar liggesusersspatstat.sparse/man/gridadjacencymatrix.Rd0000644000176200001440000000237114141451044020470 0ustar liggesusers\name{gridadjacencymatrix} \alias{gridadjacencymatrix} \title{ Create Adjacency Matrix for Spatial Grid } \description{ Given the dimensions of a rectangular grid of points, this command creates the adjacency matrix for the corresponding neighbourhood graph, whose vertices are the grid points, and whose edges are the joins between neighbouring grid points. } \usage{ gridadjacencymatrix(dims, across = TRUE, down = TRUE, diagonal=TRUE) } \arguments{ \item{dims}{ Grid dimensions. An integer, or a vector of two integers. First entry specifies the number of points in the \eqn{y} direction. } \item{across}{ Logical value equal to \code{TRUE} if horizontal neighbours should be joined. } \item{down}{ Logical value equal to \code{TRUE} if vertical neighbours should be joined. } \item{diagonal}{ Logical value equal to \code{TRUE} if diagonal neighbours should be joined. } } \details{ If \code{N = prod(dims)} is the total number of grid points, then the result is an \code{N * N} sparse matrix with logical entries equal to \code{TRUE} if the corresponding grid points are joined. } \value{ A sparse matrix. } \author{ Adrian Baddeley. } \examples{ gridadjacencymatrix(c(2,3)) } \keyword{datagen} spatstat.sparse/man/Extract.sparse3Darray.Rd0000644000176200001440000000752714141451044020620 0ustar liggesusers\name{Extract.sparse3Darray} \alias{[.sparse3Darray} \alias{[<-.sparse3Darray} \title{Extract or Replace Entries in a Sparse Array} \description{ Extract or replace entries in a sparse three-dimensional array. } \usage{ \method{[}{sparse3Darray}(x, i, j, k, drop=TRUE, \dots) \method{[}{sparse3Darray}(x, i, j, k, \dots) <- value } \arguments{ \item{x}{ Sparse three-dimensional array (object of class \code{"sparse3Darray"}). } \item{i,j,k}{ Subset indices for each dimension of the array. See Details. } \item{value}{ Replacement value for the subset. } \item{drop}{ Logical value indicating whether to return a lower-dimensional object (matrix or vector) when appropriate. } \item{\dots}{ Ignored. This argument is required for compatibility with the generic function. } } \value{ \code{[.sparse3Darray} returns either a sparse three-dimensional array (class \code{"sparse3Darray"}), a sparse matrix (class \code{sparseMatrix} in the \pkg{Matrix} package), a sparse vector (class \code{sparseVector} in the \pkg{Matrix} package), or in some cases a full array, matrix or vector. \code{[<-.sparse3Darray} returns another sparse three-dimensional array. } \details{ These functions are defined for a sparse three-dimensional array \code{x}. They extract a designated subset of the array, or replace the values in the designated subset. The function \code{[.sparse3Darray} is a method for the generic subset extraction operator \code{\link{[}}. The function \code{[<-.sparse3Darray} is a method for the generic subset replacement operator \code{\link{[<-}}. These methods use the same indexing rules as the subset operator for full arrays: \itemize{ \item If \code{i}, \code{j} and \code{k} are integer vectors, the subset is the Cartesian product (i.e. all cells in the array identified by an entry of \code{i}, an entry of \code{j} and an entry of \code{k}). \item Some or all of the arguments \code{i}, \code{j} and \code{k} may be missing from the call; a missing index argument is interpreted as meaning that all possible values of that index are allowed. \item Arguments \code{i}, \code{j} and \code{k} may be logical vectors (with the value \code{TRUE} assigned to entries that should be included). \item Arguments \code{i}, \code{j} and \code{k} may be character vectors with entries matching the corresponding \code{dimnames}. \item Argument \code{i} may be an integer matrix with 3 columns (and the arguments \code{j,k} should be absent). Each row of the matrix contains the indices of one cell in the array. } If the designated subset lies within the array bounds, then the result of \code{[} will be a sparse three-dimensional array, sparse matrix or sparse vector. If \code{drop=FALSE} the result will always be three-dimensional; if \code{drop=TRUE} (the default) the result will be reduced to two or one dimensions when appropriate. If the designated subset \emph{does not} lie within the array bounds, then the result of \code{[} will be a full three-dimensional array, matrix or vector containing \code{NA} values at the positions that were outside the array bounds. The result of \code{[<-} is always a sparse three-dimensional array. If the designated subset did not lie within the array bounds of \code{x}, then the array bounds will be extended (with a warning message). } \seealso{ \code{\link{sparse3Darray}}, \code{\link{methods.sparse3Darray}}. } \examples{ M <- sparse3Darray(i=1:4, j=sample(1:4, replace=TRUE), k=c(1,2,1,2), x=1:4, dims=c(5,5,2)) dimnames(M) <- list(letters[1:5], LETTERS[1:5], c("yes", "no")) M[ 3:4, , ] M[ 3:4, 2:4, ] M[ 4:3, 4:2, 1:2] M[, 3, ] } \author{ \spatstatAuthors. } \keyword{array} \keyword{manip} \concept{sparse} spatstat.sparse/man/Math.sparse3Darray.Rd0000755000176200001440000000760314141377563020112 0ustar liggesusers\name{Math.sparse3Darray} \alias{Math.sparse3Darray} \alias{Ops.sparse3Darray} \alias{Complex.sparse3Darray} \alias{Summary.sparse3Darray} \title{S3 Group Generic Methods for Sparse Three-Dimensional Arrays} \description{ Group generic methods which make it possible to apply the familiar mathematical operators and functions to sparse three-dimensional arrays (objects of class \code{"sparse3Darray"}). See Details for a list of implemented functions. } \usage{ ## S3 methods for group generics have prototypes: \special{Math(x, \dots)} \special{Ops(e1, e2)} \special{Complex(z)} \special{Summary(\dots, na.rm=FALSE)} %NAMESPACE S3method("Math", "sparse3Darray") %NAMESPACE S3method("Ops", "sparse3Darray") %NAMESPACE S3method("Complex", "sparse3Darray") %NAMESPACE S3method("Summary", "sparse3Darray") } \arguments{ \item{x, z, e1, e2}{ Sparse three-dimensional arrays (objects of class \code{"sparse3Darray"}). Alternatively \code{e1} or \code{e2} can be a single scalar, vector, sparse vector, matrix or sparse matrix. } \item{\dots}{further arguments passed to methods.} \item{na.rm}{ Logical value specifying whether missing values should be removed. } } \details{ These group generics make it possible to perform element-wise arithmetic and logical operations with sparse three-dimensional arrays, or apply mathematical functions element-wise, or compute standard summaries such as the mean and maximum. Below is a list of mathematical functions and operators which are defined for sparse 3D arrays. \enumerate{ \item Group \code{"Math"}: \itemize{ \item \code{abs}, \code{sign}, \code{sqrt},\cr \code{floor}, \code{ceiling}, \code{trunc},\cr \code{round}, \code{signif} \item \code{exp}, \code{log}, \code{expm1}, \code{log1p},\cr \code{cos}, \code{sin}, \code{tan},\cr \code{cospi}, \code{sinpi}, \code{tanpi},\cr \code{acos}, \code{asin}, \code{atan} \code{cosh}, \code{sinh}, \code{tanh},\cr \code{acosh}, \code{asinh}, \code{atanh} \item \code{lgamma}, \code{gamma}, \code{digamma}, \code{trigamma} \item \code{cumsum}, \code{cumprod}, \code{cummax}, \code{cummin} } \item Group \code{"Ops"}: \itemize{ \item \code{"+"}, \code{"-"}, \code{"*"}, \code{"/"}, \code{"^"}, \code{"\%\%"}, \code{"\%/\%"} \item \code{"&"}, \code{"|"}, \code{"!"} \item \code{"=="}, \code{"!="}, \code{"<"}, \code{"<="}, \code{">="}, \code{">"} } \item Group \code{"Summary"}: \itemize{ \item \code{all}, \code{any} \item \code{sum}, \code{prod} \item \code{min}, \code{max} \item \code{range} } \item Group \code{"Complex"}: \itemize{ \item \code{Arg}, \code{Conj}, \code{Im}, \code{Mod}, \code{Re} } } } \seealso{ \code{\link{sparse3Darray}}, \code{\link{tensorSparse}} } \examples{ M <- sparse3Darray(i=1:4, j=sample(1:4, replace=TRUE), k=c(1,2,1,2), x=1:4, dims=c(5,5,2)) negM <- -M twoM <- M + M Mplus <- M + 1 ## not sparse! posM <- (M > 0) range(M) sinM <- sin(M) cosM <- cos(M) ## not sparse! expM1 <- expm1(M) } \value{ The result of group \code{"Math"} functions is another three-dimensional array of the same dimensions as \code{x}, which is sparse if the function maps 0 to 0, and otherwise is a full three-dimensional array. The result of group \code{"Ops"} operators is another three-dimensional array of the same dimensions as \code{e1} and \code{e2}, which is sparse if both \code{e1} and \code{e2} are sparse. The result of group \code{"Complex"} functions is another sparse three-dimensional array of the same dimensions as \code{z}. The result of group \code{"Summary"} functions is a logical value or a numeric value or a numeric vector of length 2. } \author{ \spatstatAuthors. } \keyword{spatial} \keyword{methods} spatstat.sparse/man/matrixpower.Rd0000755000176200001440000000315114141377563017052 0ustar liggesusers\name{matrixpower} \alias{matrixpower} \alias{matrixsqrt} \alias{matrixinvsqrt} \title{ Power of a Matrix } \description{ Evaluate a specified power of a matrix. } \usage{ matrixpower(x, power, complexOK = TRUE) matrixsqrt(x, complexOK = TRUE) matrixinvsqrt(x, complexOK = TRUE) } \arguments{ \item{x}{ A square matrix containing numeric or complex values. } \item{power}{ A numeric value giving the power (exponent) to which \code{x} should be raised. } \item{complexOK}{ Logical value indicating whether the result is allowed to be complex. } } \details{ These functions raise the matrix \code{x} to the desired power: \code{matrixsqrt} takes the square root, \code{matrixinvsqrt} takes the inverse square root, and \code{matrixpower} takes the specified power of \code{x}. Up to numerical error, \code{matrixpower(x, 2)} should be equivalent to \code{x \%*\% x}, and \code{matrixpower(x, -1)} should be equivalent to \code{solve(x)}, the inverse of \code{x}. The square root \code{y <- matrixsqrt(x)} should satisfy \code{y \%*\% y = x}. The inverse square root \code{z <- matrixinvsqrt(x)} should satisfy \code{z \%*\% z = solve(x)}. Computations are performed using the eigen decomposition (\code{\link{eigen}}). } \value{ A matrix of the same size as \code{x} containing numeric or complex values. } \author{ \adrian. } \seealso{ \code{\link[base]{eigen}}, \code{\link[base]{svd}} } \examples{ x <- matrix(c(10,2,2,1), 2, 2) y <- matrixsqrt(x) y y \%*\% y z <- matrixinvsqrt(x) z \%*\% y matrixpower(x, 0.1) } \keyword{algebra} \keyword{array} spatstat.sparse/man/bind.sparse3Darray.Rd0000644000176200001440000000306214156761060020120 0ustar liggesusers\name{bind.sparse3Darray} \alias{bind.sparse3Darray} \title{ Combine Three-Dimensional Sparse Arrays } \description{ Two sparse arrays will be joined to make a larger sparse array. } \usage{ bind.sparse3Darray(A, B, along) } \arguments{ \item{A,B}{ Sparse three-dimensional arrays (objects of class \code{"sparse3Darray"}) or data acceptable to \code{\link{as.sparse3Darray}}. } \item{along}{ The dimension along which the two arrays will be joined. An integer from 1 to 3. } } \details{ This operation is similar to \code{\link[base]{rbind}}, \code{\link[base]{cbind}} and \code{\link[abind]{abind}}. The two 3D arrays \code{A} and \code{B} will be joined to make a larger 3D array by concatenating them along the dimension specified by \code{along}. The arguments \code{A} and \code{B} should be sparse three-dimensional arrays (objects of class \code{"sparse3Darray"}) or data acceptable to \code{\link{as.sparse3Darray}}. They must have identical array dimensions except in the dimension specified by \code{along}. } \value{ A sparse three-dimensional array (object of class \code{"sparse3Darray"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link{as.sparse3Darray}}, \code{\link{methods.sparse3Darray}}. See \code{\link[abind]{abind}} for joining non-sparse arrays. } \examples{ M <- sparse3Darray(i=1:3, j=c(3,1,2), k=4:2, x=runif(3), dims=rep(4, 3)) dim(M) U <- M[ , 1:3, ] dim(U) V <- bind.sparse3Darray(M, U, along=2) dim(V) } \keyword{array} \keyword{sparse} \keyword{manip} spatstat.sparse/man/spatstat.sparse-package.Rd0000644000176200001440000001004114141451044021175 0ustar liggesusers\name{spatstat.sparse-package} \alias{spatstat.sparse-package} \alias{spatstat.sparse} \docType{package} \title{The spatstat.sparse Package} \description{ The \pkg{spatstat.sparse} package defines three-dimensional sparse arrays, and supports standard operations on them. It also provides some utility functions for matrix calculations such as quadratic forms. } \details{ The \pkg{spatstat.sparse} package \itemize{ \item defines a class of sparse three-dimensional arrays and supports standard operations on them (see Section \emph{Sparse 3D Arrays}). \item provides utility functions for matrix computations that are common in statistics, such as quadratic forms (see Section \emph{Matrix Utilities}). } The code in \pkg{spatstat.sparse} was originally written for internal use within the \pkg{spatstat} package, but has now been removed and organised into a separate, stand-alone package which can be used for other purposes. } \section{Sparse 3D Arrays}{ The main purpose of \pkg{spatstat.sparse} is to define a class of sparse three-dimensional arrays. An array \code{A} is three-dimensional if it is indexed by three integer indices, so that \code{A[i,j,k]} specifies an element of the array. The array is called sparse if only a small fraction of the entries are non-zero. A sparse array can be represented economically by listing only the entries which are non-zero. The \pkg{spatstat.sparse} package defines the class \code{sparse3Darray} of sparse three-dimensional arrays. These arrays can have numeric, integer, logical, or complex entries. The package supports: \itemize{ \item creation of sparse arrays from raw data \item conversion to/from other data types \item array indexing, extraction of entries, assignment of new values \item arithmetic and logical operations \item tensor operations (generalising matrix multiplication) \item permutation of array dimensions \item binding of several arrays into a single array \item printing of sparse arrays. } The \pkg{spatstat.sparse} package uses the \pkg{Matrix} package to handle slices of three-dimensional arrays which are two-dimensional (sparse matrices) or one-dimensional (sparse vectors). The main functions are: \tabular{ll}{ \code{\link{sparse3Darray}} \tab Create a sparse 3D array \cr \code{\link{as.sparse3Darray}} \tab Convert other data to a sparse 3D array \cr \code{\link{[.sparse3Darray}} \tab Subset operator \cr \code{\link{aperm.sparse3Darray}} \tab Permute a sparse array \cr \code{\link{Ops.sparse3Darray}} \tab arithmetic and logical operators \cr \code{\link{Complex.sparse3Darray}} \tab complex operators \cr \code{\link{Math.sparse3Darray}}\tab standard mathematical functions \cr \code{\link{Summary.sparse3Darray}} \tab mean, maximum etc \cr \code{\link{tensorSparse}} \tab Tensor product \cr \code{\link{as.array.sparse3Darray}} \tab Convert sparse array to full array \cr } The class \code{"sparse3Darray"} has methods for \code{anyNA}, \code{dim}, \code{dim<-}, \code{dimnames}, \code{dimnames<-} and \code{print}, documented in \code{\link{methods.sparse3Darray}}. For other undocumented functions, see \code{\link{spatstat.sparse-internal}}. } \section{Matrix Utilities}{ The package also includes some utilities for matrix calculations: \tabular{ll}{ \code{\link{sumouter}} \tab sum of outer products of rows of a matrix \cr \code{\link{quadform}} \tab quadratic form involving rows of a matrix \cr \code{\link{bilinearform}} \tab bilinear form involving rows of a matrix \cr \code{\link{matrixsqrt}} \tab square root of a matrix \cr \code{\link{matrixpower}} \tab powers of a matrix \cr } % Functions to document: sumsymouter, checksolve, check.mat.mul } \section{Licence}{ This library and its documentation are usable under the terms of the \dQuote{GNU General Public License}, a copy of which is distributed with \R. } \author{ \spatstatAuthors. } \keyword{array} \keyword{algebra} \keyword{package} spatstat.sparse/man/as.array.sparse3Darray.Rd0000644000176200001440000000206414141451044020715 0ustar liggesusers\name{as.array.sparse3Darray} \alias{as.array.sparse3Darray} \title{ Convert Sparse Array to Full Array } \description{ Convert a sparse three-dimensional array to a full three-dimensional array. } \usage{ \method{as.array}{sparse3Darray}(x, \dots) } \arguments{ \item{x}{ Sparse three-dimensional array (object of class \code{"sparse3Darray"}). } \item{\dots}{ Ignored. } } \details{ This is a method for the generic \code{\link[base]{as.array}} for sparse three-dimensional arrays (class \code{"sparse3Darray"}). It converts the sparse three-dimensional array \code{x} into an \code{\link[base]{array}} representing the same data. } \value{ An array (class \code{"array"}) with the same dimensions as \code{x} and the same type of entries as \code{x}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{sparse3Darray}}, \code{\link{as.sparse3Darray}} } \examples{ M <- sparse3Darray(i=1:3, j=c(3,1,2), k=4:2, x=runif(3), dims=rep(4, 3)) V <- as.array(M) } \keyword{array} \keyword{manip} \concept{sparse} spatstat.sparse/man/as.sparse3Darray.Rd0000644000176200001440000000420014141451044017572 0ustar liggesusers\name{as.sparse3Darray} \alias{as.sparse3Darray} \title{ Convert Data to a Sparse Three-Dimensional Array } \description{ Convert other kinds of data to a sparse three-dimensional array. } \usage{ as.sparse3Darray(x, \dots) } \arguments{ \item{x}{ Data in another format (see Details). } \item{\dots}{ Ignored. } } \details{ This function converts data in various formats into a sparse three-dimensional array (object of class \code{"sparse3Darray"}). The argument \code{x} can be \itemize{ \item a sparse three-dimensional array (class \code{"sparse3Darray"}) \item an \code{array} \item a \code{matrix}, which will be interpreted as an array with dimension \code{c(dim(x), 1)} \item a sparse matrix (inheriting class \code{"sparseMatrix"} in the \pkg{Matrix} package) which will be interpreted as an array with dimension \code{c(dim(x), 1)} \item a vector of atomic values, which will be interpreted as an array of dimension \code{c(length(x), 1, 1)} \item a sparse vector (inheriting class \code{"sparseVector"} in the \pkg{Matrix} package) which will be interpreted as an array of dimension \code{c(x@length, 1, 1)} \item a list of matrices with the same dimensions, which will be interpreted as slices \code{A[,,k]} of an array \code{A} \item a list of sparse matrices (each inheriting class \code{"sparseMatrix"} in the \pkg{Matrix} package) with the same dimensions, which will be interpreted as slices \code{A[,,k]} of an array \code{A}. } } \value{ Sparse three-dimensional array (object of class \code{"sparse3Darray"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link{sparse3Darray}} } \examples{ A <- array(c(1,3,0,0,0,0,0,4,0,2,0,5, 0,0,1,0,0,0,1,0,0,0,1,0), dim=c(3,4,2)) #' array to sparse array B <- as.sparse3Darray(A) # positive extent #' list of matrices to sparse array B <- as.sparse3Darray(list(A[,,1], A[,,2])) #' matrix to sparse array B1 <- as.sparse3Darray(A[,,1]) #' vector to sparse array B11 <- as.sparse3Darray(A[,1,1]) } \keyword{array} \keyword{manip} \concept{sparse} spatstat.sparse/man/macros/0000755000176200001440000000000014141451044015446 5ustar liggesusersspatstat.sparse/man/macros/defns.Rd0000644000176200001440000000432014141451044017033 0ustar liggesusers%% macro definitions for spatstat man pages \newcommand{\adrian}{Adrian Baddeley \email{Adrian.Baddeley@curtin.edu.au}} \newcommand{\rolf}{Rolf Turner \email{r.turner@auckland.ac.nz}} \newcommand{\ege}{Ege Rubak \email{rubak@math.aau.dk}} \newcommand{\spatstatAuthors}{\adrian, \rolf and \ege} % Names with accents \newcommand{\Bogsted}{\ifelse{latex}{\out{B\o gsted}}{Bogsted}} \newcommand{\Cramer}{\ifelse{latex}{\out{Cram\'er}}{Cramer}} \newcommand{\Hogmander}{\ifelse{latex}{\out{H{\"o}gmander}}{Hogmander}} \newcommand{\Jyvaskyla}{\ifelse{latex}{\out{Jyv\"askyl\"a}}{Jyvaskyla}} \newcommand{\Matern}{\ifelse{latex}{\out{Mat\'ern}}{Matern}} \newcommand{\Moller}{\ifelse{latex}{\out{M\o ller}}{Moller}} \newcommand{\Oehlschlaegel}{\ifelse{latex}{\out{Oehlschl\"{a}gel}}{Oehlschlaegel}} \newcommand{\Prokesova}{\ifelse{latex}{\out{Proke\u{s}ov{\'{a}}}}{Prokesova}} \newcommand{\Sarkka}{\ifelse{latex}{\out{S\"{a}rkk\"{a}}}{Sarkka}} %% List of all Gibbs interactions \newcommand{\GibbsInteractionsList}{\code{\link{AreaInter}}, \code{\link{BadGey}}, \code{\link{Concom}}, \code{\link{DiggleGatesStibbard}}, \code{\link{DiggleGratton}}, \code{\link{Fiksel}}, \code{\link{Geyer}}, \code{\link{Hardcore}}, \code{\link{HierHard}}, \code{\link{HierStrauss}}, \code{\link{HierStraussHard}}, \code{\link{Hybrid}}, \code{\link{LennardJones}}, \code{\link{MultiHard}}, \code{\link{MultiStrauss}}, \code{\link{MultiStraussHard}}, \code{\link{OrdThresh}}, \code{\link{Ord}}, \code{\link{Pairwise}}, \code{\link{PairPiece}}, \code{\link{Penttinen}}, \code{\link{Poisson}}, \code{\link{Saturated}}, \code{\link{SatPiece}}, \code{\link{Softcore}}, \code{\link{Strauss}}, \code{\link{StraussHard}} and \code{\link{Triplets}}} %% List of interactions recognised by RMH code \newcommand{\rmhInteractionsList}{\code{\link{AreaInter}}, \code{\link{BadGey}}, \code{\link{DiggleGatesStibbard}}, \code{\link{DiggleGratton}}, \code{\link{Fiksel}}, \code{\link{Geyer}}, \code{\link{Hardcore}}, \code{\link{Hybrid}}, \code{\link{LennardJones}}, \code{\link{MultiStrauss}}, \code{\link{MultiStraussHard}}, \code{\link{PairPiece}}, \code{\link{Penttinen}}, \code{\link{Poisson}}, \code{\link{Softcore}}, \code{\link{Strauss}}, \code{\link{StraussHard}} and \code{\link{Triplets}}} spatstat.sparse/man/sparse3Darray.Rd0000644000176200001440000000660514156760776017230 0ustar liggesusers\name{sparse3Darray} \alias{sparse3Darray} \title{ Create a Sparse Three-Dimensional Array } \description{ Create a sparse representation of a three-dimensional array. } \usage{ sparse3Darray(i = integer(0), j = integer(0), k = integer(0), x = numeric(0), dims = c(max(i), max(j), max(k)), dimnames = NULL, strict = FALSE, nonzero = FALSE) } \arguments{ \item{i,j,k}{ Integer vectors of equal length (or length 1), specifying the cells in the array which have non-zero entries. } \item{x}{ Vector (numeric, integer, logical or complex) of the same length as \code{i}, \code{j} and \code{k}, giving the values of the array entries that are not zero. } \item{dims}{ Dimension of the array. An integer vector of length 3. } \item{dimnames}{ Names for the three margins of the array. Either \code{NULL} or a list of three character vectors. } \item{strict}{ Logical value specifying whether to enforce the rule that each entry in \code{i,j,k,x} refers to a different cell. If \code{strict=TRUE}, entries which refer to the same cell in the array will be reduced to a single entry by summing the \code{x} values. Default is \code{strict=FALSE}. } \item{nonzero}{ Logical value specifying whether to remove any entries of \code{x} which equal zero. } } \details{ An array \code{A} is three-dimensional if it is indexed by three integer indices, so that \code{A[i,j,k]} specifies an element of the array. The array is called sparse if only a small fraction of the entries are non-zero. A sparse array can be represented economically by listing only the entries which are non-zero. The \pkg{spatstat.sparse} package defines the class \code{sparse3Darray} of sparse three-dimensional arrays. These arrays can have numeric, integer, logical, or complex entries. The function \code{sparse3Darray} creates an object of class \code{"sparse3Darray"}. This object is essentially a list containing the vectors \code{i,j,k,x} and the arguments \code{dims,dimnames}. The arguments \code{i,j,k,x} should be vectors of equal length identifying the cells in the array which have non-zero entries (indexed by \code{i,j,k}) and giving the values in these cells (given by \code{x}). The default behaviour of \code{sparse3Darray} is to accept the arguments \code{i,j,k,x} without modifying them. This would allow some entries of \code{x} to be equal to zero, and would allow a cell in the array to be referenced more than once in the indices \code{i,j,k}. If \code{nonzero=TRUE}, entries will be removed if the \code{x} value equals zero. If \code{strict=TRUE}, entries which refer to the same cell in the array will be combined into a single entry by summing the \code{x} values. } \value{ An object of class \code{"sparse3Darray"}. } \author{ \spatstatAuthors. } \seealso{ \code{\link{as.sparse3Darray}} } \examples{ ## creation by specifying nonzero elements M <- sparse3Darray(i=1:3, j=c(3,1,2), k=4:2, x=runif(3), dims=rep(4, 3)) M ## duplicate entries Mn <- sparse3Darray(i=c(1,1,2), j=c(2,2,1), k=c(3,3,2), x=runif(3), dims=rep(3, 3)) ## cumulate entries in duplicate positions Ms <- sparse3Darray(i=c(1,1,2), j=c(2,2,1), k=c(3,3,2), x=runif(3), dims=rep(3, 3), strict=TRUE) } \keyword{array} \concept{sparse} spatstat.sparse/man/marginSumsSparse.Rd0000644000176200001440000000402214141451044017752 0ustar liggesusers\name{marginSumsSparse} \alias{marginSumsSparse} \title{ Margin Sums of a Sparse Matrix or Sparse Array } \description{ For a sparse matrix or sparse array, compute the sum of array entries for a specified margin or margins. } \usage{ marginSumsSparse(X, MARGIN) } \arguments{ \item{X}{ A matrix, an array, a sparse matrix (of class \code{"sparseMatrix"} from the \pkg{Matrix} package) or a sparse three-dimensional array (of class \code{"sparse3Darray"} from the \pkg{spatstat.sparse} package). } \item{MARGIN}{ Integer or integer vector specifying the margin or margins. } } \details{ This function computes the equivalent of \code{\link[base]{apply}(X, MARGIN, sum)} for sparse matrices and arrays \code{X}. The argument \code{X} may be \itemize{ \item a matrix \item an array of any number of dimensions \item a sparse matrix (object inheriting class \code{"sparseMatrix"} in the \pkg{Matrix} package) \item a sparse three-dimensional array (of class \code{"sparse3Darray"} from the \pkg{spatstat.sparse} package). } In the first two cases, the computation is performed by calling \code{\link[base]{apply}(X, MARGIN, sum)} and the result is a vector, matrix or array. In the last two cases, the result is a single value, a sparse vector, a sparse matrix, or a sparse three-dimensional array. } \value{ A single value, vector, matrix, array, sparse vector (class \code{"sparseVector"} in the \pkg{Matrix} package), sparse matrix (class \code{"sparseMatrix"} in the \pkg{Matrix} package), or sparse three-dimensional array (class \code{"sparse3Darray"} from the \pkg{spatstat.sparse} package). } \author{ \spatstatAuthors. } \seealso{ \code{\link[base]{apply}} } \examples{ M <- sparse3Darray(i=1:3, j=c(3,1,2), k=4:2, x=round(runif(3), 2), dims=rep(4, 3)) marginSumsSparse(M, 1:2) marginSumsSparse(M, 1) marginSumsSparse(M, integer(0)) # equivalent to sum(M) } \keyword{array} \keyword{algebra} \keyword{manip} \concept{sparse} spatstat.sparse/man/spatstat.sparse-internal.Rd0000755000176200001440000000315014156760776021451 0ustar liggesusers\name{spatstat.sparse-internal} \title{Internal Functions of spatstat.sparse Package} \alias{spatstat.sparse-internal} %DoNotExport %% indices \alias{representativeRows} %%%% undocumented linear algebra \alias{checksolve} \alias{check.mat.mul} \alias{sumsymouter} %% sparse 3D arrays \alias{unionOfSparseIndices} \alias{inside3Darray} \alias{SparseEntries} \alias{SparseIndices} \alias{EntriesToSparse} \alias{mapSparseEntries} \alias{applySparseEntries} \alias{sumsymouterSparse} \alias{rbindCompatibleDataFrames} \alias{check.anySparseVector} \alias{evalSparse3Dentrywise} \alias{expandSparse} \alias{sparseVectorCumul} \alias{tensor1x1} \description{ Internal utility functions of the \code{spatstat.sparse} package. } \usage{ %% indices representativeRows(x) %%% undocumented linear algebra checksolve(M, action, descrip, target) check.mat.mul(A, B, Acols, Brows, fatal) sumsymouter(x, w, distinct) %% sparse 3D arrays unionOfSparseIndices(A,B) inside3Darray(d, i, j, k) SparseEntries(x) SparseIndices(x) EntriesToSparse(df, dims) mapSparseEntries(x, margin, values, conform, across) applySparseEntries(x, f, \dots) sumsymouterSparse(x, w, distinct, dbg) rbindCompatibleDataFrames(x) check.anySparseVector(v, npoints, fatal, things, naok, warn, vname, oneok) evalSparse3Dentrywise(expr, envir) expandSparse(x, n, across) sparseVectorCumul(x, i, length) tensor1x1(A, B) } \details{ These internal \pkg{spatstat.sparse} functions are not usually called directly by the user. Their names and capabilities may change without warning from one version of \pkg{spatstat.utils} to the next. } \keyword{internal} spatstat.sparse/man/aperm.sparse3Darray.Rd0000644000176200001440000000236114141451044020301 0ustar liggesusers\name{aperm.sparse3Darray} \alias{aperm.sparse3Darray} \title{ Transposition of Sparse Array } \description{ Transpose a sparse three-dimensional array by permuting its dimensions. } \usage{ \method{aperm}{sparse3Darray}(a, perm = NULL, resize = TRUE, \dots) } \arguments{ \item{a}{ A sparse three-dimensional array (object of class \code{"sparse3Darray"}). } \item{perm}{ The subscript permutation vector, a permutation of the integers \code{1:3}. } \item{resize}{ Logical value specifying whether the dimensions and dimnames of the array should also be adjusted, by permuting them according to the permutation. } \item{\dots}{ Ignored. } } \details{ The function \code{\link[base]{aperm}} is generic. This is the method for the class \code{"sparse3Darray"} of sparse three-dimensional arrays. } \value{ Another sparse three-dimensional array (object of class \code{"sparse3Darray"}). } \author{ \spatstatAuthors. } \seealso{ \code{\link{sparse3Darray}}, \code{\link{tensorSparse}}. } \examples{ M <- sparse3Darray(i=1:4, j=sample(1:4, replace=TRUE), k=c(1,2,1,2), x=1:4, dims=c(5,7,2)) dim(M) P <- aperm(M, c(3,1,2)) dim(P) } \keyword{array} \keyword{manip} \concept{sparse} spatstat.sparse/man/tensorSparse.Rd0000644000176200001440000000462414141451044017147 0ustar liggesusers\name{tensorSparse} \alias{tensorSparse} \title{ Tensor Product of Sparse Vectors, Matrices or Arrays } \description{ Compute the tensor product of two vectors, matrices or arrays which may be sparse or non-sparse. } \usage{ tensorSparse(A, B, alongA = integer(0), alongB = integer(0)) } \arguments{ \item{A,B}{ Vectors, matrices, three-dimensional arrays, or objects of class \code{sparseVector}, \code{sparseMatrix} or \code{sparse3Darray}. } \item{alongA}{ Integer vector specifying the dimensions of \code{A} to be collapsed. } \item{alongB}{ Integer vector specifying the dimensions of \code{B} to be collapsed. } } \details{ This function is a generalisation, to sparse arrays, of the function \code{\link[tensor]{tensor}} in the \pkg{tensor} package. \code{tensorSparse} has the same syntax and interpretation as \code{\link[tensor]{tensor}}. For example, if \code{A} and \code{B} are matrices, then \code{tensor(A,B,2,1)} is the matrix product \code{A \%*\% B} while \code{tensor(A,B,2,2)} is \code{A \%*\% t(B)}. This function \code{tensorSparse} handles sparse vectors (class \code{"sparseVector"} in the \pkg{Matrix} package), sparse matrices (class \code{"sparseMatrix"} in the \pkg{Matrix} package) and sparse three-dimensional arrays (class \code{"sparse3Darray"} in the \pkg{spatstat.sparse} package) in addition to the usual vectors, matrices and arrays. The result is a sparse object if at least one of \code{A} and \code{B} is sparse. Otherwise, if neither \code{A} nor \code{B} is sparse, then the result is computed using \code{\link[tensor]{tensor}}. The main limitation is that the result cannot have more than 3 dimensions (because sparse arrays with more than 3 dimensions are not yet supported). } \value{ Either a scalar, a vector, a matrix, an array, a sparse vector (class \code{"sparseVector"} in the \pkg{Matrix} package), a sparse matrix (class \code{"sparseMatrix"} in the \pkg{Matrix} package) or a sparse three-dimensional array (class \code{"sparse3Darray"} in the \pkg{spatstat.sparse} package). } \author{ \spatstatAuthors. } \seealso{ \code{\link{sparse3Darray}}, \code{\link{aperm.sparse3Darray}} } \examples{ M <- sparse3Darray(i=1:4, j=sample(1:4, replace=TRUE), k=c(1,2,1,2), x=1:4, dims=c(5,5,2)) A <- tensorSparse(M, M, 1:2, 2:1) } \keyword{array} \keyword{algebra} \concept{sparse} spatstat.sparse/man/sumouter.Rd0000755000176200001440000000574114156763230016357 0ustar liggesusers\name{sumouter} \alias{sumouter} \alias{quadform} \alias{bilinearform} \title{Compute Quadratic Forms} \description{ Calculates certain quadratic forms of matrices. } \usage{ sumouter(x, w=NULL, y=x) quadform(x, v) bilinearform(x, v, y) } \arguments{ \item{x,y}{A matrix, whose rows are the vectors in the quadratic form.} \item{w}{Optional vector of weights} \item{v}{Matrix determining the quadratic form} } \value{ A vector or matrix. } \details{ The matrices \code{x} and \code{y} will be interpreted as collections of row vectors. They must have the same number of rows. The entries of \code{x} and \code{y} may be numeric, integer, logical or complex values. The command \code{sumouter} computes the sum of the outer products of corresponding row vectors, weighted by the entries of \code{w}: \deqn{ M = \sum_i w_i x_i^\top y_i }{ M = sum[i] (w[i] * outer(x[i,], y[i,])) } where \eqn{x_i}{x[i,]} is the \code{i}-th row of \code{x} and \eqn{y_i}{y[i,]} is the \code{i}-th row of \code{y} (after removing any rows containing \code{NA} or other non-finite values). If \code{w} is missing or \code{NULL}, the weights will be taken as 1. The result is a \eqn{p \times q}{p * q} matrix where \code{p = ncol(x)} and \code{q = ncol(y)}. The command \code{quadform} evaluates the quadratic form, defined by the matrix \code{v}, for each of the row vectors of \code{x}: \deqn{ y_i = x_i V x_i^\top }{ y[i] = x[i,] \%*\% v \%*\% t(x[i,]) } The result \code{y} is a numeric vector of length \code{n} where \code{n = nrow(x)}. If \code{x[i,]} contains \code{NA} or other non-finite values, then \code{y[i] = NA}. If \code{v} is missing or \code{NULL}, it will be taken as the identity matrix, so that the resulting values will be \deqn{ y_i = x_i x_i^\top }{ y[i] = x[i,] \%*\% t(x[i,]) } The command \code{bilinearform} evaluates the more general bilinear form defined by the matrix \code{v}. Here \code{x} and \code{y} must be matrices of the same dimensions. For each row vector of \code{x} and corresponding row vector of \code{y}, the bilinear form is \deqn{ z_i = x_i V y_i^\top }{ z[i] = x[i,] \%*\% v \%*\% t(y[i,]) } The result \code{z} is a numeric vector of length \code{n} where \code{n = nrow(x)}. If \code{x[i,]} or \code{y[i,]} contains \code{NA} or other non-finite values, then \code{z[i] = NA}. If \code{v} is missing or \code{NULL}, it will be taken as the identity matrix, so that the resulting values will be \deqn{ z_i = x_i y_i^\top }{ z[i] = x[i,] \%*\% t(y[i,]) } } \examples{ x <- matrix(1:12, 4, 3) dimnames(x) <- list(c("Wilma", "Fred", "Barney", "Betty"), letters[1:3]) x sumouter(x) w <- 4:1 sumouter(x, w) v <- matrix(1, 3, 3) quadform(x, v) # should be the same as quadform(x, v) bilinearform(x, v, x) # See what happens with NA's x[3,2] <- NA sumouter(x, w) quadform(x, v) } \author{ \adrian and \rolf } \keyword{array} spatstat.sparse/man/methods.sparse3Darray.Rd0000644000176200001440000000455414141451044020646 0ustar liggesusers\name{methods.sparse3Darray} \Rdversion{1.1} \alias{methods.sparse3Darray} %DoNotExport \alias{anyNA.sparse3Darray} \alias{dim.sparse3Darray} \alias{dim<-.sparse3Darray} \alias{dimnames.sparse3Darray} \alias{dimnames<-.sparse3Darray} \alias{print.sparse3Darray} \title{ Methods for Sparse Three-Dimensional Arrays } \description{ Methods for the class \code{"sparse3Darray"} of sparse three-dimensional arrays. } \usage{ \method{anyNA}{sparse3Darray}(x, recursive = FALSE) \method{dim}{sparse3Darray}(x) \method{dim}{sparse3Darray}(x) <- value \method{dimnames}{sparse3Darray}(x) \method{dimnames}{sparse3Darray}(x) <- value \method{print}{sparse3Darray}(x, \dots) } \arguments{ \item{x}{ A sparse three-dimensional array (object of class \code{"sparse3Darray"}). } \item{value}{ Replacement value (see Details). } \item{recursive,\dots}{ Ignored. } } \details{ These are methods for the generics \code{\link[base]{anyNA}}, \code{\link[base]{dim}}, \code{\link[base]{dim<-}}, \code{\link[base]{dimnames}}, \code{\link[base]{dimnames<-}} and \code{\link[base]{print}} for the class \code{"sparse#Darray"} of sparse three-dimensional arrays. For \code{dimnames(x) <- value}, the \code{value} should either be \code{NULL}, or a list of length 3 containing character vectors giving the names of the margins. For \code{dim(x) <- value}, the \code{value} should be an integer vector of length 3 giving the new dimensions of the array. Note that this operation does not change the array positions of the non-zero entries (unlike \code{dim(x) <- value} for a full array). An error occurs if some of the non-zero entries would lie outside the new extent of the array. } \value{ \code{anyNA} returns a single logical value. \code{dim} returns an integer vector of length 3. \code{dimnames} returns \code{NULL}, or a list of length 3 whose entries are character vectors. \code{dim<-} and \code{dimnames<-} return a sparse 3D array. \code{print} returns \code{NULL}, invisibly. } \author{ \spatstatAuthors. } \seealso{ \code{\link{sparse3Darray}} } \examples{ M <- sparse3Darray(i=1:4, j=sample(1:4, replace=TRUE), k=c(1,2,1,2), x=1:4, dims=c(5,5,2)) anyNA(M) dim(M) dimnames(M) dimnames(M) <- list(letters[1:5], LETTERS[1:5], c("Yes", "No")) print(M) } \keyword{array} \keyword{manip} \concept{sparse} spatstat.sparse/DESCRIPTION0000644000176200001440000000277414157003222015125 0ustar liggesusersPackage: spatstat.sparse Version: 2.1-0 Date: 2021-12-17 Title: Sparse Three-Dimensional Arrays and Linear Algebra Utilities Authors@R: c(person("Adrian", "Baddeley", role = c("aut", "cre", "cph"), email = "Adrian.Baddeley@curtin.edu.au", comment = c(ORCID="0000-0001-9499-8382")), person("Rolf", "Turner", role = c("aut", "cph"), email="r.turner@auckland.ac.nz", comment=c(ORCID="0000-0001-5521-5218")), person("Ege", "Rubak", role = c("aut", "cph"), email = "rubak@math.aau.dk", comment=c(ORCID="0000-0002-6675-533X"))) Maintainer: Adrian Baddeley Depends: R (>= 3.5.0), stats, utils, methods, Matrix, abind, tensor Imports: spatstat.utils (>= 2.1-0) Description: Defines sparse three-dimensional arrays and supports standard operations on them. The package also includes utility functions for matrix calculations that are common in statistics, such as quadratic forms. License: GPL (>= 2) URL: http://spatstat.org/ NeedsCompilation: yes ByteCompile: true BugReports: https://github.com/spatstat/spatstat.sparse/issues Packaged: 2021-12-17 01:39:03 UTC; adrian Author: Adrian Baddeley [aut, cre, cph] (), Rolf Turner [aut, cph] (), Ege Rubak [aut, cph] () Repository: CRAN Date/Publication: 2021-12-17 03:40:02 UTC spatstat.sparse/tests/0000755000176200001440000000000014156761631014565 5ustar liggesusersspatstat.sparse/tests/sparse3Darrays.R0000644000176200001440000002416414141451044017611 0ustar liggesusers#' Header for spatstat.sparse/tests/*R #' require(spatstat.sparse) ALWAYS <- FULLTEST <- TRUE #' tests/sparse3Darrays.R #' Basic tests of code in sparse3Darray.R and sparsecommon.R #' $Revision: 1.28 $ $Date: 2021/03/07 07:39:44 $ if(!exists("ALWAYS")) ALWAYS <- TRUE if(!exists("FULLTEST")) FULLTEST <- ALWAYS if(ALWAYS) { # fundamental, C code local({ #' forming arrays #' creation by specifying nonzero elements M <- sparse3Darray(i=1:3, j=c(3,1,2), k=4:2, x=runif(3), dims=rep(4, 3)) #' duplicate entries Mn <- sparse3Darray(i=c(1,1,2), j=c(2,2,1), k=c(3,3,2), x=runif(3), dims=rep(3, 3)) #' cumulate entries in duplicate positions Ms <- sparse3Darray(i=c(1,1,2), j=c(2,2,1), k=c(3,3,2), x=runif(3), dims=rep(3, 3), strict=TRUE) #' print method print(M) #' conversion of other data A <- array(c(1,3,0,0,0,0,0,4,0,2,0,5, 0,0,1,0,0,0,1,0,0,0,1,0), dim=c(3,4,2)) A1 <- A[,,1] A2 <- A[,,2] Z <- A[integer(0), , ] #' array to sparse array AA <- as.sparse3Darray(A) # positive extent ZZ <- as.sparse3Darray(Z) # zero extent #' list of matrices to sparse array AA <- as.sparse3Darray(list(A1, A2)) #' matrix to sparse array AA1 <- as.sparse3Darray(A1) #' vector to sparse array A11 <- A[,1,1] AA11 <- as.sparse3Darray(A11) #' NULL with warning as.sparse3Darray(list()) #' dim(AA) <- dim(AA) + 1 I1 <- SparseIndices(A1) I11 <- SparseIndices(A11) if(require(Matrix)) { #' sparse matrices from Matrix package A1 <- as(A1, "sparseMatrix") A2 <- as(A2, "sparseMatrix") A11 <- as(A11, "sparseVector") #' convert a list of sparse matrices to sparse array AA <- as.sparse3Darray(list(A1, A2)) #' sparse matrix to sparse array AA1 <- as.sparse3Darray(A1) #' sparse vector to sparse array AA11 <- as.sparse3Darray(A11) #' internals E1 <- SparseEntries(A1) I1 <- SparseIndices(A1) I11 <- SparseIndices(A11) df <- data.frame(i=c(1,3,5), j=3:1, k=rep(2, 3), x=runif(3)) aa <- EntriesToSparse(df, NULL) bb <- EntriesToSparse(df, 7) cc <- EntriesToSparse(df, c(7, 4)) dd <- EntriesToSparse(df, c(7, 4, 3)) #' duplicated entries dfdup <- df[c(1:3, 2), ] aa <- EntriesToSparse(dfdup, NULL) bb <- EntriesToSparse(dfdup, 7) cc <- EntriesToSparse(dfdup, c(7, 4)) dd <- EntriesToSparse(dfdup, c(7, 4, 3)) } BB <- evalSparse3Dentrywise(AA + AA/2) MM <- bind.sparse3Darray(M, M, along=1) MM <- bind.sparse3Darray(M, M, along=2) }) local({ if(require(Matrix)) { M <- sparse3Darray(i=1:4, j=sample(1:4, replace=TRUE), k=c(1,2,1,2), x=1:4, dims=c(5,5,2)) M dimnames(M) <- list(letters[1:5], LETTERS[1:5], c("yes", "no")) M U <- aperm(M, c(1,3,2)) U #' tests of [.sparse3Darray M[ 3:4, , ] M[ 3:4, 2:4, ] M[ 4:3, 4:2, 1:2] M[, 3, ] M[, 3, , drop=FALSE] M[c(FALSE,TRUE,FALSE,FALSE,TRUE), , ] M[, , c(FALSE,FALSE), drop=FALSE] M[1:2, 1, 2:3] # exceeds array bounds # matrix index M[cbind(3:5, 3:5, c(1,2,1))] M[cbind(3:5, 3:5, 2)] M[cbind(3:5, 2, 2)] M[cbind(c(2,2,4), c(3,3,2), 1)] # repeated indices M[cbind(1:4, 1, 2:3)] # exceeds array bounds MA <- as.array(M) UA <- as.array(U) Mfix <- sparse3Darray(i=1:3, j=c(3,1,2), k=4:2, x=runif(3), dims=rep(4, 3)) Mfix[cbind(1,3,4)] # single entry - occupied Mfix[cbind(1,2,4)] # single entry - unoccupied Mfix[cbind(1,c(2,3,2,3),4)] # sparse vector with repeated entries ## tests of "[<-.sparse3Darray" Mflip <- Mzero <- MandM <- Mnew <- Mext <- M Mflip[ , , 2:1] <- M stopifnot(Mflip[3,1,1] == M[3,1,2]) Mzero[1:3,1:3,] <- 0 stopifnot(all(Mzero[1,1,] == 0)) M2a <- M[,,2,drop=FALSE] M2d <- M[,,2,drop=TRUE] MandM[,,1] <- M2a MandM[,,1] <- M2d ## slices of different dimensions M[ , 3, 1] <- 1:5 M[2, , 2] <- 1:5 M[ 1, 3:5, 2] <- 4:6 M[ 2, 5:3, 2] <- 4:6 V3 <- sparseVector(x=1, i=2, length=3) M[ 1, 3:5, 2] <- V3 M[ 2, 5:3, 2] <- V3 M[,,2] <- M2a M[,,2] <- (M2a + 1) V5 <- sparseVector(x=1:2, i=2:3, length=5) M[,2,2] <- V5 M[,,2] <- V5 Mext[1,2,3] <- 4 # exceeds array bounds ## integer matrix index Mnew[cbind(3:5, 3:5, c(1,2,1))] <- 1:3 Mnew[cbind(3:5, 3:5, 2)] <- 1:3 Mnew[cbind(3:5, 2, 2)] <- 1:3 Mnew[cbind(3:5, 3:5, c(1,2,1))] <- V3 Mnew[cbind(3:5, 3:5, 2)] <- V3 Mnew[cbind(3:5, 2, 2)] <- V3 ## tests of arithmetic (Math, Ops, Summary) negM <- -M oneM <- 1 * M oneM <- M * 1 twoM <- M + M range(M) cosM <- cos(M) # non-sparse sinM <- sin(M) # sparse Mpos <- (M > 0) # sparse Mzero <- !Mpos # non-sparse stopifnot(all((M+M) == 2*M)) # non-sparse stopifnot(!any((M+M) != 2*M)) # sparse ztimesM <- (1:5) * M # sparse zplusM <- (1:5) + M # non-sparse ## reconcile dimensions Msub <- M[,,1,drop=FALSE] Mdif <- M - Msub Mduf <- Msub - M ## tensor operator o <- tensorSparse(c(1,-1), M, 1, 3) o <- tensorSparse(M, M, 1:2, 1:2) o <- tensorSparse(M, M, 1:2, 2:1) o <- tensorSparse(as.array(M), as.array(M), 1:2, 2:1) V <- sparseVector(i=c(1,3,6),x=1:3, length=7) o <- tensorSparse(V,V) o <- tensorSparse(V,V,1,1) o <- tensorSparse(M,V[1:5],1,1) A <- sparseMatrix(i=integer(0), j=integer(0), x=numeric(0), dims=c(7, 15)) A[1:4, 2:5] <- 3 o <- tensorSparse(A, A, 1, 1) o <- tensorSparse(t(A), A, 2, 1) o <- tensorSparse(V, A, 1, 1) o <- tensorSparse(t(A), V, 2, 1) o <- tensorSparse(as.vector(V), A, 1, 1) o <- tensorSparse(t(A), as.vector(V), 2, 1) v <- 0:3 o <- tensor1x1(v, Mfix) o <- tensor1x1(v, as.array(Mfix)) o <- tensor1x1(as(v, "sparseVector"), Mfix) ## test of anyNA method anyNA(M) ## previously caused an error a <- list(i = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), j = c(17L, 4L, 34L, 39L, 38L, 25L, 14L, 40L, 1L, 19L, 36L, 9L, 16L, 23L, 15L, 17L, 4L, 34L, 39L, 38L, 25L, 14L, 40L, 1L, 19L, 36L, 9L, 16L, 23L, 15L, 13L, 31L, 8L, 5L, 42L), k = c(14L, 8L, 38L, 30L, 17L, 5L, 9L, 6L, 31L, 39L, 26L, 27L, 41L, 1L, 28L, 14L, 8L, 38L, 30L, 17L, 5L, 9L, 6L, 31L, 39L, 26L, 27L, 41L, 1L, 28L, 36L, 15L, 19L, 21L, 42L)) A <- with(a, sparse3Darray(i=i, j=j, k=k, x=1, dims=c(2, 42, 42))) stopifnot(all(sumsymouterSparse(A) == sumsymouter(as.array(A)))) # no entries indexed A[integer(0), integer(0), integer(0)] <- 99 A[matrix(, 0, 3)] <- 99 if(FULLTEST) { # re-check with randomised data ## .......... a possible application in spatstat ## n <- npoints(cells) ## cl10 <- as.data.frame(closepairs(cells, 0.1)) ## cl12 <- as.data.frame(closepairs(cells, 0.12)) ## ........... n <- 42 ii <- sample(1:n, 20) jj <- sample(1:n, 20) cl12 <- data.frame(i=ii, j=jj) cl10 <- data.frame(i=ii[1:15], j=jj[1:15]) ## ........... cl10$k <- 1 cl12$k <- 2 cl <- rbind(cl10, cl12) Z <- with(cl, sparse3Darray(i=i, j=j, k=k, x=1, dims=c(n,n,2))) dimnames(Z) <- list(NULL, NULL, c("r=0.1", "r=0.12")) Z <- aperm(Z, c(3,1,2)) stopifnot(all(sumsymouterSparse(Z) == sumsymouter(as.array(Z)))) } ## complex valued arrays Mcplx <- sparse3Darray(i=1:3, j=c(3,1,2), k=4:2, x=runif(3)+runif(3)*1i, dims=rep(4, 3)) print(Mcplx) #' ----------- sparsecommon.R ----------------------- B <- sparseMatrix(i=1:3, j=3:1, x= 10 * (1:3), dims=c(4,4)) #' (and using sparse 3D array M and sparse vector V from above) V2 <- sparseVector(i=c(2,3,6),x=4:6, length=7) # different pattern check.anySparseVector(V2, 10, fatal=FALSE) Bmap <- mapSparseEntries(B, 1, 4:1) Mmap1 <- mapSparseEntries(M, 1, 5:1, across=3) Mmap2 <- mapSparseEntries(M, 3, 2:1, conform=FALSE) Mmap3 <- mapSparseEntries(M, 1, matrix(1:10, 5, 2), across=3) Vmap <- mapSparseEntries(V, 1, V2) Vmap <- mapSparseEntries(V, 1, 8) Vthrice <- expandSparse(V, 3) VthriceT <- expandSparse(V, 3, 1) VF <- as.vector(V) # non-sparse VFmap <- mapSparseEntries(VF, 1, V2) VFmap <- mapSparseEntries(VF, 1, 8) VFthrice <- expandSparse(VF, 3) VFthriceT <- expandSparse(VF, 3, 1) VFthriceX <- expandSparse(VF, 3, 2) VV <- sparseVectorCumul(rep(1:3,2), rep(c(3,1,2), 2), 5) Vsum <- applySparseEntries(V, sum) Bdouble <- applySparseEntries(B, function(x) { 2 * x }) Mminus <- applySparseEntries(M, function(x) -x) VX <- expandSparse(B, 3, 1) VX <- expandSparse(B, 3, 2) VX <- expandSparse(B, 3, 3) # empty sparse matrices/arrays Bempty <- B Bempty[] <- 0 mapSparseEntries(Bempty, 1, 42) Mempty <- M Mempty[] <- 0 Mmap1 <- mapSparseEntries(Mempty, 1, 5:1, across=3) Mmap2 <- mapSparseEntries(Mempty, 3, 2:1, conform=FALSE) Mmap3 <- mapSparseEntries(Mempty, 1, matrix(1:10, 5, 2), across=3) #' -------------- sparselinalg.R ------------------------- U <- aperm(M,c(3,1,2)) # 2 x 5 x 5 UU <- sumsymouterSparse(U, dbg=TRUE) w <- matrix(0, 5, 5) w[cbind(1:3,2:4)] <- 0.5 w <- as(w, "sparseMatrix") UU <- sumsymouterSparse(U, w, dbg=TRUE) Uempty <- sparse3Darray(dims=c(2,5,5)) UU <- sumsymouterSparse(Uempty, w, dbg=TRUE) #' complex Ucom <- U + U * 1i UU <- sumsymouterSparse(Ucom) UU <- sumsymouterSparse(Ucom, w) #' } ## 1 x 1 x 1 arrays M1 <- sparse3Darray(i=1, j=1, k=1, x=42, dims=rep(1,3)) M0 <- sparse3Darray( dims=rep(1,3)) i1 <- matrix(1, 1, 3) a1 <- M1[i1] a0 <- M0[i1] A <- array(runif(75) * (runif(75) < 0.7), dim=c(3,5,5)) M <- as.sparse3Darray(A) M[rep(1,3), c(1,1,2), rep(2, 3)] }) } spatstat.sparse/tests/linalgeb.R0000644000176200001440000000557014156761631016474 0ustar liggesusers#' Header for spatstat.sparse/tests/*R #' require(spatstat.sparse) ALWAYS <- FULLTEST <- TRUE ## ## tests/linalgeb.R ## ## checks validity of linear algebra code ## ## $Revision: 1.12 $ $Date: 2021/12/17 00:32:32 $ ## local({ p <- 3 n <- 4 k <- 2 ## correctness of 'quadform' x <- matrix(1:(n*p), n, p) v <- matrix(runif(p^2), p, p) zW <- zU <- numeric(n) for(i in 1:n) { xi <- x[i,,drop=FALSE] zW[i] <- xi %*% v %*% t(xi) zU[i] <- xi %*% t(xi) } if(!all(zU == quadform(x))) stop("quadform gives incorrect result in Unweighted case") if(!all(zW == quadform(x,v))) stop("quadform gives incorrect result in Weighted case") ## correctness of 'sumouter' w <- runif(n) y <- matrix(1:(2*n), n, k) zUS <- zWS <- matrix(0, p, p) zUA <- zWA <- matrix(0, p, k) for(i in 1:n) { zUS <- zUS + outer(x[i,],x[i,]) zWS <- zWS + w[i] * outer(x[i,],x[i,]) zUA <- zUA + outer(x[i,],y[i,]) zWA <- zWA + w[i] * outer(x[i,],y[i,]) } if(!identical(zUS, sumouter(x))) stop("sumouter gives incorrect result in Unweighted Symmetric case") if(!identical(zWS, sumouter(x,w))) stop("sumouter gives incorrect result in Weighted Symmetric case") if(!identical(zUA, sumouter(x, y=y))) stop("sumouter gives incorrect result in Unweighted Asymmetric case") if(!identical(zWA, sumouter(x, w, y))) stop("sumouter gives incorrect result in Weighted Asymmetric case") #' complex quadratic forms - execute only dimnames(x) <- list(letters[1:nrow(x)], LETTERS[1:ncol(x)]) a <- quadform(x + 1i) b <- quadform(x + 1i, v+1i) d <- quadform(x , v+1i) a <- sumouter(x + 1i) b <- sumouter(x + 1i, w + 1i) d <- sumouter(x + 1i, w + 1i, x - 1i) #' NA values xna <- x; xna[1,1] <- NA wna <- w; w[2] <- NA vna <- v; v[1,2] <- NA o <- quadform(xna) o <- quadform(xna, vna) o <- sumouter(xna) o <- sumouter(xna, w) o <- sumouter(xna, wna) #' sumsymouter x <- array(as.numeric(1:(p * n * n)), dim=c(p, n, n)) w <- matrix(1:(n*n), n, n) y <- matrix(numeric(p * p), p, p) #' check correctness for(i in 1:n) for(j in (1:n)[-i]) y <- y + w[i,j] * outer(x[,i,j], x[,j,i]) z <- sumsymouter(x, w) if(!identical(y,z)) stop("sumsymouter gives incorrect result") #' cover code blocks o <- sumsymouter(x, distinct=FALSE) a <- sumsymouter(x + 1i) b <- sumsymouter(x + 1i, w + 1i) if(require(Matrix)) o <- sumsymouter(x, as(w, "sparseMatrix")) #' power of complex matrix M <- diag(c(4,-4)) dimnames(M) <- list(letters[1:2], letters[1:2]) V <- matrixsqrt(M) V <- matrixinvsqrt(M) V <- matrixpower(M, 1/2) U <- matrixsqrt(abs(M), complexOK=FALSE) #' infrastructure A <- matrix(1:12, 3, 4) B <- matrix(1:8, 4, 2) check.mat.mul(A, B) check.mat.mul(A, B[,1]) check.mat.mul(A, A, fatal=FALSE) D <- diag(c(1,4,9)) checksolve(D) D[1,1] <- 0 checksolve(D, "silent") }) spatstat.sparse/src/0000755000176200001440000000000014141451044014176 5ustar liggesusersspatstat.sparse/src/sumsymouter.h0000755000176200001440000000504214141377563017004 0ustar liggesusers/* sumsymouter.h Code template for some functions in linalg.c $Revision: 1.4 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Macros used: FNAME = function name, WEIGHTED = #defined for weighted version DISTINCT = #defined if contributions with i=j are omitted */ void FNAME( x, #ifdef WEIGHTED w, #endif p, n, y ) double *x; /* p by n by n array */ #ifdef WEIGHTED double *w; /* n by n matrix (symmetric) */ #endif int *p, *n; double *y; /* output matrix p by p, initialised to zero */ { int N, P; register int i, j, k, m, ijpos, jipos, maxchunk; register double *xij, *xji; #ifdef WEIGHTED register double wij; #endif N = *n; P = *p; OUTERCHUNKLOOP(i, N, maxchunk, 256) { R_CheckUserInterrupt(); INNERCHUNKLOOP(i, N, maxchunk, 256) { #ifndef DISTINCT /* ........... loop over j .......................... */ for(j = 0; j < N; j++) { /* pointers to [i,j] and [j,i] in N*N matrices */ ijpos = i + N * j; jipos = j + N * i; /* pointers to x[, i, j] and x[ , j, i] */ xij = x + ijpos * P; xji = x + jipos * P; /* outer product */ #ifdef WEIGHTED wij = w[ijpos]; #endif for(k = 0; k < P; k++) { for(m = 0; m < P; m++) { #ifdef WEIGHTED y[m + k * P] += wij * xij[m] * xji[k]; #else y[m + k * P] += xij[m] * xji[k]; #endif } } } #else /* ............ loop over j != i .......................*/ if(i > 0) { for(j = 0; j < i; j++) { /* pointers to [i,j] and [j,i] in N*N matrices */ ijpos = i + N * j; jipos = j + N * i; /* pointers to x[, i, j] and x[ , j, i] */ xij = x + ijpos * P; xji = x + jipos * P; /* outer product */ #ifdef WEIGHTED wij = w[ijpos]; #endif for(k = 0; k < P; k++) { for(m = 0; m < P; m++) { #ifdef WEIGHTED y[m + k * P] += wij * xij[m] * xji[k]; #else y[m + k * P] += xij[m] * xji[k]; #endif } } } } if(i + 1 < N) { for(j = i+1; j < N; j++) { /* pointers to [i,j] and [j,i] in N*N matrices */ ijpos = i + N * j; jipos = j + N * i; /* pointers to x[, i, j] and x[ , j, i] */ xij = x + ijpos * P; xji = x + jipos * P; /* outer product */ #ifdef WEIGHTED wij = w[ijpos]; #endif for(k = 0; k < P; k++) { for(m = 0; m < P; m++) { #ifdef WEIGHTED y[m + k * P] += wij * xij[m] * xji[k]; #else y[m + k * P] += xij[m] * xji[k]; #endif } } } } /* end of loop over j */ #endif } } } spatstat.sparse/src/sparselinalg.c0000755000176200001440000000120314141377563017042 0ustar liggesusers#include #include /* sparselinalg.c Counterpart of 'linalg.c' for sparse matrices/arrays $Revision: 1.7 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #undef DBG #define FNAME CspaSumSymOut #undef WEIGHTS #include "spasumsymout.h" #undef FNAME #define FNAME CspaWtSumSymOut #define WEIGHTS #include "spasumsymout.h" #undef FNAME #define DBG #define FNAME CDspaSumSymOut #undef WEIGHTS #include "spasumsymout.h" #undef FNAME #define FNAME CDspaWtSumSymOut #define WEIGHTS #include "spasumsymout.h" #undef FNAME spatstat.sparse/src/init.c0000644000176200001440000000251114156763230015315 0ustar liggesusers /* Native symbol registration table for spatstat.sparse package Automatically generated - do not edit this file! */ #include "proto.h" #include // for NULL #include /* See proto.h for declarations for the native routines registered below. */ static const R_CMethodDef CEntries[] = { {"Cbiform", (DL_FUNC) &Cbiform, 6}, {"CDspaSumSymOut", (DL_FUNC) &CDspaSumSymOut, 9}, {"CDspaWtSumSymOut", (DL_FUNC) &CDspaWtSumSymOut, 13}, {"Cquadform", (DL_FUNC) &Cquadform, 5}, {"CspaSumSymOut", (DL_FUNC) &CspaSumSymOut, 9}, {"CspaWtSumSymOut", (DL_FUNC) &CspaWtSumSymOut, 13}, {"Csum2outer", (DL_FUNC) &Csum2outer, 6}, {"CsumDsymouter", (DL_FUNC) &CsumDsymouter, 4}, {"Csumouter", (DL_FUNC) &Csumouter, 4}, {"Csumsymouter", (DL_FUNC) &Csumsymouter, 4}, {"Cwsum2outer", (DL_FUNC) &Cwsum2outer, 7}, {"CwsumDsymouter", (DL_FUNC) &CwsumDsymouter, 5}, {"Cwsumouter", (DL_FUNC) &Cwsumouter, 5}, {"Cwsumsymouter", (DL_FUNC) &Cwsumsymouter, 5}, {NULL, NULL, 0} }; void R_init_spatstat_sparse(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } spatstat.sparse/src/proto.h0000644000176200001440000000245614156763230015532 0ustar liggesusers#include #include /* Prototype declarations for all native routines in spatstat.sparse package Automatically generated - do not edit! */ /* Functions invoked by .C */ void Csumouter(double *, int *, int *, double *); void Cwsumouter(double *, int *, int *, double *, double *); void Csum2outer(double *, double *, int *, int *, int *, double *); void Cwsum2outer(double *, double *, int *, int *, int *, double *, double *); void Cquadform(double *, int *, int *, double *, double *); void Cbiform(double *, double *, int *, int *, double *, double *); void Csumsymouter(double *, int *, int *, double *); void Cwsumsymouter(double *, double *, int *, int *, double *); void CsumDsymouter(double *, int *, int *, double *); void CwsumDsymouter(double *, double *, int *, int *, double *); void CspaSumSymOut(int *, int *, int *, int *, int *, int *, double *, int *, double *); void CspaWtSumSymOut(int *, int *, int *, int *, int *, int *, double *, int *, int *, int *, int *, double *, double *); void CDspaSumSymOut(int *, int *, int *, int *, int *, int *, double *, int *, double *); void CDspaWtSumSymOut(int *, int *, int *, int *, int *, int *, double *, int *, int *, int *, int *, double *, double *); /* Functions invoked by .Call */ spatstat.sparse/src/chunkloop.h0000644000176200001440000000161514141451044016354 0ustar liggesusers/* chunkloop.h Divide a loop into chunks Convenient for divide-and-recombine, and reducing calls to R_CheckUserInterrupt, etc. $Revision: 1.3 $ $Date: 2018/12/18 02:43:11 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ #define OUTERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \ IVAR = 0; \ ICHUNK = 0; \ while(IVAR < LOOPLENGTH) #define INNERCHUNKLOOP(IVAR, LOOPLENGTH, ICHUNK, CHUNKSIZE) \ ICHUNK += CHUNKSIZE; \ if(ICHUNK > LOOPLENGTH) ICHUNK = LOOPLENGTH; \ for(; IVAR < ICHUNK; IVAR++) #define XOUTERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \ IVAR = ISTART; \ ICHUNK = 0; \ while(IVAR <= IEND) #define XINNERCHUNKLOOP(IVAR, ISTART, IEND, ICHUNK, CHUNKSIZE) \ ICHUNK += CHUNKSIZE; \ if(ICHUNK > IEND) ICHUNK = IEND; \ for(; IVAR <= IEND; IVAR++) #define CHUNKLOOP_H spatstat.sparse/src/linalg.c0000755000176200001440000001365214141377563015637 0ustar liggesusers/* linalg.c Home made linear algebra Yes, really $Revision: 1.14 $ $Date: 2020/05/04 03:37:34 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 Csumouter Cwsumouter Csum2outer Cwsum2outer Cquadform Csumsymouter Cwsumsymouter */ #include #include #include "chunkloop.h" /* ............... matrices ..............................*/ /* ........................sums of outer products ........*/ /* Csumouter computes the sum of outer products of columns of x y = sum[j] (x[,j] %o% x[,j]) */ void Csumouter(x, n, p, y) double *x; /* p by n matrix */ int *n, *p; double *y; /* output matrix p by p, initialised to zero */ { int N, P; register int i, j, k, maxchunk; register double xij, xkj; register double *xcolj; N = *n; P = *p; OUTERCHUNKLOOP(j, N, maxchunk, 2048) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, N, maxchunk, 2048) { xcolj = x + j * P; for(i = 0; i < P; i++) { xij = xcolj[i]; for(k = 0; k < P; k++) { xkj = xcolj[k]; y[k * P + i] += xij * xkj; } } } } } /* Cwsumouter computes the weighted sum of outer products of columns of x y = sum[j] (w[j] * x[,j] %o% x[,j]) */ void Cwsumouter(x, n, p, w, y) double *x; /* p by n matrix */ int *n, *p; double *w; /* weight vector, length n */ double *y; /* output matrix p by p, initialised to zero */ { int N, P; register int i, j, k, maxchunk; register double wj, xij, wjxij, xkj; register double *xcolj; N = *n; P = *p; OUTERCHUNKLOOP(j, N, maxchunk, 2048) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, N, maxchunk, 2048) { wj = w[j]; xcolj = x + j * P; for(i = 0; i < P; i++) { xij = xcolj[i]; wjxij = wj * xij; for(k = 0; k < P; k++) { xkj = xcolj[k]; y[k * P + i] += wjxij * xkj; } } } } } /* Csum2outer computes the sum of outer products of columns of x and y z = sum[j] (x[,j] %o% y[,j]) */ void Csum2outer(x, y, n, px, py, z) double *x, *y; /* matrices (px by n) and (py by n) */ int *n, *px, *py; double *z; /* output matrix px by py, initialised to zero */ { int N, Px, Py; register int i, j, k, maxchunk; register double xij, ykj; register double *xcolj, *ycolj; N = *n; Px = *px; Py = *py; OUTERCHUNKLOOP(j, N, maxchunk, 2048) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, N, maxchunk, 2048) { xcolj = x + j * Px; ycolj = y + j * Py; for(i = 0; i < Px; i++) { xij = xcolj[i]; for(k = 0; k < Py; k++) { ykj = ycolj[k]; z[k * Px + i] += xij * ykj; } } } } } /* Cwsum2outer computes the weighted sum of outer products of columns of x and y z = sum[j] (w[j] * x[,j] %o% y[,j]) */ void Cwsum2outer(x, y, n, px, py, w, z) double *x, *y; /* matrices (px by n) and (py by n) */ int *n, *px, *py; double *w; /* weight vector, length n */ double *z; /* output matrix px by py, initialised to zero */ { int N, Px, Py; register int i, j, k, maxchunk; register double wj, xij, wjxij, ykj; register double *xcolj, *ycolj; N = *n; Px = *px; Py = *py; OUTERCHUNKLOOP(j, N, maxchunk, 2048) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, N, maxchunk, 2048) { wj = w[j]; xcolj = x + j * Px; ycolj = y + j * Py; for(i = 0; i < Px; i++) { xij = xcolj[i]; wjxij = wj * xij; for(k = 0; k < Py; k++) { ykj = ycolj[k]; z[k * Px + i] += wjxij * ykj; } } } } } /* ........................quadratic/bilinear forms ......*/ /* computes the quadratic form values y[j] = x[,j] %*% v %*% t(x[,j]) */ void Cquadform(x, n, p, v, y) double *x; /* p by n matrix */ int *n, *p; double *v; /* p by p matrix */ double *y; /* output vector, length n */ { int N, P; register int i, j, k, maxchunk; register double xij, xkj, vik, yj; register double *xcolj; N = *n; P = *p; OUTERCHUNKLOOP(j, N, maxchunk, 2048) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, N, maxchunk, 2048) { xcolj = x + j * P; yj = 0; for(i = 0; i < P; i++) { xij = xcolj[i]; for(k = 0; k < P; k++) { xkj = xcolj[k]; vik = v[k * P + i]; yj += xij * vik * xkj; } } y[j] = yj; } } } /* computes the bilinear form values z[j] = x[,j] %*% v %*% t(y[,j]) */ void Cbiform(x, y, n, p, v, z) double *x, *y; /* p by n matrices */ int *n, *p; double *v; /* p by p matrix */ double *z; /* output vector, length n */ { int N, P; register int i, j, k, maxchunk; register double xij, vik, ykj, zj; register double *xcolj, *ycolj; N = *n; P = *p; OUTERCHUNKLOOP(j, N, maxchunk, 2048) { R_CheckUserInterrupt(); INNERCHUNKLOOP(j, N, maxchunk, 2048) { xcolj = x + j * P; ycolj = y + j * P; zj = 0; for(i = 0; i < P; i++) { xij = xcolj[i]; for(k = 0; k < P; k++) { ykj = ycolj[k]; vik = v[k * P + i]; zj += xij * vik * ykj; } } z[j] = zj; } } } /* ............... 3D arrays ...................... */ #undef FNAME #undef WEIGHTED #undef DISTINCT /* sumsymouter computes the sum of outer products x[,i,j] %o% x[,j,i] over all pairs i, j */ #define FNAME Csumsymouter #include "sumsymouter.h" #undef FNAME /* wsumsymouter computes the weighted sum of outer products w[i,j] * (x[,i,j] %o% x[,j,i]) over all pairs i, j */ #define FNAME Cwsumsymouter #define WEIGHTED #include "sumsymouter.h" #undef FNAME #undef WEIGHTED #define DISTINCT /* sumDsymouter computes the sum of outer products x[,i,j] %o% x[,j,i] over all pairs i, j with i != j */ #define FNAME CsumDsymouter #include "sumsymouter.h" #undef FNAME /* wsumDsymouter computes the weighted sum of outer products w[i,j] * (x[,i,j] %o% x[,j,i]) over all pairs i, j with i != j */ #define FNAME CwsumDsymouter #define WEIGHTED #include "sumsymouter.h" #undef FNAME #undef WEIGHTED spatstat.sparse/src/spasumsymout.h0000755000176200001440000001046414141377563017165 0ustar liggesusers/* spasumsymout.h Function definitions for 'sumsymouter' for sparse matrices/arrays This file is #included in sparselinalg.c several times. Macros used FNAME function name DBG (#ifdef) debug WEIGHTS (#ifdef) use weights $Revision: 1.7 $ $Date: 2020/05/04 08:41:24 $ Copyright (C) Adrian Baddeley, Ege Rubak and Rolf Turner 2001-2018 Licence: GNU Public Licence >= 2 */ void FNAME(m, n, lenx, ix, jx, kx, x, flip, #ifdef WEIGHTS lenw, jw, kw, w, #endif y) int *m, *n; /* dimensions of array m * n * n */ int *lenx; /* number of nonzero entries in sparse array x */ int *ix, *jx, *kx; /* indices of entries in sparse array x */ double *x; /* values in sparse array x */ /* NB: ix, jx, kx are assumed to be sorted by order(j,k,i) i.e. in increasing order of j, then k within j, then i within (j,k) */ int *flip; /* reordering of ix, jx, kx, x that would achieve increasing order(k,j,i) */ #ifdef WEIGHTS int *lenw; /* length of jw, kw */ int *jw, *kw; /* indices of entries in sparse matrix w of weights */ /* Assumed sorted by order (j,k) */ double *w; /* values of weights w */ #endif double *y; /* output: full m * m matrix */ { /* Compute the sum of outer(x[,j,k], x[,k,j]) for all j != k */ int M,N,L, i,j,k,ii, l, ll, lstart, lend, t, tstart, tend, r; double xijk, xx; int *it, *jt, *kt; double *xt; #ifdef WEIGHTS int R; double wjk; #endif M = *m; N = *n; L = *lenx; #ifdef WEIGHTS R = *lenw; #endif if(L <= 1 || N <= 1 || M <= 0) return; /* Create space to store array in k-major order*/ it = (int *) R_alloc(L, sizeof(int)); jt = (int *) R_alloc(L, sizeof(int)); kt = (int *) R_alloc(L, sizeof(int)); xt = (double *) R_alloc(L, sizeof(double)); /* copy reordered array */ #ifdef DBG Rprintf("---------- Reordered: -------------------\n"); #endif for(l = 0; l < L; l++) { ll = flip[l]; it[l] = ix[ll]; jt[l] = jx[ll]; kt[l] = kx[ll]; xt[l] = x[ll]; #ifdef DBG Rprintf("%d \t [%d, %d, %d] = %lf\n", l, it[l], jt[l], kt[l], xt[l]); #endif } /* Now process array */ lstart = tstart = r = 0; lend = tend = -1; /* to keep compiler happy */ while(lstart < L && tstart < L) { /* Consider a new entry x[,j,k] */ j = jx[lstart]; k = kx[lstart]; #ifdef DBG Rprintf("Entry %d: [, %d, %d]\n", lstart, j, k); #endif #ifdef WEIGHTS /* Find weight w[j,k] */ while(r < R && ((jw[r] < j) || ((jw[r] == j) && (kw[r] < k)))) ++r; if(r < R && jw[r] == j && kw[r] == k) { /* weight w[j,k] is present */ wjk = w[r]; #endif /* Find all entries in x with the same j,k */ for(lend = lstart+1; lend < L && jx[lend] == j && kx[lend] == k; ++lend) ; --lend; #ifdef DBG Rprintf("\t lstart=%d, lend=%d\n", lstart, lend); #endif /* Find corresponding entries in transpose (k'=j, j'=k) */ /* search forward to find start of run */ while(tstart < L && ((kt[tstart] < j) || (kt[tstart] == j && jt[tstart] < k))) ++tstart; #ifdef DBG Rprintf("\t tstart=%d\n", tstart); Rprintf("\t kt[tstart]=%d, jt[tstart]=%d\n", kt[tstart], jt[tstart]); #endif if(tstart < L && kt[tstart] == j && jt[tstart] == k) { /* Both x[,j,k] and x[,k,j] are present so a contribution will occur */ /* seek end of run */ for(tend = tstart+1; tend < L && kt[tend] == j && jt[tend] == k; ++tend) ; --tend; #ifdef DBG Rprintf("\t tend=%d\n", tend); #endif /* Form products */ for(l = lstart; l <= lend; l++) { i = ix[l]; xijk = x[l]; #ifdef DBG Rprintf("Entry %d: [%d, %d, %d] = %lf\n", l, i, j, k, xijk); #endif for(t = tstart; t <= tend; t++) { ii = it[t]; xx = xijk * xt[t]; #ifdef WEIGHTS xx *= wjk; #endif /* increment result at [i, ii] and [ii, i]*/ y[i + M * ii] += xx; /* y[ii + M * i] += xx; */ #ifdef DBG Rprintf("-- matches entry %d: [%d, %d, %d] = %lf\n", t, ii, k, j, xt[t]); Rprintf("++ %lf\n", xx); #endif } } } #ifdef WEIGHTS } #endif lstart = ((lend > lstart) ? lend : lstart) + 1; /* INCORRECT: tstart = ((tend > tstart) ? tend : tstart) + 1; */ } } spatstat.sparse/NEWS0000644000176200001440000001151514156763230014122 0ustar liggesusers CHANGES IN spatstat.sparse VERSION 2.1-0 OVERVIEW o Join two sparse arrays. o Minor improvements and bug fixes. NEW FUNCTIONS o bind.sparse3Darray Join two sparse three-dimensional arrays along a specified dimension (analogously to 'rbind', 'cbind' or 'abind') to make another sparse three-dimensional array. SIGNIFICANT USER-VISIBLE CHANGES o quadform Argument 'v=NULL' is now accepted, and interpreted as the identity matrix. o bilinearform Argument 'v=NULL' is now accepted, and interpreted as the identity matrix. BUG FIXES o quadform Crashed if 'v' was missing. Fixed. CHANGES IN spatstat.sparse VERSION 2.0-0 OVERVIEW o Package adjusted to conform to the spatstat family. o New function 'gridadjacencymatrix'. NEW FUNCTIONS o gridadjacencymatrix Given the dimensions of a rectangular grid of points, create the adjacency matrix for the corresponding neighbourhood graph, whose vertices are the grid points, and whose edges are the joins between neighbouring grid points. The result is a sparse matrix. CHANGES IN spatstat.sparse VERSION 1.3-1 OVERVIEW o Internal adjustments. CHANGES IN spatstat.sparse VERSION 1.3-0 OVERVIEW o Some code has been transferred to spatstat.utils. SIGNIFICANT USER-VISIBLE CHANGES o RelevantNA, RelevantZero, RelevantEmpty, grokIndexVector These functions have been moved to the package 'spatstat.utils'. CHANGES IN spatstat.sparse VERSION 1.2-1 OVERVIEW o Internal bug fix. CHANGES IN spatstat.sparse VERSION 1.2-0 OVERVIEW o Efficiency improvement SIGNIFICANT USER-VISIBLE CHANGES o spatstat.sparse Code should run faster; we have reduced the overheads in executing C code. CHANGES IN spatstat.sparse VERSION 1.1-1 OVERVIEW o Internal code improvements. CHANGES IN spatstat.sparse VERSION 1.1-0 OVERVIEW o Internal code improvements. CHANGES IN spatstat.sparse VERSION 1.0-9 OVERVIEW o Internal code improvements. CHANGES IN spatstat.sparse VERSION 1.0-8 OVERVIEW o Internal code improvements. BUG FIXES o sumouter Crashed if 'w' contained NA values. Fixed. CHANGES IN spatstat.sparse VERSION 1.0-7 OVERVIEW o Internal code tweaks. CHANGES IN spatstat.sparse VERSION 1.0-6 OVERVIEW o More documentation. SIGNIFICANT USER-VISIBLE CHANGES o marginSumsSparse This function is now documented. CHANGES IN spatstat.sparse VERSION 1.0-5 OVERVIEW o More support for complex values SIGNIFICANT USER-VISIBLE CHANGES o sumouter, quadform, bilinearform These functions now handle complex-valued matrices and vectors. o marginSumsSparse This function now handles complex-valued sparse arrays. CHANGES IN spatstat.sparse VERSION 1.0-4 OVERVIEW o spatstat.sparse now 'requires' the Matrix package. SIGNIFICANT USER-VISIBLE CHANGES o spatstat.sparse package spatstat.sparse now 'requires' the Matrix package, so that Matrix is loaded when spatstat.sparse is loaded. CHANGES IN spatstat.sparse VERSION 1.0-3 OVERVIEW o More documentation. SIGNIFICANT USER-VISIBLE CHANGES o "[.sparse3Darray" The subset extraction operator is now documented. o "[<-.sparse3Darray" The subset assignment operator is now documented. o as.array.sparse3Darray This method is now documented. o anyNA.sparse3Darray This method is now documented. o dim.sparse3Darray, "dim<-.sparse3Darray" These methods are now documented. o dimnames.sparse3Darray, "dimnames<-.sparse3Darray" These methods are now documented. o sumouter A mathematical statement in the help file has been corrected. CHANGES IN spatstat.sparse VERSION 1.0-2 OVERVIEW o More documentation SIGNIFICANT USER-VISIBLE CHANGES o sparse3Darray This function is now documented. o aperm.sparse3Darray This function is now documented. o as.sparse3Darray This function is now documented. o tensorSparse This function is now documented. o Math.sparse3Darray, Ops.sparse3Darray, Complex.sparse3Darray, Summary.sparse3Darray The methods for the group generics are now documented. CHANGES IN spatstat.sparse VERSION 1.0-1 OVERVIEW o Corrections to the internal structure. o Bug fixes. o More functions are documented SIGNIFICANT USER-VISIBLE CHANGES o sumsymouter New argument 'distinct'. BUG FIXES o sumsymouter Results were incorrect for sparse arrays in some cases: some contributions to the sum were omitted. Fixed. CHANGES IN spatstat.sparse VERSION 1.0-0 OVERVIEW o This new package has been created from code removed from the spatstat package. spatstat.sparse/R/0000755000176200001440000000000014141451044013610 5ustar liggesusersspatstat.sparse/R/linalg.R0000644000176200001440000002374614156763230015226 0ustar liggesusers#' #' linalg.R #' #' Linear Algebra #' #' Copyright (c) Adrian Baddeley, Ege Rubak and Rolf Turner 2016-2020 #' GNU Public Licence >= 2.0 #' #' $Revision: 1.37 $ $Date: 2021/12/17 01:17:06 $ #' sumouter <- function(x, w=NULL, y=x) { #' compute matrix sum_i (w[i] * outer(x[i,], y[i,])) stopifnot(is.matrix(x)) weighted <- !is.null(w) symmetric <- missing(y) || identical(x,y) if(!symmetric) { stopifnot(is.matrix(y)) stopifnot(nrow(x) == nrow(y)) } if(weighted) { if(max(1L, dim(w)) > 1L) stop("w should be a vector") w <- as.vector(w) if(is.complex(w)) { stopifnot(length(w) == nrow(x)) } else { w <- as.numeric(w) check.nvector(w, nrow(x), things="rows of x", naok=TRUE) } } #' ............ complex arguments .................... #' handle complex weights ... if(weighted && is.complex(w)) { a <- if(symmetric) sumouter(x, Re(w)) else sumouter(x, Re(w), y) b <- if(symmetric) sumouter(x, Im(w)) else sumouter(x, Im(w), y) result <- a + b * 1i return(result) } #' handle complex x, y ... if(is.complex(x) || is.complex(y)) { Rex <- Re(x) Imx <- Im(x) Sux <- Rex + Imx if(symmetric) { RexRey <- sumouter(Rex, w) ImxImy <- sumouter(Imx, w) SuxSuy <- sumouter(Sux, w) } else { Rey <- Re(y) Imy <- Im(y) Suy <- Rey + Imy RexRey <- sumouter(Rex, w, Rey) ImxImy <- sumouter(Imx, w, Imy) SuxSuy <- sumouter(Sux, w, Suy) } result <- RexRey - ImxImy + (SuxSuy - RexRey - ImxImy) * 1i return(result) } #' .......... All arguments are numeric. ................. #' Transpose (compute outer squares of columns) tx <- t(x) if(!symmetric) ty <- t(y) #' check for NA etc ok <- apply(is.finite(tx), 2, all) if(!symmetric) ok <- ok & apply(is.finite(ty), 2, all) if(weighted) ok <- ok & is.finite(w) #' remove NA etc if(!all(ok)) { tx <- tx[ , ok, drop=FALSE] if(!symmetric) ty <- ty[ , ok, drop=FALSE] if(weighted) w <- w[ok] } #' call C code if(symmetric) { n <- ncol(tx) p <- nrow(tx) if(is.null(w)) { zz <- .C(SP_Csumouter, x=as.double(tx), n=as.integer(n), p=as.integer(p), y=as.double(numeric(p * p)), PACKAGE = "spatstat.sparse") } else { zz <- .C(SP_Cwsumouter, x=as.double(tx), n=as.integer(n), p=as.integer(p), w=as.double(w), y=as.double(numeric(p * p)), PACKAGE = "spatstat.sparse") } out <- matrix(zz$y, p, p) if(!is.null(nama <- colnames(x))) dimnames(out) <- list(nama, nama) } else { n <- ncol(tx) px <- nrow(tx) py <- nrow(ty) if(is.null(w)) { zz <- .C(SP_Csum2outer, x=as.double(tx), y=as.double(ty), n=as.integer(n), px=as.integer(px), py=as.integer(py), z=as.double(numeric(px * py)), PACKAGE = "spatstat.sparse") } else { zz <- .C(SP_Cwsum2outer, x=as.double(tx), y=as.double(ty), n=as.integer(n), px=as.integer(px), py=as.integer(py), w=as.double(w), z=as.double(numeric(px * py))) } out <- matrix(zz$z, px, py) namx <- colnames(x) namy <- colnames(y) if(!is.null(namx) || !is.null(namy)) dimnames(out) <- list(namx, namy) } return(out) } quadform <- function(x, v) { #' compute vector of values y[i] = x[i, ] %*% v %*% t(x[i,]) stopifnot(is.matrix(x)) #' if(missing(v) || is.null(v)) { v <- diag(ncol(x)) } else { stopifnot(is.matrix(v)) if(nrow(v) != ncol(v)) stop("v should be a square matrix") stopifnot(ncol(x) == nrow(v)) } #' handle complex values if(is.complex(v)) { a <- quadform(x, Re(v)) b <- quadform(x, Im(v)) result <- a + b * 1i return(result) } if(is.complex(x)) { A <- quadform(Re(x), v) B <- quadform(Im(x), v) D <- quadform(Re(x) + Im(x), v) result <- A - B + (D - A - B) * 1i return(result) } #' arguments are numeric p <- ncol(x) n <- nrow(x) nama <- rownames(x) # transpose (evaluate quadratic form for each column) tx <- t(x) ok <- apply(is.finite(tx), 2, all) allok <- all(ok) if(!allok) { tx <- tx[ , ok, drop=FALSE] n <- ncol(tx) } z <- .C(SP_Cquadform, x=as.double(tx), n=as.integer(n), p=as.integer(p), v=as.double(v), y=as.double(numeric(n)), PACKAGE = "spatstat.sparse") result <- z$y names(result) <- nama[ok] if(allok) return(result) fullresult <- rep.int(NA_real_, length(ok)) fullresult[ok] <- result names(fullresult) <- nama return(fullresult) } bilinearform <- function(x, v, y) { #' compute vector of values z[i] = x[i, ] %*% v %*% t(y[i,]) stopifnot(is.matrix(x)) stopifnot(is.matrix(y)) stopifnot(identical(dim(x), dim(y))) if(missing(v) || is.null(v)) { v <- diag(ncol(x)) } else { stopifnot(is.matrix(v)) if(nrow(v) != ncol(v)) stop("v should be a square matrix") stopifnot(ncol(x) == nrow(v)) } #' handle complex values if(is.complex(v)) { a <- bilinearform(x, Re(v), y) b <- bilinearform(x, Im(v), y) result <- a + b * 1i return(result) } if(is.complex(x) || is.complex(y)) { a <- bilinearform(Re(x), v, Re(y)) b <- bilinearform(Im(x), v, Im(y)) d <- bilinearform(Re(x)+Im(x), v, Re(y)+Im(y)) result <- a - b + (d - a - b) * 1i return(result) } #' arguments are numeric p <- ncol(x) n <- nrow(x) nama <- rownames(x) # transpose (evaluate quadratic form for each column) tx <- t(x) ty <- t(y) ok <- matcolall(is.finite(tx)) & matcolall(is.finite(ty)) allok <- all(ok) if(!allok) { tx <- tx[ , ok, drop=FALSE] ty <- ty[ , ok, drop=FALSE] n <- ncol(tx) } z <- .C(SP_Cbiform, x=as.double(tx), y=as.double(ty), n=as.integer(n), p=as.integer(p), v=as.double(v), z=as.double(numeric(n)), PACKAGE = "spatstat.sparse") result <- z$z names(result) <- nama[ok] if(allok) return(result) fullresult <- rep.int(NA_real_, length(ok)) fullresult[ok] <- result names(fullresult) <- nama return(fullresult) } sumsymouter <- function(x, w=NULL, distinct=TRUE) { ## x is a 3D array ## w is a matrix ## Computes the sum of outer(x[,i,j], x[,j,i]) * w[i,j] over all pairs i != j ## handle complex values if(is.complex(w)) { a <- sumsymouter(x, Re(w), distinct=distinct) b <- sumsymouter(x, Im(w), distinct=distinct) result <- a + b * 1i return(result) } if(is.complex(x)) { a <- sumsymouter(Re(x), w=w, distinct=distinct) b <- sumsymouter(Im(x), w=w, distinct=distinct) d <- sumsymouter(Re(x)+Im(x), w=w, distinct=distinct) result <- a - b + (d - a - b) * 1i return(result) } ## handle sparse arrays if(inherits(x, c("sparseSlab", "sparse3Darray")) && (is.null(w) || inherits(w, "sparseMatrix"))) return(sumsymouterSparse(x, w, distinct=distinct)) ## arguments are numeric x <- as.array(x) stopifnot(length(dim(x)) == 3) if(dim(x)[2L] != dim(x)[3L]) stop("The second and third dimensions of x should be equal") if(!is.null(w)) { w <- as.matrix(w) if(!all(dim(w) == dim(x)[-1L])) stop("Dimensions of w should match the second and third dimensions of x") } p <- dim(x)[1L] n <- dim(x)[2L] if(!distinct) { ## contributions from all pairs i,j if(is.null(w)) { zz <- .C(SP_Csumsymouter, x = as.double(x), p = as.integer(p), n = as.integer(n), y = as.double(numeric(p * p)), PACKAGE = "spatstat.sparse") } else { zz <- .C(SP_Cwsumsymouter, x = as.double(x), w = as.double(w), p = as.integer(p), n = as.integer(n), y = as.double(numeric(p * p)), PACKAGE = "spatstat.sparse") } } else { ## contributions from pairs i != j if(is.null(w)) { zz <- .C(SP_CsumDsymouter, x = as.double(x), p = as.integer(p), n = as.integer(n), y = as.double(numeric(p * p)), PACKAGE = "spatstat.sparse") } else { zz <- .C(SP_CwsumDsymouter, x = as.double(x), w = as.double(w), p = as.integer(p), n = as.integer(n), y = as.double(numeric(p * p)), PACKAGE = "spatstat.sparse") } } matrix(zz$y, p, p) } ## matrix utilities checksolve <- function(M, action=c("fatal", "warn", "silent"), descrip, target="inverse") { Mname <- short.deparse(substitute(M)) action <- match.arg(action) Minv <- try(solve(M), silent=(action=="silent")) if(!inherits(Minv, "try-error")) return(Minv) if(missing(descrip) || sum(nzchar(descrip)) == 0) descrip <- paste("the matrix", sQuote(Mname)) whinge <- paste("Cannot compute", paste0(target, ":"), descrip, "is singular") switch(action, fatal=stop(whinge, call.=FALSE), warn= warning(whinge, call.=FALSE), silent={}) return(NULL) } check.mat.mul <- function(A, B, Acols="columns of A", Brows="rows of B", fatal=TRUE) { # check whether A %*% B would be valid: if not, print a useful message if(!is.matrix(A)) A <- matrix(A, nrow=1, dimnames=list(NULL, names(A))) if(!is.matrix(B)) B <- matrix(B, ncol=1, dimnames=list(names(B), NULL)) nA <- ncol(A) nB <- nrow(B) if(nA == nB) return(TRUE) if(!fatal) return(FALSE) if(any(nzchar(Anames <- colnames(A)))) message(paste0("Names of ", Acols, ": ", commasep(Anames))) if(any(nzchar(Bnames <- rownames(B)))) message(paste0("Names of ", Brows, ": ", commasep(Bnames))) stop(paste("Internal error: number of", Acols, paren(nA), "does not match number of", Brows, paren(nB)), call.=FALSE) } spatstat.sparse/R/matrixpower.R0000755000176200001440000000474414144332041016326 0ustar liggesusers#' #' matrixpower.R #' #' Copyright (c) Adrian Baddeley, Ege Rubak and Rolf Turner 2016-2020 #' GNU Public Licence >= 2.0 #' #' $Revision: 1.4 $ $Date: 2020/06/02 01:07:46 $ #' matrixsqrt <- function(x, complexOK=TRUE) { ## matrix square root if(length(dim(x)) != 2) stop("x must be a matrix") if(!is.matrix(x)) x <- as.matrix(x) if(missing(complexOK) && is.complex(x)) complexOK <- TRUE if(!complexOK) stopifnot(is.numeric(x)) else stopifnot(is.numeric(x) || is.complex(x)) e <- eigen(x) values <- e$values vectors <- e$vectors if(any(values < 0)) { if(complexOK) values <- as.complex(values) else stop("matrix has negative eigenvalues: square root is complex", call.=FALSE) } y <- vectors %*% diag(sqrt(values)) %*% t(vectors) if(!is.null(dn <- dimnames(x))) dimnames(y) <- rev(dn) return(y) } matrixinvsqrt <- function(x, complexOK=TRUE) { ## matrix inverse square root if(length(dim(x)) != 2) stop("x must be a matrix") if(!is.matrix(x)) x <- as.matrix(x) if(missing(complexOK) && is.complex(x)) complexOK <- TRUE if(!complexOK) stopifnot(is.numeric(x)) else stopifnot(is.numeric(x) || is.complex(x)) e <- eigen(x) values <- e$values vectors <- e$vectors if(any(values == 0)) stop("matrix is singular; cannot compute inverse square root", call.=FALSE) if(any(values < 0)) { if(complexOK) values <- as.complex(values) else stop("matrix has negative eigenvalues: inverse square root is complex", call.=FALSE) } y <- vectors %*% diag(1/sqrt(values)) %*% t(vectors) if(!is.null(dn <- dimnames(x))) dimnames(y) <- rev(dn) return(y) } matrixpower <- function(x, power, complexOK=TRUE) { check.1.real(power) if(length(dim(x)) != 2) stop("x must be a matrix") if(!is.matrix(x)) x <- as.matrix(x) if(missing(complexOK) && is.complex(x)) complexOK <- TRUE if(!complexOK) stopifnot(is.numeric(x)) else stopifnot(is.numeric(x) || is.complex(x)) e <- eigen(x) values <- e$values vectors <- e$vectors if(any(values == 0) && power < 0) stop("matrix is singular; cannot compute negative power", call.=FALSE) if(any(values < 0) && (power != ceiling(power))) { if(complexOK) values <- as.complex(values) else stop("matrix has negative eigenvalues: result is complex", call.=FALSE) } y <- vectors %*% diag(values^power) %*% t(vectors) if(!is.null(dn <- dimnames(x))) dimnames(y) <- rev(dn) return(y) } spatstat.sparse/R/sparsecommon.R0000644000176200001440000002321514144332041016442 0ustar liggesusers#' #' sparsecommon.R #' #' Utilities for sparse arrays #' #' Copyright (c) Adrian Baddeley, Ege Rubak and Rolf Turner 2016-2020 #' GNU Public Licence >= 2.0 #' #' $Revision: 1.18 $ $Date: 2021/02/06 04:31:41 $ #' #' .............. completely generic .................... inside3Darray <- function(d, i, j, k) { stopifnot(length(d) == 3) if(length(dim(i)) == 2 && missing(j) && missing(k)) { stopifnot(ncol(i) == 3) j <- i[,2] k <- i[,3] i <- i[,1] } ans <- inside.range(i, c(1, d[1])) & inside.range(j, c(1, d[2])) & inside.range(k, c(1, d[3])) return(ans) } #' .............. depends on Matrix package ................ sparseVectorCumul <- function(x, i, length) { #' extension of 'sparseVector' to allow repeated indices #' (the corresponding entries are added) z <- tapply(x, list(factor(i, levels=1:length)), sum) z <- z[!is.na(z)] sparseVector(i=as.integer(names(z)), x=as.numeric(z), length=length) } #' .............. code that mentions sparse3Darray ................ expandSparse <- function(x, n, across) { #' x is a sparse vector/matrix; replicate it 'n' times #' and form a sparse matrix/array #' in which each slice along the 'across' dimension is identical to 'x' #' Default is across = length(dim(x)) + 1 check.1.integer(n) stopifnot(n >= 1) dimx <- dim(x) if(is.null(dimx)) { if(inherits(x, "sparseVector")) dimx <- x@length else if(is.vector(x)) dimx <- length(x) else stop("Format of x is not understood", call.=FALSE) } nd <- length(dimx) if(missing(across)) across <- nd + 1L else { check.1.integer(across) if(!(across %in% (1:(nd+1L)))) stop(paste("Argument 'across' must be an integer from 1 to", nd+1L), call.=FALSE) } if(nd == 1) { if(inherits(x, "sparseVector")) { m <- length(x@x) y <- switch(across, sparseMatrix(i=rep(1:n, times=m), j=rep(x@i, each=n), x=rep(x@x, each=n), dims=c(n, dimx)), sparseMatrix(i=rep(x@i, each=n), j=rep(1:n, times=m), x=rep(x@x, each=n), dims=c(dimx, n))) } else { y <- switch(across, outer(1:n, x, function(a,b) b), outer(x, 1:n, function(a,b) a)) } } else if(nd == 2) { if(inherits(x, "sparseMatrix")) { z <- as(x, "TsparseMatrix") m <- length(z@x) y <- switch(across, sparse3Darray(i=rep(1:n, times=m), j=rep(z@i + 1L, each=n), k=rep(z@j + 1L, each=n), x=rep(z@x, each=n), dims=c(n, dimx)), sparse3Darray(i=rep(z@i + 1L, each=n), j=rep(1:n, times=m), k=rep(z@j + 1L, each=n), x=rep(z@x, each=n), dims=c(dimx[1], n, dimx[2])), sparse3Darray(i=rep(z@i + 1L, each=n), j=rep(z@j + 1L, each=n), k=rep(1:n, times=m), x=rep(z@x, each=n), dims=c(dimx, n))) } else stop("Not yet implemented for full arrays") } else stop("Not implemented for arrays of more than 2 dimensions", call.=FALSE) return(y) } mapSparseEntries <- function(x, margin, values, conform=TRUE, across) { # replace the NONZERO entries of sparse vector, matrix or array # by values[l] where l is one of the slice indices dimx <- dim(x) if(is.null(dimx)) { if(inherits(x, "sparseVector")) dimx <- x@length else if(is.vector(x)) dimx <- length(x) else stop("Format of x is not understood", call.=FALSE) } if(length(dimx) == 1) { x <- as(x, "sparseVector") i <- x@i if(length(i) == 0) { # no entries return(x) } if(!missing(margin) && !is.null(margin)) stopifnot(margin == 1) check.anySparseVector(values, dimx, things="entries", oneok=TRUE) nv <- if(inherits(values, "sparseVector")) values@length else length(values) yvalues <- if(nv > 1) as.vector(values[i]) else rep(values[1], length(i)) y <- sparseVector(i=i, x=yvalues, length=dimx) return(y) } if(inherits(x, "sparseMatrix")) { x <- as(x, Class="TsparseMatrix") if(length(x@i) == 0) { # no entries return(x) } check.1.integer(margin) stopifnot(margin %in% 1:2) check.anySparseVector(values, dimx[margin], things=c("rows","columns")[margin], oneok=TRUE) nv <- if(inherits(values, "sparseVector")) values@length else length(values) i <- x@i + 1L j <- x@j + 1L yindex <- switch(margin, i, j) yvalues <- if(nv > 1) values[yindex] else rep(values[1], length(yindex)) y <- sparseMatrix(i=i, j=j, x=yvalues, dims=dimx, dimnames=dimnames(x)) y <- drop0(y) return(y) } if(inherits(x, "sparse3Darray")) { if(length(x$i) == 0) { # no entries return(x) } ijk <- cbind(i=x$i, j=x$j, k=x$k) if(conform) { #' ensure common pattern of sparse values #' in each slice on 'across' margin force(across) nslice <- dimx[across] #' pick one representative of each equivalence class ## ---- old code --------- ## dup <- duplicated(ijk[,-across,drop=FALSE]) ## ijk <- ijk[!dup, , drop=FALSE] ## --------------------- use <- representativeRows(ijk[,-across,drop=FALSE]) ijk <- ijk[use, , drop=FALSE] ## npattern <- nrow(ijk) #' repeat this pattern in each 'across' slice ijk <- apply(ijk, 2, rep, times=nslice) ijk[, across] <- rep(seq_len(nslice), each=npattern) } if(is.vector(values) || inherits(values, "sparseVector")) { # vector of values matching margin extent check.anySparseVector(values, dimx[margin], things=c("rows","columns","planes")[margin], oneok=TRUE) nv <- if(inherits(values, "sparseVector")) values@length else length(values) yindex <- ijk[,margin] yvalues <- if(nv > 1) values[yindex] else rep(values[1], length(yindex)) y <- sparse3Darray(i=ijk[,1], j=ijk[,2], k=ijk[,3], x=yvalues, dims=dimx, dimnames=dimnames(x)) return(y) } else if(is.matrix(values) || inherits(values, "sparseMatrix")) { #' matrix of values. force(across) stopifnot(across != margin) #' rows of matrix must match 'margin' if(nrow(values) != dimx[margin]) stop(paste("Number of rows of values", paren(nrow(values)), "does not match array size in margin", paren(dimx[margin])), call.=FALSE) #' columns of matrix must match 'across' if(ncol(values) != dimx[across]) stop(paste("Number of columns of values", paren(ncol(values)), "does not match array size in 'across'", paren(dimx[across])), call.=FALSE) # map yindex <- ijk[,margin] zindex <- ijk[,across] y <- sparse3Darray(i=ijk[,1], j=ijk[,2], k=ijk[,3], x=values[cbind(yindex,zindex)], dims=dimx, dimnames=dimnames(x)) return(y) } else stop("Format of values not understood", call.=FALSE) } stop("Format of x not understood", call.=FALSE) } applySparseEntries <- local({ applySparseEntries <- function(x, f, ...) { ## apply vectorised function 'f' only to the nonzero entries of 'x' if(inherits(x, "sparseMatrix")) { x <- applytoxslot(x, f, ...) } else if(inherits(x, "sparse3Darray")) { x <- applytoxentry(x, f, ...) } else { x <- f(x, ...) } return(x) } applytoxslot <- function(x, f, ...) { xx <- x@x n <- length(xx) xx <- f(xx, ...) if(length(xx) != n) stop(paste("Function f returned the wrong number of values:", length(xx), "instead of", n), call.=FALSE) x@x <- xx return(x) } applytoxentry <- function(x, f, ...) { xx <- x$x n <- length(xx) xx <- f(xx, ...) if(length(xx) != n) stop(paste("Function f returned the wrong number of values:", length(xx), "instead of", n), call.=FALSE) x$x <- xx return(x) } applySparseEntries }) check.anySparseVector <- function(v, npoints=NULL, fatal=TRUE, things="data points", naok=FALSE, warn=FALSE, vname, oneok=FALSE) { # vector, factor or sparse vector of values for each point/thing if(missing(vname)) vname <- sQuote(deparse(substitute(v))) whinge <- NULL isVector <- is.atomic(v) && is.null(dim(v)) isSparse <- inherits(v, "sparseVector") nv <- if(isSparse) v@length else length(v) if(!isVector && !isSparse) whinge <- paste(vname, "is not a vector, factor or sparse vector") else if(!(is.null(npoints) || (nv == npoints)) && !(oneok && nv == 1)) whinge <- paste("The length of", vname, paren(paste0("=", nv)), "should equal the number of", things, paren(paste0("=", npoints))) else if(!naok && anyNA(v)) whinge <- paste("Some values of", vname, "are NA or NaN") # if(!is.null(whinge)) { if(fatal) stop(whinge) if(warn) warning(whinge) ans <- FALSE attr(ans, "whinge") <- whinge return(ans) } return(TRUE) } representativeRows <- function(x) { ## select a unique representative of each equivalence class of rows, ## in a numeric matrix or data frame of numeric values. nr <- nrow(x) if(nr == 1L) return(TRUE) if(nr == 2L) { agree <- all(x[1,] == x[2,]) ans <- c(TRUE, !agree) return(ans) } ord <- do.call(order, as.list(as.data.frame(x))) y <- x[ord, , drop=FALSE] dy <- apply(y, 2, diff) answer <- logical(nrow(y)) answer[ord] <- c(TRUE, !matrowall(dy == 0)) return(answer) } spatstat.sparse/R/sparselinalg.R0000644000176200001440000002501214144332041016415 0ustar liggesusers#' #' sparselinalg.R #' #' Counterpart of linalg.R for sparse matrices/arrays #' #' Copyright (c) Adrian Baddeley, Ege Rubak and Rolf Turner 2016-2020 #' GNU Public Licence >= 2.0 #' #' $Revision: 1.19 $ $Date: 2021/01/08 01:16:41 $ marginSumsSparse <- function(X, MARGIN) { #' equivalent to apply(X, MARGIN, sum) if(length(MARGIN) == 0) return(sum(X)) if(is.array(X) || is.matrix(X)) return(apply(X, MARGIN, sum)) dimX <- dim(X) if(length(MARGIN) == length(dimX)) return(aperm(X, MARGIN)) if(any(huh <- (MARGIN < 0 | MARGIN > length(dimX)))) stop(paste(commasep(sQuote(paste0("MARGIN=", MARGIN[huh]))), ngettext(sum(huh), "is", "are"), "not defined"), call.=FALSE) df <- SparseEntries(X) # discard other indices nonmargin <- setdiff(seq_along(dimX), MARGIN) df <- df[ , -nonmargin, drop=FALSE] # implicitly accumulate result <- EntriesToSparse(df, dimX[MARGIN]) return(result) } tensor1x1 <- function(A, B) { ## equivalent of tensor(A, B, 1, 1) ## when A is a vector and B is a sparse array. stopifnot(length(dim(B)) == 3) A <- as.vector(as.matrix(A)) stopifnot(length(A) == dim(B)[1]) if(is.array(B)) { result <- tensor::tensor(A,B,1,1) } else if(inherits(B, "sparse3Darray")) { result <- sparseMatrix(i=B$j, j=B$k, x=B$x * A[B$i], # values for same (i,j) are summed dims=dim(B)[-1], dimnames=dimnames(B)[2:3]) result <- drop0(result) } else stop("Format of B not understood", call.=FALSE) return(result) } tensorSparse <- local({ tensorSparse <- function(A, B, alongA=integer(0), alongB=integer(0)) { #' full arrays? if(isfull(A) && isfull(B)) return(tensor::tensor(A=A, B=B, alongA=alongA, alongB=alongB)) #' check dimensions dimA <- dim(A) %orifnull% length(A) dnA <- dimnames(A) if(is.null(dnA)) dnA <- rep(list(NULL), length(dimA)) dimB <- dim(B) %orifnull% length(B) dnB <- dimnames(B) if(is.null(dnB)) dnB <- rep(list(NULL), length(dimB)) #' check 'along' if (length(alongA) != length(alongB)) stop("\"along\" vectors must be same length") mtch <- dimA[alongA] == dimB[alongB] if (any(is.na(mtch)) || !all(mtch)) stop("Mismatch in \"along\" dimensions") #' dimensions of result retainA <- !(seq_along(dimA) %in% alongA) retainB <- !(seq_along(dimB) %in% alongB) dimC <- c(dimA[retainA], dimB[retainB]) nC <- length(dimC) if(nC > 3) stop("Sorry, sparse arrays of more than 3 dimensions are not supported", call.=FALSE) #' fast code for special cases if(length(dimA) == 1 && length(alongA) == 1 && !isfull(B)) { BB <- SparseEntries(B) Bx <- BB[,ncol(BB)] ijk <- BB[,-ncol(BB),drop=FALSE] kalong <- ijk[,alongB] ABalong <- as.numeric(Bx * A[kalong]) ndimB <- ncol(ijk) switch(ndimB, { result <- sum(ABalong) }, { iout <- ijk[,-alongB] result <- sparseVectorCumul(i=iout, x=ABalong, # values aggregated by i length=dimC) }, { ijout <- ijk[,-alongB,drop=FALSE] result <- sparseMatrix(i=ijout[,1], j=ijout[,2], x=ABalong, # values aggregated by (i,j) dims=dimC, dimnames=dnB[-alongB]) result <- drop0(result) }) return(result) } if(length(dimB) == 1 && length(alongB) == 1 && !isfull(A)) { AA <- SparseEntries(A) Ax <- AA[,ncol(AA)] ijk <- AA[,-ncol(AA),drop=FALSE] kalong <- ijk[,alongA] ABalong <- as.numeric(Ax * B[kalong]) nA <- ncol(ijk) switch(nA, { result <- sum(ABalong) }, { iout <- ijk[,-alongA] result <- sparseVectorCumul(i=iout, x=ABalong, # values aggregated by i length=dimC) }, { ijout <- ijk[,-alongA,drop=FALSE] result <- sparseMatrix(i=ijout[,1], j=ijout[,2], x=ABalong, # values aggregated by (i,j) dims=dimC, dimnames=dnA[-alongA]) result <- drop0(result) }) return(result) } #' extract indices and values of nonzero entries dfA <- SparseEntries(A) dfB <- SparseEntries(B) #' assemble all tuples which contribute if(length(alongA) == 0) { #' outer product dfC <- outersparse(dfA, dfB) } else { if(length(alongA) == 1) { Acode <- dfA[,alongA] Bcode <- dfB[,alongB] } else { Along <- unname(as.list(dfA[,alongA, drop=FALSE])) Blong <- unname(as.list(dfB[,alongB, drop=FALSE])) Acode <- do.call(paste, append(Along, list(sep=","))) Bcode <- do.call(paste, append(Blong, list(sep=","))) } lev <- unique(c(Acode,Bcode)) Acode <- factor(Acode, levels=lev) Bcode <- factor(Bcode, levels=lev) splitA <- split(dfA, Acode) splitB <- split(dfB, Bcode) splitC <- mapply(outersparse, splitA, splitB, SIMPLIFY=FALSE) dfC <- rbindCompatibleDataFrames(splitC) } #' form product of contributing entries dfC$x <- with(dfC, A.x * B.x) #' retain only appropriate columns retain <- c(retainA, FALSE, retainB, FALSE, TRUE) dfC <- dfC[, retain, drop=FALSE] #' collect result result <- EntriesToSparse(dfC, dimC) return(result) } isfull <- function(z) { if(is.array(z) || is.matrix(z) || is.data.frame(z)) return(TRUE) if(inherits(z, c("sparseVector", "sparseMatrix", "sparse3Darray"))) return(FALSE) return(TRUE) } outersparse <- function(dfA, dfB) { if(is.null(dfA) || is.null(dfB)) return(NULL) IJ <- expand.grid(I=seq_len(nrow(dfA)), J=seq_len(nrow(dfB))) dfC <- with(IJ, cbind(A=dfA[I,,drop=FALSE], B=dfB[J,,drop=FALSE])) return(dfC) } tensorSparse }) sumsymouterSparse <- function(x, w=NULL, distinct=TRUE, dbg=FALSE) { dimx <- dim(x) if(length(dimx) != 3) stop("x should be a 3D array") stopifnot(dim(x)[2] == dim(x)[3]) if(!is.null(w)) { stopifnot(inherits(w, "sparseMatrix")) stopifnot(all(dim(w) == dim(x)[2:3])) } ## handle complex values #' there are no complex-valued sparse matrices yet ## if(is.complex(w)) { ## a <- sumsymouter(x, Re(w), distinct=distinct) ## b <- sumsymouter(x, Im(w), distinct=distinct) ## result <- a + b * 1i ## return(result) ## } if(is.complex(x)) { a <- sumsymouter(Re(x), w=w, distinct=distinct) b <- sumsymouter(Im(x), w=w, distinct=distinct) d <- sumsymouter(Re(x)+Im(x), w=w, distinct=distinct) result <- a - b + (d - a - b) * 1i return(result) } ## arguments are sparse numeric arrays m <- dimx[1] n <- dimx[2] if(inherits(x, "sparse3Darray")) { df <- data.frame(i = x$i - 1L, # need 0-based indices j = x$j - 1L, k = x$k - 1L, value = x$x) } else stop("x is not a recognised kind of sparse array") if(distinct) { #' remove entries with j = k ok <- with(df, j != k) df <- df[ok, , drop=TRUE] } ## trivial? if(nrow(df) < 2) { y <- matrix(0, m, m) dimnames(y) <- rep(dimnames(x)[1], 2) return(y) } ## order by increasing j, then k oo <- with(df, order(j, k, i)) df <- df[oo, ] ## now provide ordering by increasing k then j ff <- with(df, order(k,j,i)) ## if(dbg) { cat("----------------- Data ---------------------\n") print(df) cat("-------------- Reordered data --------------\n") print(df[ff,]) cat("Calling......\n") } if(!dbg) { if(is.null(w)) { z <- .C(SP_CspaSumSymOut, m = as.integer(m), n = as.integer(n), lenx = as.integer(nrow(df)), ix = as.integer(df$i), # indices are already 0-based jx = as.integer(df$j), kx = as.integer(df$k), x = as.double(df$value), flip = as.integer(ff - 1L), # convert 1-based to 0-based y = as.double(numeric(m * m)), PACKAGE = "spatstat.sparse") } else { ## extract triplet representation of w w <- as(w, Class="TsparseMatrix") dfw <- data.frame(j=w@i, k=w@j, w=w@x) woo <- with(dfw, order(j, k)) dfw <- dfw[woo, , drop=FALSE] z <- .C(SP_CspaWtSumSymOut, m = as.integer(m), n = as.integer(n), lenx = as.integer(nrow(df)), ix = as.integer(df$i), # indices are already 0-based jx = as.integer(df$j), kx = as.integer(df$k), x = as.double(df$value), flip = as.integer(ff - 1L), # convert 1-based to 0-based lenw = as.integer(nrow(dfw)), jw = as.integer(dfw$j), kw = as.integer(dfw$k), w = as.double(dfw$w), y = as.double(numeric(m * m)), PACKAGE = "spatstat.sparse") } } else { if(is.null(w)) { z <- .C(SP_CDspaSumSymOut, m = as.integer(m), n = as.integer(n), lenx = as.integer(nrow(df)), ix = as.integer(df$i), # indices are already 0-based jx = as.integer(df$j), kx = as.integer(df$k), x = as.double(df$value), flip = as.integer(ff - 1L), # convert 1-based to 0-based y = as.double(numeric(m * m)), PACKAGE = "spatstat.sparse") } else { ## extract triplet representation of w w <- as(w, Class="TsparseMatrix") dfw <- data.frame(j=w@i, k=w@j, w=w@x) woo <- with(dfw, order(j, k)) dfw <- dfw[woo, , drop=FALSE] z <- .C(SP_CDspaWtSumSymOut, m = as.integer(m), n = as.integer(n), lenx = as.integer(nrow(df)), ix = as.integer(df$i), # indices are already 0-based jx = as.integer(df$j), kx = as.integer(df$k), x = as.double(df$value), flip = as.integer(ff - 1L), # convert 1-based to 0-based lenw = as.integer(nrow(dfw)), jw = as.integer(dfw$j), kw = as.integer(dfw$k), w = as.double(dfw$w), y = as.double(numeric(m * m)), PACKAGE = "spatstat.sparse") } } y <- matrix(z$y, m, m) dimnames(y) <- rep(dimnames(x)[1], 2) return(y) } spatstat.sparse/R/sparse3Darray.R0000644000176200001440000010161314144332041016456 0ustar liggesusers#' #' sparse3Darray.R #' #' Sparse 3D arrays represented as list(i,j,k,x) #' #' Copyright (c) Adrian Baddeley, Ege Rubak and Rolf Turner 2016-2020 #' GNU Public Licence >= 2.0 #' #' $Revision: 1.44 $ $Date: 2021/03/04 07:42:18 $ #' sparse3Darray <- function(i=integer(0), j=integer(0), k=integer(0), x=numeric(0), dims=c(max(i),max(j),max(k)), dimnames=NULL, strict=FALSE, nonzero=FALSE) { dat <- data.frame(i=as.integer(i), j=as.integer(j), k=as.integer(k), x=x) if(typeof(x) == "complex") warning(paste( "complex-valued sparse 3D arrays are supported in spatstat,", "but complex-valued sparse matrices", "are not yet supported by the Matrix package"), call.=FALSE) stopifnot(length(dims) == 3) dims <- as.integer(dims) if(!all(i >= 1 & i <= dims[1])) stop("indices i are outside range") if(!all(j >= 1 & j <= dims[2])) stop("indices j are outside range") if(!all(k >= 1 & k <= dims[3])) stop("indices k are outside range") if(!is.null(dimnames)) { stopifnot(is.list(dimnames)) stopifnot(length(dimnames) == 3) notnull <- !sapply(dimnames, is.null) dimnames[notnull] <- lapply(dimnames[notnull], as.character) } if(nonzero || strict) { #' drop zeroes ok <- (x != RelevantZero(x)) dat <- dat[ok, , drop=FALSE] } if(strict) { #' arrange in 'R order' dat <- dat[with(dat, order(k,j,i)), , drop=FALSE] #' duplicates will be adjacent dup <- with(dat, c(FALSE, diff(i) == 0 & diff(j) == 0 & diff(k) == 0)) if(any(dup)) { #' accumulate values at the same array location retain <- !dup newrow <- cumsum(retain) newx <- as(tapply(dat$x, newrow, sum), typeof(dat$x)) newdat <- dat[retain,,drop=FALSE] newdat$x <- newx dat <- newdat } } result <- append(as.list(dat), list(dim=dims, dimnames=dimnames)) class(result) <- "sparse3Darray" return(result) } as.sparse3Darray <- function(x, ...) { if(inherits(x, "sparse3Darray")) { y <- x } else if(inherits(x, c("matrix", "sparseMatrix"))) { z <- as(x, Class="TsparseMatrix") dn <- dimnames(x) dn <- if(is.null(dn)) NULL else c(dn, list(NULL)) one <- if(length(z@i) > 0) 1L else integer(0) y <- sparse3Darray(i=z@i + 1L, j=z@j + 1L, k=one, x=z@x, dims=c(dim(x), 1L), dimnames=dn) } else if(is.array(x)) { stopifnot(length(dim(x)) == 3) dimx <- dim(x) if(prod(dimx) == 0) { y <- sparse3Darray(, dims=dimx, dimnames=dimnames(x)) } else { ijk <- which(x != RelevantZero(x), arr.ind=TRUE) ijk <- cbind(as.data.frame(ijk), x[ijk]) y <- sparse3Darray(i=ijk[,1L], j=ijk[,2L], k=ijk[,3L], x=ijk[,4L], dims=dimx, dimnames=dimnames(x)) } } else if(inherits(x, "sparseVector")) { one <- if(length(x@i) > 0) 1L else integer(0) y <- sparse3Darray(i=x@i, j=one, k=one, x=x@x, dims=c(x@length, 1L, 1L)) } else if(is.null(dim(x)) && is.atomic(x)) { n <- length(x) dn <- names(x) if(!is.null(dn)) dn <- list(dn, NULL, NULL) one <- if(n > 0) 1L else integer(0) y <- sparse3Darray(i=seq_len(n), j=one, k=one, x=x, dims=c(n, 1L, 1L), dimnames=dn) } else if(is.list(x) && length(x) > 0) { n <- length(x) if(all(sapply(x, is.matrix))) { z <- Reduce(abind, x) y <- as.sparse3Darray(z) } else if(all(sapply(x, inherits, what="sparseMatrix"))) { dimlist <- unique(lapply(x, dim)) if(length(dimlist) > 1) stop("Dimensions of matrices do not match") dimx <- c(dimlist[[1L]], n) dnlist <- lapply(x, dimnames) isnul <- sapply(dnlist, is.null) dnlist <- unique(dnlist[!isnul]) if(length(dnlist) > 1) stop("Dimnames of matrices do not match") dn <- if(length(dnlist) == 0) NULL else c(dnlist[[1L]], list(NULL)) for(k in seq_len(n)) { mk <- as(x[[k]], "TsparseMatrix") kvalue <- if(length(mk@i) > 0) k else integer(0) dfk <- data.frame(i=mk@i + 1L, j=mk@j + 1L, k=kvalue, x=mk@x) df <- if(k == 1) dfk else rbind(df, dfk) } y <- sparse3Darray(i=df$i, j=df$j, k=df$k, x=df$x, dims=dimx, dimnames=dn) } else { warning("I don't know how to convert a list to a sparse array") return(NULL) } } else { warning("I don't know how to convert x to a sparse array") return(NULL) } return(y) } dim.sparse3Darray <- function(x) { x$dim } "dim<-.sparse3Darray" <- function(x, value) { stopifnot(length(value) == 3) if(!all(inside.range(x$i, c(1, value[1])))) stop("indices i are outside new range") if(!all(inside.range(x$j, c(1, value[2])))) stop("indices j are outside new range") if(!all(inside.range(x$k, c(1, value[3])))) stop("indices k are outside new range") dimx <- dim(x) x$dim <- value if(!is.null(dimnames(x))) { dn <- dimnames(x) for(n in 1:3) { if(value[n] < dimx[n]) dn[[n]] <- dn[[n]][1:value[n]] else if(value[n] > dimx[n]) dn[n] <- list(NULL) } dimnames(x) <- dn } return(x) } dimnames.sparse3Darray <- function(x) { x$dimnames } "dimnames<-.sparse3Darray" <- function(x, value) { if(!is.list(value)) value <- list(value) if(length(value) == 1) value <- rep(value, 3) x$dimnames <- value return(x) } print.sparse3Darray <- function(x, ...) { dimx <- dim(x) cat("Sparse 3D array of dimensions", paste(dimx, collapse="x"), fill=TRUE) if(prod(dimx) == 0) return(invisible(NULL)) dn <- dimnames(x) %orifnull% rep(list(NULL), 3) d3 <- dimx[3] dn3 <- dn[[3]] %orifnull% as.character(seq_len(d3)) df <- data.frame(i=x$i, j=x$j, k=x$k, x=x$x) pieces <- split(df, factor(df$k, levels=1:d3)) dim2 <- dimx[1:2] dn2 <- dn[1:2] if(typeof(x$x) == "complex") { splat("Complex-valued") splat("\t\tReal component:") stuff <- capture.output(eval(Re(x))) cat(stuff[-1],sep="\n") splat("\n\n\t\tImaginary component:") stuff <- capture.output(eval(Im(x))) cat(stuff[-1],sep="\n") } else { for(k in seq_along(pieces)) { cat(paste0("\n\t[ , , ", dn3[k], "]\n\n")) Mi <- with(pieces[[k]], sparseMatrix(i=i, j=j, x=x, dims=dim2, dimnames=dn2)) stuff <- capture.output(eval(Mi)) #' Remove 'sparse Matrix' header blurb stuff <- stuff[-1] if(is.blank(stuff[1])) stuff <- stuff[-1] cat(stuff, sep="\n") } } return(invisible(NULL)) } aperm.sparse3Darray <- function(a, perm=NULL, resize=TRUE, ...) { if(is.null(perm)) return(a) stopifnot(length(perm) == 3) a <- unclass(a) a[c("i", "j", "k")] <- a[c("i", "j", "k")][perm] if(resize) { a$dim <- a$dim[perm] if(length(a$dimnames)==3) a$dimnames <- a$dimnames[perm] } class(a) <- c("sparse3Darray", class(a)) return(a) } as.array.sparse3Darray <- function(x, ...) { zerovalue <- vector(mode=typeof(x$x), length=1L) z <- array(zerovalue, dim=dim(x), dimnames=dimnames(x)) z[cbind(x$i,x$j,x$k)] <- x$x return(z) } "[.sparse3Darray" <- local({ Extract <- function(x, i,j,k, drop=TRUE, ...) { dimx <- dim(x) dn <- dimnames(x) %orifnull% rep(list(NULL), 3) if(!missing(i) && length(dim(i)) == 2) { ## matrix index i <- as.matrix(i) if(!(missing(j) && missing(k))) stop("If i is a matrix, j and k should not be given", call.=FALSE) if(ncol(i) != 3) stop("If i is a matrix, it should have 3 columns", call.=FALSE) ## start with vector of 'zero' answers of the correct type answer <- sparseVector(x=RelevantEmpty(x$x), i=integer(0), length=nrow(i)) ## values outside array return NA if(anybad <- !all(good <- inside3Darray(dim(x), i))) { bad <- !good answer[bad] <- NA } ## if entire array is zero, there is nothing to match if(length(x$x) == 0) return(answer) ## restrict attention to entries inside array igood <- if(anybad) i[good, , drop=FALSE] else i ## match desired indices to sparse entries varies <- (dimx > 1) nvary <- sum(varies) varying <- which(varies) if(nvary == 3) { ## ---- older code ----- ## convert triples of integers to character codes #### icode <- apply(i, 1, paste, collapse=",") << is too slow >> ## icode <- paste(i[,1], i[,2], i[,3], sep=",") ## dcode <- paste(x$i, x$j, x$k, sep=",") ## ------------------ mgood <- matchIntegerDataFrames(igood, cbind(x$i, x$j, x$k)) } else if(nvary == 2) { ## effectively a sparse matrix ## ---- older code ----- ## icode <- paste(i[,varying[1]], i[,varying[2]], sep=",") ## ijk <- cbind(x$i, x$j, x$k) ## dcode <- paste(ijk[,varying[1]], ijk[,varying[2]], sep=",") ## ------------------ ijk <- cbind(x$i, x$j, x$k) mgood <- matchIntegerDataFrames(igood[,varying,drop=FALSE], ijk[,varying,drop=FALSE]) } else if(nvary == 1) { ## effectively a sparse vector ## ---- older code ----- ## icode <- i[,varying] ## dcode <- switch(varying, x$i, x$j, x$k) ## ------------------ mgood <- match(igood[,varying], switch(varying, x$i, x$j, x$k)) } else { ## effectively a single value ## ---- older code ----- ## icode <- rep(1, nrow(i)) ## dcode <- 1 # since we know length(x$x) > 0 mgood <- 1 } ## insert any found elements found <- logical(nrow(i)) found[good] <- foundgood <- !is.na(mgood) answer[found] <- x$x[mgood[foundgood]] return(answer) } if(!(missing(i) && missing(j) && missing(k))) { I <- grokIndexVector(if(missing(i)) NULL else i, dimx[1], dn[[1]]) J <- grokIndexVector(if(missing(j)) NULL else j, dimx[2], dn[[2]]) K <- grokIndexVector(if(missing(k)) NULL else k, dimx[3], dn[[3]]) IJK <- list(I,J,K) if(!all(sapply(lapply(IJK, getElement, name="full"), is.null))) { ## some indices exceed array bounds; ## result is a full array containing NA's fullindices <- lapply(IJK, fullIndexSequence) strictindices <- lapply(IJK, strictIndexSequence) result <- array(data=RelevantNA(x$x), dim=lengths(fullindices)) matches <- mapply(match, x=fullindices, table=strictindices) ok <- lapply(lapply(matches, is.na), "!") result[ok[[1]], ok[[2]], ok[[3]]] <- as.array(x)[matches[[1]][ok[[1]]], matches[[2]][ok[[2]]], matches[[3]][ok[[3]]]] if(drop) result <- result[,,,drop=TRUE] return(result) } IJK <- lapply(IJK, getElement, name="strict") I <- IJK[[1]] J <- IJK[[2]] K <- IJK[[3]] #' number of values to be returned along each margin newdims <- sapply(IJK, getElement, name="n") #' dimnames of return array newdn <- lapply(IJK, getElement, name="s") #' find all required data (not necessarily in required order) inI <- I$lo inJ <- J$lo inK <- K$lo df <- data.frame(i=x$i, j=x$j, k=x$k, x=x$x) use <- with(df, inI[i] & inJ[j] & inK[k]) df <- df[use, ,drop=FALSE] #' contract sub-array to (1:n) * (1:m) * (1:l) df <- transform(df, i = cumsum(inI)[i], j = cumsum(inJ)[j], k = cumsum(inK)[k]) Imap <- I$map Jmap <- J$map Kmap <- K$map if(nrow(df) == 0 || (is.null(Imap) && is.null(Jmap) && is.null(Kmap))) { ## return values are already in correct position outdf <- df } else { #' invert map to determine output positions (reorder/repeat entries) snI <- seq_len(I$n) snJ <- seq_len(J$n) snK <- seq_len(K$n) imap <- Imap %orifnull% snI jmap <- Jmap %orifnull% snJ kmap <- Kmap %orifnull% snK whichi <- split(seq_along(imap), factor(imap, levels=snI)) whichj <- split(seq_along(jmap), factor(jmap, levels=snJ)) whichk <- split(seq_along(kmap), factor(kmap, levels=snK)) dat.i <- whichi[df$i] dat.j <- whichj[df$j] dat.k <- whichk[df$k] stuff <- mapply(expandwithdata, i=dat.i, j=dat.j, k=dat.k, x=df$x, SIMPLIFY=FALSE) outdf <- rbindCompatibleDataFrames(stuff) } x <- sparse3Darray(i=outdf$i, j=outdf$j, k=outdf$k, x=outdf$x, dims=newdims, dimnames=newdn) dimx <- newdims dn <- newdn } if(drop) { retain <- (dimx > 1) nretain <- sum(retain) if(nretain == 2) { #' result is a matrix retained <- which(retain) newi <- getElement(x, name=c("i","j","k")[ retained[1] ]) newj <- getElement(x, name=c("i","j","k")[ retained[2] ]) newdim <- dimx[retain] newdn <- dn[retain] return(sparseMatrix(i=newi, j=newj, x=x$x, dims=newdim, dimnames=newdn)) } else if(nretain == 1) { #' sparse vector retained <- which(retain) newi <- getElement(x, name=c("i","j","k")[retained]) #' ensure 'strict' ord <- order(newi) newi <- newi[ord] newx <- x$x[ord] if(any(dup <- c(FALSE, diff(newi) == 0))) { retain <- !dup ii <- cumsum(retain) newi <- newi[retain] newx <- as(tapply(newx, ii, sum), typeof(newx)) } x <- sparseVector(x=newx, i=newi, length=dimx[retained]) } else if(nretain == 0) { #' single value x <- as.vector(as.array(x)) } } return(x) } expandwithdata <- function(i, j, k, x) { z <- expand.grid(i=i, j=j, k=k) if(nrow(z) > 0) z$x <- x return(z) } Extract }) rbindCompatibleDataFrames <- function(x) { #' faster version of Reduce(rbind, x) when entries are known to be compatible nama2 <- colnames(x[[1]]) y <- vector(mode="list", length=length(nama2)) names(y) <- nama2 for(nam in nama2) y[[nam]] <- unlist(lapply(x, getElement, name=nam)) return(as.data.frame(y)) } "[<-.sparse3Darray" <- function(x, i, j, k, ..., value) { dimx <- dim(x) dn <- dimnames(x) %orifnull% rep(list(NULL), 3) #' interpret indices if(!missing(i) && length(dim(i)) == 2) { ## matrix index ijk <- as.matrix(i) if(!(missing(j) && missing(k))) stop("If i is a matrix, j and k should not be given", call.=FALSE) if(ncol(ijk) != 3) stop("If i is a matrix, it should have 3 columns", call.=FALSE) if(!all(inside3Darray(dimx, i))) stop("Some indices lie outside array limits", call.=FALSE) if(nrow(ijk) == 0) return(x) # no items to replace ## assemble data frame xdata <- data.frame(i=x$i, j=x$j, k=x$k, x=x$x) ## match xdata into ijk (not necessarily the first match in original order) m <- matchIntegerDataFrames(xdata[,1:3,drop=FALSE], ijk) ## ------- OLDER VERSION: -------- ## convert triples of integers to character codes ## icode <- apply(ijk, 1, paste, collapse=",") << is too slow >> ## icode <- paste(ijk[,1], ijk[,2], ijk[,3], sep=",") ## xcode <- paste(x$i, x$j, x$k, sep=",") ## m <- match(xcode, icode) ## ------------------------------- ## remove any matches, retaining only data that do not match 'i' xdata <- xdata[is.na(m), , drop=FALSE] # sic ## ensure replacement value is vector-like value <- as.vector(value) nv <- length(value) if(nv != nrow(i) && nv != 1) stop(paste("Number of items to replace", paren(nrow(i)), "does not match number of items given", paren(nv)), call.=FALSE) vdata <- data.frame(i=ijk[,1], j=ijk[,2], k=ijk[,3], x=value) ## combine ydata <- rbind(xdata, vdata) y <- with(ydata, sparse3Darray(i=i,j=j,k=k,x=x, dims=dimx, dimnames=dn, strict=TRUE)) return(y) } I <- grokIndexVector(if(missing(i)) NULL else i, dimx[1], dn[[1]]) J <- grokIndexVector(if(missing(j)) NULL else j, dimx[2], dn[[2]]) K <- grokIndexVector(if(missing(k)) NULL else k, dimx[3], dn[[3]]) IJK <- list(I,J,K) if(!all(sapply(lapply(IJK, getElement, name="full"), is.null))) { warning("indices exceed array bounds; extending the array dimensions", call.=FALSE) fullindices <- lapply(IJK, fullIndexSequence) ## strictindices <- lapply(IJK, strictIndexSequence) dnew <- pmax(dimx, sapply(fullindices, max)) result <- array(data=RelevantZero(x$x), dim=dnew) result[cbind(x$i, x$j, x$k)] <- x$x result[fullindices[[1]], fullindices[[2]], fullindices[[3]]] <- value result <- as.sparse3Darray(result) return(result) } IJK <- lapply(IJK, getElement, name="strict") if(all(sapply(IJK, getElement, name="nind") == 0)) { # no elements are indexed return(x) } I <- IJK[[1]] J <- IJK[[2]] K <- IJK[[3]] #' extract current array entries xdata <- data.frame(i=x$i, j=x$j, k=x$k, x=x$x) #' identify data volume that will be overwritten inI <- I$lo inJ <- J$lo inK <- K$lo #' remove data that will be overwritten retain <- !with(xdata, inI[i] & inJ[j] & inK[k]) xdata <- xdata[retain,,drop=FALSE] #' expected dimensions of 'value' implied by indices dimVshould <- sapply(IJK, getElement, name="nind") dimV <- dim(value) if(length(dimV) == 3) { #' both source and destination are 3D if(all(dimVshould == dimV)) { #' replace 3D block by 3D block of same dimensions value <- as.sparse3Darray(value) vdata <- data.frame(i=value$i, j=value$j, k=value$k, x=value$x) # determine positions of replacement data in original array vdata <- transform(vdata, i=replacementIndex(i, I), j=replacementIndex(j, J), k=replacementIndex(k, K)) } else stop(paste("Replacement value has wrong dimensions:", paste(dimV, collapse="x"), "instead of", paste(dimVshould, collapse="x")), call.=FALSE) } else if(is.null(dimV)) { #' replacement value is a vector or sparseVector value <- as(value, "sparseVector") iv <- value@i xv <- value@x nv <- value@length collapsing <- (dimVshould == 1) realdim <- sum(!collapsing) if(nv == 1) { #' replacement value is a constant value <- as.vector(value[1]) if(identical(value, RelevantZero(x$x))) { #' assignment causes relevant entries to be set to zero; #' these entries have already been deleted from 'xdata'; #' nothing to add vdata <- data.frame(i=integer(0), j=integer(0), k=integer(0), x=x$x[integer(0)]) } else { #' replicate the constant vdata <- expand.grid(i=I$i, j=J$i, k=K$i, x=as.vector(value[1])) } } else if(realdim == 0) { stop(paste("Replacement value has too many entries:", nv, "instead of 1"), call.=FALSE) } else if(realdim == 1) { theindex <- which(!collapsing) # target slice is one-dimensional if(nv != dimVshould[theindex]) stop(paste("Replacement value has wrong number of entries:", nv, "instead of", dimVshould[theindex]), call.=FALSE) newpos <- replacementIndex(iv, IJK[[theindex]]) vdata <- switch(theindex, data.frame(i=newpos, j=J$i, k=K$i, x=xv), data.frame(i=I$i, j=newpos, k=K$i, x=xv), data.frame(i=I$i, j=J$i, k=newpos, x=xv)) } else { # target slice is two-dimensional sdim <- dimVshould[!collapsing] sd1 <- sdim[1] sd2 <- sdim[2] if(nv != sd1) stop(paste("Length of replacement vector", paren(nv), "does not match dimensions of array subset", paren(paste(dimVshould, collapse="x"))), call.=FALSE) firstindex <- which(!collapsing)[1] secondindex <- which(!collapsing)[2] pos1 <- replacementIndex(iv, IJK[[firstindex]]) pos2 <- replacementIndex(seq_len(sd2), IJK[[secondindex]]) xv <- rep(xv, sd2) pos2 <- rep(pos2, each=length(pos1)) pos1 <- rep(pos1, sd2) pos3 <- if(length(pos1)) IJK[[which(collapsing)]]$i else integer(0) vdata <- data.frame(i=pos3, j=pos3, k=pos3, x=xv) vdata[,firstindex] <- pos1 vdata[,secondindex] <- pos2 } } else if(identical(dimVshould[dimVshould > 1], dimV[dimV > 1])) { #' lower dimensional sets of the same dimension value <- value[drop=TRUE] dimV <- dim(value) dropping <- (dimVshould == 1) if(length(dimV) == 2) { value <- as(value, "TsparseMatrix") iv <- value@i + 1L jv <- value@j + 1L xv <- value@x firstindex <- which(!dropping)[1] secondindex <- which(!dropping)[2] pos1 <- replacementIndex(iv, IJK[[firstindex]]) pos2 <- replacementIndex(jv, IJK[[secondindex]]) pos3 <- if(length(pos1)) IJK[[which(dropping)]]$i else integer(0) vdata <- data.frame(i=pos3, j=pos3, k=pos3, x=xv) vdata[,firstindex] <- pos1 vdata[,secondindex] <- pos2 } else { value <- as(value, "sparseVector") iv <- value@i xv <- value@x vdata <- data.frame(i=if(dropping[1]) I$i else replacementIndex(iv, I), j=if(dropping[2]) J$i else replacementIndex(iv, J), k=if(dropping[3]) K$i else replacementIndex(iv, K), x=xv) } } else stop(paste("Replacement value has wrong dimensions:", paste(dimV, collapse="x"), "instead of", paste(dimVshould, collapse="x")), call.=FALSE) ## combine if(nrow(vdata) > 0) xdata <- rbind(xdata, vdata) y <- with(xdata, sparse3Darray(i=i,j=j,k=k,x=x, dims=dimx, dimnames=dn, strict=TRUE)) return(y) } bind.sparse3Darray <- function(A,B,along) { A <- as.sparse3Darray(A) B <- as.sparse3Darray(B) check.1.integer(along) stopifnot(along %in% 1:3) dimA <- dim(A) dimB <- dim(B) if(!all(dimA[-along] == dimB[-along])) stop("dimensions of A and B do not match") dimC <- dimA dimC[along] <- dimA[along] + dimB[along] # extract data Adf <- SparseEntries(A) Bdf <- SparseEntries(B) # realign 'B' coordinate Bdf[,along] <- Bdf[,along] + dimA[along] # combine C <- EntriesToSparse(rbind(Adf, Bdf), dimC) # add dimnames dnA <- dimnames(A) dnB <- dimnames(B) if(!is.null(dnA) || !is.null(dnB)) { if(length(dnA) != 3) dnA <- rep(list(NULL), 3) if(length(dnB) != 3) dnB <- rep(list(NULL), 3) dnC <- dnA dnC[[along]] <- c(dnA[[along]] %orifnull% rep("", dimA[along]), dnB[[along]] %orifnull% rep("", dimB[along])) dimnames(C) <- dnC } return(C) } anyNA.sparse3Darray <- function(x, recursive=FALSE) { anyNA(x$x) } unionOfSparseIndices <- function(A, B) { #' A, B are data frames of indices i, j, k ijk <- unique(rbind(A, B)) colnames(ijk) <- c("i", "j", "k") return(ijk) } Ops.sparse3Darray <- function(e1,e2=NULL){ if(nargs() == 1L) { switch(.Generic, "!" = { result <- do.call(.Generic, list(as.array(e1))) }, "-" = , "+" = { result <- e1 result$x <- do.call(.Generic, list(e1$x)) }, stop(paste("Unary", sQuote(.Generic), "is undefined for sparse 3D arrays."), call.=FALSE)) return(result) } # binary operation # Decide whether full or sparse elist <- list(e1, e2) isfull <- sapply(elist, inherits, what=c("matrix", "array")) if(any(isfull) && any(sapply(lapply(elist[isfull], dim), prod) > 1)) { # full array n1 <- length(dim(e1)) n2 <- length(dim(e2)) e1 <- if(n1 == 3) as.array(e1) else if(n1 == 2) as.matrix(e1) else as.vector(as.matrix(as.array(e1))) e2 <- if(n2 == 3) as.array(e2) else if(n2 == 2) as.matrix(e2) else as.vector(as.matrix(as.array(e2))) result <- do.call(.Generic, list(e1, e2)) return(result) } # sparse result (usually) e1 <- as.sparse3Darray(e1) e2 <- as.sparse3Darray(e2) dim1 <- dim(e1) dim2 <- dim(e2) mode1 <- typeof(e1$x) mode2 <- typeof(e2$x) zero1 <- vector(mode=mode1, length=1L) zero2 <- vector(mode=mode2, length=1L) if(prod(dim1) == 1) { ## e1 is constant e1 <- as.vector(as.array(e1)) z12 <- do.call(.Generic, list(e1, zero2)) if(!isRelevantZero(z12)) { # full matrix/array will be generated result <- do.call(.Generic, list(e1, as.array(e2)[drop=TRUE])) } else { # sparse result <- e2 result$x <- do.call(.Generic, list(e1, e2$x)) } return(result) } if(prod(dim2) == 1) { ## e2 is constant e2 <- as.vector(as.array(e2)) z12 <- do.call(.Generic, list(zero1, e2)) if(!isRelevantZero(z12)) { # full matrix/array will be generated result <- do.call(.Generic, list(as.array(e1)[drop=TRUE], e2)) } else { # sparse result <- e1 result$x <- do.call(.Generic, list(e1$x, e2)) } return(result) } z12 <- do.call(.Generic, list(zero1, zero2)) if(!isRelevantZero(z12)) { #' Result is an array e1 <- as.array(e1) e2 <- as.array(e2) result <- do.call(.Generic, list(e1, e2)) return(result) } # Result is sparse if(identical(dim1, dim2)) { #' extents are identical ijk1 <- SparseIndices(e1) ijk2 <- SparseIndices(e2) if(identical(ijk1, ijk2)) { #' patterns of nonzero entries are identical ijk <- ijk1 values <- do.call(.Generic, list(e1$x, e2$x)) } else { #' different patterns of nonzero entries ijk <- unionOfSparseIndices(ijk1, ijk2) values <- as.vector(do.call(.Generic, list(e1[ijk], e2[ijk]))) } dn <- dimnames(e1) %orifnull% dimnames(e2) result <- sparse3Darray(i=ijk$i, j=ijk$j, k=ijk$k, x=values, dims=dim1, dimnames=dn, strict=TRUE) return(result) } drop1 <- (dim1 == 1) drop2 <- (dim2 == 1) if(!any(drop1 & !drop2) && identical(dim1[!drop2], dim2[!drop2])) { #' dim2 is a slice of dim1 ijk1 <- data.frame(i=e1$i, j=e1$j, k=e1$k) ijk2 <- data.frame(i=e2$i, j=e2$j, k=e2$k) expanding <- which(drop2 & !drop1) if(length(expanding) == 1) { n <- dim1[expanding] m <- nrow(ijk2) ijk2 <- as.data.frame(lapply(ijk2, rep, times=n)) ijk2[,expanding] <- rep(seq_len(n), each=m) ijk <- unionOfSparseIndices(ijk1, ijk2) ijkdrop <- ijk if(nrow(ijkdrop) > 0) ijkdrop[,expanding] <- 1 xout <- do.call(.Generic, list(e1[ijk], e2[ijkdrop])) result <- sparse3Darray(i=ijk[,1L], j=ijk[,2L], k=ijk[,3L], x=as.vector(xout), dims=dim1, dimnames=dimnames(e1), strict=TRUE) return(result) } } if(!any(drop2 & !drop1) && identical(dim2[!drop1], dim1[!drop1])) { #' dim1 is a slice of dim2 ijk1 <- data.frame(i=e1$i, j=e1$j, k=e1$k) ijk2 <- data.frame(i=e2$i, j=e2$j, k=e2$k) expanding <- which(drop1 & !drop2) if(length(expanding) == 1) { n <- dim2[expanding] m <- nrow(ijk1) ijk1 <- as.data.frame(lapply(ijk1, rep, times=n)) ijk1[,expanding] <- rep(seq_len(n), each=m) ijk <- unionOfSparseIndices(ijk1, ijk2) ijkdrop <- ijk if(nrow(ijkdrop) > 0) ijkdrop[,expanding] <- 1L xout <- do.call(.Generic, list(e1[ijkdrop], e2[ijk])) result <- sparse3Darray(i=ijk[,1L], j=ijk[,2L], k=ijk[,3L], x=as.vector(xout), dims=dim2, dimnames=dimnames(e2), strict=TRUE) return(result) } } if(all(drop1[-1]) && dim1[1L] == dim2[1L]) { #' e1 is a (sparse) vector matching the first extent of e2 if(.Generic %in% c("*", "&")) { # result is sparse ijk <- data.frame(i=e2$i, j=e2$j, k=e2$k) ones <- rep(1L, nrow(ijk)) i11 <- data.frame(i=e2$i, j=ones, k=ones) xout <- do.call(.Generic, list(e1[i11], e2[ijk])) result <- sparse3Darray(i=ijk[,1L], j=ijk[,2L], k=ijk[,3L], x=as.vector(xout), dims=dim2, dimnames=dimnames(e2), strict=TRUE) } else { # result is full array e1 <- as.array(e1)[,,,drop=TRUE] e2 <- as.array(e2) result <- do.call(.Generic, list(e1, e2)) } return(result) } stop(paste("Non-conformable arrays:", paste(dim1, collapse="x"), "and", paste(dim2, collapse="x")), call.=FALSE) } Math.sparse3Darray <- function(x, ...){ z <- RelevantZero(x$x) fz <- do.call(.Generic, list(z)) if(!isRelevantZero(fz)) { # result is a full array result <- do.call(.Generic, list(as.array(x), ...)) return(result) } x$x <- do.call(.Generic, list(x$x)) return(x) } Complex.sparse3Darray <- function(z) { oo <- RelevantZero(z$x) foo <- do.call(.Generic, list(z=oo)) if(!isRelevantZero(foo)) { # result is a full array result <- do.call(.Generic, list(z=as.array(z))) return(result) } z$x <- do.call(.Generic, list(z=z$x)) return(z) } Summary.sparse3Darray <- function(..., na.rm=FALSE) { argh <- list(...) is3D <- sapply(argh, inherits, what="sparse3Darray") if(any(is3D)) { xvalues <- lapply(argh[is3D], getElement, name="x") fullsizes <- sapply(lapply(argh[is3D], dim), prod) argh[is3D] <- xvalues #' zero entry should be appended if and only if there are any empty cells zeroes <- lapply(xvalues, RelevantZero) zeroes <- zeroes[lengths(xvalues) < fullsizes] argh <- append(argh, zeroes) } rslt <- do.call(.Generic, append(argh, list(na.rm=na.rm))) return(rslt) } SparseIndices <- function(x) { #' extract indices of entries of sparse vector/matrix/array nd <- length(dim(x)) if(nd > 3) stop("Arrays of more than 3 dimensions are not supported", call.=FALSE) if(nd == 0 || nd == 1) { x <- as(x, "sparseVector") df <- data.frame(i=x@i) } else if(nd == 2) { x <- as(x, "TsparseMatrix") df <- data.frame(i=x@i + 1L, j=x@j + 1L) } else if(nd == 3) { x <- as.sparse3Darray(x) df <- data.frame(i=x$i, j=x$j, k=x$k) } return(df) } SparseEntries <- function(x) { #' extract entries of sparse vector/matrix/array nd <- length(dim(x)) if(nd > 3) stop("Arrays of more than 3 dimensions are not supported", call.=FALSE) if(nd == 0 || nd == 1) { x <- as(x, "sparseVector") df <- data.frame(i=x@i, x=x@x) } else if(nd == 2) { x <- as(x, "TsparseMatrix") df <- data.frame(i=x@i + 1L, j=x@j + 1L, x=x@x) } else if(nd == 3) { x <- as.sparse3Darray(x) df <- data.frame(i=x$i, j=x$j, k=x$k, x=x$x) } return(df) } EntriesToSparse <- function(df, dims) { #' convert data frame of indices and values #' to sparse vector/matrix/array nd <- length(dims) if(nd == 0) return(with(df, as(sum(x), typeof(x)))) sn <- seq_len(nd) colnames(df)[sn] <- c("i","j","k")[sn] if(nd == 1) { #' sparse vector: duplicate entries not allowed df <- df[with(df, order(i)), , drop=FALSE] dup <- c(FALSE, with(df, diff(i) == 0)) if(any(dup)) { #' accumulate values at the same array location first <- !dup newi <- cumsum(first) newx <- as(tapply(df$x, newi, sum), typeof(df$x)) df <- data.frame(i=newi[first], x=newx) } result <- with(df, sparseVector(i=i, x=x, length=dims)) } else if(nd == 2) { result <- with(df, sparseMatrix(i=i, j=j, x=x, dims=dims)) } else if(nd == 3) { result <- with(df, sparse3Darray(i=i, j=j, k=k, x=x, dims=dims)) } return(result) } evalSparse3Dentrywise <- function(expr, envir) { ## DANGER: this assumes all sparse arrays in the expression ## have the same pattern of nonzero elements! e <- as.expression(substitute(expr)) ## get names of all variables in the expression varnames <- all.vars(e) allnames <- all.names(e, unique=TRUE) funnames <- allnames[!(allnames %in% varnames)] if(length(varnames) == 0) stop("No variables in this expression") ## get the values of the variables if(missing(envir)) { envir <- parent.frame() # WAS: sys.parent() } else if(is.list(envir)) { envir <- list2env(envir, parent=parent.frame()) } vars <- mget(varnames, envir=envir, inherits=TRUE, ifnotfound=list(NULL)) funs <- mget(funnames, envir=envir, inherits=TRUE, ifnotfound=list(NULL)) ## find out which variables are sparse3Darray isSpud <- sapply(vars, inherits, what="sparse3Darray") if(!any(isSpud)) stop("No sparse 3D arrays in this expression") spuds <- vars[isSpud] template <- spuds[[1L]] ## replace each array by its entries, and evaluate spudvalues <- lapply(spuds, getElement, name="x") ## minimal safety check if(length(unique(lengths(spudvalues))) > 1) stop("Different numbers of sparse entries", call.=FALSE) vars[isSpud] <- spudvalues v <- eval(e, append(vars, funs)) ## reshape as 3D array result <- sparse3Darray(x=v, i=template$i, j=template$j, k=template$k, dims=dim(template), dimnames=dimnames(template)) return(result) } spatstat.sparse/R/gridadjacency.R0000644000176200001440000000261514141451044016526 0ustar liggesusers#' #' gridadjacency.R #' #' Adjacency matrix for points on a 2D integer grid. #' #' $Revision: 1.1 $ $Date: 2021/03/15 05:59:26 $ #' gridadjacencymatrix <- function(dims, across=TRUE, down=TRUE, diagonal=TRUE) { dims <- ensure2vector(dims) nr <- dims[1] nc <- dims[2] n <- prod(dims) serial <- matrix(1:n, nr, nc) m <- sparseMatrix(i=integer(0), j=integer(0), x=logical(0), dims=c(n,n)) if(across) { #' join cells in adjacent columns (i, j) ~ (i, j+1) across each row allbutlastcol <- as.vector(serial[ , -nc, drop=FALSE]) allbutfirstcol <- as.vector(serial[ , -1, drop=FALSE]) m[cbind(allbutfirstcol, allbutlastcol)] <- TRUE } if(down) { #' join cells in adjacent rows (i, j) ~ (i+1, j) down each column allbutlastrow <- as.vector(serial[-nr, , drop=FALSE]) allbutfirstrow <- as.vector(serial[ -1, , drop=FALSE]) m[cbind(allbutfirstrow, allbutlastrow)] <- TRUE } if(diagonal) { #' join cells (i, j) ~ (i+1, j+1) allexcbotleft <- as.vector(serial[-1, -1, drop=FALSE]) allexctopright <- as.vector(serial[-nr, -nc, drop=FALSE]) m[cbind(allexcbotleft, allexctopright)] <- TRUE #' join cells (i, j) ~ (i+1, j-1) allexcbotright <- as.vector(serial[-nr, -1, drop=FALSE]) allexctopleft <- as.vector(serial[-1, -nc, drop=FALSE]) m[cbind(allexcbotright, allexctopleft)] <- TRUE } m <- m | t(m) return(m) } spatstat.sparse/MD50000644000176200001440000000354114157003222013720 0ustar liggesusersb7188e8d3680d8243e5a4b5676a9bfed *DESCRIPTION ac50c0b7f8040a9d371b2a853b680174 *NAMESPACE e5fb576aa3fd5b2514ad33627cd971d4 *NEWS 90de543d11bf2ba4a505743ff184f06c *R/gridadjacency.R 20f2e0c815e9c807931ebb4bd9d94bcb *R/linalg.R 4fb41311aebaa063c752221b28d7ab02 *R/matrixpower.R abf3f3d6e4fa2cddaf895e4cc7ffb323 *R/sparse3Darray.R cb4594cad1498af35944def65efc095f *R/sparsecommon.R 064ac2c2d4dd36443ed6f9bc8f2dd99d *R/sparselinalg.R 8fededea421bc542b623faae42f9aefe *inst/doc/packagesizes.txt 49be0b578554c65b0d922741c5afb49f *man/Extract.sparse3Darray.Rd b96f1f5454a0bb4d61f07dd72b2567ba *man/Math.sparse3Darray.Rd c55fd3e281ae5d16297cf1b36ad060b6 *man/aperm.sparse3Darray.Rd c643296491b7a26b5b4759977f6dfc67 *man/as.array.sparse3Darray.Rd 3370fbfd635292c0b73aabf265b03570 *man/as.sparse3Darray.Rd b42678efa696258b5471e304d3467736 *man/bind.sparse3Darray.Rd b004d081c72b7bbfa7f4d0e8452b9f85 *man/gridadjacencymatrix.Rd 390c43841b92ba3277f25852a55d2cc9 *man/macros/defns.Rd e8388843f360eb8ed9b59105a51f974f *man/marginSumsSparse.Rd 2bbafee72c33faca8f1edf1c0a747419 *man/matrixpower.Rd f728169b92089befc36b92cd14b22a3e *man/methods.sparse3Darray.Rd ea2fb15d8de31fdcc8be96f0bfc80708 *man/sparse3Darray.Rd 8fc5967743db5018d81c5cba95e64c9e *man/spatstat.sparse-internal.Rd 2fb69dd9f6ed9b445473f26a8861b42f *man/spatstat.sparse-package.Rd c660da4a813367f39326bab376bf2eb8 *man/sumouter.Rd b2ff05da42e6fd0a6529d951ef3aaf65 *man/tensorSparse.Rd 542e6e474340e0aac3ed97f6a92777b4 *src/chunkloop.h aec63aa7d7b7e9fceb56ef71d0c09a11 *src/init.c cef9a229c5a1ee4513e85754c5d2d152 *src/linalg.c 10fcc0c834bd9311bee6d58f5432de93 *src/proto.h 6c8b4069a7310085ce7bb7c7cab8d821 *src/sparselinalg.c ceb300f3f81d94e6a735a2fbd2d0a7b1 *src/spasumsymout.h d4aaa68f9d5c8dbb6f76f5f52feca432 *src/sumsymouter.h 7d0115000fc56562f752207648e13db8 *tests/linalgeb.R 538446024b2591753676f76e4cb317d1 *tests/sparse3Darrays.R spatstat.sparse/inst/0000755000176200001440000000000014141377563014401 5ustar liggesusersspatstat.sparse/inst/doc/0000755000176200001440000000000014141451044015131 5ustar liggesusersspatstat.sparse/inst/doc/packagesizes.txt0000644000176200001440000000127614156763230020362 0ustar liggesusersdate version nhelpfiles nobjects ndatasets Rlines srclines "2020-05-03" "1.0-0" 4 53 0 2039 659 "2020-05-04" "1.0-1" 4 53 0 2102 732 "2020-05-05" "1.0-2" 9 53 0 2105 732 "2020-05-06" "1.0-3" 12 55 0 2105 732 "2020-05-06" "1.0-4" 12 55 0 2105 732 "2020-05-08" "1.0-5" 12 55 0 2202 732 "2020-05-09" "1.0-7" 13 55 0 2203 732 "2020-05-10" "1.0-8" 13 57 0 2206 732 "2020-05-22" "1.0-9" 13 57 0 2206 732 "2020-06-02" "1.1-0" 13 57 0 2223 732 "2021-01-06" "1.1-1" 13 57 0 2223 732 "2021-01-08" "1.2-0" 13 57 0 2223 733 "2021-02-06" "1.2-1" 13 57 0 2230 733 "2021-03-07" "1.3-0" 13 47 0 2017 733 "2021-03-13" "1.3-1" 13 47 0 2017 733 "2021-03-16" "2.0-0" 14 48 0 2059 733 "2021-12-17" "2.1-0" 15 48 0 2059 733