R/extract_model_properties.R

In OxWearables/epicoda: Supports epidemiological analyses using compositional exposure variables

#' Extract dataset from model object
#'
#' Used by predict_fit_and_ci and plot_transfers.
#'
#' @inheritParams predict_fit_and_ci
#' @param transf_labels Ilr-transformed compositional column labels.
#' @param type Model type.
#' @return Dataset used to create model with compositional columns on original scale.
#' @export
#' @examples
#' lm_outcome <- comp_model(
#' type = "linear",
#' outcome = "BMI",
#' covariates = c("agegroup", "sex"),
#' data = simdata,
#' comp_labels = c("vigorous", "moderate", "light", "sedentary", "sleep"),
#' det_limit = 0.00119
#' )
#'
#' comp_labels <- c("vigorous", "moderate", "light", "sedentary", "sleep")
#' tl <- transf_labels(comp_labels = comp_labels, transformation_type = "ilr")
#' get_dataset_from_model(model = lm_outcome, comp_labels = comp_labels,
#'                        transf_labels = tl, type = "linear")
get_dataset_from_model <- function(model, comp_labels, transf_labels, type){
  ## We get dataset from model frame
  dataset <- stats::model.frame(model)

  ## We verify that the correct column names are present
  if (!(all(transf_labels  %in% colnames(dataset)[grepl("ilr", colnames(dataset))]))){
    stop("Specified comp_labels do not match those used to develop the model (e.g. different order?)")
  }
  if (!(all(colnames(dataset)[grepl("ilr", colnames(dataset))] %in% transf_labels))){
    stop("Specified comp_labels do not match those used to develop the model (e.g. missing labels?)")
  }

  ## We add the compositional columns on the untransformed scale
  comp_cols <- ilr_trans_inv(dataset[, transf_labels])
  colnames(comp_cols) <- comp_labels
  dataset <- cbind(dataset, comp_cols)

  ## We remove the "strata" prefix from any Cox strata variables
  if (type == "cox"){
    strata_list <- colnames(dataset)[grepl("strata\\(",colnames(dataset) )]
    for (name in strata_list){
      plain <- gsub("strata\\(", "", name)
      plain <- gsub("\\)", "", plain)
      dataset[, plain] <- dataset[, name]
  }
  }

  ## We return the dataset without the compositional columns
  dataset_ready <- dataset[,!(colnames(dataset) %in% c(transf_labels, "survival_object"))]

  return(dataset_ready)
}


#' Extract compositional mean from model object
#'
#' Used by predict_fit_and_ci and plot_transfers.
#'
#' @inheritParams predict_fit_and_ci
#' @param transf_labels Ilr-transformed compositional column labels.
#' @return Compositional mean of data used to create models, on both original and transformed scale (two element list).
#' @export
#' @examples
#' lm_outcome <- comp_model(
#' type = "linear",
#' outcome = "BMI",
#' covariates = c("agegroup", "sex"),
#' data = simdata,
#' comp_labels = c("vigorous", "moderate", "light", "sedentary", "sleep"),
#' det_limit = 0.00119
#' )
#'
#' comp_labels <- c("vigorous", "moderate", "light", "sedentary", "sleep")
#' tl <- transf_labels(comp_labels = comp_labels, transformation_type = "ilr")
#' get_cm_from_model(model = lm_outcome, comp_labels = comp_labels,
#' transf_labels = tl)
get_cm_from_model <- function(model, comp_labels, transf_labels){
  mm <- stats::model.frame(model)[, transf_labels]
  cm_transf_df <- apply(mm, 2, mean)
  cm_transf_df <- as.data.frame(t(cm_transf_df))
  cm <- ilr_trans_inv(cm_transf_df)
  colnames(cm) <- comp_labels
return(list("cm"= cm, "cm_transf_df" = cm_transf_df))
}