bdsmatrix/0000755000176200001440000000000013607156261012256 5ustar liggesusersbdsmatrix/NAMESPACE0000644000176200001440000000141113216772161013471 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/0000755000176200001440000000000013607147232013027 5ustar liggesusersbdsmatrix/man/listbdsmatrix.Rd0000644000176200001440000000240413216772161016210 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.Rd0000644000176200001440000000466313216772161016454 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.Rd0000644000176200001440000000330113216772161015537 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.Rd0000644000176200001440000000145013216772161017256 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.Rd0000644000176200001440000000114413216772161017221 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.Rd0000644000176200001440000000366213216772161015323 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.Rd0000644000176200001440000000412013216772161017507 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.Rd0000644000176200001440000000572213216772161015524 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.Rd0000644000176200001440000000424013216772161014413 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.Rd0000644000176200001440000001211413216772161016416 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.Rd0000644000176200001440000000341713216772161016056 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.Rd0000644000176200001440000000445513216772161015300 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.Rd0000644000176200001440000000244013216772161015042 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.Rd0000644000176200001440000000132513216772161014201 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/DESCRIPTION0000644000176200001440000000133113607156261013762 0ustar liggesusersPackage: bdsmatrix Title: Routines for Block Diagonal Symmetric Matrices Maintainer: Terry Therneau Version: 1.3-4 Date: 2020-01-07-13 Depends: methods, R (>= 2.0.0) LazyData: Yes 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: 2020-01-13 20:10:02 UTC; therneau Repository: CRAN Date/Publication: 2020-01-13 21:10:09 UTC bdsmatrix/tests/0000755000176200001440000000000013607147232013416 5ustar liggesusersbdsmatrix/tests/corner.Rout.save0000644000176200001440000000310013216772161016511 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.R0000644000176200001440000000304713216772161015216 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.save0000644000176200001440000000373313216772161016527 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.save0000644000176200001440000000505613216772161016215 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.R0000644000176200001440000000142313216772161014676 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.save0000644000176200001440000000355613216772161016614 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.R0000644000176200001440000000317213216772161014525 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.save0000644000176200001440000000522113216772161016677 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.R0000644000176200001440000000171513216772161015122 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.save0000644000176200001440000000424313216772161020103 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.save0000644000176200001440000000547213216772161016611 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.save0000644000176200001440000000342713216772161016541 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.R0000644000176200001440000000122213216772161014747 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.R0000644000176200001440000000154413216772161015052 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.R0000644000176200001440000000131313216772161015030 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.save0000644000176200001440000000303413216772161016437 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.save0000644000176200001440000000367213216772161016365 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.R0000644000176200001440000000406213216772161015507 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.R0000644000176200001440000000232213216772161016412 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.R0000644000176200001440000000346013216772161015117 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.save0000644000176200001440000000620313216772161017173 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.save0000644000176200001440000000326513216772161016371 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.R0000644000176200001440000000202713216772161014671 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.R0000644000176200001440000000205513216772161015036 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/0000755000176200001440000000000013607147232013043 5ustar liggesusersbdsmatrix/src/bdsmatrix_prod4.c0000644000176200001440000000443613216772161016324 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(Sint *nblock, Sint *bsize, Sint *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(Sint *nblock, Sint *bsize, Sint *flag, Sint *nrow, Sint *rows, Sint *indexa, Sint *indexb, Sint *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.h0000644000176200001440000000460613216772161015220 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(Sint *nblock, Sint *bsize, Sint *flag, Sint *nrow, Sint *rows, Sint *indexa, Sint *indexb, Sint *indexc); void bdsmatrix_index2(Sint *nblock, Sint *bsize, Sint *rows, Sint *cols); void bdsmatrix_index3(Sint *nblock, Sint *bsize, Sint *index); void bdsmatrix_prod(Sint *nb, Sint *bsize, Sint *ydim, double *bmat, double *rmat, double *offdiag, double *temp, Sint *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(Sint *nr, Sint *nb, Sint *bsize, double *bmat, double *rmat, Sint *rhs, Sint *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(Sint *n2, double *matrix, double *toler); void gchol_inv(Sint *n2, double *matrix, Sint *flag2); void gchol_solve(Sint *n2, double *matrix, double *y, Sint *flag2); void gchol_bds(Sint *nb, Sint *bs2, Sint *n2, double *dmat, double *rmat, double toler[]) ; void gchol_bdsinv(Sint *nb, Sint *bs2, Sint *n2, double *dmat, double *rmat, double *toler, Sint *flag); void gchol_bdssolve(Sint *nb, Sint *bs2, Sint *n2, double *blocks, double *rmat, double *toler, double *y, Sint *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.c0000644000176200001440000000261213216772161014741 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(Sint *nb, Sint *bs2, Sint *n2, double *blocks, double *rmat, double *toler, double *y, Sint *flag) { int i,j; int *bsize, bsum, n, nblock; double **mat; /* copy over arguments from Sint 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.c0000644000176200001440000000315413216772161015121 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(Sint *nr, Sint *nb, Sint *bsize, double *bmat, double *rmat, Sint *rhs, Sint *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.R0000644000176200001440000000146313216772161013466 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.R0000644000176200001440000000545713216772161017033 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.R0000644000176200001440000000241713216772161015476 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.R0000644000176200001440000000275413216772161016464 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.R0000644000176200001440000000451213216772161014554 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.R0000644000176200001440000000241113216772161015477 0ustar liggesuserssetMethod('diag', 'bdsmatrix', function(x, nrow, ncol) { if (class(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 (class(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.R0000644000176200001440000003031313216772161014576 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 (class(x) != 'bdsmatrix') stop("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.R0000644000176200001440000002503113216772161015672 0ustar liggesusers# # Cholesky decompostition for block-diagonal square matrices # if (is.R() || length(getClass('gchol.bdsmatrix')@slots)==0) { 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 (class(x) != 'bdsmatrix') stop ("Bad argument") 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 (class(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.R0000644000176200001440000000373413216772161016512 0ustar liggesusersas.matrix.bdsmatrix <- function(x, ...) { if (class(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.R0000644000176200001440000000201413216772161015021 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.R0000644000176200001440000000100113216772161014314 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.R0000644000176200001440000000740213216772161013700 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.R0000644000176200001440000001302213216772161015331 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.R0000644000176200001440000000715613216772161015736 0ustar liggesusers# Cholesky decompostion and solution solve.bdsmatrix<- function(a, b, full=TRUE, tolerance=1e-10, ...) { if (class(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/MD50000644000176200001440000001010713607156261012565 0ustar liggesusers44c9b30b139277934bff88c1a1211a7f *DESCRIPTION a28766fc330da05fe30e033478f7f102 *NAMESPACE 10e20f8c9fde4e6599a10bf4f97cc0ff *R/as.matrix.bdsmatrix.R 64fdb1533e5795c4e40ee430c44a2569 *R/backsolve.R e8f3204410684243d2f8e5bac6201874 *R/bdsBlock.R 1cc149cddb1bea39bc077a0e045c6669 *R/bdsI.R 81a3a8ca326a5d7b2718a0eefcc77c3a *R/bdsmatrix.R eb5cedafb29b516cdcb69ff36b6ea280 *R/bdsmatrix.ibd.R 128ce3113ea1a47071bf892a8891601b *R/bdsmatrix.reconcile.R fce194c6d531675b0bdd8c84370330f7 *R/diag.bdsmatrix.R 533a24f60cc1e776d205e80cfeaeeedd *R/gchol.R f636ffc7d10d43b73ace336904a4018d *R/gchol.bdsmatrix.R 11aeb88e699ff4f620823eda55efd28f *R/listbdsmatrix.R 7d49fbf54086ce778973858dc448e736 *R/multiply.bdsmatrix.R c92db9d4667266d4281b2a352d684918 *R/solve.bdsmatrix.R da7ea57a4b21afee06a6586c45883c42 *R/solve.gchol.R 92dd6f302b53cfe89597601797574b23 *R/solve.gchol.bdsmatrix.R 06ec3bb9d3d46cb5c25a985724614663 *inst/COPYRIGHTS e7d9b89ac9b3d31e379a80bc37f21d32 *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 52b8322c43ea645a754a1679d795a51d *src/bdsS.h f0de41ef3c958cf306cd3c1f353623f8 *src/bdsmatrix.h 3034c9275e2254dd09946061f975e608 *src/bdsmatrix_index1.c de431b1664e29c6b60e3118e87faac72 *src/bdsmatrix_index2.c e1615f1bfd150d9897bb2e33f4edb8dd *src/bdsmatrix_index3.c d2c0cdf64a0d7bb7bb8178c5d7eaf6d7 *src/bdsmatrix_prod.c c397f2d57245e73440b3a8cb8adffd36 *src/bdsmatrix_prod2.c 1483372cdf3bf411655903524eac74be *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 f282e4814f5a7994c151e89b9aa643a0 *src/gchol.c 25c83806053caf63c6c6baef64140f2c *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/0000755000176200001440000000000013607147232013231 5ustar liggesusersbdsmatrix/inst/COPYRIGHTS0000755000176200001440000000034213216772161014652 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/0000755000176200001440000000000013607147232014654 5ustar liggesusersbdsmatrix/inst/include/bdsmatrix_stub.h0000644000176200001440000000471713216772161020071 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.h0000755000176200001440000000202513216772161017025 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.Rd0000644000176200001440000000222413607147203014272 0ustar liggesusers\name{NEWS} \title{NEWS file for the bdsmatrix package} \section{Changes in version 1.3.4}{ \itemize{ \item Change an instance of class(x) == to inherits(x, This was causing errors for coxme. }} \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. }}