Skip to content

Commit

Permalink
slightly better error handling in core calculations
Browse files Browse the repository at this point in the history
  • Loading branch information
mayer79 committed Nov 7, 2023
1 parent 2062c6f commit 096e969
Show file tree
Hide file tree
Showing 3 changed files with 13 additions and 11 deletions.
15 changes: 5 additions & 10 deletions R/utils_calculate.R
Original file line number Diff line number Diff line change
Expand Up @@ -85,7 +85,7 @@ wcolMeans <- function(x, w = NULL) {
#' @noRd
#' @keywords internal
#'
#' @param x Factor.
#' @param x Factor-like.
#' @returns Named vector.
colMeans_factor <- function(x) {
x <- as.factor(x)
Expand Down Expand Up @@ -133,9 +133,6 @@ wrowmean <- function(x, ngroups = 1L, w = NULL) {
}

# General version
if (!is.matrix(x)) {
x <- as.matrix(x)
}
wrowmean_matrix(x, ngroups = ngroups, w = w)
}

Expand All @@ -146,13 +143,11 @@ wrowmean <- function(x, ngroups = 1L, w = NULL) {
#' @noRd
#' @keywords internal
#'
#' @param x Factor.
#' @param x Factor-like.
#' @param ngroups Number of subsequent, equals sized groups.
#' @returns Matrix with column names.
rowmean_factor <- function(x, ngroups = 1L) {
if (!is.factor(x)) {
stop("x must be a factor.")
}
x <- as.factor(x)
lev <- levels(x)
n_bg <- length(x) %/% ngroups
dim(x) <- c(n_bg, ngroups)
Expand Down Expand Up @@ -192,13 +187,13 @@ wrowmean_vector <- function(x, ngroups = 1L, w = NULL) {
#' @noRd
#' @keywords internal
#'
#' @param x Matrix.
#' @param x Matrix-like.
#' @param ngroups Number of subsequent, equals sized groups.
#' @param w Optional vector of case weights of length `NROW(x) / ngroups`.
#' @returns Matrix.
wrowmean_matrix <- function(x, ngroups = 1L, w = NULL) {
if (!is.matrix(x)) {
stop("x must be a matrix.")
x <- as.matrix(x)
}
n_bg <- nrow(x) %/% ngroups
g <- rep_each(ngroups, each = n_bg) # rep(seq_len(ngroups), each = n_bg)
Expand Down
8 changes: 8 additions & 0 deletions backlog/colMeans_factors.R
Original file line number Diff line number Diff line change
Expand Up @@ -17,3 +17,11 @@ gcolMeans_factor <- function(x, g = NULL) {
out
}

wrowmean_matrix2 <- function(x, ngroups = 1L, w = NULL) {
if (!is.matrix(x)) {
stop("x must be a matrix.")
}
dim(x) <- c(nrow(x)/ngroups, ngroups, ncol(x))
out <- colMeans(aperm(x, c(1, 3, 2)))
t.default(out)
}
1 change: 0 additions & 1 deletion tests/testthat/test_calculate.R
Original file line number Diff line number Diff line change
Expand Up @@ -112,7 +112,6 @@ test_that("rowmean_factor() works for factor input", {
x <- factor(c("C", "A", "C", "C", "A", "A"))
out <- rowmean_factor(x, ngroups = 2L)

expect_error(rowmean_factor(1:3))
expect_true(is.matrix(out))
expect_equal(out, cbind(A = c(1/3, 2/3), C = c(2/3, 1/3)))
expect_equal(out, wrowmean_matrix(fdummy(x), ngroups = 2L))
Expand Down

0 comments on commit 096e969

Please sign in to comment.