bdsmatrix/0000755000176200001440000000000014570616144012257 5ustar liggesusersbdsmatrix/NAMESPACE0000644000176200001440000000141113216771370013472 0ustar liggesusersuseDynLib(bdsmatrix, .registration=TRUE) # Currently group generics have to be explicitly imported (Bug?) #importFrom("methods", Ops, Arith, Math, Math2) import("methods") importFrom("stats", "median") export("bdsmatrix", "gchol", "bdsmatrix.reconcile", "bdsmatrix.ibd", "listbdsmatrix", "bdsBlock", "bdsI") exportClasses("bdsmatrix", "gchol", "gchol.bdsmatrix") exportMethods("Math", "Math2", "Ops", "%*%", "gchol", "min", "max", "range", "any", "all", "sum", "prod", "diag", "diag<-", "backsolve") S3method(as.matrix, bdsmatrix) S3method(as.matrix, gchol) S3method(as.matrix, gchol.bdsmatrix) S3method(print, bdsmatrix) S3method(solve, gchol) S3method(solve, bdsmatrix) S3method(solve, gchol.bdsmatrix) S3method(unique, bdsmatrix) bdsmatrix/man/0000755000176200001440000000000014570341370013026 5ustar liggesusersbdsmatrix/man/listbdsmatrix.Rd0000644000176200001440000000240413216771367016217 0ustar liggesusers\name{listbdsmatrix} \Rdversion{1.1} \alias{listbdsmatrix} \title{List out a bdsmatrix as row/col/value triplets} \description{ This routine is the inverse of the bdsmatrix.ibd function found in the kinship library. } \usage{listbdsmatrix(x, id = TRUE, diag = FALSE)} \arguments{ \item{x}{a \code{bdsmatrix} object} \item{id}{if true, the dimnames of the object are used as the row and column identifiers in the output, if false integer row and column numbers are used} \item{diag}{include the diagonal elements in the output} } \details{ The non-zero elements of the matrix are listed out as row-col-value triplets, one per line, in a data frame. Since the matrix is known to be symmetric, only elements with row >= col are listed. When familial correlation data is represented in a bdsmatrix, e.g. kinship or identity-by-descent information, the diagonal is a known value and can be omitted from the listing. Genetic software often produces matrices in the list form; this routine is the inverse of the bdsmatrix.ibd routine, found in the kinship library, which converts list form to bdsmatrix form. } \value{a data frame with variables \code{row}, \code{col}, and \code{value}. } \author{Terry Therneau} \seealso{\code{\link{bdsmatrix}}} bdsmatrix/man/solve.bdsmatrix.Rd0000644000176200001440000000466313216771367016463 0ustar liggesusers\name{solve.bdsmatrix} \alias{solve.bdsmatrix} \title{ Solve a matrix equation using the generalized Cholesky decompostion } \description{ This function solves the equation Ax=b for x, when A is a block diagonal sparse matrix (an object of class \code{bdsmatrix}). } \usage{ \method{solve}{bdsmatrix}(a, b, full=TRUE, tolerance=1e-10, ...) } \arguments{ \item{a}{ a block diagonal sparse matrix object } \item{b}{ a numeric vector or matrix, that forms the right-hand side of the equation. } \item{full}{ if true, return the full inverse matrix; if false return only that portion corresponding to the blocks. This argument is ignored if \code{b} is present. If the bdsmatrix \code{a} has a non-sparse portion, i.e., if the \code{rmat} component is present, then the inverse of \code{a} will not be block-diagonal sparse. In this case setting full=F returns only a portion of the inverse. The elements that are returned are those of the full inverse, but the off-diagonal elements that are not returned would not have been zero. } \item{tolerance}{ the tolerance for detecting singularity in the a matrix } \item{...}{other arguments are ignored} } \value{ if argument \code{b} is not present, the inverse of \code{a} is returned, otherwise the solution to matrix equation. The equation is solved using a generalized Cholesky decomposition. } \details{ The matrix \code{a} consists of a block diagonal sparse portion with an optional dense border. The inverse of \code{a}, which is to be computed if \code{y} is not provided, will have the same block diagonal structure as \code{a} only if there is no dense border, otherwise the resulting matrix will not be sparse. However, these matrices may often be very large, and a non sparse version of one of them will require gigabytes of even terabytes of space. For one of the common computations (degrees of freedom in a penalized model) only those elements of the inverse that correspond to the non-zero part of \code{a} are required; the \code{full=F} option returns only that portion of the (block diagonal portion of) the inverse matrix. } \seealso{ bdsmatrix, gchol } \examples{ tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dim(tmat) solve(tmat, cbind(1:13, rep(1,13))) } \keyword{array} % docclass is function % Converted by Sd2Rd version 43267. bdsmatrix/man/solve.gchol.Rd0000644000176200001440000000330113216771367015546 0ustar liggesusers\name{solve.gchol} \alias{solve.gchol} \title{ Solve a matrix equation using the generalized Cholesky decompostion } \description{ This function solves the equation Ax=b for x, given b and the generalized Cholesky decompostion of A. If only the first argument is given, then a G-inverse of A is returned. } \usage{ \method{solve}{gchol}(a, b, full=TRUE, ...) } \arguments{ \item{a}{ a generalized cholesky decompostion of a matrix, as returned by the \code{gchol} function. } \item{b}{ a numeric vector or matrix, that forms the right-hand side of the equation. } \item{full}{ solve the problem for the full (orignal) matrix, or for the cholesky matrix. } \item{...}{other arguments are ignored} } \value{ if argument \code{b} is not present, the inverse of \code{a} is returned, otherwise the solution to matrix equation. } \details{ A symmetric matrix A can be decomposed as LDL', where L is a lower triangular matrix with 1's on the diagonal, L' is the transpose of L, and D is diagonal. This routine solves either the original problem Ay=b (\code{full} argument) or the subproblem sqrt(D)L'y=b. If \code{b} is missing it returns the inverse of A or L, respectively. } \seealso{ gchol } \examples{ # Create a matrix that is symmetric, but not positive definite # The matrix temp has column 6 redundant with cols 1-5 smat <- matrix(1:64, ncol=8) smat <- smat + t(smat) + diag(rep(20,8)) #smat is 8 by 8 symmetric temp <- smat[c(1:5, 5:8), c(1:5, 5:8)] ch1 <- gchol(temp) ginv <- solve(ch1, full=FALSE) # generalized inverse of ch1 tinv <- solve(ch1, full=TRUE) # generalized inverse of temp all.equal(temp \%*\% tinv \%*\% temp, temp) } \keyword{array} % docclass is function % Converted by Sd2Rd version 43267. bdsmatrix/man/bdsmatrix.reconcile.Rd0000644000176200001440000000145013216771367017265 0ustar liggesusers\name{bdsmatrix.reconcile} \Rdversion{1.1} \alias{bdsmatrix.reconcile} \title{ Ensure alignment of two bdsmatrix objects } \description{ This function is used by coxme. When a random effect is expressed as a sum of variance terms (matrices), it is important that all of them have the same row/column order and the same block structure. This does so, while retaining as much sparsity in the result as possible. } \usage{ bdsmatrix.reconcile(varlist, group) } \arguments{ \item{varlist}{ a list, each element of which is a matrix or bdsmatrix object } \item{group}{ a vector of dimnames, the target match for matrice's dimnames } } \value{ a varlist, whose individual elements may have had row/column rearrangment. } \author{Terry Therneau} \seealso{ \code{\link{bdsmatrix}} } \keyword{array} bdsmatrix/man/as.matrix.bdsmatrix.Rd0000644000176200001440000000114413216771367017230 0ustar liggesusers\name{as.matrix.bdsmatrix} \alias{as.matrix.bdsmatrix} \title{Convert a bdsmatrix to a ordinary (dense) matrix} \description{Method to convert from a Block Diagonal Sparse (bdsmatrix) matrix representation to an ordinary one} \usage{ \method{as.matrix}{bdsmatrix}(x, ...)} \arguments{ \item{x}{a bdsmatrix object} \item{...}{other arguments are ignored (necessary to match the \code{as.matrix} template)} } \value{ a matrix} \details{ Note that the conversion of a large bdsmatrix can easily exceed memory. } \seealso{bdsmatrix } \keyword{array} % docclass is function % Converted by Sd2Rd version 43267. bdsmatrix/man/bdsmatrix.Rd0000644000176200001440000000366213216771367015332 0ustar liggesusers\name{bdsmatrix} \alias{bdsmatrix} \title{ Create a sparse symmetric block diagonal matrix object } \description{ Sparse block diagonal matrices are used in the the large parameter matrices that can arise in random-effects coxph and survReg models. This routine creates such a matrix. Methods for these matrices allow them to be manipulated much like an ordinary matrix, but the total memory use can be much smaller. } \usage{ bdsmatrix(blocksize, blocks, rmat, dimnames) } \arguments{ \item{blocksize}{ vector of sizes for the matrices on the diagonal } \item{blocks}{ contents of the diagonal blocks, strung out as a vector } \item{rmat}{ the dense portion of the matrix, forming a right and lower border } \item{dimnames}{ a list of dimension names for the matrix } } \value{ an object of type bdsmatrix } \details{ Consider the following matrix, which has been divided into 4 parts. 1 2 0 0 0 | 4 5 2 1 0 0 0 | 6 7 0 0 3 1 2 | 8 8 0 0 1 4 3 | 1 1 0 0 2 3 5 | 2 2 --------------+----- 4 6 8 1 2 | 7 6 5 7 8 1 2 | 6 9 The upper left is block diagonal, and can be stored in a compressed form without the zeros. With a large number of blocks, the zeros can actually account for over 99\% of a matrix; this commonly happens with the kinship matrix for a large collection of families (one block/family). The arguments to this routine would be block sizes of 2 and 3, along with a 2 by 7 "right hand" matrix. Since the matrix is symmetrical, the bottom slice is not needed. } \examples{ # The matrix shown above is created by tmat <- bdsmatrix(c(2,3), c(1,2,1, 3,1,2, 4,3, 5), rmat=matrix(c(4,6,8,1,2,7,6, 5,7,8,1,2,6,9), ncol=2)) # Note that only the lower part of the blocks is needed, however, the # entire block set is also allowed, i.e., c(1,2,2,1, 3,1,2,1,4,3,2,3,5) } \keyword{array} % docclass is function % Converted by Sd2Rd version 43267. bdsmatrix/man/gchol.bdsmatrix-class.Rd0000644000176200001440000000412013216771367017516 0ustar liggesusers\name{gchol.bdsmatrix-class} \docType{class} \alias{gchol.bdsmatrix-class} \alias{\%*\%,gchol.bdsmatrix,matrix-method} \alias{\%*\%,gchol.bdsmatrix,numeric-method} \alias{\%*\%,matrix,gchol.bdsmatrix-method} \alias{\%*\%,numeric,gchol.bdsmatrix-method} \alias{[,gchol.bdsmatrix-method} \alias{coerce,gchol.bdsmatrix,matrix-method} \alias{diag,gchol.bdsmatrix-method} \alias{dim,gchol.bdsmatrix-method} \alias{show,gchol.bdsmatrix-method} \title{Class "gchol.bdsmatrix"} \description{Generalized cholesky decomposition of a \code{bdsmatrix} object, A= LDL' where A is symmetric, L is lower triangular with 1 on the diagonal, and D is diagonal.} \section{Objects from the Class}{ These are created by the \code{gchol} function. } \section{Slots}{ \describe{ \item{\code{blocksize}:}{Integer vector of block sizes} \item{\code{blocks}:}{Numeric vector containing the blocks} \item{\code{rmat}:}{Dense portion of the decomposition} \item{\code{rank}:}{The rank of A} \item{\code{Dim}:}{Integer vector of length 2 containing the dimension} \item{\code{Dimnames}:}{List of length 2 containing the dimnames} } } \section{Methods}{ \describe{ \item{\%*\%}{\code{signature(x = "gchol.bdsmatrix", y = "matrix")}: ... } \item{\%*\%}{\code{signature(x = "gchol.bdsmatrix", y = "numeric")}: ... } \item{\%*\%}{\code{signature(x = "matrix", y = "gchol.bdsmatrix")}: ... } \item{\%*\%}{\code{signature(x = "numeric", y = "gchol.bdsmatrix")}: ... } \item{[}{\code{signature(x = "gchol.bdsmatrix")}: ... } \item{coerce}{\code{signature(from = "gchol.bdsmatrix", to = "matrix")}: ... } \item{diag}{\code{signature(x = "gchol.bdsmatrix")}: ... } \item{dim}{\code{signature(x = "gchol.bdsmatrix")}: ... } \item{show}{\code{signature(object = "gchol.bdsmatrix")}: ... } } } \author{Terry Therneau} \note{ The Cholesky decompostion of a block diagonal symmetric matrix is also block diagonal symmetric, so is stored in the same manner as a \code{bdsmatrix} object} \seealso{\code{\link{bdsmatrix}}, \code{\link{gchol}}} \examples{ showClass("gchol.bdsmatrix") } \keyword{classes} bdsmatrix/man/gchol-class.Rd0000644000176200001440000000572213216771367015533 0ustar liggesusers\name{gchol-class} \docType{class} \alias{gchol-class} \alias{coerce,gchol,matrix-method} \alias{diag,gchol-method} \alias{dim,gchol-method} \alias{dimnames,gchol-method} \alias{show,gchol-method} \alias{gchol,matrix-method} \alias{[,gchol-method} \alias{\%*\%,gchol,matrix-method} \alias{\%*\%,matrix,gchol-method} \title{Class "gchol"} \description{The result of a generalized Cholesky decomposition A=LDL' where A is a symmetric matrix, L is lower triangular with 1s on the diagonal, and D is a diagonal matrix.} \section{Objects from the Class}{ These objects are created by the \code{gchol} function. } \section{Slots}{ \describe{ \item{\code{.Data}:}{A numeric vector containing the results of the decompostion} \item{\code{Dim}:}{An integer vector of length 2, the dimension of the matrix} \item{\code{Dimnames}:}{A list of length 2 containing the dimnames. These default to the dimnames of the matrix A} \item{\code{rank}:}{The rank of the matrix} } } \section{Methods}{ \describe{ \item{\%*\%}{\code{signature(x = "gchol", y = "matrix")}: multiply the cholesky decomposition by a matrix. That is, if A=LDL' is the decomposition, then \code{gchol(A) \%*\% B} will return L D^.5 B. } \item{\%*\%}{\code{signature(x = "matrix", y = "gchol")}: multiply by a matrix on the left } \item{[}{\code{signature(x = "gchol")}: if a square portion from the upper left corner is selected, then the result will be a gchol object, otherwise an ordinary matrix is returned. The latter most often occurs when printing part of the matrix at the command line.} \item{coerce}{\code{signature(from = "gchol", to = "matrix")}: Use of the \code{as.matrix} function will return L} \item{diag}{\code{signature(x = "gchol")}: Use of the \code{diag} function will return D} \item{dim}{\code{signature(x = "gchol")}: returns the dimension of the matrix } \item{dimnames}{\code{signature(x = "gchol")}: returns the dimnames} \item{show}{\code{signature(object = "gchol")}: By default a triangular matrix is printed showing D on the diagonal and L off the diagonal } \item{gchol}{\code{signature(x= "matrix")}: create a generalized Cholesky decompostion of the matrix} } } \author{Terry Therneau} \note{The primary advantages of the genearlized decomposition, as compared to the standard \code{chol function}, has to do with redundant columns and generalized inverses (g-inverse). The lower triangular matrix L is always of full rank. The diagonal matrix D has a 0 element at position j if and only if the jth column of A is linearly dependent on columns 1 to j-1 preceding it. The g-inverse of A involves the inverse of L and a g-inverse of D. The g-inverse of D retains the zeros and inverts non-zero elements of D. This is very useful inside modeling functions such as \code{coxph}, since the X matrix can often contain a redundant column.} \seealso{\code{\link{gchol}}} \examples{ showClass("gchol") } \keyword{classes} bdsmatrix/man/gchol.Rd0000644000176200001440000000424013216771367014422 0ustar liggesusers\name{gchol} \alias{gchol} \title{ Generalized Cholesky decompostion } \description{ Perform the generalized Cholesky decompostion of a real symmetric matrix. } \usage{ gchol(x, tolerance=1e-10) } \arguments{ \item{x}{ the symmetric matrix to be factored } \item{tolerance}{ the numeric tolerance for detection of singular columns in x. } } \value{ an object of class \code{gchol} containing the generalized Cholesky decompostion. It has the appearance of a lower triangular matrix. } \details{ A symmetric matrix A can be decomposed as LDL', where L is a lower triangular matrix with 1's on the diagonal, L' is the transpose of L, and D is diagonal. The inverse of L is also lower-triangular, with 1's on the diagonal. If all elements of D are positive, then A must be symmetric positive definite (SPD), and the solution can be reduced the usual Cholesky decomposition U'U where U is upper triangular and U = sqrt(D) L'. The main advantage of the generalized form is that it admits of matrices that are not of full rank: D will contain zeros marking the redundant columns, and the rank of A is the number of non-zero columns. If all elements of D are zero or positive, then A is a non-negative definite (NND) matrix. The generalized form also has the (quite minor) numerical advantage of not requiring square roots during its calculation. To extract the components of the decompostion, use the \code{diag} and \code{as.matrix} functions. The \code{solve} has a method for gchol decompostions, and there are gchol methods for block diagonal symmetric (\code{bdsmatrix}) matrices as well. } \seealso{ bsdmatrix, solve.gchol } \examples{ # Create a matrix that is symmetric, but not positive definite # The matrix temp has column 6 redundant with cols 1-5 smat <- matrix(1:64, ncol=8) smat <- smat + t(smat) + diag(rep(20,8)) #smat is 8 by 8 symmetric temp <- smat[c(1:5, 5:8), c(1:5, 5:8)] ch1 <- gchol(temp) print(as.matrix(ch1), digits=4) # print out L print(diag(ch1)) # Note the zero at position 6 ginv <- solve(ch1) # generalized inverse diag(ginv) # also has column 6 marked as singular } \keyword{array} % docclass is function % Converted by Sd2Rd version 43267. bdsmatrix/man/bdsmatrix-class.Rd0000644000176200001440000001211413216771367016425 0ustar liggesusers\name{bdsmatrix-class} \docType{class} \alias{bdsmatrix-class} \alias{\%*\%,matrix,bdsmatrix-method} \alias{\%*\%,numeric,bdsmatrix-method} \alias{\%*\%,bdsmatrix,matrix-method} \alias{\%*\%,bdsmatrix,numeric-method} \alias{Math2,bdsmatrix-method} \alias{Math,bdsmatrix-method} \alias{Ops,bdsmatrix,numeric-method} \alias{Ops,bdsmatrix,bdsmatrix-method} \alias{Ops,bdsmatrix,matrix-method} \alias{Ops,numeric,bdsmatrix-method} \alias{Ops,matrix,bdsmatrix-method} \alias{[,bdsmatrix-method} \alias{all,bdsmatrix-method} \alias{any,bdsmatrix-method} \alias{coerce,bdsmatrix,matrix-method} \alias{coerce,bdsmatrix,vector-method} \alias{diag,bdsmatrix-method} \alias{diag<-,bdsmatrix-method} \alias{dim,bdsmatrix-method} \alias{dimnames,bdsmatrix-method} \alias{dimnames<-,bdsmatrix-method} \alias{gchol,bdsmatrix-method} \alias{max,bdsmatrix-method} \alias{min,bdsmatrix-method} \alias{prod,bdsmatrix-method} \alias{range,bdsmatrix-method} \alias{show,bdsmatrix-method} \alias{sum,bdsmatrix-method} \title{Class "bdsmatrix"} \description{Representation for a Block Diagonal Sparse matrix} \section{Objects from the Class}{ Objects of this class are usually created using the \code{bdsmatrix}, \code{bdsI} or \code{bdsBlock} functions. The result is a symmetrix matrix whose upper left portion is block-diagonal, with an optional border on the right and bottom that is dense. The matrices were originally created to represent familial correlation structures, which have a block for each family but no connection between families. } \section{Slots}{ \describe{ \item{\code{blocksize}:}{An integer vector containing the sizes of the diagonal blocks} \item{\code{blocks}:}{A numeric vector containing the contents of the block portion. Only the lower triangle of each block is stored.} \item{\code{rmat}:}{An optional numeric matrix containing the dense portion} \item{\code{offdiag}:}{A single numeric element, default zero, which is the value for elements off the block-diagonal } \item{\code{Dim}:}{The dimension of the matrix, an integer vector of length 2} \item{\code{Dimnames}:}{The dimnames of the matrix, a list with 2 elements} } } \section{Methods}{ \describe{ \item{\%*\%}{\code{signature(x = "matrix", y = "bdsmatrix")}: the result will be an ordinary matrix} \item{\%*\%}{\code{signature(x = "numeric", y = "bdsmatrix")}: the result will be a vector} \item{\%*\%}{\code{signature(x = "bdsmatrix", y = "matrix")}: the result will be an ordinary matrix} \item{\%*\%}{\code{signature(x = "bdsmatrix", y = "numeric")}: the result will be a vector} \item{Math2}{\code{signature(x = "bdsmatrix")}: } \item{Math}{\code{signature(x = "bdsmatrix")}: } \item{Ops}{\code{signature(e1 = "bdsmatrix", e2 = "numeric")}: } \item{Ops}{\code{signature(e1 = "bdsmatrix", e2 = "bdsmatrix")}: } \item{Ops}{\code{signature(e1 = "bdsmatrix", e2 = "matrix")}: } \item{Ops}{\code{signature(e1 = "numeric", e2 = "bdsmatrix")}: } \item{Ops}{\code{signature(e1 = "matrix", e2 = "bdsmatrix")}: } \item{[}{\code{signature(x = "bdsmatrix")}: if the subscripts are a set of increasing integers, and the row and column subscripts are identical, then the result is aslo a bdsmatrix. This is useful for example to create the kinship matrix for all females from an overall kinship matrix. If the subscripts do not match, then an ordinary matrix is created} \item{all}{\code{signature(x = "bdsmatrix")}: ... } \item{any}{\code{signature(x = "bdsmatrix")}: ... } \item{coerce}{\code{signature(from = "bdsmatrix", to = "matrix")}: ... } \item{coerce}{\code{signature(from = "bdsmatrix", to = "vector")}: ... } \item{diag}{\code{signature(x = "bdsmatrix")}: retrieve the diagonal of the matrix} \item{diag<-}{\code{signature(x = "bdsmatrix")}: set the diagonal of the matrix to a given value} \item{dim}{\code{signature(x = "bdsmatrix")}: dimension of the matrix} \item{dimnames}{\code{signature(x = "bdsmatrix")}: dimnames of the matrix} \item{dimnames<-}{\code{signature(x = "bdsmatrix")}: set the dimnames of the matrix} \item{gchol}{\code{signature(x = "bdsmatrix")}: generalized cholesky decomposition of the matrix } \item{max}{\code{signature(x = "bdsmatrix")}: maximum of the matrix} \item{min}{\code{signature(x = "bdsmatrix")}: minimum of the matrix} \item{prod}{\code{signature(x = "bdsmatrix")}: } \item{range}{\code{signature(x = "bdsmatrix")}: } \item{show}{\code{signature(object = "bdsmatrix")}: print out the matrix} \item{sum}{\code{signature(x = "bdsmatrix")}: } } } \note{ Many of the actions above will result in conversion to an ordinary matrix object, including \code{print}, addition to an ordinary matrix, etc. This can easily create objects that are too large for system memory. By default the value of options('bdsmatrixsize') is consulted first, and if the resulting object would be have a length greater than this option the conversion an error is generated and conversion is not attempted. The default value for the option is 1000. } \author{Terry Therneau} \seealso{\code{\link{gchol}} } \examples{ showClass("bdsmatrix") } \keyword{classes} bdsmatrix/man/bdsmatrix.ibd.Rd0000644000176200001440000000341713216771367016065 0ustar liggesusers\name{bdsmatrix.ibd} \alias{bdsmatrix.ibd} \title{ Create a bdsmatrix from a list } \description{ Routines that create identity-by-descent (ibd) coefficients often output their results as a list of values (i, j, x[i,j]), with unlisted values of the x matrix assumed to be zero. This routine recasts such a list into \code{bdsmatrix} form. } \usage{ bdsmatrix.ibd(id1, id2, x, idmap, diagonal) } \arguments{ \item{id1}{ row identifier for the value, in the final matrix. Optionally, \code{id1} can be a 3 column matrix or data.frame, in which case it is assumed to contain the first 3 arguments, in order. } \item{id2}{ column identifier for the value, in the final matrix. } \item{x}{ the value to place in the matrix } \item{idmap}{ a two column matrix or data frame. Sometimes routines create output with integer values for \code{id1} and \code{id2}, and then this argument is the mapping from this internal label to the ``real'' name) } \item{diagonal}{ If diagonal elements are not preserved in the list, this value will be used for the diagonal of the result. If the argument appears, then the output matrix will contain an entry for each value in \code{idlist}. Otherwise only those with an explicit entry appear. } } \value{ a \code{bdsmatrix} object representing a block-diagonal sparse matrix. } \details{ The routine first checks for non-symmetric or otherwise inconsistent input. It then groups observations together into `families' of related subjects, which determines the structure of the final matrix. As with the \code{makekinship} function, singletons with no relationships are first in the output matrix, and then families appear one by one. } \seealso{ bdsmatrix, kinship, coxme, lmekin } \examples{ \dontrun{ ibdmat <- bdsmatrix.ibd(i,j, ibdval, idlist=subject) } } \keyword{array} bdsmatrix/man/backsolve.Rd0000644000176200001440000000445513216771367015307 0ustar liggesusers\name{backsolve} \alias{backsolve-methods} \title{Solve an Upper or Lower Triangular System} \alias{backsolve} \alias{backsolve,gchol-method} \alias{backsolve,gchol.bdsmatrix-method} \description{ Solves a system of linear equations where the coefficient matrix is upper (or \sQuote{right}, \sQuote{R}) or lower (\sQuote{left}, \sQuote{L}) triangular.\cr \code{x <- backsolve(R, b)} solves \eqn{R x = b}. } \usage{ backsolve(r, \dots) \S4method{backsolve}{gchol}(r, x, k=ncol(r), upper.tri=TRUE, \dots) \S4method{backsolve}{gchol.bdsmatrix}(r, x, k=ncol(r), upper.tri=TRUE, \dots) } \arguments{ \item{r}{a matrix or matrix-like object} \item{x}{a vector or a matrix whose columns give the right-hand sides for the equations.} \item{k}{The number of columns of \code{r} and rows of \code{x} to use.} \item{upper.tri}{logical; if \code{TRUE} (default), the \emph{upper} \emph{tri}angular part of \code{r} is used. Otherwise, the lower one.} \item{\dots}{further arguments passed to other methods} } \value{ The solution of the triangular system. The result will be a vector if \code{x} is a vector and a matrix if \code{x} is a matrix. Note that \code{forwardsolve(L, b)} is just a wrapper for \code{backsolve(L, b, upper.tri=FALSE)}. } \section{Methods}{ Use \code{\link{showMethods}(backsolve)} to see all the defined methods; the two created by the bdsmatrix library are described here: \describe{ \item{bdsmatrix}{\code{signature=(r= "gchol")} for a generalized cholesky decomposition} \item{bdsmatrix}{\code{signature=(r= "gchol.bdsmatrix")} for the generalize cholesky decomposition of a bdsmatrix object} } } \details{ The generalized Cholesky decompostion of a symmetric matrix A is \eqn{A = LDL'}{A= LD t(L)} where D is diagonal, L is lower triangular, and \eqn{L'}{t(L)} is the transpose of L. These functions solve either \eqn{L\sqrt{D} x =b}{L sqrt(D) x=b} (when \code{upper.tri=FALSE}) or \eqn{\sqrt{D}L' x=b}{sqrt(D) t(L) x=b}. } \note{ The \code{bdsmatrix} package promotes the base R \code{backsolve} function to a generic. To see the full documentation for the default method, view \code{backsolve} from the \code{base} package. } \seealso{ \code{\link{forwardsolve}}, \code{\link{gchol}} } \keyword{ array } \keyword{ algebra } bdsmatrix/man/bdsBlock.Rd0000644000176200001440000000244013216771367015051 0ustar liggesusers\name{bdsBlock} \alias{bdsBlock} \title{ Block diagonal matrices. } \description{ Create a block-diagonal matrix of ones. } \usage{ bdsBlock(id, group) } \arguments{ \item{id}{ the identifier list. This will become the dimnames of the final matrix, and must be a set of unique values. It's length determines the dimension of the final matrix } \item{group}{ a vector giving the grouping structure. All rows/cols belonging to a given group will form a block of 1's in the final matrix. } } \value{ a block-diagonal matrix of class \code{bdsmatrix} } \seealso{ bdsmatrix, bdsI } \examples{ id <- letters[1:10] group <- c(1,1,3,2,3,3,2,3,2,4) bdsBlock(id, group) \dontrun{ a b d g i c e f h j a 1 1 0 0 0 0 0 0 0 0 b 1 1 0 0 0 0 0 0 0 0 d 0 0 1 1 1 0 0 0 0 0 g 0 0 1 1 1 0 0 0 0 0 i 0 0 1 1 1 0 0 0 0 0 c 0 0 0 0 0 1 1 1 1 0 e 0 0 0 0 0 1 1 1 1 0 f 0 0 0 0 0 1 1 1 1 0 h 0 0 0 0 0 1 1 1 1 0 j 0 0 0 0 0 0 0 0 0 1 # Create the matrices for a sparse nested fit of family within city group <- paste(mydata$city, mydata$family, sep='/') mat1 <- bdsI(group) mat2 <- bdsBlock(group, mydata$city) fit <- coxme(Surv(time, status) ~ age + sex + (1|group), data=mydata, varlist=list(mat1, mat2)) }} \keyword{array} % docclass is function % Converted by Sd2Rd version 43267. bdsmatrix/man/bdsI.Rd0000644000176200001440000000132513216771367014210 0ustar liggesusers\name{bdsI} \alias{bdsI} \title{ Sparse identity matrices } \description{ This function will create an identitiy matrix, in the sparse \code{bdsmatrix} format. } \usage{ bdsI(id, blocksize) } \arguments{ \item{id}{ the identifier list. This will become the dimnames of the final matrix, and must be a set of unique values. It's length determines the dimension of the final matrix } \item{blocksize}{ the blocksize vector of the final matrix. If supplied, the sum of blocksizes must equal the dimension of the matrix. By default, the created matrix is as sparse as possible. } } \value{ an identity matrix. } \examples{ imat <- bdsI(1:10) } \keyword{survival} % docclass is function % Converted by Sd2Rd version 43267. bdsmatrix/DESCRIPTION0000644000176200001440000000131614570616144013766 0ustar liggesusersPackage: bdsmatrix Title: Routines for Block Diagonal Symmetric Matrices Maintainer: Terry Therneau Version: 1.3-7 Date: 2024-03-01 Depends: methods, R (>= 2.0.0) LazyLoad: Yes Author: Terry Therneau Description: This is a special case of sparse matrices, used by coxme. License: LGPL-2 Collate: bdsmatrix.R gchol.R gchol.bdsmatrix.R as.matrix.bdsmatrix.R bdsBlock.R bdsI.R bdsmatrix.ibd.R bdsmatrix.reconcile.R diag.bdsmatrix.R listbdsmatrix.R multiply.bdsmatrix.R solve.bdsmatrix.R solve.gchol.R solve.gchol.bdsmatrix.R backsolve.R NeedsCompilation: yes Packaged: 2024-03-01 12:06:55 UTC; therneau Repository: CRAN Date/Publication: 2024-03-02 12:32:36 UTC bdsmatrix/tests/0000755000176200001440000000000014570341413013413 5ustar liggesusersbdsmatrix/tests/corner.Rout.save0000644000176200001440000000310013216771367016520 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # > # Test out the behavior of a 1x1 bds corner. > # Actually, the problem that motivated this occurred whenever the > # rmat portion was larger than the block diagonal portion. > # > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > test1 <- bdsmatrix(blocksize=1, blocks=33, + rmat=matrix(c(17,33,7,-1, -7,7,48,-7, + 1, -1, -7,4),4)) > > test2 <- bdsmatrix(blocksize=2, blocks=c(33,17,33), + rmat=matrix(c( -7,7,48,-7, 1, -1, -7,4),4)) > all.equal(as.matrix(test1), as.matrix(test2)) [1] TRUE > > g1 <- gchol(test1) > g2 <- gchol(test2) > all.equal(as.matrix(g1), as.matrix(g2)) [1] TRUE > > s1 <- solve(g1, full=T) > s2 <- solve(g2, full=T) > all.equal(as.matrix(s1), as.matrix(s2)) [1] TRUE > > all.equal(solve(test1), solve(test2)) [1] TRUE > > proc.time() user system elapsed 0.518 0.040 0.572 bdsmatrix/tests/bdstest.R0000644000176200001440000000304713216771367015225 0ustar liggesusers# # Test out math aspects # library(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) aeq(smat+2.1, as.matrix(tmat+2.1)) aeq(smat/2.1, as.matrix(tmat/2.1)) aeq(smat-2.1, as.matrix(tmat-2.1)) aeq(smat*2.1, as.matrix(tmat*2.1)) aeq(round(smat,1), as.matrix(round(tmat,1))) aeq(exp(smat), as.matrix(exp(tmat))) aeq(sum(smat), sum(tmat)) aeq(prod(smat), prod(tmat)) aeq(sum(smat+3), sum(tmat+3)) aeq(prod(smat+2), prod(tmat+2)) aeq(range(smat), range(tmat)) aeq(max(smat), max(tmat)) aeq(min(smat), min(tmat)) aeq(smat+1:13, tmat+1:13) aeq(smat+1:13, 1:13 +tmat ) aeq(smat+tmat, 2*smat) all.equal(tmat+tmat, 2*tmat) aeq(sort(unique(c(smat))), sort(unique(tmat))) # # check out the alternate input style, with full blocks # rmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,1,21,3,2,3,20, 19,4,4,18, 17,5,5,16, 15,6,7,8,6,14,9,10,7,9,13,11,8,10,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2), dimnames=list(NULL, letters[1:13])) all.equal(rmat, tmat) # Do some subscripting zz <- c(1,2,7,8,9,11) aeq(smat[zz,zz], as.matrix(tmat[zz,zz])) all.equal(smat[zz, 8:13], tmat[zz, 8:13]) # both are matrices # Diagonals aeq(diag(smat), diag(tmat)) zz <- diag(smat) diag(smat) <- zz*2 diag(tmat) <- zz*2 all.equal(smat, as.matrix(tmat)) bdsmatrix/tests/chtest.Rout.save0000644000176200001440000000373313216771367016536 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # > # Test out the Cholesky > # > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > smat <- as.matrix(tmat) > yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) > > aeq(diag(tmat), diag(smat)) [1] TRUE > zz <- seq(1,13,2) > aeq(as.matrix(tmat[zz,zz]), smat[zz,zz]) [1] TRUE > > ch0 <- chol(smat) > ch1 <- gchol(smat) > ch2 <- gchol(tmat) > # The gchol routines use the composition LDL', where L is lower triangular > # with a diagonal of 1's, and D is diagonal. chol() uses U'U where U is > # upper trangular. > # The as.matrix function returns L and the diag function returns D. > # Convert and compare > aeq(diag(ch1), diag(ch2)) [1] TRUE > temp <- as.matrix(ch2) > aeq(temp, as.matrix(ch1)) [1] TRUE > temp3 <- temp %*% diag(sqrt(diag(ch2))) > aeq(temp3, t(ch0)) [1] TRUE > > zz0 <- solve(smat, yy) > zz1 <- solve(ch1, yy) > zz2 <- solve(tmat, yy) > aeq(zz1, zz2) [1] TRUE > aeq(zz0, zz1) [1] TRUE > > > proc.time() user system elapsed 0.533 0.036 0.612 bdsmatrix/tests/tinv.Rout.save0000644000176200001440000000505613216771367016224 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > > smat <- as.matrix(tmat) > yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) > # look at inverses more closely > # (I needed this when some of the other tests weren't being passed, > # to figure out where in the decomposition/inversion/multiply process > # the flaw was). > > ch1 <- gchol(smat) > ch2 <- gchol(tmat) > > inv1 <- solve(as.matrix(ch1)) > inv2 <- solve(ch2,full=F) #inverse of the cholesky, not of tmat > aeq(inv1, as.matrix(inv2)) [1] TRUE > > # Full matrix tests > inv3 <- solve(smat) > inv4 <- solve(tmat) > inv5 <- solve(gchol(smat), full=T) > aeq(inv3, inv4) [1] TRUE > aeq(inv3, inv5) [1] TRUE > > # The following test is false by design: when called with a bdsmatrix > # object that has an rmat portion, the true inverse is dense. But > # coxme only needs the trace for one calcluation; solve(gchol(tmat)) > # cheats and only returns the block diagonal portion of the inverse. > #inv6 <- solve(gchol(tmat), full=T) > #aeq(inv3, inv6) > > # > # Now test the solution to a partial solve > # We want to be able to transform a matrix to uncorrelated form > # If tmat= LDL', and A is general, I want (D^{-1/2}) L^{-1} A > # > amat <- matrix(runif(5*nrow(tmat)), nrow=nrow(tmat)) > xx1 <- diag(1/sqrt(diag(ch1))) %*% solve(as.matrix(ch1), amat) > xx2 <- solve(ch2, amat, full=F) > aeq(xx1, xx2) [1] TRUE > > xx1 <- diag(1/sqrt(diag(ch1))) %*% solve(as.matrix(ch1), yy) > xx2 <- solve(ch2, yy, full=F) > aeq(xx1, xx2) [1] TRUE > > proc.time() user system elapsed 0.524 0.042 0.581 bdsmatrix/tests/nullr.R0000644000176200001440000000142313216771367014705 0ustar liggesusers# # Make sure things work in the simpler case of no rmat component # library(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(blocksize= c(3,2,2,4), blocks= c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12)) dimnames(tmat) <- list(NULL, letters[1:11]) smat <- as.matrix(tmat) yy <- c(30,35,42,56,34,45,32,37,78,56,40) aeq(diag(tmat), diag(smat)) zz <- seq(1,11,2) aeq(as.matrix(tmat[zz,zz]), smat[zz,zz]) ch0 <- chol(smat) ch1 <- gchol(smat) ch2 <- gchol(tmat) aeq(diag(ch1), diag(ch2)) temp <- as.matrix(ch2) aeq(temp, as.matrix(ch1)) temp3 <- temp %*% diag(sqrt(diag(ch2))) aeq(temp3, t(ch0)) zz0 <- solve(smat, yy) zz1 <- solve(ch1, yy) zz2 <- solve(tmat, yy) aeq(zz1, zz2) aeq(zz0, zz1) bdsmatrix/tests/chtest2.Rout.save0000644000176200001440000000355613216771367016623 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # > # Inverse of the matrix: > # > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > > smat <- as.matrix(tmat) > > inv1 <- solve(smat) > inv2 <- as.matrix(solve(tmat)) # the result is a full, non-sparse matrix > aeq(inv1, inv2) [1] TRUE > > inv3 <- solve(gchol(tmat)) #sparse version, not all parts will be there > inherits(inv3, 'bdsmatrix') #This should be true [1] TRUE > aeq(inv3@blocksize, tmat@blocksize) # Should be the same shape at tmat [1] TRUE > inv3 <- as.matrix(inv3) # What is returned should be correct > aeq(inv1[1:3,1:3], inv3[1:3, 1:3]) [1] TRUE > aeq(inv1[4:5,4:5], inv3[4:5, 4:5]) [1] TRUE > aeq(inv1[6:7,6:7], inv3[6:7, 6:7]) [1] TRUE > aeq(inv1[8:11,8:11], inv3[8:11, 8:11]) [1] TRUE > aeq(inv1[,12:13], inv3[, 12:13]) # and rmat the same too [1] TRUE > > proc.time() user system elapsed 0.832 0.035 0.883 bdsmatrix/tests/tinv.R0000644000176200001440000000317213216771367014534 0ustar liggesuserslibrary(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) # look at inverses more closely # (I needed this when some of the other tests weren't being passed, # to figure out where in the decomposition/inversion/multiply process # the flaw was). ch1 <- gchol(smat) ch2 <- gchol(tmat) inv1 <- solve(as.matrix(ch1)) inv2 <- solve(ch2,full=F) #inverse of the cholesky, not of tmat aeq(inv1, as.matrix(inv2)) # Full matrix tests inv3 <- solve(smat) inv4 <- solve(tmat) inv5 <- solve(gchol(smat), full=T) aeq(inv3, inv4) aeq(inv3, inv5) # The following test is false by design: when called with a bdsmatrix # object that has an rmat portion, the true inverse is dense. But # coxme only needs the trace for one calcluation; solve(gchol(tmat)) # cheats and only returns the block diagonal portion of the inverse. #inv6 <- solve(gchol(tmat), full=T) #aeq(inv3, inv6) # # Now test the solution to a partial solve # We want to be able to transform a matrix to uncorrelated form # If tmat= LDL', and A is general, I want (D^{-1/2}) L^{-1} A # amat <- matrix(runif(5*nrow(tmat)), nrow=nrow(tmat)) xx1 <- diag(1/sqrt(diag(ch1))) %*% solve(as.matrix(ch1), amat) xx2 <- solve(ch2, amat, full=F) aeq(xx1, xx2) xx1 <- diag(1/sqrt(diag(ch1))) %*% solve(as.matrix(ch1), yy) xx2 <- solve(ch2, yy, full=F) aeq(xx1, xx2) bdsmatrix/tests/bdstest.Rout.save0000644000176200001440000000522113216771367016706 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # > # Test out math aspects > # > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > > smat <- as.matrix(tmat) > > aeq(smat+2.1, as.matrix(tmat+2.1)) [1] TRUE > aeq(smat/2.1, as.matrix(tmat/2.1)) [1] TRUE > aeq(smat-2.1, as.matrix(tmat-2.1)) [1] TRUE > aeq(smat*2.1, as.matrix(tmat*2.1)) [1] TRUE > aeq(round(smat,1), as.matrix(round(tmat,1))) [1] TRUE > aeq(exp(smat), as.matrix(exp(tmat))) [1] TRUE > > aeq(sum(smat), sum(tmat)) [1] TRUE > aeq(prod(smat), prod(tmat)) [1] TRUE > aeq(sum(smat+3), sum(tmat+3)) [1] TRUE > aeq(prod(smat+2), prod(tmat+2)) [1] TRUE > aeq(range(smat), range(tmat)) [1] TRUE > aeq(max(smat), max(tmat)) [1] TRUE > aeq(min(smat), min(tmat)) [1] TRUE > > aeq(smat+1:13, tmat+1:13) [1] TRUE > aeq(smat+1:13, 1:13 +tmat ) [1] TRUE > aeq(smat+tmat, 2*smat) [1] TRUE > all.equal(tmat+tmat, 2*tmat) [1] TRUE > > aeq(sort(unique(c(smat))), sort(unique(tmat))) [1] TRUE > > # > # check out the alternate input style, with full blocks > # > rmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,1,21,3,2,3,20, 19,4,4,18, 17,5,5,16, + 15,6,7,8,6,14,9,10,7,9,13,11,8,10,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2), + dimnames=list(NULL, letters[1:13])) > all.equal(rmat, tmat) [1] TRUE > > > # Do some subscripting > zz <- c(1,2,7,8,9,11) > aeq(smat[zz,zz], as.matrix(tmat[zz,zz])) [1] TRUE > > all.equal(smat[zz, 8:13], tmat[zz, 8:13]) # both are matrices [1] TRUE > > # Diagonals > aeq(diag(smat), diag(tmat)) [1] TRUE > zz <- diag(smat) > diag(smat) <- zz*2 > diag(tmat) <- zz*2 > all.equal(smat, as.matrix(tmat)) [1] TRUE > > proc.time() user system elapsed 1.013 0.050 1.075 bdsmatrix/tests/chtest2.R0000644000176200001440000000171513216771367015131 0ustar liggesusers# # Inverse of the matrix: # library(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) inv1 <- solve(smat) inv2 <- as.matrix(solve(tmat)) # the result is a full, non-sparse matrix aeq(inv1, inv2) inv3 <- solve(gchol(tmat)) #sparse version, not all parts will be there inherits(inv3, 'bdsmatrix') #This should be true aeq(inv3@blocksize, tmat@blocksize) # Should be the same shape at tmat inv3 <- as.matrix(inv3) # What is returned should be correct aeq(inv1[1:3,1:3], inv3[1:3, 1:3]) aeq(inv1[4:5,4:5], inv3[4:5, 4:5]) aeq(inv1[6:7,6:7], inv3[6:7, 6:7]) aeq(inv1[8:11,8:11], inv3[8:11, 8:11]) aeq(inv1[,12:13], inv3[, 12:13]) # and rmat the same too bdsmatrix/tests/backsolvetest.Rout.save0000644000176200001440000000424313216771367020112 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > # > # A test of the backsolve function > # > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- matrix(rep(1:5,5), 5, 5) > tmat <- tmat + t(tmat) > diag(tmat) <- diag(tmat) + 10 > > gt <- gchol(tmat) > g1 <- as.matrix(gt) > gd <- diag(sqrt(diag(gt))) > gc <- gd %*% t(g1) #usual cholesky form > > xmat <- cbind(1:5, 11:15) > > s1 <- backsolve(gt, xmat, upper=TRUE) #the default > aeq(gd %*% t(g1) %*% s1, xmat) [1] TRUE > all.equal(s1, backsolve(gc, xmat)) [1] TRUE > > s2 <- backsolve(gt, xmat, upper=FALSE) > aeq(g1 %*% gd %*% s2, xmat) [1] TRUE > all.equal(backsolve(gt,xmat, upper=F), backsolve(t(gc),xmat, upper=F)) [1] TRUE > > > # Now for bdsmatrix objects > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > smat <- as.matrix(tmat) > > gt <- gchol(tmat) > gs <- gchol(smat) > > xmat <- cbind(1:13, 1:13*2 + 3) > > s1 <- backsolve(gt, xmat) > s2 <- backsolve(gs, xmat) > s3 <- backsolve(gt, xmat, upper=FALSE) > s4 <- backsolve(gs, xmat, upper=FALSE) > > aeq(s1, s2) [1] TRUE > aeq(s3, s4) [1] TRUE > > g1 <- as.matrix(gt) > gd <- diag(sqrt(diag(gt))) > aeq(gd %*% t(g1) %*% s1, xmat) [1] TRUE > aeq(g1 %*% gd %*% s3, xmat) [1] TRUE > > proc.time() user system elapsed 0.700 0.048 0.759 bdsmatrix/tests/corner2.Rout.save0000644000176200001440000000547213216771367016620 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # > # Test out the Cholesky, special case of a null block corner > # In this case there is no advantage to a bdsmatrix as it consists of only > # the ordinary matrix part. This case arises in coxme with an (x1+x2 | 1) > # term, however, so it is nice to have it work instead of coding lots of > # if/else logic in that code base. > # > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > smat <- as.matrix(tmat) > tmat <- bdsmatrix(integer(0), numeric(0), rmat=smat) > yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) > > aeq(diag(tmat), diag(smat)) [1] TRUE > zz <- seq(1,13,2) > aeq(as.matrix(tmat[zz,zz]), smat[zz,zz]) [1] TRUE > > ch0 <- chol(smat) > ch1 <- gchol(smat) > ch2 <- gchol(tmat) > # The gchol routines use the composition LDL', where L is lower triangular > # with a diagonal of 1's, and D is diagonal. chol() uses U'U where U is > # upper trangular. > # The as.matrix function returns L and the diag function returns D. > # Convert and compare > aeq(diag(ch1), diag(ch2)) [1] TRUE > temp <- as.matrix(ch2) > aeq(temp, as.matrix(ch1)) [1] TRUE > temp3 <- temp %*% diag(sqrt(diag(ch2))) > aeq(temp3, t(ch0)) [1] TRUE > > zz0 <- solve(smat, yy) > zz1 <- solve(ch1, yy) > zz2 <- solve(tmat, yy) > aeq(zz1, zz2) [1] TRUE > aeq(zz0, zz1) [1] TRUE > > inv1 <- solve(smat) > inv2 <- as.matrix(solve(tmat)) # the result is a full, non-sparse matrix > aeq(inv1, inv2) [1] TRUE > > inv3 <- solve(gchol(tmat)) > aeq(inv1, as.matrix(inv3)) [1] TRUE > > gmat <- gchol(tmat) > g2 <- as.matrix(gmat) %*% diag(sqrt(diag(gmat))) > aeq(1:13 %*% g2, 1:13 %*% gmat) #vectors first [1] TRUE > aeq(g2 %*% 1:13, gmat %*% 1:13) [1] TRUE > temp <- matrix(runif(39), nrow=3) > aeq(temp %*% g2, temp %*% gmat) [1] TRUE > aeq(g2 %*% t(temp), gmat %*% t(temp)) [1] TRUE > > proc.time() user system elapsed 0.849 0.044 0.917 bdsmatrix/tests/matrix.Rout.save0000644000176200001440000000342713216771367016550 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > > smat <- as.matrix(tmat) > yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) > > # matrix multiplication > zz <- runif(13) > aeq(zz%*% smat, zz%*% tmat) [1] TRUE > aeq(smat%*%zz, tmat%*% zz) [1] TRUE > > xx <- matrix(1:39, ncol=3) > aeq(smat %*% zz, tmat %*% zz) [1] TRUE > aeq(t(xx) %*% smat, t(xx) %*% tmat) [1] TRUE > > > amat <- tmat > amat@offdiag <- pi > bmat <- as.matrix(amat) > > aeq(zz%*% amat, zz%*% bmat) [1] TRUE > aeq(amat%*%zz, bmat%*% zz) [1] TRUE > > > # Solve the right-hand side wrt a matrix > yy2 <- cbind(yy, -yy, yy+3) > zz1 <- solve(smat, yy2) > zz2 <- solve(tmat, yy2) > aeq(zz1, zz2) [1] TRUE > aeq(zz2[,1], solve(tmat, yy)) [1] TRUE > > proc.time() user system elapsed 0.922 0.051 0.987 bdsmatrix/tests/gtest2.R0000644000176200001440000000122213216771367014756 0ustar liggesuserslibrary(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) # # Test multiplication of a vector/matrix times a gchol # tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) gmat <- gchol(tmat) g2 <- as.matrix(gmat) %*% diag(sqrt(diag(gmat))) aeq(1:13 %*% g2, 1:13 %*% gmat) #vectors first aeq(g2 %*% 1:13, gmat %*% 1:13) temp <- matrix(runif(39), nrow=3) aeq(temp %*% g2, temp %*% gmat) aeq(g2 %*% t(temp), gmat %*% t(temp)) bdsmatrix/tests/matrix.R0000644000176200001440000000154413216771367015061 0ustar liggesuserslibrary(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) # matrix multiplication zz <- runif(13) aeq(zz%*% smat, zz%*% tmat) aeq(smat%*%zz, tmat%*% zz) xx <- matrix(1:39, ncol=3) aeq(smat %*% zz, tmat %*% zz) aeq(t(xx) %*% smat, t(xx) %*% tmat) amat <- tmat amat@offdiag <- pi bmat <- as.matrix(amat) aeq(zz%*% amat, zz%*% bmat) aeq(amat%*%zz, bmat%*% zz) # Solve the right-hand side wrt a matrix yy2 <- cbind(yy, -yy, yy+3) zz1 <- solve(smat, yy2) zz2 <- solve(tmat, yy2) aeq(zz1, zz2) aeq(zz2[,1], solve(tmat, yy)) bdsmatrix/tests/corner.R0000644000176200001440000000131313216771367015037 0ustar liggesusers# # Test out the behavior of a 1x1 bds corner. # Actually, the problem that motivated this occurred whenever the # rmat portion was larger than the block diagonal portion. # library(bdsmatrix) test1 <- bdsmatrix(blocksize=1, blocks=33, rmat=matrix(c(17,33,7,-1, -7,7,48,-7, 1, -1, -7,4),4)) test2 <- bdsmatrix(blocksize=2, blocks=c(33,17,33), rmat=matrix(c( -7,7,48,-7, 1, -1, -7,4),4)) all.equal(as.matrix(test1), as.matrix(test2)) g1 <- gchol(test1) g2 <- gchol(test2) all.equal(as.matrix(g1), as.matrix(g2)) s1 <- solve(g1, full=T) s2 <- solve(g2, full=T) all.equal(as.matrix(s1), as.matrix(s2)) all.equal(solve(test1), solve(test2)) bdsmatrix/tests/gtest2.Rout.save0000644000176200001440000000303413216771367016446 0ustar liggesusers R Under development (unstable) (2014-08-14 r66373) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: i686-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > # > # Test multiplication of a vector/matrix times a gchol > # > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > > gmat <- gchol(tmat) > g2 <- as.matrix(gmat) %*% diag(sqrt(diag(gmat))) > > > aeq(1:13 %*% g2, 1:13 %*% gmat) #vectors first [1] TRUE > aeq(g2 %*% 1:13, gmat %*% 1:13) [1] TRUE > > temp <- matrix(runif(39), nrow=3) > aeq(temp %*% g2, temp %*% gmat) [1] TRUE > aeq(g2 %*% t(temp), gmat %*% t(temp)) [1] TRUE > > proc.time() user system elapsed 0.584 0.024 0.666 bdsmatrix/tests/gtest.Rout.save0000644000176200001440000000367213216771367016374 0ustar liggesusers R Under development (unstable) (2014-08-14 r66373) -- "Unsuffered Consequences" Copyright (C) 2014 The R Foundation for Statistical Computing Platform: i686-pc-linux-gnu (32-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > dimnames(tmat) <- list(NULL, letters[1:13]) > > smat <- as.matrix(tmat) > > # Create a matrix that is symmetric, but not positive definite > # The first one, temp, has column 6 redundant with cols 1-5 > temp <- smat[c(1:5, 5:10), c(1:5, 5:10)] > ch1 <- gchol(temp) > aeq(diag(ch1)[6], 0) # Check that it has a zero in the proper place [1] TRUE > ginv <- solve(ch1) # see if I get a generalized inverse > aeq(temp %*% ginv %*% temp, temp) [1] TRUE > aeq(ginv %*% temp %*% ginv, ginv) [1] TRUE > > # Now create one that is negative definite > ch2 <- gchol(smat) > temp2 <- as.matrix(ch2) > temp3 <- diag(ch2) * rep(c(1, -1), length=nrow(smat)) > xmat <- temp2 %*% diag(temp3) %*% t(temp2) > xmat <- (xmat + t(xmat))/2 #work out round-off errors > ch3 <- gchol(xmat) > > aeq(diag(ch3), temp3) [1] TRUE > aeq(as.matrix(ch3), temp2) [1] TRUE > > proc.time() user system elapsed 0.600 0.008 0.675 bdsmatrix/tests/reconcile.R0000644000176200001440000000406213216771367015516 0ustar liggesusers# # Test cases for bdsmatrix.reconcile # library(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) id <- letters[1:13] dimnames(tmat) <- list(id, id) rmat <- matrix(1:169, 13,13) rmat <- (rmat + t(rmat))/2 dimnames(rmat) <- list(rev(id), rev(id)) xmat <- bdsmatrix.reconcile(list(tmat, rmat), group=id) temp <- xmat[[1]] aeq(temp@blocksize, 13) aeq(as.matrix(temp), as.matrix(tmat)) temp <- xmat[[2]] aeq(temp@blocksize, 13) aeq(as.matrix(temp), rmat[13:1, 13:1]) xmat <- bdsmatrix.reconcile(list(rmat, bdsI, tmat), group= rev(id)) temp <- xmat[[1]] aeq(as.matrix(temp), rmat) temp <- xmat[[2]] aeq(as.matrix(temp), diag(13)) temp <- xmat[[3]] aeq(as.matrix(temp), (as.matrix(tmat))[13:1,13:1]) # # Simplest case # xmat <- bdsmatrix.reconcile(bdsI, id) all(xmat@blocksize==1) aeq(as.matrix(xmat), diag(13)) # # The case list(tmat, tmat) will fail - can't have 2 rmats # #xmat <- bdsmatrix.reconcile(list(tmat, tmat), id) xmat <- bdsmatrix.reconcile(list(tmat, bdsI), rev(id)) temp <- xmat[[1]] aeq(as.matrix(temp), as.matrix(tmat)) aeq(dimnames(temp)[[1]], id) aeq(as.matrix(xmat[[2]]), diag(13)) # # Now for the hard one: 2 bdsmatrices, different orders, different # blocksize, but one contains the other # tmat <- tmat[1:11, 1:11] tord <- c(11:8, 2,1,3, 6,7,5,4) rmat <- (as.matrix(tmat))[tord, tord] rmat <- bdsmatrix(blocksize=c(4,5,2), blocks=c(rmat[1:4,1:4], rmat[5:9,5:9], rmat[10:11, 10:11]), dimnames=list(id[tord], id[tord])) aeq(as.matrix(tmat)[tord,tord], as.matrix(rmat)) xmat <- bdsmatrix.reconcile(list(tmat/2, rmat), id[1:11]) all.equal(xmat[[2]], rmat) all.equal(xmat[[1]]*2, rmat) # Now toss out a row/col # Give it a different name, too xx <- id[tord] xx[1] <- 44 dimnames(rmat) <- list(xx,xx) xmat <- bdsmatrix.reconcile(list(tmat/2, rmat), id[1:9]) all.equal(xmat[[1]]*2, xmat[[2]]) bdsmatrix/tests/backsolvetest.R0000644000176200001440000000232213216771367016421 0ustar liggesuserslibrary(bdsmatrix) # # A test of the backsolve function # aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- matrix(rep(1:5,5), 5, 5) tmat <- tmat + t(tmat) diag(tmat) <- diag(tmat) + 10 gt <- gchol(tmat) g1 <- as.matrix(gt) gd <- diag(sqrt(diag(gt))) gc <- gd %*% t(g1) #usual cholesky form xmat <- cbind(1:5, 11:15) s1 <- backsolve(gt, xmat, upper=TRUE) #the default aeq(gd %*% t(g1) %*% s1, xmat) all.equal(s1, backsolve(gc, xmat)) s2 <- backsolve(gt, xmat, upper=FALSE) aeq(g1 %*% gd %*% s2, xmat) all.equal(backsolve(gt,xmat, upper=F), backsolve(t(gc),xmat, upper=F)) # Now for bdsmatrix objects tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) gt <- gchol(tmat) gs <- gchol(smat) xmat <- cbind(1:13, 1:13*2 + 3) s1 <- backsolve(gt, xmat) s2 <- backsolve(gs, xmat) s3 <- backsolve(gt, xmat, upper=FALSE) s4 <- backsolve(gs, xmat, upper=FALSE) aeq(s1, s2) aeq(s3, s4) g1 <- as.matrix(gt) gd <- diag(sqrt(diag(gt))) aeq(gd %*% t(g1) %*% s1, xmat) aeq(g1 %*% gd %*% s3, xmat) bdsmatrix/tests/corner2.R0000644000176200001440000000346013216771367015126 0ustar liggesusers# # Test out the Cholesky, special case of a null block corner # In this case there is no advantage to a bdsmatrix as it consists of only # the ordinary matrix part. This case arises in coxme with an (x1+x2 | 1) # term, however, so it is nice to have it work instead of coding lots of # if/else logic in that code base. # library(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) tmat <- bdsmatrix(integer(0), numeric(0), rmat=smat) yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) aeq(diag(tmat), diag(smat)) zz <- seq(1,13,2) aeq(as.matrix(tmat[zz,zz]), smat[zz,zz]) ch0 <- chol(smat) ch1 <- gchol(smat) ch2 <- gchol(tmat) # The gchol routines use the composition LDL', where L is lower triangular # with a diagonal of 1's, and D is diagonal. chol() uses U'U where U is # upper trangular. # The as.matrix function returns L and the diag function returns D. # Convert and compare aeq(diag(ch1), diag(ch2)) temp <- as.matrix(ch2) aeq(temp, as.matrix(ch1)) temp3 <- temp %*% diag(sqrt(diag(ch2))) aeq(temp3, t(ch0)) zz0 <- solve(smat, yy) zz1 <- solve(ch1, yy) zz2 <- solve(tmat, yy) aeq(zz1, zz2) aeq(zz0, zz1) inv1 <- solve(smat) inv2 <- as.matrix(solve(tmat)) # the result is a full, non-sparse matrix aeq(inv1, inv2) inv3 <- solve(gchol(tmat)) aeq(inv1, as.matrix(inv3)) gmat <- gchol(tmat) g2 <- as.matrix(gmat) %*% diag(sqrt(diag(gmat))) aeq(1:13 %*% g2, 1:13 %*% gmat) #vectors first aeq(g2 %*% 1:13, gmat %*% 1:13) temp <- matrix(runif(39), nrow=3) aeq(temp %*% g2, temp %*% gmat) aeq(g2 %*% t(temp), gmat %*% t(temp)) bdsmatrix/tests/reconcile.Rout.save0000644000176200001440000000620313216771367017202 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # > # Test cases for bdsmatrix.reconcile > # > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(c(3,2,2,4), + c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), + matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, + 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) > id <- letters[1:13] > dimnames(tmat) <- list(id, id) > > rmat <- matrix(1:169, 13,13) > rmat <- (rmat + t(rmat))/2 > dimnames(rmat) <- list(rev(id), rev(id)) > > xmat <- bdsmatrix.reconcile(list(tmat, rmat), group=id) > temp <- xmat[[1]] > aeq(temp@blocksize, 13) [1] TRUE > aeq(as.matrix(temp), as.matrix(tmat)) [1] TRUE > > temp <- xmat[[2]] > aeq(temp@blocksize, 13) [1] TRUE > aeq(as.matrix(temp), rmat[13:1, 13:1]) [1] TRUE > > xmat <- bdsmatrix.reconcile(list(rmat, bdsI, tmat), group= rev(id)) > temp <- xmat[[1]] > aeq(as.matrix(temp), rmat) [1] TRUE > > temp <- xmat[[2]] > aeq(as.matrix(temp), diag(13)) [1] TRUE > > temp <- xmat[[3]] > aeq(as.matrix(temp), (as.matrix(tmat))[13:1,13:1]) [1] TRUE > > # > # Simplest case > # > xmat <- bdsmatrix.reconcile(bdsI, id) > all(xmat@blocksize==1) [1] TRUE > aeq(as.matrix(xmat), diag(13)) [1] TRUE > > # > # The case list(tmat, tmat) will fail - can't have 2 rmats > # > #xmat <- bdsmatrix.reconcile(list(tmat, tmat), id) > > xmat <- bdsmatrix.reconcile(list(tmat, bdsI), rev(id)) > temp <- xmat[[1]] > aeq(as.matrix(temp), as.matrix(tmat)) [1] TRUE > aeq(dimnames(temp)[[1]], id) [1] TRUE > > aeq(as.matrix(xmat[[2]]), diag(13)) [1] TRUE > > # > # Now for the hard one: 2 bdsmatrices, different orders, different > # blocksize, but one contains the other > # > tmat <- tmat[1:11, 1:11] > tord <- c(11:8, 2,1,3, 6,7,5,4) > rmat <- (as.matrix(tmat))[tord, tord] > rmat <- bdsmatrix(blocksize=c(4,5,2), + blocks=c(rmat[1:4,1:4], rmat[5:9,5:9], rmat[10:11, 10:11]), + dimnames=list(id[tord], id[tord])) > > aeq(as.matrix(tmat)[tord,tord], as.matrix(rmat)) [1] TRUE > > xmat <- bdsmatrix.reconcile(list(tmat/2, rmat), id[1:11]) > all.equal(xmat[[2]], rmat) [1] TRUE > all.equal(xmat[[1]]*2, rmat) [1] TRUE > > # Now toss out a row/col > # Give it a different name, too > xx <- id[tord] > xx[1] <- 44 > dimnames(rmat) <- list(xx,xx) > xmat <- bdsmatrix.reconcile(list(tmat/2, rmat), id[1:9]) > all.equal(xmat[[1]]*2, xmat[[2]]) [1] TRUE > > proc.time() user system elapsed 0.866 0.042 0.922 bdsmatrix/tests/nullr.Rout.save0000644000176200001440000000326513216771367016400 0ustar liggesusers R version 3.0.2 (2013-09-25) -- "Frisbee Sailing" Copyright (C) 2013 The R Foundation for Statistical Computing Platform: x86_64-unknown-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # > # Make sure things work in the simpler case of no rmat component > # > library(bdsmatrix) Attaching package: 'bdsmatrix' The following object is masked from 'package:base': backsolve > aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) > > tmat <- bdsmatrix(blocksize= c(3,2,2,4), + blocks= c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, + 8,14,9,10,13,11,12)) > dimnames(tmat) <- list(NULL, letters[1:11]) > smat <- as.matrix(tmat) > yy <- c(30,35,42,56,34,45,32,37,78,56,40) > > aeq(diag(tmat), diag(smat)) [1] TRUE > zz <- seq(1,11,2) > aeq(as.matrix(tmat[zz,zz]), smat[zz,zz]) [1] TRUE > > ch0 <- chol(smat) > ch1 <- gchol(smat) > ch2 <- gchol(tmat) > > aeq(diag(ch1), diag(ch2)) [1] TRUE > temp <- as.matrix(ch2) > aeq(temp, as.matrix(ch1)) [1] TRUE > temp3 <- temp %*% diag(sqrt(diag(ch2))) > aeq(temp3, t(ch0)) [1] TRUE > > zz0 <- solve(smat, yy) > zz1 <- solve(ch1, yy) > zz2 <- solve(tmat, yy) > aeq(zz1, zz2) [1] TRUE > aeq(zz0, zz1) [1] TRUE > > proc.time() user system elapsed 0.851 0.038 0.906 bdsmatrix/tests/gtest.R0000644000176200001440000000202713216771367014700 0ustar liggesuserslibrary(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) # Create a matrix that is symmetric, but not positive definite # The first one, temp, has column 6 redundant with cols 1-5 temp <- smat[c(1:5, 5:10), c(1:5, 5:10)] ch1 <- gchol(temp) aeq(diag(ch1)[6], 0) # Check that it has a zero in the proper place ginv <- solve(ch1) # see if I get a generalized inverse aeq(temp %*% ginv %*% temp, temp) aeq(ginv %*% temp %*% ginv, ginv) # Now create one that is negative definite ch2 <- gchol(smat) temp2 <- as.matrix(ch2) temp3 <- diag(ch2) * rep(c(1, -1), length=nrow(smat)) xmat <- temp2 %*% diag(temp3) %*% t(temp2) xmat <- (xmat + t(xmat))/2 #work out round-off errors ch3 <- gchol(xmat) aeq(diag(ch3), temp3) aeq(as.matrix(ch3), temp2) bdsmatrix/tests/chtest.R0000644000176200001440000000205513216771367015045 0ustar liggesusers# # Test out the Cholesky # library(bdsmatrix) aeq <- function(x,y) all.equal(as.vector(x), as.vector(y)) tmat <- bdsmatrix(c(3,2,2,4), c(22,1,2,21,3,20,19,4,18,17,5,16,15,6,7, 8,14,9,10,13,11,12), matrix(c(1,0,1,1,0,0,1,1,0,1,0,10,0, 0,1,1,0,1,1,0,1,1,0,1,0,10), ncol=2)) dimnames(tmat) <- list(NULL, letters[1:13]) smat <- as.matrix(tmat) yy <- c(30,35,42,56,34,45,32,37,78,56,40,52,39) aeq(diag(tmat), diag(smat)) zz <- seq(1,13,2) aeq(as.matrix(tmat[zz,zz]), smat[zz,zz]) ch0 <- chol(smat) ch1 <- gchol(smat) ch2 <- gchol(tmat) # The gchol routines use the composition LDL', where L is lower triangular # with a diagonal of 1's, and D is diagonal. chol() uses U'U where U is # upper trangular. # The as.matrix function returns L and the diag function returns D. # Convert and compare aeq(diag(ch1), diag(ch2)) temp <- as.matrix(ch2) aeq(temp, as.matrix(ch1)) temp3 <- temp %*% diag(sqrt(diag(ch2))) aeq(temp3, t(ch0)) zz0 <- solve(smat, yy) zz1 <- solve(ch1, yy) zz2 <- solve(tmat, yy) aeq(zz1, zz2) aeq(zz0, zz1) bdsmatrix/src/0000755000176200001440000000000014570342174013045 5ustar liggesusersbdsmatrix/src/bdsmatrix_prod4.c0000644000176200001440000000443614246171636016330 0ustar liggesusers/* ** Product of a gchol.bdsmatrix object and a vector ** Variant of bdsmatrix_prod3, for internal calls by C ** instead of from S. The multiplication vector is (b, beta), ** where beta is known to be zero, so only the frailties b ** are passed in. ** ** nrow total number of rows in the bdsmatrix ** nblock number of blocks for the bdsmatrix ** bsize the block sizes "" ** bmat the vector of blocks "" ** rmat right hand matrix "" ** nfrail number of rows that we are using (length of y) ** y the left hand matrix, which will be overwritten ** */ #include "bdsS.h" #include "bdsmatrix.h" double sqrt(double); void bdsmatrix_prod4(int nrow, int nblock, int *bsize, double *bmat, double *rmat, int nfrail, double *y) { int brow, rrow; int i,j, k; int block; int icol, offset; double *x, *rx; double sum, scale; brow =0; /* number of rows in the block diagonal portion */ for (i=0; i0; j--) { offset = icol; /* starting with y[offset] */ scale = sqrt(*x); sum = y[icol] *scale; /* mult by implicit 1 on diag */ x++; offset++; /* First the sparse rows, beyond diag, for this col of L */ for (k=1; k void bdsmatrix_index3(int *nblock, int *bsize, int *index) { int i, j; int blocksize; int nc; /* number returned so far, for the index vector */ int block; /* block currently being processed */ int irow; /* global row counter */ int pos; /* current position in the blocks array */ int lastrow; irow=0; nc=0; pos =0; for (block=0; block < *nblock; block++) { blocksize = bsize[block]; lastrow = irow + blocksize; for (i=0; i0) rmat = dmatrix(REAL(srmat), ncols(srmat), nrows(srmat)); else rmat=NULL; sy = PROTECT(duplicate(sx)); /* this cause row/col names to duplicate */ y = REAL(sy); nr = nrows(sx); nc= ncols(sx); upper = asLogical(supper); flag = 1+upper; /* for chsolve4, 2=lower and 1=upper */ rmat = dmatrix(REAL(srmat), nr, nr); for (i=0; i b isn't done, etc ** The row/col numbers are assumed to be in sorted order ** ** The "1+" on all output is to S-subscripts, starting at 1 */ #include "bdsS.h" #include "bdsmatrix.h" void bdsmatrix_index1(int *nblock, int *bsize, int *flag, int *nrow, int *rows, int *indexa, int *indexb, int *indexc) { int i, j, k; int blocksize; int na, nb, nc; /* current pos in indexa, indexb, or indexc vector */ int block; /* block currently being processed */ int irow; /* global row counter */ int jrow; /* current progress through the "desired" list */ int pos; /* current position in the blocks array */ int lastrow; /* last row of a block */ int newblock; /*final size of current block */ irow=0; jrow=0; nb=0; na=0; nc=0; pos =0; for (block=0; block < *nblock; block++) { blocksize = bsize[block]; lastrow = irow + blocksize -1; newblock =0; for (i=0; i0; j--) { /* Invert D */ if (bd[ii] ==0) continue; else bd[ii] = 1/bd[ii]; /* ** solve Fb =e , using eq 2.2.2 of A. George and A Liu, Computer ** Solution of Large Sparse Positive Definite Systems, ** Prentice-Hall, 1981. ** e = vector of 0's with a 1 at position i ** i2 = column of L currently being "solved against" */ /* backsolve wrt the "1" on the diagonal */ for (k=1; k0; j2--) { temp = bd[yi]; for (k=1; k 0) { matrix[i][i+m] = 1/matrix[i][i+m]; for (k=i+1; k0; j--) { if (bd[ii] ==0) { /* this column of the inverse is all zeros */ for (k=0; k0), but we don't have ** anywhere to store it and so ignore it ** finish with inner product of this block and the dense */ for (j2=0; j2< n2; j2++) { temp = matrix[j2][i]; i2 = j2 + m; for (k=j2+1; k int cholesky4(double **matrix, int n, int nblock, int *bsize, double *bd, double toler) { double temp; int i,j,k, m; double eps, pivot; int rank; int n2; int ii, ji, jj, kj, blocksize; int block; m=0; eps =0; /* Find the max diagonal element of the matrix, for scaling */ ii =0; for (block=0; block0; blocksize--) { if (fabs(bd[ii]) > eps) eps = bd[ii]; ii += blocksize; } } n2=n-m; for (i=0; i eps) eps = fabs(matrix[i][i+m]); if (eps > 0.0) eps *= toler; else eps = toler; /* just in case diagonal ==0 */ /* ** Do the Cholesky for the blocks diagonal portion */ ji=0; rank =0; ii =0; i =0; for (block=0; block0; blocksize--) { jj = ii; pivot = bd[ii]; if (fabs(pivot) < eps) { for (j=0; j= max(bsize) */ #include "bdsS.h" #include "bdsmatrix.h" void bdsmatrix_prod2(int nblock, int *bsize, int nrow, double *bmat, double *rmat, double *y, double *result, int *itemp) { int brow, rrow; int i,j, k; int blocksize, irow, n, block; double x; brow =0; /* number of rows in the block diagonal portion */ for (i=0; ii) itemp[j] += blocksize - (i+1); else itemp[j] += 1; } result[irow] = x; irow++; n += blocksize -i; } } /* Add in the rmat part, if present */ if (rrow >0) { /* First, the pieces on the rhs of the block-diagonal part */ for (irow=0; irowi) itemp[j] += blocksize - (i+1); else itemp[j] += 1; } temp[irow] = x; irow++; n += blocksize -i; } } /* Add in the rmat part, if present */ if (rrow >0) { /* First, the pieces on the rhs of the block-diagonal part */ for (irow=0; irow #include #include "bdsmatrix.h" /* Define routines that can be called from R, or by another package */ static const R_CMethodDef Centries[] = { {"Cbdsmatrix_index1", (DL_FUNC) &bdsmatrix_index1, 8}, {"Cbdsmatrix_index2", (DL_FUNC) &bdsmatrix_index2, 4}, {"Cbdsmatrix_index3", (DL_FUNC) &bdsmatrix_index3, 3}, {"Cbdsmatrix_prod", (DL_FUNC) &bdsmatrix_prod, 9}, {"Cbdsmatrix_prod2", (DL_FUNC) &bdsmatrix_prod2, 8}, {"Cbdsmatrix_prod3", (DL_FUNC) &bdsmatrix_prod3, 9}, {"Cbdsmatrix_prod4", (DL_FUNC) &bdsmatrix_prod4, 7}, {"Ccholesky4", (DL_FUNC) &cholesky4, 6}, {"Ccholesky5", (DL_FUNC) &cholesky5, 3}, {"Cchinv4", (DL_FUNC) &chinv4, 6}, {"chinv5", (DL_FUNC) &chinv5, 3}, {"Cchsolve4", (DL_FUNC) &chsolve4, 7}, {"Cchsolve5", (DL_FUNC) &chsolve5, 4}, {"Cgchol_bds", (DL_FUNC) &gchol_bds, 6}, {"Cgchol", (DL_FUNC) &gchol, 3}, {"Cgchol_bdsinv", (DL_FUNC) &gchol_bdsinv, 7}, {"Cgchol_bdssolve", (DL_FUNC) &gchol_bdssolve, 8}, {"Cgchol_inv", (DL_FUNC) &gchol_inv, 3}, {"Cgchol_solve", (DL_FUNC) &gchol_solve, 4}, {NULL, NULL, 0} }; static const R_CallMethodDef Callentries[] = { {"Cgcback", (DL_FUNC) &gcback, 4}, {"Cgcback2", (DL_FUNC) &gcback2, 5}, {NULL, NULL, 0} }; /* The callable routines can be used by other packages */ void R_init_bdsmatrix(DllInfo *dll) { R_RegisterCCallable("bdsmatrix","bdsmatrix_prod2", (DL_FUNC) &bdsmatrix_prod2); R_RegisterCCallable("bdsmatrix","bdsmatrix_prod4", (DL_FUNC) &bdsmatrix_prod4); R_RegisterCCallable("bdsmatrix","cholesky4", (DL_FUNC) &cholesky4); R_RegisterCCallable("bdsmatrix","cholesky5", (DL_FUNC) &cholesky5); R_RegisterCCallable("bdsmatrix","chinv4", (DL_FUNC) &chinv4); R_RegisterCCallable("bdsmatrix","chinv5", (DL_FUNC) &chinv5); R_RegisterCCallable("bdsmatrix","chsolve4", (DL_FUNC) &chsolve4); R_RegisterCCallable("bdsmatrix","chsolve5", (DL_FUNC) &chsolve5); /* register the interal routines. We have no .Fortran or .External call in the code, hence the NULL, NULL at the end */ R_registerRoutines(dll, Centries, Callentries, NULL, NULL); /* The following line makes only those routines defined above available to outside packages, i.e., internal things like dmatrix() are now invisible. */ R_useDynamicSymbols(dll, FALSE); /* ** This line makes them only available via the symbols above ** i.e., .Call("tmerge", ) won't work but .Call(Ctmerge, ) will ** This feature was added in version 3.0.0 */ #if defined(R_VERSION) && R_VERSION >= R_Version(3, 0, 0) R_forceSymbols(dll, TRUE); #endif } bdsmatrix/src/bdsmatrix.h0000644000176200001440000000453614246171636015226 0ustar liggesusers/* ** This contains the prototype calls for all the .c functions that ** are called by another C function, or by R ** It stops errors due to having things declared differently ** in different routines, and serves as input to R_init_bdsmatrix */ void bdsmatrix_index1(int *nblock, int *bsize, int *flag, int *nrow, int *rows, int *indexa, int *indexb, int *indexc); void bdsmatrix_index2(int *nblock, int *bsize, int *rows, int *cols); void bdsmatrix_index3(int *nblock, int *bsize, int *index); void bdsmatrix_prod(int *nb, int *bsize, int *ydim, double *bmat, double *rmat, double *offdiag, double *temp, int *itemp, double *y); void bdsmatrix_prod2(int nblock, int *bsize, int nrow, double *bmat, double *rmat, double *y, double *result, int *itemp); void bdsmatrix_prod3(int *nr, int *nb, int *bsize, double *bmat, double *rmat, int *rhs, int *ny2, double *y, double *temp); void bdsmatrix_prod4(int nrow, int nblock, int *bsize, double *bmat, double *rmat, int nfrail, double *y); void chinv4(double **matrix, int n, int nblock, int *bsize, double *bd, int flag) ; void chinv5(double **matrix , int n, int flag); int cholesky4(double **matrix, int n, int nblock, int *bsize, double *bd, double toler) ; int cholesky5(double **matrix, int n, double toler); void chsolve4(double **matrix, int n, int nblock, int *bsize, double *bd, double *y, int flag); void chsolve5(double **matrix, int n, double *y, int flag); double **dmatrix(double *array, int ncol, int nrow); void gchol(int *n2, double *matrix, double *toler); void gchol_inv(int *n2, double *matrix, int *flag2); void gchol_solve(int *n2, double *matrix, double *y, int *flag2); void gchol_bds(int *nb, int *bs2, int *n2, double *dmat, double *rmat, double toler[]) ; void gchol_bdsinv(int *nb, int *bs2, int *n2, double *dmat, double *rmat, double *toler, int *flag); void gchol_bdssolve(int *nb, int *bs2, int *n2, double *blocks, double *rmat, double *toler, double *y, int *flag); SEXP gcback(SEXP sr, SEXP sx, SEXP supper, SEXP sk); SEXP gcback2(SEXP sblocksize, SEXP sblocks, SEXP srmat, SEXP sx, SEXP supper); bdsmatrix/src/chsolve5.c0000644000176200001440000000261214246171636014745 0ustar liggesusers/* ** Solve the equation Ab = y, where the cholesky decomposition of A and y ** are the inputs. ** ** Input **matrix, which contains the chol decomp of an n by n ** matrix in its lower triangle. ** y[n] contains the right hand side ** ** y is overwriten with b ** ** This differs from chsolve2 only in the flag. ** We recieved the cholesky A= LDL' where L is lower triangular, this ** is solveed in 3 stages: L' a = y, Db =a, Lc = b. ** If flag=0 we do all three, if 1 we do 1 and sqrt(D)b =a, ** if 2 we do ssqrt(D)b=a and stage 3. ** These latter support the backsolve routine. ** ** Terry Therneau */ #include "bdsS.h" #include "bdsmatrix.h" #include void chsolve5(double **matrix, int n, double *y, int flag) { int i,j; double temp; /* ** solve L'z =y, */ if (flag <2) { for (i=0; i0) { /* ** solve D^{1/2}b =z */ for (i=0; i=0; i--) { temp = y[i]; for (j= i+1; j void chsolve4(double **matrix, int n, int nblock, int *bsize, double *bd, double *y, int flag) { int i,j, k, n2; int ii, block, blocksize; double temp; int m; m =0; for (i=0; i0; j--) { temp = y[i]; for (k=1; k 0) { /* solve sqrt(D) b =z */ i =0; ii=0; for (block=0; block0; j--) { /* ii points to A[i,i] */ if (bd[ii] >0) y[i] /= sqrt(bd[ii]); else y[i] = 0; i++; ii += j; } } /* dense portion */ for (j=0; j0) y[j+i] /= sqrt(temp); else y[i+j] = 0; } } else { /* solve Db =z */ i =0; ii=0; for (block=0; block0; j--) { /* ii points to A[i,i] */ if (bd[ii] >0) y[i] /= bd[ii]; else y[i] = 0; i++; ii += j; } } /* dense portion */ for (j=0; j0) y[j+i] /= temp; else y[i+j] = 0; } } /* solve L'b =z */ if (flag != 1) { /* ** solve DF'b =z, using equation 2.2.1 */ /* dense portion */ for (j=(n2-1); j>=0; j--) { if (matrix[j][j+m]==0) y[j+m] =0; else { temp = y[j+m]; for (k= j+1; k=0; block--) { for (blocksize=1; blocksize <=bsize[block]; blocksize++) { i--; ii -= blocksize; if (bd[ii] ==0) y[i] =0; else { temp = y[i]; for (j=1; j bsum) { mat = dmatrix(rmat, n, n-bsum); } else { mat = (double **) 0; /* in this case cholesky4 will never touch the "mat" argument doing nothing here certainly LOOKS like a bug, however */ } i = cholesky4(mat, n, nblock, bsize, dmat, *toler); *toler = i; /* zero out the upper triangle */ for (i=0; i bsum) { mat = dmatrix(rmat, n, n-bsum); } if (*flag==0 || *flag==2) { i = cholesky4(mat, n, nblock, bsize, dmat, *toler); *toler = i; for (i=0; i=2) chinv4(mat, n, nblock, bsize, dmat, 0); else chinv4(mat, n, nblock, bsize, dmat, 1); } /* ** Solve Ab = y for an input vector y. y is overwritten with b. ** The decompostion is A=LDL' ** flag= 0: input is A (original matrix) ** or 1: input is LD ** plus ** 0: return solution to Ab=y ** or 2: return solution to sqrt(D)L'b =y ** */ void gchol_bdssolve(int *nb, int *bs2, int *n2, double *blocks, double *rmat, double *toler, double *y, int *flag) { int i,j; int *bsize, bsum, n, nblock; double **mat; /* copy over arguments from int to int form */ nblock = *nb; n = *n2; bsize = (int *) ALLOC(nblock, sizeof(int)); bsum =0; for (i=0; i bsum) { mat = dmatrix(rmat, n, n-bsum); } if (*flag==0 || *flag==2) { i = cholesky4(mat, n, nblock, bsize, blocks, *toler); for (i=0; i1) chsolve4(mat, n, nblock, bsize, blocks, y, 1); else chsolve4(mat, n, nblock, bsize, blocks, y, 0); } bdsmatrix/src/cholesky5.c0000644000176200001440000000315414246171636015125 0ustar liggesusers/* ** subroutine to do a generalized Cholesky decompostion on a matrix: C = FDF' ** where F is lower triangular with 1's on the diagonal, and D is diagonal ** If D is all >0, then C was symmetric positive definite, if D >=0, C is ** non-negative definite. ** ** The only difference between this routine and cholesky2 is what it does ** with negative pivots: cholesky2 considers them to be zero. ** ** arguments are: ** n the size of the matrix to be factored ** **matrix a ragged array containing an n by n submatrix to be factored ** toler the threshold value for detecting "singularity" ** ** The factorization is returned in the lower triangle, D occupies the ** diagonal and the upper triangle is left undisturbed. ** ** Return value: the rank of the matrix ** ** If a column is deemed to be redundant, then that diagonal is set to zero. ** ** Terry Therneau */ #include "bdsS.h" #include "bdsmatrix.h" #include int cholesky5(double **matrix, int n, double toler) { double temp; int i,j,k; double eps, pivot; int rank; eps =0; for (i=0; i eps) eps = fabs(matrix[i][i]); } if (eps==0) eps = toler; else eps *= toler; rank =0; for (i=0; i double sqrt(double); void bdsmatrix_prod3(int *nr, int *nb, int *bsize, double *bmat, double *rmat, int *rhs, int *ny2, double *y, double *temp) { int nblock; int nrow, ny ; int brow, rrow; int i,j, k, col, yrow; int itemp; int nk; int icol; int blocksize, offset, irow, n, block; double sum, scale; double *x, *rx; nblock = *nb; nrow = *nr; ny = *ny2; brow =0; /* number of rows in the block diagonal portion */ for (i=0; i0; j--) { offset = yrow + icol*ny; /* starting with y[offset] */ scale = sqrt(*x); sum = y[offset] *scale; /* mult by implicit 1 on diag */ x++; offset += ny; /* First the sparse rows, beyond diag, for this col of L */ for (k=1; k 5) temp <- temp[1:5] stop(paste("Group", paste(temp, collapse=' '), "is in the data but not in a varlist matrix")) } # Extract the subset of varlist that corresponds to the data temp <- !is.na(match(kid, group)) if(!all(temp)) { #some rows need to be tossed varlist <- varlist[temp, temp] } } else stop("Invalid object in a variance list") return(varlist) } # The interesting case -- a list was handed to us # First -- all the bdsmatrices must be in the same order. # Check for legal dimnames on all the matrices, and find out # how many bdsmatrices we have. # Toss away any dimensions of the matrices that I don't need. i <- 0 nbds <- 0 any.matrix <- F # are there any ordinary matrices? for(j in 1:length(varlist)) { kmat <- varlist[[j]] if(ismat(kmat)) { i <- i + 1 kid <- dimnames(kmat)[[1]] if(length(kid) == 0) stop("No dimnames found on a variance matrix") else { indx <- match(group, kid) if(any(is.na(indx))) { temp <- group[is.na(indx)] if(length(temp) > 5) temp <- temp[1:5] stop(paste("Group", paste(temp, collapse=' '), "is in the data but not in a varlist matrix")) } if(length(kid) > length(indx)) { # toss unneeded rows/cols indx <- sort(indx) kmat <- kmat[indx, indx] varlist[[j]] <- kmat } if(inherits(kmat, "bdsmatrix")) { nbds <- nbds + 1 blocks <- kmat@blocksize rcol <- length(kmat@rmat)/nrow(kmat) } else any.matrix <- T if(i == 1 || inherits(kmat, "bdsmatrix")) newgroup <- kid[!is.na(match(kid, group))] } } } # # Now, if there are any ordinary matrices, the job is trivial # Turn them all into a large bdsmatrix. This won't happen very # often, I expect. if(any.matrix) { brow <- .C(Cbdsmatrix_index2, as.integer(1), as.integer(msize), rows = integer((msize * (msize + 1))/2), cols = integer((msize * (msize + 1))/2)) hash1 <- (brow$rows - 1) * msize + brow$cols for(i in 1:length(varlist)) { kmat <- varlist[[i]] if(is.function(kmat)) { # Someone called us with just a bdsI() call-- trivial case kmat <- kmat(group) if(!inherits(kmat, "bdsmatrix")) stop("Invalid function call in a varlist") } kid <- dimnames(kmat)[[1]] indx <- match(kid, group) if(inherits(kmat, "bdsmatrix")) { # Turn it into a bdsmatrix with only 1 block! bb <- kmat@blocksize bsize <- sum((bb * (bb + 1))/2) temp <- .C(Cbdsmatrix_index2, as.integer(length(bb)), as.integer(bb), rows = integer(bsize), cols = integer(bsize)) newrow <- indx[temp$rows] newcol <- indx[temp$cols] hash2 <- (pmax(newrow, newcol) - 1) * msize + pmin(newrow, newcol) if(length(kmat@rmat)) { rdim <- dim(kmat@rmat) first <- rdim[1] - rdim[2] newrow <- indx[row(kmat@rmat)] newcol <- indx[first + col(kmat@rmat)] hash2 <- c(hash2, (pmax(newrow, newcol) -1) * msize + pmin(newrow, newcol)) indx <- match(hash1, hash2, nomatch = 0) temp <- c(0, kmat@blocks, kmat@rmat) kmat <- bdsmatrix(blocksize = msize, blocks = temp[indx + 1], dimnames = list(group, group)) } else { temp <- c(0, kmat@blocks) indx <- match(hash1, hash2, nomatch = 0 ) kmat <- bdsmatrix(blocksize = msize, blocks = temp[indx + 1], dimnames = list(group, group)) } } else kmat <- bdsmatrix(blocksize = msize, blocks = c(kmat[indx, indx]), dimnames = list(group, group)) varlist[[i]] <- kmat } return(varlist) } else group <- newgroup # # So much for the easy cases. There exists at least one bdsmatrix, # and we need to respect it's sparseness. # Now, if there are 0 or 1 bdsmatrices, then group has already # been reordered the way we like it. Otherwise, we need to # do the hard part -- find that bdsmatrix with the biggest blocks, # and verify that all other bdsmatrices can be coerced to fit this # one's shape. # if(nbds > 1) { j <- 0 for(i in 1:length(varlist)) { kmat <- varlist[[i]] if(inherits(kmat, "bdsmatrix")) { if(length(kmat@rmat) > 0) { # I just can't handle 2 bdsmatrices with an rmat # Yes, in theory one could. stop("Can't handle 2 rmats in one list") } j <- j + 1 kid <- dimnames(kmat)[[1]] indx <- match(group, kid) block2 <- (rep(1:length(kmat@blocksize), kmat@blocksize)) block2 <- block2[indx] if(j == 1) { block1 <- block2 save <- kid # this is currently the "ruling" mat blocks <- kmat@blocksize } else { ufun <- function(x) length(unique(x)) if(all(tapply(block2, block1, ufun) == 1)) { #Every block in the prior "winner" is a strict # subset of one block in kmat. Ergo, kmat # is larger; we have a new winner. block1 <- block2 save <- kid blocks <- kmat@blocksize } else if(!all(tapply(block1, block2, ufun) == 1)) { # Neither is a subset of the other, which means # that the id's are the same, but the family # groupings aren't. The user messed up. stop(paste("Two variance matrices have", "incompatable structure")) } } } } group <- save } # # Now "group" is in the right order, and all matrices can be # made to conform to it. Make it so. # The "hash1" index contains the indexing for the blocks of # the master matrix that we are creating. bsize <- sum((blocks * (blocks + 1))/2) brow <- .C(Cbdsmatrix_index2, as.integer(length(blocks)), as.integer(blocks), rows = integer(bsize), cols = integer(bsize)) hash1 <- (brow$rows - 1) * msize + brow$cols for(i in 1:length(varlist)) { kmat <- varlist[[i]] if(is.function(kmat)) { kmat <- kmat(group) #create a matrix if(!inherits(kmat, "bdsmatrix")) stop("varlist has a function that did not create a bdsmatrix") varlist[[i]] <- kmat } # kmat is guarranteed to be a bdsmatrix kid <- dimnames(kmat)[[1]] indx <- match(kid, group) if(any(indx != 1:length(indx)) || (length(kmat@blocksize) != length(blocks)) || any(kmat@blocksize != blocks)) { # I need to reorder it bb <- kmat@blocksize bsize <- sum((bb * (bb + 1))/2) temp <- .C(Cbdsmatrix_index2, as.integer(length(bb)), as.integer(bb), rows = integer(bsize), cols = integer(bsize)) newrow <- indx[temp$rows] newcol <- indx[temp$cols] hash2 <- (pmax(newrow, newcol) - 1) * msize + pmin(newrow, newcol) indx <- match(hash1, hash2, nomatch = 0) if(rcol > 0) { if(length(kmat@rmat) > 0) stop("Impossible branch! Show this message to TMT" ) # The parent we are matching has an rmat, kmat does not # hash3 will be the hash index for rmat first <- (msize - rcol) newrow <- rep(1:msize, rcol) newcol <- rep(first + 1:rcol, rep(msize, rcol)) hash3 <- (pmax(newrow, newcol) - 1) * msize + pmin(newrow, newcol) indx2 <- match(hash3, hash2, nomatch = 0) kmat <- bdsmatrix(blocksize = blocks, blocks = c(0, kmat@blocks)[indx + 1], rmat = matrix(c(0, kmat@blocks)[indx2 + 1], ncol = rcol), dimnames = list(group, group)) } else { kmat@blocksize <- blocks kmat@blocks <- (c(0, kmat@blocks))[1 + indx] kmat@Dimnames <- list(group, group) } varlist[[i]] <- kmat } } varlist } bdsmatrix/R/bdsI.R0000644000176200001440000000146313216771370013467 0ustar liggesusers# Constructor function for a bds identity matrix # The first arg will become the dimnames # bdsI <- function(id, blocksize) { n <- length(id) if (n==1 && is.integer(id) && id >0) { # like diag(), we allow a simple count bdsmatrix(blocksize=rep(1,id), blocks=rep(1., id)) } else { if (missing(blocksize)) { bdsmatrix(blocksize=rep(1,n), blocks=rep(1., n), dimnames=list(id,id)) } else { if (sum(blocksize) != length(id)) stop("Inconsitent arguments") temp <- sum(blocksize*(blocksize+1)/2) x <- bdsmatrix(blocksize=blocksize, blocks=rep(0., temp), dimnames=list(id,id)) diag(x) <- rep(1.0, length(id)) x } } } bdsmatrix/R/solve.gchol.bdsmatrix.R0000644000176200001440000000545713216771370017034 0ustar liggesusers# Backsolve or invert a gchol decompostion of a bds matrix # The "toler" arg to the C routines isn't used for this case, so # a dummy value of 0 has been inserted. (Tolerance only is used in # the initial Cholesky decompostion). # Assume that A is a bdsmatrix. This routine mostly exists so that # solve(gchol(A), x) will give the same solution as solve(A,x). # Occasionally, the full=F argument may be needed as well. # solve.gchol.bdsmatrix<- function(a, b, full=TRUE, ...) { if (!inherits(a, 'gchol.bdsmatrix')) stop("First argument must be the gchol of a bdsmatrix") if (full) flag<-1 else flag <- 3 nblock <- length(a@blocksize) if (length(a@rmat)==0) rmat <- 0.0 #dummy value to keep .C happy else rmat <- as.double(c(a@rmat)) adim <- dim(a) if (missing(b)) { temp <- .C(Cgchol_bdsinv, as.integer(nblock), as.integer(a@blocksize), as.integer(a@Dim), dmat= as.double(a@blocks), rmat= rmat, as.double(0.0), as.integer(flag)) if (length(a@rmat) >0) { if (full) new('bdsmatrix', blocksize=a@blocksize, blocks=temp$dmat, rmat=matrix(temp$rmat, nrow=nrow(a@rmat)), Dim=a@Dim, offdiag=0., Dimnames=a@Dimnames) else new('gchol.bdsmatrix', blocksize=a@blocksize, blocks=temp$dmat, rmat=matrix(temp$rmat, nrow=nrow(a@rmat)), Dim=a@Dim, rank=a@rank, Dimnames=a@Dimnames) } else { if (full) new('bdsmatrix', blocksize=a@blocksize, blocks=temp$dmat, Dim=a@Dim, offdiag=0., Dimnames=a@Dimnames) else new('gchol.bdsmatrix', blocksize=a@blocksize, blocks=temp$dmat, Dim=a@Dim, rank=a@rank, Dimnames=a@Dimnames) } } else { if (length(b) == adim[1]) { .C(Cgchol_bdssolve, as.integer(nblock), as.integer(a@blocksize), as.integer(adim), block = as.double(a@blocks), rmat= rmat, as.double(0.0), beta= as.double(b), as.integer(flag))$beta } else if (!is.matrix(b) || nrow(b) != adim[1]) stop("number or rows of b must equal number of columns of a") else { temp <- b for (i in 1:ncol(temp)) { temp[,i] <- .C(Cgchol_bdssolve, as.integer(nblock), as.integer(a@blocksize), as.integer(adim), block = as.double(a@blocks), rmat= rmat, as.double(0.0), beta= as.double(b[,i]), as.integer(flag))$beta } temp } } } bdsmatrix/R/listbdsmatrix.R0000644000176200001440000000241713216771370015477 0ustar liggesusers# # Export a bds matrix in "list mode". # This has one row for each non-zero element # Input: a bdsmatrix # Output: a data frame containing "row", "col", "value" as variables # # Options: # id: True: row/col contain the subject id (dimnames of the matrix) # False:row/col contain integers # diag: True -- the output contains the diagonal of the matrix # False-- the output does not contain the diagonal # listbdsmatrix <- function(x, id=TRUE, diag=FALSE) { if (!inherits(x, 'bdsmatrix')) stop("Invalid argument") nblock <- length(x@blocksize) bsize <- length(x@blocks) indx <- .C(Cbdsmatrix_index2, as.integer(nblock), as.integer(x@blocksize), rows= integer(bsize), cols= integer(bsize)) # toss any zeros, and optionally the diagonal if (diag) toss <- (x@blocks==0) else toss <- (x@blocks==0 | indx$rows== indx$cols) dd <- dimnames(x)[[1]] if (id && !is.null(dd)) { xr <- dd[indx$rows] xc <- dd[indx$cols] } else { xr <- indx$rows xc <- indx$cols } if (any(toss)) data.frame(row=xr[!toss], col=xc[!toss], value=x@blocks[!toss]) else data.frame(row=xr, col=xc, value=x@blocks) } bdsmatrix/R/multiply.bdsmatrix.R0000644000176200001440000000275413216771370016465 0ustar liggesusers# # Matrix multiplication for symmetric block diagonal (bds) matrices # bdsmult <- function(x, y) { dy <- dim(y) dx <- dim(x) ldy <- length(dy) if (ldy!=2) dy <- c(length(y), 1) # y is a vector if (dx[2] != dy[1]) stop("Number of columns of x should be the same as number of rows of y") # Do the multiplication in C code. Y is replaced by the result # (Since x is a square matrix, the result is the same size as y) nblock <- length(x@blocksize) temp <- .C(Cbdsmatrix_prod, as.integer(nblock), as.integer(x@blocksize), as.integer(dy), as.double(x@blocks), as.double(x@rmat), as.double(x@offdiag), temp = double(dy[1]), itemp= integer(max(1,x@blocksize)), y = as.double(y)) z <- matrix(temp$y, nrow=dx[1]) # Create dimnames for the result, using the dimnames of the input args dnx <- dimnames(x) dny <- dimnames(y) if(!is.null(dnx) || !is.null(dny)) { dnz <- list(NULL, NULL) if(!is.null(dnx)) dnz[1] <- dnx[1] if(!is.null(dny)) dnz[2] <- dny[2] dimnames(z) <- dnz } z } setMethod("%*%", signature(x='bdsmatrix', y='matrix'), bdsmult) setMethod("%*%", signature(x='bdsmatrix', y='numeric'), bdsmult) # # This allows for multiplication in the other direction # setMethod("%*%", signature(x='matrix', y='bdsmatrix'), function(x, y) { t(y%*% t(x)) }) setMethod("%*%", signature(x='numeric', y='bdsmatrix'), function(x, y) { t(y%*% x) }) bdsmatrix/R/backsolve.R0000644000176200001440000000451213216771370014555 0ustar liggesusers# # The backsolve method for my matrices # If B= gchol(A) = LDL' the backsolve(B, x) solves L sqrt(D) y = x # Since B is symmetric the transpose argument is ignored # # The next lines are taken directly from the "Writing R Extensions" # manual. setGeneric("backsolve", function(r, ...) standardGeneric("backsolve"), useAsDefault= function(r, ...) base::backsolve(r, ...)) #backsolve.default <- base:::backsolve #formals(backsolve.default) <- c(formals(backsolve.default), alist(... = )) setMethod("backsolve", "gchol", function(r, x, k = ncol(r), upper.tri=TRUE, ...) { if (any(diag(r) < 0)) stop("Argument has a negative diagonal, cannot backsolve") if (!is.numeric(x)) stop("Invalid data type for x") x <- as.matrix(x) if (k!= floor(k)) stop("k must be an integer") if (k<1 || k > ncol(r)) stop("invalid value for k") if (nrow(x) != k) stop("Number of rows of x needs to match k") if (!is.logical(upper.tri) || is.na(upper.tri)) stop("Invalid value for upper.tri option") storage.mode(x) <- "double" # I don't call with "r" itself, since the documentation on how # to handle S4 classes internally is sparse to non-existent. # Looking at the code of Matrix, I can mimic, but don't trust. # The matrix x is fine though. drop(.Call(Cgcback, r@.Data, x, upper.tri, as.integer(k))) }) setMethod("backsolve", "gchol.bdsmatrix", function(r, x, k=ncol(r), upper.tri=TRUE, ...) { if (any(diag(r) < 0)) stop("Argument has a negative diagonal, cannot backsolve") if (!is.numeric(x)) stop("Invalid data type for x") x <- as.matrix(x) if (k!= floor(k)) stop("k must be an integer") if (k<1 || k > ncol(r)) stop("invalid value for k") #Indexing a partial matrix would use less memory, but it's # too much trouble in the remaining code. if (k < ncol(r)) r <- r[1:k, 1:k] if (nrow(x) != nrow(r)) stop("Number of rows of x needs to match dimension of r") if (!is.logical(upper.tri) || is.na(upper.tri)) stop("Invalid value for upper.tri optoin") storage.mode(x) <- "double" drop(.Call(Cgcback2, r@blocksize, r@blocks, r@rmat, x, upper.tri)) }) bdsmatrix/R/diag.bdsmatrix.R0000644000176200001440000000241514246374773015516 0ustar liggesuserssetMethod('diag', 'bdsmatrix', function(x, nrow, ncol) { if (!inherits(x, 'bdsmatrix')) stop('argument must be a bdsmatrix object') d <- x@Dim d3 <- sum(x@blocksize) temp <- .C(Cbdsmatrix_index1, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(c(0,1,0)), as.integer(d3), as.integer(1:d3 -1), integer(1), indexb = integer(d3), integer(1))$indexb if (length(x@rmat) > 0) { temp2 <- seq(from=d3+1, by= d[2]+1, length= d[1] - d3) c(x@blocks[temp], x@rmat[temp2]) } else x@blocks[temp] }) setMethod("diag<-","bdsmatrix" ,function(x, value) { if (!inherits(x, 'bdsmatrix')) stop('argument must be a bdsmatrix object') d <- x@Dim if (length(value) != d[1]) stop("Wrong length for diagonal") d3 <- sum(x@blocksize) temp <- .C(Cbdsmatrix_index1, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(c(0,1,0)), as.integer(d3), as.integer(1:d3 -1), integer(1), indexb = integer(d3), integer(1))$indexb x@blocks[temp] <- value[1:d3] if (length(x@rmat) > 0) { temp2 <- seq(from=d3+1, by= d[2]+1, length= d[1] - d3) x@rmat[temp2] <- value[-(1:d3)] } x }) bdsmatrix/R/bdsmatrix.R0000644000176200001440000003032614246374773014615 0ustar liggesusers# $Id: bdsmatrix.s,v 1.5 2006/04/04 21:08:15 lunde Exp $ setClass('bdsmatrix', representation(blocksize = 'integer', blocks = 'numeric', rmat = 'matrix', offdiag = 'numeric', Dim='integer', Dimnames='list')) setMethod('Math', 'bdsmatrix', function(x) { x@offdiag <- callGeneric(x@offdiag) x@blocks <- callGeneric(x@blocks) x@rmat <- callGeneric(x@rmat) x }) setMethod('Math2', 'bdsmatrix', function(x, digits) { x@offdiag <- callGeneric(x@offdiag, digits) x@blocks <- callGeneric(x@blocks, digits) x@rmat <- callGeneric(x@rmat, digits) x }) # For the summary method, we need to count the number of zeros (the off # diagonal elements of the block portion) that are not stored, and put them # into the computation. This is trivial for min, max, and etc, but for # means and products we have written them out as weighted computations. # (The number of off-diagonal elements can be in the billions, rep() would # not be wise). # Per a note from Bill Dunlap, max(c(x1,x2,x3)) is faster than max(x1, x2, x3), # when x1, x2, etc are all numeric. (Up to 50 times faster!) # setMethod('max', 'bdsmatrix', function(x, na.rm=FALSE) { if (length(x@rmat)) max(c(x@offdiag, x@blocks, x@rmat), na.rm=na.rm) else max(c(x@offdiag, x@blocks), na.rm=na.rm) }) setMethod('min', 'bdsmatrix', function(x, na.rm=FALSE) { if (length(x@rmat)) min(c(x@offdiag, x@blocks, x@rmat), na.rm=na.rm) else min(c(x@offdiag, x@blocks), na.rm=na.rm) }) setMethod('range', 'bdsmatrix', function(x, ..., na.rm=FALSE) { if (length(x@rmat)) range(c(x@offdiag, x@blocks, x@rmat), na.rm=na.rm) else range(c(x@offdiag, x@blocks), na.rm=na.rm) }) setMethod('any', 'bdsmatrix', function(x, ..., na.rm=FALSE) { if (length(x@rmat)) any(c(x@offdiag, x@blocks, x@rmat), na.rm=na.rm) else any(c(x@offdiag, x@blocks), na.rm=na.rm) }) setMethod('all', 'bdsmatrix', function(x, ..., na.rm=FALSE) { if (length(x@rmat)) all(c(x@offdiag, x@blocks, x@rmat), na.rm=na.rm) else all(c(x@offdiag, x@blocks), na.rm=na.rm) }) setMethod('sum', 'bdsmatrix', function(x, ..., na.rm=FALSE) { d <- x@Dim d3 <- sum(x@blocksize) temp <- .C(Cbdsmatrix_index1, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(c(0,1,0)), as.integer(d3), as.integer(1:d3 -1), integer(1), indexb = integer(d3), integer(1))$indexb #index of diagonal elements n2 <- length(x@blocks) nz <- d3^2 - sum(x@blocksize^2) #number of "offdiag" elements wts <- rep(2, n2) wts[temp] <- 1 # the diagonal elements tsum <- sum(c(nz *x@offdiag, wts*x@blocks), na.rm=na.rm) if (length(x@rmat)) { wt2 <- rep(2, length(x@rmat)) wt2[row(x@rmat) > d3] <- 1 tsum <- tsum + sum(wt2*x@rmat, na.rm=na.rm) } tsum }) setMethod('prod', 'bdsmatrix', function(x, ..., na.rm=FALSE) { d <- x@Dim d3 <- sum(x@blocksize) temp <- .C(Cbdsmatrix_index1, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(c(0,1,0)), as.integer(d3), as.integer(1:d3 -1), integer(1), indexb = integer(d3), integer(1))$indexb #index of diagonal elements n2 <- length(x@blocks) nz <- d3^2 - sum(x@blocksize^2) #number of "offdiag" tprod <- 1 if (nz>0) { if (x@offdiag==0) return(x@offdiag) if (!is.na(x@offdiag) || na.rm==FALSE) tprod<- x@offdiag^nz } wts <- rep(2, n2) wts[temp] <- 1 # the diagonal elements tprod <- tprod * prod(x@blocks^wts, na.rm=na.rm) if (length(x@rmat)) { wt2 <- rep(2, length(x@rmat)) wt2[row(x@rmat) > d3] <- 1 tprod <- tprod * prod(x@rmat^wt2, na.rm=na.rm) } tprod }) # # For arithmetic operations, adding a single number preserves the structure # of the matrix, but adding a vector creates a matrix result which is # not block-diagonal. Ditto for *, -, etc # setMethod('Ops', signature(e1='bdsmatrix', e2='numeric'), function(e1, e2) { if (length(e2)==1) { e1@offdiag <- callGeneric(e1@offdiag, e2) e1@blocks <- callGeneric(e1@blocks, e2) if (length(e1@rmat)) e1@rmat <- callGeneric(e1@rmat, e2) e1 } else { bdsize <- .Options$bdsmatrixsize if (is.null(bdsize)) bdsize <- 1000 if (prod(e1@Dim) > bdsize) stop("Automatic conversion would too large a matrix") else callGeneric(as(e1, 'matrix'), e2) } } ) setMethod('Ops', signature(e1='numeric', e2='bdsmatrix'), function(e1, e2) { if (length(e1)==1) { e2@offdiag <- callGeneric(e1, e2@offdiag) e2@blocks <- callGeneric(e1, e2@blocks) if (length(e2@rmat)) e2@rmat <- callGeneric(e1, e2@rmat) e2 } else { bdsize <- .Options$bdsmatrixsize if (is.null(bdsize)) bdsize <- 1000 if (prod(e2@Dim) > bdsize) stop("Automatic conversion would create too large a matrix") else callGeneric(e1, as(e2, 'matrix')) } } ) setMethod('Ops', signature(e1='bdsmatrix', e2='bdsmatrix'), function(e1, e2) { if (all(e1@Dim == e2@Dim) && (length(e1@blocksize) == length(e2@blocksize)) && all(e1@blocksize== e2@blocksize)) { e1@offdiag <- callGeneric(e1@offdiag, e2@offdiag) e1@blocks <- callGeneric(e1@blocks, e2@blocks) if (length(e1@rmat)) e1@rmat <- callGeneric(e1@rmat, e2@rmat) e1 } else { bdsize <- .Options$bdsmatrixsize if (is.null(bdsize)) bdsize <- 1000 if (prod(e1@Dim) > bdsize || prod(e2@Dim) > bdsize) stop("Automatic conversion would create too large a matrix") else callGeneric(as(e1, 'matrix'), as(e2, 'matrix')) } }) setMethod('Ops', signature(e1='matrix', e2='bdsmatrix'), function(e1, e2) { bdsize <- .Options$bdsmatrixsize if (is.null(bdsize)) bdsize <- 1000 if (prod(e2@Dim) > bdsize) stop("Automatic conversion would create too large a matrix") else callGeneric(e1, as(e2, 'matrix')) }) setMethod('Ops', signature(e1='bdsmatrix', e2='matrix'), function(e1, e2) { bdsize <- .Options$bdsmatrixsize if (is.null(bdsize)) bdsize <- 1000 if (prod(e1@Dim) > bdsize) stop("Automatic conversion would create too large a matrix") else callGeneric(as(e1, 'matrix'), e2) }) #setMethod('unique', 'bdsmatrix', # function(x, incomparables=FALSE, ...) # unique(c(x@offdiag, x@blocks, x@rmat), incomparables)) unique.bdsmatrix <- function(x, incomparables=FALSE, ...) unique(c(x@offdiag, x@blocks, x@rmat), incomparables) bdsmatrix <- function(blocksize, blocks, rmat, dimnames=NULL) { nblock <- length(blocksize) if (any(blocksize <=0)) stop("Block sizes must be >0") if (any(as.integer(blocksize) != blocksize)) stop("Block sizes must be integers") n1 <- as.integer(sum(blocksize)) n2 <- as.integer(sum(blocksize^2)) n3 <- as.integer(sum(blocksize * (blocksize+1))/2) if (length(blocks) == n2) { # Assume that they gave the full blocks, we only want the bottom # half temp <- .C(Cbdsmatrix_index3, as.integer(nblock), as.integer(blocksize), index=integer(n3))$index blocks <- blocks[temp] } else if (length(blocks) != n3) stop("Length mismatch between blocks and blocksize") if (missing(rmat) || length(rmat)==0) { rmat <- matrix(0,0,0) n2 <- n1 } else { rmat <- as.matrix(rmat) n2 <- n1 + ncol(rmat) if (nrow(rmat) != n2) stop("Incompatable dimension for rmat") } if (!missing(dimnames) && !is.null(dimnames)) { if (is.list(dimnames) && length(dimnames)==2) { if (length(dimnames[[1]])==0) val1 <- NULL else { val1 <- dimnames[[1]] if (length(val1) != n2) stop("Invalid length for row dimnames") } if (length(dimnames[[2]])==0) val2 <- NULL else { val2 <- dimnames[[2]] if (length(val2) != n2) stop("Invalid length for column dimnames") } dimnames <- list(val1, val2) } else stop("dimnames must be a list of length 2") } else dimnames=list(NULL, NULL) new('bdsmatrix', Dim=c(n2,n2), blocksize=as.integer(blocksize), blocks=blocks, rmat=rmat, offdiag=0, Dimnames=dimnames) } setMethod('[', 'bdsmatrix', function(x, i, j, ..., drop=TRUE) { if (!inherits(x, 'bdsmatrix')) stop('argument must be a bdsmatrix object') if (missing(i) || missing(j)) stop("Two subscripts are required") nblock <- length(x@blocksize) d <- x@Dim d3 <- sum(x@blocksize) d4 <- length(x@blocks) if (any(i > d[1])) stop(paste("Array subscript (", max(i), ") out of bounds, should be at most ", d[1], sep='')) if (any(j > d[2])) stop(paste("Array subscript (", max(j), ") out of bounds, should be at most ", d[2], sep='')) rows <- (1:d[1])[i] cols <- (1:d[2])[j] brows <- rows[rows <= d3] #the block-diagonal portion bcols <- cols[cols <= d3] brlen <- length(brows) bclen <- length(bcols) if (brlen>1 && (length(rows)==length(cols)) && all(rows==cols) && all(diff(rows)>0)) { # The result will be block-diagonal symmetric # Note: we don't allow for reordering the row/col indices: too hard # to keep track of what's happening temp <- .C(Cbdsmatrix_index1, as.integer(nblock), bsize = as.integer(x@blocksize), as.integer(c(0,0,1)), as.integer(brlen), as.integer(brows -1), integer(1), integer(1), indexc = integer(d4)) x@blocksize <- temp$bsize[temp$bsize>0] x@blocks <- x@blocks[temp$indexc] if (length(x@rmat)) { if (any(cols>d3)) x@rmat <- x@rmat[rows, cols[cols>d3]-d3, drop=FALSE] else x@rmat <- matrix(0,0,0) } temp <- x@Dimnames if (!is.null(temp[[1]])) temp[[1]] <- temp[[1]][rows] if (!is.null(temp[[2]])) temp[[2]] <- temp[[2]][cols] x@Dimnames <- temp x@Dim <- rep(length(rows),2) x } else { # Now if brows==bcols, I would still have a bdmatrix object (the # only asymmetry was in columns/rows of rmat), # but the case is rare enough that I'm ignoring it. Otherwise... # The result will not be block diagonal! if (brlen>0 && bclen>0) { bdsize <- .Options$bdsmatrixsize if (is.null(bdsize)) bdsize <- 1000 if (length(rows)*length(cols) > bdsize ) stop("Automatic conversion would create too large a matrix") # I need to subscript the block diagonal portion # index2 is the rows() and cols() function for the block portion temp <- .C(Cbdsmatrix_index2, as.integer(nblock), as.integer(x@blocksize), rows= integer(length(x@blocks)), cols= integer(length(x@blocks))) newmat <- matrix(x@offdiag, brlen, bclen) rindex <- match(temp$rows, brows, nomatch=0) cindex <- match(temp$cols, bcols, nomatch=0) keep <- (rindex>0 & cindex >0) #the row/col is one we want to keep if (any(keep)) newmat[cbind(rindex[keep], cindex[keep])] <- x@blocks[keep] # the above has snatched and inserted all of the below the # diagonal parts. For above diagonal, realize that I can just # swap the temp$rows, temp$cols for the 'upper trianglar' # stored version of blocks rindex <- match(temp$cols, brows, nomatch=0) cindex <- match(temp$rows, bcols, nomatch=0) keep <- (rindex>0 & cindex >0) #the row/col is one we want to keep if (any(keep)) newmat[cbind(rindex[keep], cindex[keep])] <- x@blocks[keep] if (length(x@rmat)) { if (any(rows > d3)) { newmat <- rbind(newmat, t(x@rmat[bcols, rows[rows>d3]-d3])) } if (any(cols > d3)) { newmat <- cbind(newmat, x@rmat[rows, cols[cols>d3]-d3]) } } } else newmat <-x@rmat[rows, cols[cols>d3]-d3, drop=FALSE] temp <- x@Dimnames if (!is.null(temp[[1]])) temp[[1]] <- temp[[1]][rows] if (!is.null(temp[[2]])) temp[[2]] <- temp[[2]][cols] if (length(temp[[1]]) >0 || length(temp[[2]])>0) dimnames(newmat) <- temp newmat[,,drop=drop] } }) bdsmatrix/R/gchol.bdsmatrix.R0000644000176200001440000002475014570340127015676 0ustar liggesusers# # Cholesky decompostition for block-diagonal square matrices # setClass('gchol.bdsmatrix', representation(blocksize = 'integer', blocks = 'numeric', rmat = 'matrix', rank = 'integer', Dim = 'integer', Dimnames = 'list')) setMethod('gchol', 'bdsmatrix', function(x, tolerance=1e-9) { if (!inherits(x, 'bdsmatrix')) stop('argument must be a bdsmatrix object') if (x@offdiag !=0) return(gchol(as.matrix(x))) dd <- x@Dim if (length(x@rmat) >0) { nc <- ncol(x@rmat) temp <- .C(Cgchol_bds, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(dd), dmat= as.double(x@blocks), rmat= as.double(x@rmat), flag= as.double(tolerance)) newr <- matrix(temp$rmat, ncol=nc) if (nc>1) { # The C-routine doesn't zero out t(r) above the diagonal # (the lower right corner) d3 <- sum(x@blocksize) for (i in 1:(nc-1)) newr[(1+d3+i):dd[1],i] <- 0 } new('gchol.bdsmatrix', blocksize=x@blocksize, blocks=temp$dmat, rmat=newr, Dim=x@Dim, rank= as.integer(temp$flag), Dimnames=x@Dimnames) } else { temp <- .C(Cgchol_bds, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(dd), blocks =as.double(x@blocks), as.double(0), flag= as.double(tolerance)) new('gchol.bdsmatrix', blocksize=x@blocksize, blocks=temp$blocks, rmat=matrix(0,0,0), Dim=x@Dim, rank=as.integer(temp$flag), Dimnames=x@Dimnames) } }) # # return L, from the LDL' decompostion # as.matrix.gchol.bdsmatrix <- function(x, ones=TRUE, ...){ dd <- x@Dim n <- dd[1] newmat <- matrix(0., n, n, dimnames=x@Dimnames) temp <- .C(Cbdsmatrix_index2, as.integer(length(x@blocksize)), as.integer(x@blocksize), rows= integer(length(x@blocks)), cols= integer(length(x@blocks))) rindex <- match(temp$rows, 1:n, nomatch=0) cindex <- match(temp$cols, 1:n, nomatch=0) newmat[cbind(rindex, cindex)] <- x@blocks if (length(x@rmat)){ d3 <- sum(x@blocksize) newmat[(d3+1):n, ]<- t(x@rmat) } if (ones) diag(newmat) <- 1 newmat } setAs('gchol.bdsmatrix', 'matrix', function (from) as.matrix.gchol.bdsmatrix(from)) setMethod('diag', signature=('gchol.bdsmatrix'), function(x, nrow, ncol) { d <- x@Dim d3 <- sum(x@blocksize) temp <- .C(Cbdsmatrix_index1, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(c(0,1,0)), as.integer(d3), as.integer(1:d3 -1), integer(1), indexb = integer(d3), integer(1))$indexb if (length(x@rmat) > 0) { temp2 <- seq(from=d3+1, by= d[2]+1, length= d[1] - d3) c(x@blocks[temp], x@rmat[temp2]) } else x@blocks[temp] }) setMethod('dim', 'gchol.bdsmatrix', function(x) x@Dim) setMethod('show', 'gchol.bdsmatrix', function(object) show(as.matrix(object, F))) # The subscript method is almost identical to that for bdsmatix, # the main difference being that the bdsmatrix method fills in symmetry # when the result is not sparse setMethod('[', 'gchol.bdsmatrix', function(x, i,j, drop=TRUE) { if (!inherits(x, 'gchol.bdsmatrix')) stop("Must be a gchol.bdsmatrix object") if (missing(i) || missing(j)) stop("Two subscripts are required") nblock <- length(x@blocksize) d <- x@Dim d3 <- sum(x@blocksize) d4 <- length(x@blocks) if (any(i > d[1])) stop(paste("Array subscript (", max(i), ") out of bounds, should be at most ", d[1], sep='')) if (any(j > d[2])) stop(paste("Array subscript (", max(j), ") out of bounds, should be at most ", d[2], sep='')) rows <- (1:d[1])[i] cols <- (1:d[2])[j] # The only case where the result is still a Cholesky is if you grab the # first k rows/cols if (length(rows)==length(cols) && all(rows==cols) && all(rows== 1:(length(rows)))) { brows <- rows[rows <= d3] #the block-diagonal portion brlen <- length(brows) # The result will be block-diagonal symmetric # Note: we don't allow for reordering the row/col indices: too hard # to keep track of what's happening temp <- .C(Cbdsmatrix_index1, as.integer(nblock), bsize = as.integer(x@blocksize), as.integer(c(0,0,1)), as.integer(brlen), as.integer(brows -1), integer(1), integer(1), indexc = integer(d4)) x@blocksize <- temp$bsize[temp$bsize>0] x@blocks <- x@blocks[temp$indexc] if (length(x@rmat)) { if (any(cols>d3)) x@rmat <- x@rmat[rows, cols[cols>d3]-d3, drop=FALSE] else x@rmat <- matrix(0,0,0) } temp <- x@Dimnames if (!is.null(temp[[1]])) temp[[1]] <- temp[[1]][rows] if (!is.null(temp[[2]])) temp[[2]] <- temp[[2]][cols] x@Dimnames <- temp x@Dim <- rep(length(rows),2) dd <- diag(x) x@rank <- sum(dd!=0) x } else { # The result is not a gchol.bdsmatrix object brows <- rows[rows <= d3] #the block-diagonal portion brlen <- length(brows) bcols <- cols[cols <= d3] bclen <- length(bcols) if (brlen>0 && bclen>0) { bdsize <- .Options$bdsmatrixsize if (is.null(bdsize)) bdsize <- 1000 if (prod(x@Dim) > bdsize ) stop("Automatic conversion would create too large a matrix") # I need to subscript the block diagonal portion # index2 is the rows() and cols() function for the block portion temp <- .C(Cbdsmatrix_index2, as.integer(nblock), as.integer(x@blocksize), rows= integer(length(x@blocks)), cols= integer(length(x@blocks))) newmat <- matrix(x@offdiag, brlen, bclen) rindex <- match(temp$rows, brows, nomatch=0) cindex <- match(temp$cols, bcols, nomatch=0) keep <- (rindex>0 & cindex >0) #the row/col is one we want to keep if (any(keep)) newmat[cbind(rindex[keep], cindex[keep])] <- x@blocks[keep] if (length(x@rmat)) { if (any(rows > d3)) { newmat <- rbind(newmat, t(x@rmat[bcols, rows[rows>d3]-d3])) } if (any(cols > d3)) { newmat <- cbind(newmat, x@rmat[rows, cols[cols>d3]-d3]) } } } else newmat <-x@rmat[rows, cols[cols>d3]-d3, drop=F] temp <- x@Dimnames if (!is.null(temp[[1]])) temp[[1]] <- temp[[1]][rows] if (!is.null(temp[[2]])) temp[[2]] <- temp[[2]][cols] x@Dimnames <- temp newmat[,,drop=drop] } }) # Multiplication methods. # If the gchol can be written as Cholesky decompostion, i.e., if # all of the diagonal elements are >=0, then return the product # of the cholesky with the vector or matrix. Otherwise squawk. # setMethod("%*%", signature(x='gchol.bdsmatrix', y='matrix'), function(x, y) { if (inherits(y, 'bdsmatrix')) stop("Product of two bdsmatrices is not supported") if (!is.numeric(y)) stop("Matrix multiplication is defined only for numeric objects") dy <- dim(y) dx <- dim(x) ldy <- length(dy) if (ldy!=2) dy <- c(length(y), 1) if (dx[2] != dy[1]) stop("Number of columns of x should be the same as number of rows of y") if (any(diag(x) < 0)) stop("gchol matrix does not have a Cholesky representation: no matrix product is possible") # Do the multiplication in C code. Y is replaced by the result # (Since x is a square matrix, the result is the same size as y) nblock <- length(x@blocksize) temp <- .C(Cbdsmatrix_prod3, as.integer(dx[1]), as.integer(nblock), as.integer(x@blocksize), as.double(x@blocks), as.double(x@rmat), as.integer(1), as.integer(dy[2]), y = as.double(y), temp = double(dx[1])) answer = matrix(temp$y, nrow=dx[1]) d1 <- dimnames(x)[[1]] d2 <- dimnames(y)[[2]] if (!is.null(d1) || !is.null(d2)) dimnames(answer) <- list(d1, d2) answer }) setMethod("%*%", signature(x='matrix', y='gchol.bdsmatrix'), function(x, y) { if (inherits(x, 'bdsmatrix')) stop("Product of two bdsmatrices is not supported") if (!is.numeric(x)) stop("Matrix multiplication is defined only for numeric objects") dy <- dim(y) dx <- dim(x) if (length(dx) != 2) stop("Matrix must have 2 dimensions") if (dx[2] != dy[1]) stop("Number of columns of x should be the same as number of rows of y") if (any(diag(y) < 0)) stop("gchol matrix does not have a Cholesky representation: no matrix product is possible") # Do the multiplication in C code. x is replaced by the result # (Since y is a square matrix, the result is the same size as x) nblock <- length(y@blocksize) temp <- .C(Cbdsmatrix_prod3, as.integer(dy[1]), as.integer(nblock), as.integer(y@blocksize), as.double(y@blocks), as.double(y@rmat), as.integer(0), as.integer(dx[1]), result = as.double(x), temp = double(1)) answer = matrix(temp$result, nrow=dx[1]) d1 <- dimnames(x)[[1]] d2 <- dimnames(y)[[2]] if (!is.null(d1) || !is.null(d2)) dimnames(answer) <- list(d1, d2) answer }) setMethod("%*%", signature(x='numeric', y='gchol.bdsmatrix'), function(x, y) { matrix(x, nrow=1) %*% y }) setMethod("%*%", signature(x='gchol.bdsmatrix', y='numeric'), function(x, y) x %*% matrix(y, ncol=1) ) bdsmatrix/R/as.matrix.bdsmatrix.R0000644000176200001440000000373614246374773016527 0ustar liggesusersas.matrix.bdsmatrix <- function(x, ...) { if (!inherits(x, 'bdsmatrix')) stop('argument must be a bdsmatrix object') if (length(x@blocksize)==0) return(x@rmat) dd <- dim(x) d3 <- sum(x@blocksize) # dim of square portion d4 <- sum(x@blocksize^2) # size of x@blocks newmat <- matrix(0., dd[1], dd[2], dimnames=x@Dimnames) temp <- .C(Cbdsmatrix_index1, as.integer(length(x@blocksize)), as.integer(x@blocksize), as.integer(c(1,0,0)), as.integer(d3), as.integer(1:d3 -1), indexa = integer(d3*d3), indexb = 0, indexc = 0)$indexa newmat[1:d3, 1:d3] <- c(x@offdiag, x@blocks)[1+temp] if (length(x@rmat)>0) { newmat[, -(1:d3)] <- x@rmat newmat[-(1:d3),] <- t(x@rmat) } newmat } setAs('bdsmatrix', 'matrix', function(from)as.matrix.bdsmatrix(from)) setMethod('dim', 'bdsmatrix', function(x) x@Dim) setMethod('dimnames', 'bdsmatrix', function(x) x@Dimnames) setMethod('dimnames<-', 'bdsmatrix', function(x, value) { dd <- x@Dim if (is.null(value)) x@Dimnames <- NULL else { if (is.list(value) && length(value)==2) { if (length(value[[1]])==0) val1 <- NULL else { val1 <- value[[1]] if (length(val1) != dd[1]) stop("Invalid length for row dimnames") } if (length(value[[2]])==0) val2 <- NULL else { val2 <- value[[2]] if (length(val2) != dd[2]) stop("Invalid length for column dimnames") } x@Dimnames <- list(val1, val2) } else stop("dimnames must be a list of length 2") } x }) print.bdsmatrix<- function(x, ...) print(as(x, 'matrix'), ...) setMethod('show', 'bdsmatrix', function(object) show(as(object, 'matrix'))) setAs('bdsmatrix', 'vector', function(from) as.vector(as.matrix.bdsmatrix(from))) # this was commented out later: we don't want to inadvertently # create gigantic regular matrices #setIs('bdsmatrix', 'matrix', # coerce=function(object)as.matrix.bdsmatrix(object)) bdsmatrix/R/solve.gchol.R0000644000176200001440000000201413216771370015022 0ustar liggesusers# solve a generalized Cholesky matrix solve.gchol <- function(a, b, full=TRUE, ...) { if (full) flag<-0 else flag<-1 d <- a@Dim if (missing(b)) { # Return the inverse of the original matrix, for which a is the chol temp <- .C(Cgchol_inv, as.integer(d), x=as.double(a@.Data), as.integer(flag))$x matrix(temp, d[1]) } else { # solve for right-hand side if (length(b) == d[1]) { temp <- .C(Cgchol_solve, as.integer(d), as.double(a@.Data), y=as.double(b), as.integer(flag))$y temp } else { if (!is.matrix(b) || nrow(b) != d[1]) stop("number or rows of b must equal number of columns of a") new <- b for (i in 1:ncol(b)) { new[,i] <- .C(Cgchol_solve, as.integer(d), as.double(a@.Data), y=as.double(b[,i]), as.integer(flag))$y } new } } } bdsmatrix/R/bdsBlock.R0000644000176200001440000000100113216771370014315 0ustar liggesusers# A constructor function for a bdsmatrix with blocks of ones # It is used for nested effects # group: the grouping variable # id : the eventual dimnames # bdsBlock <- function(id, group) { if (any(is.na(group))) stop ("Missing group indicator not allowed") blocksize <- as.vector(table(group)) id <- id[order(group)] # resort the data in group order temp <- sum(blocksize * (blocksize+1)/2) bdsmatrix(blocksize=blocksize, blocks=rep(1.0, temp), dimnames=list(id, id)) } bdsmatrix/R/gchol.R0000644000176200001440000000740213216771370013701 0ustar liggesusers# # Code for the generalized cholesky A = LDL', where L is lower triangular # with 1's on the diagonal, and D is diagonal. # The decompostions exists for any square symmetric matrix. # If A is positive definite, then all elements of D will be positve. # If A is not full rank, then 0's on the diagonal of D signal the redundant # columns. # Note that gchol is both a class (setClass) and a generic function. # setClass('gchol', representation(.Data= 'numeric', Dim = 'integer', Dimnames = 'list', rank = 'integer')) setGeneric('gchol', function(x, tolerance=1e-10) standardGeneric('gchol'), useAsDefault=FALSE) as.matrix.gchol <- function(x, ones=TRUE, ...) { temp <- matrix(x@.Data, x@Dim[1], dimnames=x@Dimnames, byrow=TRUE) if (ones) diag(temp) <- 1 temp } setAs('gchol', 'matrix', function(from) as.matrix.gchol(from)) setMethod('gchol', signature(x='matrix'), function(x, tolerance) { d <- dim(x) if (d[1] != d[2]) stop("Cholesky decomposition requires a square matrix") # if (!is.logical(all.equal(as.vector(x), as.vector(t(x))))) # stop("Cholesky decomposition requires a symmetric matrix") temp <- .C(Cgchol, as.integer(d[1]), x = as.double(x), rank= as.double(tolerance)) dnames <- dimnames(x) if (is.null(dnames)) dnames <- list(NULL, NULL) new('gchol', .Data= temp$x , Dim=d, Dimnames= dnames, rank=as.integer(temp$rank)) }) setMethod('diag', signature(x='gchol'), function(x, nrow, ncol) { d <- x@Dim[1] x@.Data[ seq(1, length=d, by=d+1)] }) setMethod('show', 'gchol', function(object) show(as.matrix(object, F))) setMethod('dim', 'gchol', function(x) x@Dim) setMethod('dimnames', 'gchol', function(x) x@Dimnames) # Multiplication methods. # If the gchol can be written as Cholesky decompostion, i.e., if # all of the diagonal elements are >=0, then return the product # of the cholesky with the vector or matrix. Otherwise squawk. # setMethod("%*%", signature(x='gchol', y='matrix'), function(x, y) { if (!is.numeric(y)) stop("Matrix multiplication is defined only for numeric objects") dy <- dim(y) dx <- dim(x) ldy <- length(dy) if (ldy!=2) dy <- c(length(y), 1) if (dx[2] != dy[1]) stop("Number of columns of x should be the same as number of rows of y") if (any(diag(x) < 0)) stop("gchol matrix does not have a Cholesky repres entation: no matrix product is possible") as.matrix(x) %*% (sqrt(diag(x)) * y) }) setMethod("%*%", signature(x='matrix', y='gchol'), function(x, y) { if (!is.numeric(x)) stop("Matrix multiplication is defined only for numeric objects") dy <- dim(y) dx <- dim(x) ldx <- length(dx) if (ldx!=2) dx <- c(length(x), 1) if (dx[2] != dy[1]) stop("Number of columns of x should be the same as number of rows of y") if (any(diag(y) < 0)) stop("gchol matrix does not have a Cholesky repres entation: no matrix product is possible") (y %*% as.matrix(x)) * rep(sqrt(diag(y)), each=ncol(y)) }) setMethod('[', "gchol", function(x, i,j, drop=TRUE) { if (missing(i) && missing(j)) return(x) temp <- matrix(x@.Data, nrow=x@Dim[1], dimnames=x@Dimnames) if (missing(i)) temp[,j,drop=drop] else { if (missing(j)) temp[i,,drop=drop] else { temp <- temp[i,j,drop=drop] if (length(i)==length(j) && length(i)>1 && all(i==j)) { # in this case only, the result is a gchol object new("gchol", .Data= as.vector(temp), Dim=dim(temp), Dimnames=dimnames(temp), rank=sum(diag(temp) !=0)) } else temp } } }) bdsmatrix/R/bdsmatrix.ibd.R0000644000176200001440000001302213216771370015332 0ustar liggesusers# Read in an ibd file, and convert it to a bdsmatrix object # # The real work is essentially the same as makefamid -- we need to # figure out who makes up a family block # # Each row of the data is a pair of id's, followed by the ibd value. # The optional idlist is an alternate dimnames bdsmatrix.ibd <- function(id1, id2, x, idmap, diagonal) { nc <- ncol(id1) if (length(nc) && nc==3) { id2 <- id1[,2] x <- id1[,3] id1 <- id1[,1] } # The line below was later dropped -- someone might be # making an entirely differnt type of matrix # if (any(x <0 | x >1)) stop ("Invalid X values") keep <- (x != 0) if (!all(keep)) { id1 <- id1[keep] id2 <- id2[keep] x <- x[keep] } # assign small integers to each idlist <- sort(unique(c(id1, id2))) if (missing(idmap)) { idmap <- idlist } else { temp <- ncol(idmap) if (is.null(temp) || temp !=2) stop("idmap must have 2 columns") temp <- match(idlist, idmap[,1]) if (any(is.na(temp))) stop("Values appear in id1 or id2 that are not in idmap") idmap <- idmap[temp,2] } id1 <- match(id1,idlist) id2 <- match(id2, idlist) if (any(is.na(id1) |is.na(id2))) stop("idlist is not complete") # make sure the diagonal element is correct if (any(id1==id2)) { temp <- range(x[id1==id2]) if (temp[1] != temp[2]) warning("X values for the diagonal are not constant") temp <- median(x[id1==id2]) if (!missing(diagonal) && diagonal!= temp) warning("Specified diagonal value disagrees with the data") if (missing(diagonal)) diagonal <- temp } else { if (missing(diagonal)) stop(paste("No diagonal elements in the data,", "and no diagonal argument was given")) } # # If "diagonal" was specified, ensure that everyone is in the final output # by adding a dummy line for them into the data set # if (!missing(diagonal)) { n <- length(idlist) id1 <- c(id1, 1:n) id2 <- c(id2, 1:n) x <- c(x, rep(diagonal, n)) } # put the smaller first in the list # remember, the output is a symmetric matrix temp <- pmin(id1, id2) id2 <- pmax(id1, id2) id1 <- temp # # Remove duplicate data. Note that if the input had # two entries for an element, say (1,2,10) and (2,1,12), then # this will remove the latter, and never notice the inconsistent # data values of 10 vs 12. dup <- duplicated(cbind(id1, id2)) if (any(dup)) { id1 <- id1[!dup] id2 <- id2[!dup] x <- x[!dup] } # Now, finally we get to go to work # Basic algorithm: iteratively set famid=min(id[members of family]) # Initially, everyone is a unique family id # At each step, compare them to the family id's of "sibs" # I really don't think it will take many iterations -- test cases # are all 3-4. Worst case is a tri-diagonal submatrix of dimension # k, where it takes k-1 iterations. For the large breast data # pedigree: on iteration 1 all of the blood relatives of each family # collapse to a single id, and all the marry-ins with children map # to the old id of that blood relative. On the second iteration # all the ids are final, and then one more for it to recognize that # it is done. # famid <- 1:length(idlist) for (i in 1:length(idlist)) { newfam <- tapply(famid[c(id1,id2)], famid[c(id2,id1)], min) indx <- as.numeric(names(newfam)) # at this point indx= old family id, newfam = new family id # they will differ for families that are about to be merged if (all(indx == newfam)) break famid <- newfam[match(famid, indx)] #give everyone their new id } if (i>= length(idlist)) stop("Routine failed with an infinite loop") # # Now build a bdsmatrix # newid will be the dimname # The remaining routine shares a lot with makekinship. newid <- idmap #gives it the right length and class, to start counts <- table(famid) famlist <- sort(unique(famid)) #labels of the counts vector unrelated <- (counts==1) if (any(unrelated)) { nzero <- sum(unrelated) who <- !is.na(match(famid, famlist[unrelated])) newid[1:nzero] <- idmap[who] famlist <- famlist[!unrelated] counts <- counts[!unrelated] cumcount <- cumsum(counts) + nzero } else { cumcount <- cumsum(counts) nzero <- 0 } blockn <- counts*(counts+1)/2 #size of storage for each block n2 <- sum(blockn) # total amount needed bdata <- double(n2) j <- cumsum(blockn) for (i in 1:length(counts)) { who <- (famid == famlist[i]) n <- counts[i] #number of people in this "family" #rows of data which apply whichrows <- !is.na(match(famid[id1], famlist[i])) whichid <- sort(unique(c(id1[whichrows], id2[whichrows]))) #member ids fid1 <- match(id1[whichrows], whichid) fid2 <- match(id2[whichrows], whichid) temp <- matrix(0.0, n, n) temp[cbind(fid1, fid2)] <- x[whichrows] temp[cbind(fid2, fid1)] <- x[whichrows] diag(temp) <- diagonal bdata[seq(to=j[i], length=blockn[i])] <- temp[row(temp)>=col(temp)] newid[seq(to=cumcount[i], length=counts[i])] <- idmap[who] } bdsmatrix(blocksize=c(rep(1,nzero), counts), blocks = c(rep(diagonal,nzero), bdata), dimnames=list(newid, newid)) } bdsmatrix/R/solve.bdsmatrix.R0000644000176200001440000000715714246374773015752 0ustar liggesusers# Cholesky decompostion and solution solve.bdsmatrix<- function(a, b, full=TRUE, tolerance=1e-10, ...) { if (!inherits(a, 'bdsmatrix')) stop("First argument must be a bdsmatrix") if (a@offdiag !=0) return(solve(as.matrix(a), b, tolerance=tolerance)) nblock <- length(a@blocksize) adim <- dim(a) if (missing(b)) { # The inverse of the Cholesky is sparse, but if rmat is not 0 # the inverse of the martrix as a whole is not # For df computations in a Cox model, however, it turns out that # I only need the diagonal of the matrix anyway. if (length(a@rmat)==0 || full==FALSE) { # The C-code will do the inverse for us temp <- .C(Cgchol_bdsinv, as.integer(nblock), as.integer(a@blocksize), as.integer(a@Dim), dmat= as.double(a@blocks), rmat= as.double(a@rmat), flag= as.double(tolerance), as.integer(0)) if (length(a@rmat) >0) { new("bdsmatrix", blocksize=a@blocksize, blocks = temp$dmat, offdiag=0, rmat = matrix(temp$rmat, nrow=nrow(a@rmat)), Dim=a@Dim, Dimnames= a@Dimnames) } else { new("bdsmatrix", blocksize=a@blocksize, blocks = temp$dmat, offdiag=0, Dim=a@Dim, Dimnames= a@Dimnames) } } else { # Get back the inverse of the cholesky from the C code # and then multiply out the results ourselves (the C # program doesn't have the memory space assigned to # write out a full matrix). The odds of a "not enough # memory" message are high, if a is large. temp <- .C(Cgchol_bdsinv, as.integer(nblock), as.integer(a@blocksize), as.integer(a@Dim), dmat= as.double(a@blocks), rmat= as.double(a@rmat), flag= as.double(tolerance), as.integer(2)) inv <- new('gchol.bdsmatrix', blocksize=a@blocksize, blocks=temp$dmat, rmat=matrix(temp$rmat, ncol=ncol(a@rmat)), Dim=a@Dim, rank= as.integer(temp$flag), Dimnames=a@Dimnames) dd <- diag(inv) rtemp <- as.matrix(inv) #This may well complain about "too big" t(rtemp) %*% (dd* rtemp) } } else { # # If the rhs is a vector, save a little time by doing the decomp # and the backsolve in a single .C call # if (length(b) == adim[1]) { .C(Cgchol_bdssolve, as.integer(nblock), as.integer(a@blocksize), as.integer(a@Dim), block = as.double(a@blocks), rmat= as.double(a@rmat), as.double(tolerance), beta= as.double(b), flag=as.integer(0))$beta } else { # The rhs is a matrix. # In this case, it's faster to do the decomp once, and then # solve against it multiple times. # if (!is.matrix(b) || nrow(b) != adim[1]) stop("number or rows of b must equal number of columns of a") else solve(gchol(a, tolerance=tolerance), b) } } } bdsmatrix/MD50000644000176200001440000001010714570616144012566 0ustar liggesusersd4807c6399dc5639bc0749e7e44e1dac *DESCRIPTION a28766fc330da05fe30e033478f7f102 *NAMESPACE d5f1467b2eb0bd23048b3039f06c2020 *R/as.matrix.bdsmatrix.R 64fdb1533e5795c4e40ee430c44a2569 *R/backsolve.R e8f3204410684243d2f8e5bac6201874 *R/bdsBlock.R 1cc149cddb1bea39bc077a0e045c6669 *R/bdsI.R 096728744e6d3d835ac2889c64e44b27 *R/bdsmatrix.R eb5cedafb29b516cdcb69ff36b6ea280 *R/bdsmatrix.ibd.R f3d16a415a24978b7ed9dd592f67a1bc *R/bdsmatrix.reconcile.R a46d5044af56de4707d90cdec0a8fcea *R/diag.bdsmatrix.R 533a24f60cc1e776d205e80cfeaeeedd *R/gchol.R 6521ce790e8351a9b148035414a9ecdc *R/gchol.bdsmatrix.R 11aeb88e699ff4f620823eda55efd28f *R/listbdsmatrix.R 7d49fbf54086ce778973858dc448e736 *R/multiply.bdsmatrix.R a40d224caac8a09909c6d246e90bee24 *R/solve.bdsmatrix.R da7ea57a4b21afee06a6586c45883c42 *R/solve.gchol.R 92dd6f302b53cfe89597601797574b23 *R/solve.gchol.bdsmatrix.R 06ec3bb9d3d46cb5c25a985724614663 *inst/COPYRIGHTS d1a1f0cf8254afaea2aab6af60d20c8f *inst/NEWS.Rd 080c1219ad3fd68f63fea0cb337c50c2 *inst/include/bdsmatrix.h 00239674d380e2a43414a89d7cede64c *inst/include/bdsmatrix_stub.h 9a5af8525aaeea040dfd0f62bff26437 *man/as.matrix.bdsmatrix.Rd b95f870bfb48f20e77b169a4319d976b *man/backsolve.Rd 729c0883ace7d8370727d6e971dd2abd *man/bdsBlock.Rd d21f2f38eb9de122a102e2063c474386 *man/bdsI.Rd 1f192a818a8b12041ddf57b3a093e132 *man/bdsmatrix-class.Rd 27a224f2699462767798aa4c31d716d6 *man/bdsmatrix.Rd 0f3c7658ab774bd003e06e4569b67ecc *man/bdsmatrix.ibd.Rd 467b7069f06045ab5130742ef20987ce *man/bdsmatrix.reconcile.Rd f6183849b708100b2ec4c617ae579b74 *man/gchol-class.Rd e54bb1a12e410e9d482d244389003167 *man/gchol.Rd 10526ba89abfc766ee82ca229ab85c5a *man/gchol.bdsmatrix-class.Rd bbc8b5962087a446c2c49c529164d7a0 *man/listbdsmatrix.Rd 535db3a728f2a836f2a1cd7be8ceb7e5 *man/solve.bdsmatrix.Rd e40ae6c1c8158484f7e07d1ec96d6f34 *man/solve.gchol.Rd 864aa5f38c8ba38f76e97475e35e92cf *src/R_init_bdsmatrix.c 9bb9016a8b462675aaceca6510913c5a *src/bdsS.h 54e2f85e396da8ff1cd4ab976c292f53 *src/bdsmatrix.h 128e0f0eff3987ecf6bbeab2d3cb727a *src/bdsmatrix_index1.c 951c3de579d8fd0981d424985f261c19 *src/bdsmatrix_index2.c 6daa070698a50050914bb4806567b1c3 *src/bdsmatrix_index3.c 21f10ebdaea19131c9fdba598e48ccdc *src/bdsmatrix_prod.c c397f2d57245e73440b3a8cb8adffd36 *src/bdsmatrix_prod2.c f50e70a60da7e1b2a6dbfdd3ab5e0440 *src/bdsmatrix_prod3.c ab626faf4cc5e78b0e3b4aca7226fbcb *src/bdsmatrix_prod4.c b85b16cf1f30ea43e7d9ce0ef67b3160 *src/chinv4.c 77759685caefd6f842997fde674ad2ba *src/chinv5.c dde26f607b397d2f71f3f94227d2b473 *src/cholesky4.c afc241665ce15debcf39d49311ac0980 *src/cholesky5.c 008904f4c7a57a026a4ee91fd8237cda *src/chsolve4.c 30f7cbb94703d1c62f7d6d4def39f639 *src/chsolve5.c 50ea66135cf33220fbc13f10d8d21c70 *src/dmatrix.c 52aac3a07236bf5f687a7287cdd1f9eb *src/gcback.c 67d8d3530b912aa1ce3f1a8508c59618 *src/gchol.c fa2792616e8ce559e82d4a36e68e5dd2 *src/gchol_bds.c bc22c9e90099058efc3d7f1f83333518 *tests/backsolvetest.R ccf20024e3164d74e0cf67f70d6f19ed *tests/backsolvetest.Rout.save 862ac0234cd237ecaa9485475dced13e *tests/bdstest.R cc6125635e09684570b1cd6741798a71 *tests/bdstest.Rout.save e9a639ee9b68eaf36041d0de089ef899 *tests/chtest.R c45c41aa07d3bf329c9c3be7cd0c9b53 *tests/chtest.Rout.save edba557e7eedfbbbe9c1ab4c08e45ca8 *tests/chtest2.R 768a1790e9ea3e3b83cc94d326de508d *tests/chtest2.Rout.save 186cc08c13a81148f3f788eddf4f543a *tests/corner.R 689b64341555f54a8faf0d5c13ed391f *tests/corner.Rout.save e9d2312365e6bede4fbb4d7de46104ce *tests/corner2.R 79e02e00c522e2d651b44b6a3aa174c1 *tests/corner2.Rout.save f41208c7eef87e1ce0d43e95b0bdb56f *tests/gtest.R bccdef78626edecb3f19b48c5e9c4847 *tests/gtest.Rout.save 8b6293848b17c5cb171bc387e30ff495 *tests/gtest2.R 0719e8331dc9f116c8d016397024dcc2 *tests/gtest2.Rout.save b05ec953aa5450447c93f58e6284c374 *tests/matrix.R 70661ac8d208b615250309cd914793dd *tests/matrix.Rout.save 796f5aed4c62e35776adb1e4a87c02aa *tests/nullr.R ae1de8651f0e54d2d3dc68b19ea8dd79 *tests/nullr.Rout.save f46036caa1d13e153a52ead8533755f4 *tests/reconcile.R 877d40af4744e20c91acaa869d3a68db *tests/reconcile.Rout.save 8363ea788044a5a46a665e88092f88b5 *tests/tinv.R fac2301eb30dbe59dae8afe1ba6a08b8 *tests/tinv.Rout.save bdsmatrix/inst/0000755000176200001440000000000014570341331013225 5ustar liggesusersbdsmatrix/inst/COPYRIGHTS0000744000176200001440000000034213216771370014651 0ustar liggesusersCopyright 2000 Mayo Foundation for Medical Education and Research. This software is accepted by users "as is" and without warranties or guarantees of any kind. This software is distributed under the LGPL version 2 or later. bdsmatrix/inst/include/0000755000176200001440000000000014570341355014656 5ustar liggesusersbdsmatrix/inst/include/bdsmatrix_stub.h0000644000176200001440000000471713216771370020072 0ustar liggesusers/* ** Define all the bdsmatrix routines */ #include "bdsmatrix.h" #include #include void bdsmatrix_prod2(int nblock, int *bsize, int nrow, double *bmat, double *rmat, double *y, double *result, int *itemp) { static void (*fun)() = NULL; if (fun==NULL) fun = (void (*)) R_GetCCallable("bdsmatrix", "bdsmatrix_prod2"); fun(nblock, bsize, nrow, bmat, rmat, y, result, itemp); } void bdsmatrix_prod4(int nrow, int nblock, int *bsize, double *bmat, double *rmat, int nfrail, double *y) { static void (*fun)() = NULL; if (fun==NULL) fun = (void (*)) R_GetCCallable("bdsmatrix", "bdsmatrix_prod4"); fun(nrow, nblock, bsize, bmat, rmat, nfrail, y); } int cholesky4(double **matrix, int n, int nblock, int *bsize, double *bd, double toler) { static int (*fun)() =NULL; if (fun==NULL) fun= (int(*)) R_GetCCallable("bdsmatrix", "cholesky4"); return(fun(matrix, n, nblock, bsize, bd, toler)); } int cholesky5(double **matrix, int n, double toler){ static int (*fun)() =NULL; if (fun==NULL) fun= (int(*)) R_GetCCallable("bdsmatrix", "cholesky5"); return(fun(matrix, n, toler)); } void chinv4(double **matrix, int n, int nblock, int *bsize, double *bd, int flag) { static void (*fun)() = NULL; if (fun==NULL) fun= (void (*)) R_GetCCallable("bdsmatrix", "chinv4"); fun(matrix, n, nblock, bsize, bd, flag); } void chinv5(double **matrix , int n, int flag) { static void (*fun)() = NULL; if (fun==NULL) fun= (void (*)) R_GetCCallable("bdsmatrix", "chinv5"); fun(matrix, n, flag); } void chsolve4(double **matrix, int n, int nblock, int *bsize, double *bd, double *y, int flag){ static void (*fun)() = NULL; if (fun==NULL) fun= (void (*)) R_GetCCallable("bdsmatrix", "chsolve4"); fun(matrix, n, nblock, bsize, bd, y, flag); } void chsolve5(double **matrix, int n, double *y,int flag){ static void (*fun)() = NULL; if (fun==NULL) fun= (void (*)) R_GetCCallable("bdsmatrix", "chsolve5"); fun(matrix, n, y, flag); } double **dmatrix(double *array, int ncol, int nrow){ static double **((*fun)())= NULL; if (fun==NULL) fun= (double **(*)) R_GetCCallable("bdsmatrix", "dmatrix"); return(fun(array, ncol, nrow)); } bdsmatrix/inst/include/bdsmatrix.h0000755000176200001440000000202513216771370017026 0ustar liggesusers/* ** This contains the prototype calls for all the .c functions that ** are called by another C function ** Mostly, it stops errors due to having things declared differently ** in different routines. */ void bdsmatrix_prod2(int nblock, int *bsize, int nrow, double *bmat, double *rmat, double *y, double *result, int *itemp) ; void chinv4(double **matrix, int n, int nblock, int *bsize, double *bd, int flag) ; void chinv5(double **matrix , int n, int flag); int cholesky4(double **matrix, int n, int nblock, int *bsize, double *bd, double toler) ; int cholesky5(double **matrix, int n, double toler); void chsolve4(double **matrix, int n, int nblock, int *bsize, double *bd, double *y, int flag); void chsolve5(double **matrix, int n, double *y, int flag); double **dmatrix(double *array, int ncol, int nrow); void bdsmatrix_prod4(int nrow, int nblock, int *bsize, double *bmat, double *rmat, int nfrail, double *y); bdsmatrix/inst/NEWS.Rd0000644000176200001440000000264614570340334014302 0ustar liggesusers\name{NEWS} \title{NEWS file for the bdsmatrix package} \section{Changes in version 1.3.7}{ \itemize{ \item Remove a call to is.R() }} \section{Changes in version 1.3.6}{ \itemize{ \item Change lines with "if (class(x) == 'bsdmatrix')" to use inherit() }} \section{Changes in version 1.3.5}{ \itemize{ \item Remove Sint C type, per request from CRAN \item The internal ismat() function had an if (condition) where the condition was length 2. Fixed }} \section{Changes in version 1.3.3}{ \itemize{ \item Change base:::backsolve to base::backsolve per request from CRAN \item Add modern declarations of internal symbols, e.g. R_CMethodDef, R_CallMethodDef, RuseDynamicSymbols to the init routine. }} \section{Changes in version 1.3.2}{ \itemize{ \item Fix an inconsistency between the COPYRIGHT and DESCRIPTION files }} \section{Changes in version 1.3.1}{ \itemize{ \item Fix an inconsistency between the COPYRIGHT and DESCRIPTION files \item Avoid a "not initialized" compiler warning in gchol_bds.c }} \section{Changes in version 1.3}{ \itemize{ \item Make backsolve an S4 generic instead of S3. The documentation file for chol in the Matrix package was a big help in sorting out how to make the CMD check process content. }} \section{Changes in version 1.2}{ \itemize{ \item Add the backsolve method for ghcol and gchol.bdsmatrix objects. }}