R/dataclasses.R

In insightsengineering/rbmi: Reference Based Multiple Imputation

#' Create object of `sample_single` class
#'
#' @description
#' Creates an object of class `sample_single` which is a named list
#' containing the input parameters and validate them.
#'
#' @param ids Vector of characters containing the ids of the subjects included in the original dataset.
#' @param beta Numeric vector of estimated regression coefficients.
#' @param sigma List of estimated covariance matrices (one for each level of `vars$group`).
#' @param theta Numeric vector of transformed covariances.
#' @param failed Logical. `TRUE` if the model fit failed.
#' @param ids_samp Vector of characters containing the ids of the subjects included in the given sample.
#'
#' @return
#' A named list of class `sample_single`. It contains the following:
#' - `ids` vector of characters containing the ids of the subjects included in the original dataset.
#' - `beta` numeric vector of estimated regression coefficients.
#' - `sigma` list of estimated covariance matrices (one for each level of `vars$group`).
#' - `theta` numeric vector of transformed covariances.
#' - `failed` logical. `TRUE` if the model fit failed.
#' - `ids_samp` vector of characters containing the ids of the subjects included in the given sample.
#'
sample_single <- function(
    ids,
    beta = NA,
    sigma = NA,
    theta = NA,
    failed = any(is.na(beta)),
    ids_samp = ids
) {
    x <- list(
        ids = ids,
        failed = failed,
        beta = beta,
        sigma = sigma,
        theta = theta,
        ids_samp = ids_samp
    )
    class(x) <- c("sample_single", "list")
    validate(x)
    return(x)
}


#' Validate `sample_single` object
#'
#' @param x A `sample_single` object generated by [sample_single()].
#' @param ... Not used.
#' @export
validate.sample_single <- function(x, ...) {

    assert_that(
        x$failed %in% c(TRUE, FALSE),
        is.character(x$ids),
        length(x$ids) > 1,
        is.character(x$ids_samp),
        length(x$ids_samp) > 1
    )

    if (x$failed == TRUE) {
        assert_that(
            is.na(x$beta),
            is.na(x$sigma),
            is.na(x$theta)
        )
    } else {
        assert_that(
            is.numeric(x$beta),
            all(!is.na(x$beta)),
            is.list(x$sigma),
            !is.null(names(x$sigma)),
            all(vapply(x$sigma, is.matrix, logical(1)))
        )
    }
}








#' Create and validate a `sample_list` object
#'
#' @description
#' Given a list of `sample_single` objects generate by [sample_single()],
#' creates a `sample_list` objects and validate it.
#'
#'
#' @param ... A list of `sample_single` objects.
sample_list <- function(...) {
    x <- list(...)
    if (length(x) == 1 && !has_class(x[[1]], "sample_single")) {
        x <- x[[1]]
    }
    class(x) <- c("sample_list", "list")
    validate(x)
    return(x)
}


#' Validate `sample_list` object
#'
#' @param x A `sample_list` object generated by [sample_list()].
#' @param ... Not used.
#' @export
validate.sample_list <- function(x, ...) {
    assert_that(
        is.null(names(x)),
        all(vapply(x, has_class, logical(1), "sample_single")),
        all(vapply(x, validate, logical(1)))
    )
}







#' Create a valid `imputation_single` object
#'
#' @param id a character string specifying the subject id.
#' @param values a numeric vector indicating the imputed values.
imputation_single <- function(id, values) {
    x <- list(id = id, values = values)
    class(x) <- c("imputation_single", "list")
    return(x)
}

#' @export
print.imputation_single <- function(x, ...) {
    cat(sprintf("imputation_single: id=%s values=%s\n", x$id, repr(x$values)))
}







#' Create a valid `imputation_df` object
#'
#' @param ... a list of `imputation_single`.
imputation_df <- function(...) {
    x <- list(...)
    if (length(x) == 1 && class(x[[1]])[[1]] != "imputation_single") {
        x <- x[[1]]
    }
    class(x) <- c("imputation_df", "list")
    return(x)
}

#' @export
validate.imputation_df <- function(x, ...) {

    assert_that(
        is.null(names(x)),
        all(vapply(x, function(x) class(x)[[1]] == "imputation_single", logical(1)))
    )

    is_valid_imputation_single <- function(x) {
        length(x$id) == 1 &
            is.character(x$id) &
            (is.numeric(x$values) | is.null(x$values))
    }

    are_singles_valid <- vapply(x, is_valid_imputation_single, logical(1))
    assert_that(all(are_singles_valid))
    return(TRUE)
}

#' @export
print.imputation_df <- function(x, ...) {
    validate(x)
    cat("imputation_df:\n")
    for (i in x) {
        cat("  ")
        print(i)
    }
}








#' A collection of `imputation_singles()` grouped by a single subjid ID
#'
#' @param imputations a list of [imputation_single()] objects ordered so that repetitions
#' are grouped sequentially
#' @param D the number of repetitions that were performed which determines how many columns
#' the imputation matrix should have
#'
#' This is a constructor function to create a `imputation_list_single` object
#' which contains a matrix of [imputation_single()] objects grouped by a single `id`. The matrix
#' is split so that it has D columns (i.e. for non-bmlmi methods this will always be 1)
#'
#' The `id` attribute is determined by extracting the `id` attribute from the contributing
#' [imputation_single()] objects. An error is throw if multiple `id` are detected
imputation_list_single <- function(imputations, D = 1) {

    ids <- vapply(imputations, `[[`, character(1), "id")
    id <- unique(ids)

    assert_that(
        length(imputations) %% D == 0,
        length(id) == 1,
        msg = "multiple `ids` were detected"
    )

    x <- list(
        id = id,
        imputations = matrix(imputations, ncol = D, byrow = TRUE)
    )
    class(x) <- c("imputation_list_single", "list")
    return(x)
}


#' @export
validate.imputation_list_single <- function(x, ...) {
    assert_that(
        is.character(x$id),
        length(x$id) == 1,
        is.matrix(x$imputations),
        all(apply(x$imputations, c(1, 2), function(z) has_class(z[[1]], "imputation_single"))),
        all(vapply(x$imputations, `[[`, character(1), "id") == x$id)
    )
    return(TRUE)
}

#' @export
print.imputation_list_single <- function(x, ...) {
    validate(x)
    cat(sprintf("imputation_list_single:\n"))
    cat(sprintf("  id: %s\n", x$id))
    cat(sprintf("  imputations: %s by %s matrix\n", nrow(x$imputations), ncol(x$imputations)))
}








#' List of imputations_df
#'
#' A container for multiple [imputation_df]'s
#'
#' @param ... objects of class `imputation_df`
imputation_list_df <- function(...) {
    x <- list(...)
    class(x) <- c("imputation_list_df", "list")
    return(x)
}


#' @export
validate.imputation_list_df <- function(x, ...) {
    assert_that(
        all(vapply(x, has_class, logical(1), "imputation_df")),
        all(vapply(x, validate, logical(1)))
    )
}

#' @export
print.imputation_list_df <- function(x, ...) {
    validate(x)
    lens <- vapply(x, length, numeric(1))
    cat(sprintf("imputation_list_df:\n"))
    for (i in lens) {
        cat(sprintf("  imputation_df: %s imputation_single's\n", i))
    }
}




repr <- function(x, ...) {
    UseMethod("repr")
}

#' @export
repr.numeric <- function(x, ...) {
    paste0("c(", paste0(round(x, 2), collapse = ", "), ")")
}