From 88d1f95c5e5077ce8ab33aee48d153d64ffee850 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Sun, 19 May 2024 00:50:29 -0400 Subject: [PATCH 01/13] potential patch for markmfredrickson/RItools#124 --- R/utils.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index 45f6c68..44bb13b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -26,9 +26,13 @@ formula.xbal<-function(x,...){ ##' @return Result of \code{fun}. withOptions <- function(optionsToChange, fun) { oldOpts <- options() - on.exit(options(oldOpts)) options(optionsToChange) - tryCatch(fun(), finally = options(oldOpts)) + # store the old values of the options, just for the options that were changed + old.opt.values <- list() + for (i in 1:length(optionsToChange)) { + old.opt.values[[names(optionsToChange)[i]]] <- oldOpts[[names(optionsToChange)[i]]] + } + tryCatch(fun(), finally = options(old.opt.values)) } ##Our own version of these to handle the signif stars. From edbe74275d16d575f5b036dae4a937b95b3a01d3 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Tue, 21 May 2024 00:53:28 -0400 Subject: [PATCH 02/13] simplifying code for markmfredrickson/RItools#124 patch --- R/utils.R | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/R/utils.R b/R/utils.R index 44bb13b..6fd24ef 100644 --- a/R/utils.R +++ b/R/utils.R @@ -28,11 +28,8 @@ withOptions <- function(optionsToChange, fun) { oldOpts <- options() options(optionsToChange) # store the old values of the options, just for the options that were changed - old.opt.values <- list() - for (i in 1:length(optionsToChange)) { - old.opt.values[[names(optionsToChange)[i]]] <- oldOpts[[names(optionsToChange)[i]]] - } - tryCatch(fun(), finally = options(old.opt.values)) + oldOptValues <- oldOpts[names(optionsToChange)] + tryCatch(fun(), finally = options(oldOptValues)) } ##Our own version of these to handle the signif stars. From 032343598674e45da3c8a20aacf0b37e54678209 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Mon, 24 Jun 2024 16:10:19 -0400 Subject: [PATCH 03/13] implementing SparseM based fix to markmfredrickson/RItools#134 --- R/utils.R | 109 +++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 87 insertions(+), 22 deletions(-) diff --git a/R/utils.R b/R/utils.R index c16cb5d..d6f073e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -185,19 +185,19 @@ SparseMMFromFactor <- function(thefactor) { ) } - -## Variant of slm.fit.csr -## -## SparseM's slm.fit.csr has a bug for intercept only models -## (admittedly, these are generally a little silly to be done as a -## sparse matrix), but in order to avoid duplicate code, if -## everything is in a single strata, we use the intercept only model. -## -## @param x As slm.fit.csr -## @param y As slm.fit.csr -## @param ... As slm.fit.csr -## @return As slm.fit.csr -## @importFrom SparseM chol backsolve +#' new version of slm.fit.csr +#' +#' SparseM's slm.fit.csr has a bug for intercept only models +#' (admittedly, these are generally a little silly to be done as a +#' sparse matrix), but in order to avoid duplicate code, if +#' everything is in a single strata, we use the intercept only model. +#' This implementation contains some workarounds to ensure that only +#' positive definite matrices are handed off to SparseM::chol() +#' +#' @param x As slm.fit.csr +#' @param y As slm.fit.csr +#' @param ... As slm.fit.csr +#' @return As slm.fit.csr slm.fit.csr.fixed <- function(x, y, ...) { if (is.matrix(y)) { n <- nrow(y) @@ -211,29 +211,94 @@ slm.fit.csr.fixed <- function(x, y, ...) { stop("x and y don't match n") } - fit <- .lm.fit(as.matrix(x), as.matrix(y)) - coef <- fit$coefficients - - ## Note above: we no longer import chol or backsolve from SparseM in this function - # chol <- SparseM::chol(t(x) %*% x, ...) - # xy <- t(x) %*% y - # coef <- SparseM::backsolve(chol, xy) + temp_sol <- sparseM_solve(x, y, ...) + coef <- temp_sol[["coef"]] + chol <- temp_sol[["chol"]] if (is.vector(coef)) { coef <- matrix(coef, ncol = ycol, nrow = p) } - fitted <- as.matrix(x %*% coef) resid <- y - fitted df <- n - p list( coefficients = coef, - # chol = chol, + chol = chol, residuals = resid, fitted = fitted, df.residual = df ) } + +#' Helper function to slm.fit.csr.fixed +#' +#' This function generates a matrix that can be used to reduce +#' the dimensions of x'x and xy such that positive definiteness is +#' ensured and more practically, that SparseM::chol will work +#' +#' @param x logical vector indicating which entries of x'x are zeroes. +#' @return SparseM matrix that will reduce the dimension of x'x and xy +#' @importFrom SparseM chol backsolve +create_SparseM_reduction_matrix <- function(zeroes) +{ + num_rows <- length(zeroes) + num_cols <- sum(!zeroes) + non_zero_indices <- which(!zeroes) + + # Calculate the column indices for non-zero values + col_indices <- sapply(non_zero_indices, + function(i) i - sum(zeroes[1:i])) + values <- rep(1, num_cols) + + # Define the row pointer array + ia <- cumsum(c(1, !zeroes)) + + dimension <- as.integer(c(num_rows, num_cols)) + reducing_matrix <- new("matrix.csr", ra = values, + ja = as.integer(col_indices), + ia = as.integer(ia), + dimension = dimension) + + return(reducing_matrix) +} + + +#' Helper function to slm.fit.csr.fixed +#' +#' This function performs some checks and takes action to +#' ensure positive definiteness of matrices passed to SparseM functions. +#' +#' @param x A slm.fit.csr +#' @param y A slm.fit.csr +#' @param ... A slm.fit.csr +#' @return list containing coefficients (vector or matrix) and Cholesky decomposition (of class matrix.csr.chol) +#' @importFrom SparseM chol backsolve +sparseM_solve <- function(x, y, ...) +{ + xy <- t(x) %*% y + xprimex <- t(x) %*% x + diag.xx <- diag(xprimex) + zeroes <- diag.xx == 0 + if (any(zeroes)) #check explicitly for zeroes here so we don't do matrix math without needing to + { # this branch deals with issue 134 + reducing_matrix <- create_SparseM_reduction_matrix(zeroes) + xpx.sub <- t(reducing_matrix) %*% xprimex %*% reducing_matrix + xy.sub <- t(reducing_matrix) %*% xy + chol.result <- SparseM::chol(xpx.sub, ...) + coef.nonzero <- SparseM::backsolve(chol.result, xy.sub) + num_rows <- length(zeroes) + coef.all <- numeric(num_rows) + coef.all[!zeroes] <- coef.nonzero + } else + { + chol.result <- SparseM::chol(xprimex, ...) + coef.all <- SparseM::backsolve(chol.result, xy) + } + + return(list("coef" = coef.all, + "chol" = chol.result)) +} + ## slm.wfit with two fixes ## ## slm.wfit shares the intercept-only issue with slm.fit, From d73b972da7a18b9149ffa9ced66bbade851a4ca6 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Mon, 24 Jun 2024 16:15:26 -0400 Subject: [PATCH 04/13] documentation changes --- NAMESPACE | 2 ++ man/create_SparseM_reduction_matrix.Rd | 19 +++++++++++++++++++ man/slm.fit.csr.fixed.Rd | 26 ++++++++++++++++++++++++++ man/sparseM_solve.Rd | 22 ++++++++++++++++++++++ 4 files changed, 69 insertions(+) create mode 100644 man/create_SparseM_reduction_matrix.Rd create mode 100644 man/slm.fit.csr.fixed.Rd create mode 100644 man/sparseM_solve.Rd diff --git a/NAMESPACE b/NAMESPACE index 8797fee..51eb101 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,8 @@ import(methods) import(stats) import(svd) import(xtable) +importFrom(SparseM,backsolve) +importFrom(SparseM,chol) importFrom(SparseM,is.matrix.csr) importFrom(dplyr,mutate) importFrom(graphics,abline) diff --git a/man/create_SparseM_reduction_matrix.Rd b/man/create_SparseM_reduction_matrix.Rd new file mode 100644 index 0000000..d45e620 --- /dev/null +++ b/man/create_SparseM_reduction_matrix.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{create_SparseM_reduction_matrix} +\alias{create_SparseM_reduction_matrix} +\title{Helper function to slm.fit.csr.fixed} +\usage{ +create_SparseM_reduction_matrix(zeroes) +} +\arguments{ +\item{x}{logical vector indicating which entries of x'x are zeroes.} +} +\value{ +SparseM matrix that will reduce the dimension of x'x and xy +} +\description{ +This function generates a matrix that can be used to reduce +the dimensions of x'x and xy such that positive definiteness is +ensured and more practically, that SparseM::chol will work +} diff --git a/man/slm.fit.csr.fixed.Rd b/man/slm.fit.csr.fixed.Rd new file mode 100644 index 0000000..5418715 --- /dev/null +++ b/man/slm.fit.csr.fixed.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{slm.fit.csr.fixed} +\alias{slm.fit.csr.fixed} +\title{new version of slm.fit.csr} +\usage{ +slm.fit.csr.fixed(x, y, ...) +} +\arguments{ +\item{x}{As slm.fit.csr} + +\item{y}{As slm.fit.csr} + +\item{...}{As slm.fit.csr} +} +\value{ +As slm.fit.csr +} +\description{ +SparseM's slm.fit.csr has a bug for intercept only models +(admittedly, these are generally a little silly to be done as a +sparse matrix), but in order to avoid duplicate code, if +everything is in a single strata, we use the intercept only model. +This implementation contains some workarounds to ensure that only +positive definite matrices are handed off to SparseM::chol() +} diff --git a/man/sparseM_solve.Rd b/man/sparseM_solve.Rd new file mode 100644 index 0000000..95aa995 --- /dev/null +++ b/man/sparseM_solve.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{sparseM_solve} +\alias{sparseM_solve} +\title{Helper function to slm.fit.csr.fixed} +\usage{ +sparseM_solve(x, y, ...) +} +\arguments{ +\item{x}{A slm.fit.csr} + +\item{y}{A slm.fit.csr} + +\item{...}{A slm.fit.csr} +} +\value{ +list containing coefficients (vector or matrix) and Cholesky decomposition (of class matrix.csr.chol) +} +\description{ +This function performs some checks and takes action to +ensure positive definiteness of matrices passed to SparseM functions. +} From 58a69360f6f9346f12864dd4db6299b30bae30d1 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Mon, 24 Jun 2024 16:31:26 -0400 Subject: [PATCH 05/13] handling edge case where all xprimex diagonal values are zero --- R/utils.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/utils.R b/R/utils.R index d6f073e..752d325 100644 --- a/R/utils.R +++ b/R/utils.R @@ -241,6 +241,11 @@ slm.fit.csr.fixed <- function(x, y, ...) { #' @importFrom SparseM chol backsolve create_SparseM_reduction_matrix <- function(zeroes) { + if (all(zeroes)) + { + stop("Diagonal of X'X is all zeroes. Unable to proceed.") + } + num_rows <- length(zeroes) num_cols <- sum(!zeroes) non_zero_indices <- which(!zeroes) From 57246d34ba4fedd8ab4e182ddd6fac57ad40254f Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Mon, 24 Jun 2024 16:37:39 -0400 Subject: [PATCH 06/13] adding tests for helper function related to dimension reduction of SparseM matrices --- tests/testthat/test.utils.R | 69 +++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) diff --git a/tests/testthat/test.utils.R b/tests/testthat/test.utils.R index 78aeff2..9daf6f2 100644 --- a/tests/testthat/test.utils.R +++ b/tests/testthat/test.utils.R @@ -54,6 +54,75 @@ test_that("sparse design strat mean calculator returns 0 for strata w/o non-null } ) +test_that("create_SparseM_reduction_matrix works as expected", + { + expect_true(require("SparseM")) + #let tl stand in for xprimex + tl <- diag(1, 5) + diag(tl)[c(1,2,4)] <- 0 + zeroes <- diag(tl) == 0 + not.zeroes <- !zeroes + stl <- tl[, not.zeroes] + sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + + expect_identical(stl, as.matrix(sparse_matrix)) + + tl <- diag(1, 5) + diag(tl)[c(2,4)] <- 0 + zeroes <- diag(tl) == 0 + not.zeroes <- !zeroes + stl <- tl[, not.zeroes] + sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + + expect_identical(stl, as.matrix(sparse_matrix)) + + + tl <- diag(1, 5) + diag(tl)[c(2)] <- 0 + zeroes <- diag(tl) == 0 + not.zeroes <- !zeroes + stl <- tl[, not.zeroes] + sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + + expect_identical(stl, as.matrix(sparse_matrix)) + + + tl <- diag(1, 5) + diag(tl)[c(5)] <- 0 + zeroes <- diag(tl) == 0 + not.zeroes <- !zeroes + stl <- tl[, not.zeroes] + sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + + expect_identical(stl, as.matrix(sparse_matrix)) + + tl <- diag(1, 5) + diag(tl)[c(1, 5)] <- 0 + zeroes <- diag(tl) == 0 + not.zeroes <- !zeroes + stl <- tl[, not.zeroes] + sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + + expect_identical(stl, as.matrix(sparse_matrix)) + + tl <- diag(1, 2) + diag(tl)[c(1)] <- 0 + zeroes <- diag(tl) == 0 + not.zeroes <- !zeroes + stl <- tl[, not.zeroes, drop = FALSE] + sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + + expect_identical(stl, as.matrix(sparse_matrix)) + + tl <- diag(1, 2) + diag(tl)[c(1, 2)] <- 0 + zeroes <- diag(tl) == 0 + + expect_error(create_SparseM_reduction_matrix(zeroes)) + + } +) + test_that("Residuals from weighted regressions w/ sparse designs", { nullfac <- factor(rep("a", 4)) From 4fa526a9b048ec452d0c420d61b23378e8c74322 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Mon, 24 Jun 2024 16:48:37 -0400 Subject: [PATCH 07/13] renaming slm.fit.csr.fixed to slm_fit_csr --- R/Design.R | 2 +- R/utils.R | 8 ++++---- man/create_SparseM_reduction_matrix.Rd | 2 +- man/slm.fit.csr.fixed.Rd | 6 +++--- man/sparseM_solve.Rd | 2 +- tests/testthat/test.utils.R | 2 +- 6 files changed, 11 insertions(+), 11 deletions(-) diff --git a/R/Design.R b/R/Design.R index 0024a87..b596e6a 100644 --- a/R/Design.R +++ b/R/Design.R @@ -892,7 +892,7 @@ alignDesignsByStrata <- function(a_stratification, design, post.align.transform ## Do this for the not-missing indicators as well as for the manifest variables. covars <- cbind(Covs_w_touchups, 0+NM[,NMcolperm]) covars <- suppressWarnings( - slm.fit.csr.fixed(S, covars*non_null_record_wts)$residuals + slm_fit_csr(S, covars*non_null_record_wts)$residuals ) colnames(covars) <- vars diff --git a/R/utils.R b/R/utils.R index 752d325..c5c3700 100644 --- a/R/utils.R +++ b/R/utils.R @@ -198,7 +198,7 @@ SparseMMFromFactor <- function(thefactor) { #' @param y As slm.fit.csr #' @param ... As slm.fit.csr #' @return As slm.fit.csr -slm.fit.csr.fixed <- function(x, y, ...) { +slm_fit_csr <- function(x, y, ...) { if (is.matrix(y)) { n <- nrow(y) ycol <- ncol(y) @@ -230,7 +230,7 @@ slm.fit.csr.fixed <- function(x, y, ...) { } -#' Helper function to slm.fit.csr.fixed +#' Helper function to slm_fit_csr #' #' This function generates a matrix that can be used to reduce #' the dimensions of x'x and xy such that positive definiteness is @@ -268,7 +268,7 @@ create_SparseM_reduction_matrix <- function(zeroes) } -#' Helper function to slm.fit.csr.fixed +#' Helper function to slm_fit_csr #' #' This function performs some checks and takes action to #' ensure positive definiteness of matrices passed to SparseM functions. @@ -330,7 +330,7 @@ slm.wfit.csr <- function(x, y, weights, ...) { w <- sqrt(weights) wx <- as(w, "matrix.diag.csr") %*% x wy <- y * w - fit <- slm.fit.csr.fixed(wx, wy, ...) + fit <- slm_fit_csr(wx, wy, ...) fit$fitted <- as.matrix(x %*% fit$coef) fit$residuals <- y - fit$fitted diff --git a/man/create_SparseM_reduction_matrix.Rd b/man/create_SparseM_reduction_matrix.Rd index d45e620..dfaeabf 100644 --- a/man/create_SparseM_reduction_matrix.Rd +++ b/man/create_SparseM_reduction_matrix.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils.R \name{create_SparseM_reduction_matrix} \alias{create_SparseM_reduction_matrix} -\title{Helper function to slm.fit.csr.fixed} +\title{Helper function to slm_fit_csr} \usage{ create_SparseM_reduction_matrix(zeroes) } diff --git a/man/slm.fit.csr.fixed.Rd b/man/slm.fit.csr.fixed.Rd index 5418715..9bdde3f 100644 --- a/man/slm.fit.csr.fixed.Rd +++ b/man/slm.fit.csr.fixed.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R -\name{slm.fit.csr.fixed} -\alias{slm.fit.csr.fixed} +\name{slm_fit_csr} +\alias{slm_fit_csr} \title{new version of slm.fit.csr} \usage{ -slm.fit.csr.fixed(x, y, ...) +slm_fit_csr(x, y, ...) } \arguments{ \item{x}{As slm.fit.csr} diff --git a/man/sparseM_solve.Rd b/man/sparseM_solve.Rd index 95aa995..b44c9ee 100644 --- a/man/sparseM_solve.Rd +++ b/man/sparseM_solve.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils.R \name{sparseM_solve} \alias{sparseM_solve} -\title{Helper function to slm.fit.csr.fixed} +\title{Helper function to slm_fit_csr} \usage{ sparseM_solve(x, y, ...) } diff --git a/tests/testthat/test.utils.R b/tests/testthat/test.utils.R index 9daf6f2..7c9dbc8 100644 --- a/tests/testthat/test.utils.R +++ b/tests/testthat/test.utils.R @@ -33,7 +33,7 @@ test_that("fitter for sparse designs handles intercept only design", # we get to revert to SparseM:slm.fit.csr lm.n <- lm.fit(matrix(1,4,1), quickY) - slm.n1 <- slm.fit.csr.fixed(nullfac.csr, quickY) + slm.n1 <- slm_fit_csr(nullfac.csr, quickY) expect_equal(lm.n$fitted, as.vector(slm.n1$fitted)) expect_equal(lm.n$residuals, as.vector(slm.n1$residuals)) From e3c46fcf819d3f3e3d2487d1233199f0ba7f1873 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Mon, 24 Jun 2024 23:02:25 -0400 Subject: [PATCH 08/13] fixing naming issue --- R/utils.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index c5c3700..4440e4f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -211,7 +211,7 @@ slm_fit_csr <- function(x, y, ...) { stop("x and y don't match n") } - temp_sol <- sparseM_solve(x, y, ...) + temp_sol <- SparseM_solve(x, y, ...) coef <- temp_sol[["coef"]] chol <- temp_sol[["chol"]] @@ -278,7 +278,7 @@ create_SparseM_reduction_matrix <- function(zeroes) #' @param ... A slm.fit.csr #' @return list containing coefficients (vector or matrix) and Cholesky decomposition (of class matrix.csr.chol) #' @importFrom SparseM chol backsolve -sparseM_solve <- function(x, y, ...) +SparseM_solve <- function(x, y, ...) { xy <- t(x) %*% y xprimex <- t(x) %*% x From af95a346056fa4ac0ad6d6aeb447b6c938197414 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Tue, 25 Jun 2024 00:00:54 -0400 Subject: [PATCH 09/13] fixing documentation issues --- man/{sparseM_solve.Rd => SparseM_solve.Rd} | 6 +++--- man/{slm.fit.csr.fixed.Rd => slm_fit_csr.Rd} | 0 2 files changed, 3 insertions(+), 3 deletions(-) rename man/{sparseM_solve.Rd => SparseM_solve.Rd} (87%) rename man/{slm.fit.csr.fixed.Rd => slm_fit_csr.Rd} (100%) diff --git a/man/sparseM_solve.Rd b/man/SparseM_solve.Rd similarity index 87% rename from man/sparseM_solve.Rd rename to man/SparseM_solve.Rd index b44c9ee..607b564 100644 --- a/man/sparseM_solve.Rd +++ b/man/SparseM_solve.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R -\name{sparseM_solve} -\alias{sparseM_solve} +\name{SparseM_solve} +\alias{SparseM_solve} \title{Helper function to slm_fit_csr} \usage{ -sparseM_solve(x, y, ...) +SparseM_solve(x, y, ...) } \arguments{ \item{x}{A slm.fit.csr} diff --git a/man/slm.fit.csr.fixed.Rd b/man/slm_fit_csr.Rd similarity index 100% rename from man/slm.fit.csr.fixed.Rd rename to man/slm_fit_csr.Rd From 592797635237fcb7af3cecea4de2dfec9f000d17 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Tue, 25 Jun 2024 17:17:16 -0400 Subject: [PATCH 10/13] documentation fixes --- R/utils.R | 2 +- man/create_SparseM_reduction_matrix.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index 4440e4f..c0daf5d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -236,7 +236,7 @@ slm_fit_csr <- function(x, y, ...) { #' the dimensions of x'x and xy such that positive definiteness is #' ensured and more practically, that SparseM::chol will work #' -#' @param x logical vector indicating which entries of x'x are zeroes. +#' @param zeroes logical vector indicating which entries of x'x are zeroes. #' @return SparseM matrix that will reduce the dimension of x'x and xy #' @importFrom SparseM chol backsolve create_SparseM_reduction_matrix <- function(zeroes) diff --git a/man/create_SparseM_reduction_matrix.Rd b/man/create_SparseM_reduction_matrix.Rd index dfaeabf..edd7128 100644 --- a/man/create_SparseM_reduction_matrix.Rd +++ b/man/create_SparseM_reduction_matrix.Rd @@ -7,7 +7,7 @@ create_SparseM_reduction_matrix(zeroes) } \arguments{ -\item{x}{logical vector indicating which entries of x'x are zeroes.} +\item{zeroes}{logical vector indicating which entries of x'x are zeroes.} } \value{ SparseM matrix that will reduce the dimension of x'x and xy From ea17c62ebfc7ab19ac222060a6fbdffc307a2ab4 Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Wed, 26 Jun 2024 14:49:35 -0400 Subject: [PATCH 11/13] return gramian reduction index --- R/utils.R | 11 +++++++---- man/SparseM_solve.Rd | 2 +- man/create_SparseM_reduction_matrix.Rd | 2 +- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/R/utils.R b/R/utils.R index c0daf5d..903ba33 100644 --- a/R/utils.R +++ b/R/utils.R @@ -225,7 +225,9 @@ slm_fit_csr <- function(x, y, ...) { coefficients = coef, chol = chol, residuals = resid, - fitted = fitted, df.residual = df + fitted = fitted, + df.residual = df, + gramian_reduction_index = temp_sol[["gramian_reduction_index"]] ) } @@ -236,7 +238,7 @@ slm_fit_csr <- function(x, y, ...) { #' the dimensions of x'x and xy such that positive definiteness is #' ensured and more practically, that SparseM::chol will work #' -#' @param zeroes logical vector indicating which entries of x'x are zeroes. +#' @param zeroes logical vector indicating which entries of the diagonal of x'x are zeroes. #' @return SparseM matrix that will reduce the dimension of x'x and xy #' @importFrom SparseM chol backsolve create_SparseM_reduction_matrix <- function(zeroes) @@ -276,7 +278,7 @@ create_SparseM_reduction_matrix <- function(zeroes) #' @param x A slm.fit.csr #' @param y A slm.fit.csr #' @param ... A slm.fit.csr -#' @return list containing coefficients (vector or matrix) and Cholesky decomposition (of class matrix.csr.chol) +#' @return list containing coefficients (vector or matrix), the Cholesky decomposition (of class matrix.csr.chol), and a vector specifying the indicies of which values on the diagonal of x'x are nonzero. These are named "coef", "chol" and "gramian_reduction_index", respectively. #' @importFrom SparseM chol backsolve SparseM_solve <- function(x, y, ...) { @@ -301,7 +303,8 @@ SparseM_solve <- function(x, y, ...) } return(list("coef" = coef.all, - "chol" = chol.result)) + "chol" = chol.result, + "gramian_reduction_index" = which(!zeroes))) } ## slm.wfit with two fixes diff --git a/man/SparseM_solve.Rd b/man/SparseM_solve.Rd index 607b564..6918853 100644 --- a/man/SparseM_solve.Rd +++ b/man/SparseM_solve.Rd @@ -14,7 +14,7 @@ SparseM_solve(x, y, ...) \item{...}{A slm.fit.csr} } \value{ -list containing coefficients (vector or matrix) and Cholesky decomposition (of class matrix.csr.chol) +list containing coefficients (vector or matrix), the Cholesky decomposition (of class matrix.csr.chol), and a vector specifying the indicies of which values on the diagonal of x'x are nonzero. These are named "coef", "chol" and "gramian_reduction_index", respectively. } \description{ This function performs some checks and takes action to diff --git a/man/create_SparseM_reduction_matrix.Rd b/man/create_SparseM_reduction_matrix.Rd index edd7128..d93864d 100644 --- a/man/create_SparseM_reduction_matrix.Rd +++ b/man/create_SparseM_reduction_matrix.Rd @@ -7,7 +7,7 @@ create_SparseM_reduction_matrix(zeroes) } \arguments{ -\item{zeroes}{logical vector indicating which entries of x'x are zeroes.} +\item{zeroes}{logical vector indicating which entries of the diagonal of x'x are zeroes.} } \value{ SparseM matrix that will reduce the dimension of x'x and xy From 832bbc1d388dca545cefd65565b45cd6f134f56e Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Wed, 26 Jun 2024 14:55:33 -0400 Subject: [PATCH 12/13] integrating renamed function --- R/utils.R | 4 ++-- tests/testthat/test.utils.R | 16 ++++++++-------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/utils.R b/R/utils.R index 903ba33..0f62835 100644 --- a/R/utils.R +++ b/R/utils.R @@ -241,7 +241,7 @@ slm_fit_csr <- function(x, y, ...) { #' @param zeroes logical vector indicating which entries of the diagonal of x'x are zeroes. #' @return SparseM matrix that will reduce the dimension of x'x and xy #' @importFrom SparseM chol backsolve -create_SparseM_reduction_matrix <- function(zeroes) +gramian_reduction <- function(zeroes) { if (all(zeroes)) { @@ -288,7 +288,7 @@ SparseM_solve <- function(x, y, ...) zeroes <- diag.xx == 0 if (any(zeroes)) #check explicitly for zeroes here so we don't do matrix math without needing to { # this branch deals with issue 134 - reducing_matrix <- create_SparseM_reduction_matrix(zeroes) + reducing_matrix <- gramian_reduction(zeroes) xpx.sub <- t(reducing_matrix) %*% xprimex %*% reducing_matrix xy.sub <- t(reducing_matrix) %*% xy chol.result <- SparseM::chol(xpx.sub, ...) diff --git a/tests/testthat/test.utils.R b/tests/testthat/test.utils.R index 7c9dbc8..f9ae624 100644 --- a/tests/testthat/test.utils.R +++ b/tests/testthat/test.utils.R @@ -54,7 +54,7 @@ test_that("sparse design strat mean calculator returns 0 for strata w/o non-null } ) -test_that("create_SparseM_reduction_matrix works as expected", +test_that("gramian_reduction works as expected", { expect_true(require("SparseM")) #let tl stand in for xprimex @@ -63,7 +63,7 @@ test_that("create_SparseM_reduction_matrix works as expected", zeroes <- diag(tl) == 0 not.zeroes <- !zeroes stl <- tl[, not.zeroes] - sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + sparse_matrix <- gramian_reduction(zeroes) expect_identical(stl, as.matrix(sparse_matrix)) @@ -72,7 +72,7 @@ test_that("create_SparseM_reduction_matrix works as expected", zeroes <- diag(tl) == 0 not.zeroes <- !zeroes stl <- tl[, not.zeroes] - sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + sparse_matrix <- gramian_reduction(zeroes) expect_identical(stl, as.matrix(sparse_matrix)) @@ -82,7 +82,7 @@ test_that("create_SparseM_reduction_matrix works as expected", zeroes <- diag(tl) == 0 not.zeroes <- !zeroes stl <- tl[, not.zeroes] - sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + sparse_matrix <- gramian_reduction(zeroes) expect_identical(stl, as.matrix(sparse_matrix)) @@ -92,7 +92,7 @@ test_that("create_SparseM_reduction_matrix works as expected", zeroes <- diag(tl) == 0 not.zeroes <- !zeroes stl <- tl[, not.zeroes] - sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + sparse_matrix <- gramian_reduction(zeroes) expect_identical(stl, as.matrix(sparse_matrix)) @@ -101,7 +101,7 @@ test_that("create_SparseM_reduction_matrix works as expected", zeroes <- diag(tl) == 0 not.zeroes <- !zeroes stl <- tl[, not.zeroes] - sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + sparse_matrix <- gramian_reduction(zeroes) expect_identical(stl, as.matrix(sparse_matrix)) @@ -110,7 +110,7 @@ test_that("create_SparseM_reduction_matrix works as expected", zeroes <- diag(tl) == 0 not.zeroes <- !zeroes stl <- tl[, not.zeroes, drop = FALSE] - sparse_matrix <- create_SparseM_reduction_matrix(zeroes) + sparse_matrix <- gramian_reduction(zeroes) expect_identical(stl, as.matrix(sparse_matrix)) @@ -118,7 +118,7 @@ test_that("create_SparseM_reduction_matrix works as expected", diag(tl)[c(1, 2)] <- 0 zeroes <- diag(tl) == 0 - expect_error(create_SparseM_reduction_matrix(zeroes)) + expect_error(gramian_reduction(zeroes)) } ) From 5728a2729df206950eb3880ce64f532d8c8e283a Mon Sep 17 00:00:00 2001 From: Adam Rauh Date: Wed, 26 Jun 2024 14:56:17 -0400 Subject: [PATCH 13/13] updating docs with new name --- ...ate_SparseM_reduction_matrix.Rd => gramian_reduction.Rd} | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) rename man/{create_SparseM_reduction_matrix.Rd => gramian_reduction.Rd} (81%) diff --git a/man/create_SparseM_reduction_matrix.Rd b/man/gramian_reduction.Rd similarity index 81% rename from man/create_SparseM_reduction_matrix.Rd rename to man/gramian_reduction.Rd index d93864d..e657a51 100644 --- a/man/create_SparseM_reduction_matrix.Rd +++ b/man/gramian_reduction.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R -\name{create_SparseM_reduction_matrix} -\alias{create_SparseM_reduction_matrix} +\name{gramian_reduction} +\alias{gramian_reduction} \title{Helper function to slm_fit_csr} \usage{ -create_SparseM_reduction_matrix(zeroes) +gramian_reduction(zeroes) } \arguments{ \item{zeroes}{logical vector indicating which entries of the diagonal of x'x are zeroes.}