feat: add correlation figure/table

R/compute_correlations.R

@@ -5,9 +5,14 @@
 #' a model fitted by `time_model()`, compute the correlations between
 #' each intervals derived parameters.
 #'
-#' @param dt A `data.frame` with AUC or slopes for each individuals/samples.
+#' @param fit A model object from a statistical model such as
+#'   from a call to `time_model()`.
+#' @param method The type of model provided in `fit`,
+#'   _i.e._, one of `"cubic_slope"`, `"linear_splines"` or `"cubic_splines"`.
+#' @param period The intervals knots on which AUCs are to be computed.
+#' @param knots The knots as defined `fit` and according to `method`.
 #'
-#' @return A `data.frame` with correlations between each intervals derived parameters.
+#' @return A `ggplot2` object with correlations between each intervals derived parameters.
 #'
 #' @export
 #'
@@ -20,7 +25,7 @@
 #'   data = bmigrowth[bmigrowth[["sex"]] == 0, ],
 #'   method = "linear_splines"
 #' )
-#' aucs <- compute_aucs(
+#' compute_correlations(
 #'   fit = ls_mod,
 #'   method = "linear_splines",
 #'   period = c(0, 0.5, 1.5, 3.5, 6.5, 10, 12, 17)#,
@@ -30,7 +35,43 @@
 #'   #   "cubic_splines" = c(2, 8, 12)
 #'   # )[[method]]
 #' )
-#' compute_correlations(aucs)
-compute_correlations <- function(data) {
-
+compute_correlations <- function(
+  fit,
+  method,
+  period = c(0, 0.5, 1.5, 3.5, 6.5, 10, 12, 17),
+  knots = list(
+    "cubic_slope" = NULL,
+    "linear_splines" = c(5.5, 11),
+    "cubic_splines" = c(2, 8, 12)
+  )[[method]]
+) {
+  pl <- lapply(
+    X = list(
+      compute_aucs(fit, method, period, knots),
+      compute_slopes(fit, method, period, knots)
+    ),
+    FUN = function(data) {
+      data_corrr_fmt <- data_corrr <- corrr::correlate(data[grep("^auc_|^slope_", names(data))])
+      data_corrr_fmt[, -1] <- round(data_corrr_fmt[, -1], digits = 3)
+      patchwork::wrap_plots(
+        gridExtra::tableGrob(data_corrr_fmt),
+        corrr::network_plot(
+          rdf = data_corrr,
+          min_cor = 0,
+          colors = c("#b22222", "#22b222")
+        ) +
+        ggplot2::theme(legend.position = "top") +
+        ggplot2::guides(
+          color = ggplot2::guide_colourbar(
+            barwidth = ggplot2::unit(0.25, "npc"),
+            barheight = ggplot2::unit(0.05, "npc")
+          )
+        ) +
+        ggplot2::theme(plot.margin = ggplot2::unit(c(0.5, 0.5, 0.5, 0.5), "lines")),
+        ncol = 1,
+        heights = c(0.3, 0.70)
+      )
+    }
+  )
+  patchwork::wrap_plots(pl, ncol = 2, nrow = 1)
 }

R/egg_correlations.R

@@ -0,0 +1,65 @@
+
+#' Compute correlations the derived parameters from a cubic splines mixed-effects model by `egg_model()`.
+#'
+#' Based on computed area under the curves (_i.e._, `egg_aucs()`)
+#' and slopes (_i.e._, `egg_slopes()`) for several intervals using
+#' a model fitted by `egg_model()`, compute the correlations between
+#' each intervals derived parameters.
+#'
+#' @param fit A model object from a statistical model
+#'   such as from a call to `egg_model()`.
+#' @param period The intervals knots on which slopes are to be computed.
+#' @param knots The knots as defined `fit` and according to `method`.
+#'
+#' @return A `ggplot2` object with correlations between each intervals derived parameters.
+#'
+#' @export
+#'
+#' @examples
+#' data("bmigrowth")
+#' res <- egg_model(
+#'   formula = log(bmi) ~ age,
+#'   data = bmigrowth[bmigrowth[["sex"]] == 0, ],
+#'   id_var = "ID",
+#'   random_complexity = 1
+#' )
+#' egg_correlations(
+#'   fit = res,
+#'   period = c(0, 0.5, 1.5, 3.5, 6.5, 10, 12, 17),
+#'   knots = c(2, 8, 12)
+#' )
+egg_correlations <- function(
+  fit,
+  period = c(0, 0.5, 1.5, 3.5, 6.5, 10, 12, 17),
+  knots = c(2, 8, 12)
+) {
+pl <- lapply(
+    X = list(
+      egg_aucs(fit, period, knots),
+      egg_slopes(fit, period, knots)
+    ),
+    FUN = function(data) {
+      data_corrr_fmt <- data_corrr <- corrr::correlate(data[grep("^auc_|^slope_", names(data))])
+      data_corrr_fmt[, -1] <- round(data_corrr_fmt[, -1], digits = 3)
+      patchwork::wrap_plots(
+        gridExtra::tableGrob(data_corrr_fmt),
+        corrr::network_plot(
+          rdf = data_corrr,
+          min_cor = 0,
+          colors = c("#b22222", "#22b222")
+        ) +
+        ggplot2::theme(legend.position = "top") +
+        ggplot2::guides(
+          color = ggplot2::guide_colourbar(
+            barwidth = ggplot2::unit(0.25, "npc"),
+            barheight = ggplot2::unit(0.05, "npc")
+          )
+        ) +
+        ggplot2::theme(plot.margin = ggplot2::unit(c(0.5, 0.5, 0.5, 0.5), "lines")),
+        ncol = 1,
+        heights = c(0.3, 0.70)
+      )
+    }
+  )
+  patchwork::wrap_plots(pl, ncol = 2, nrow = 1)
+}

R/run_eggla.R

@@ -76,6 +76,9 @@ run_eggla <- function(
   measurement <- param <- NULL # no visible binding for global variable from data.table
 
   working_directory <- normalizePath(working_directory)
+
+  period <- c(0, 0.5, 1.5, 3.5, 6.5, 10, 12, 17)
+  knots <- c(2, 8, 12)
 
   dt_long <- data.table::melt(
     data = data.table::as.data.table(data)[
@@ -158,6 +161,7 @@ run_eggla <- function(
         id_var = "egg_id",
         random_complexity = random_complexity,
         use_car1 = use_car1,
+        knots = knots,
         quiet = quiet
       )
 
@@ -179,27 +183,12 @@ run_eggla <- function(
         file = file.path(results_directory, "model-coefficients.csv")
       )
 
-      data.table::fwrite(
-        x = egg_slopes(
-          fit = results,
-          period = c(0, 0.5, 1.5, 3.5, 6.5, 10, 12, 17)
-        ),
-        file = file.path(results_directory, "derived-slopes.csv")
-      )
-
-      data.table::fwrite(
-        x = egg_aucs(
-          fit = results,
-          period = c(0, 0.5, 1.5, 3.5, 6.5, 10, 12, 17)
-        ),
-        file = file.path(results_directory, "derived-aucs.csv")
-      )
-
       grDevices::png(
         filename = file.path(results_directory, "model-residuals.png"),
-        width = 600,
-        height = 480,
-        res = 72
+        width = 4 * 2.5,
+        height = 3 * 2.5,
+        units = "in",
+        res = 120
       )
       print(
         plot_residuals(
@@ -217,6 +206,38 @@ run_eggla <- function(
       )
       invisible(grDevices::dev.off())
 
+      data.table::fwrite(
+        x = egg_slopes(
+          fit = results,
+          period = period,
+          knots = knots
+        ),
+        file = file.path(results_directory, "derived-slopes.csv")
+      )
+
+      data.table::fwrite(
+        x = egg_aucs(
+          fit = results,
+          period = period,
+          knots = knots
+        ),
+        file = file.path(results_directory, "derived-aucs.csv")
+      )
+
+      grDevices::png(
+        filename = file.path(results_directory, "model-correlations.png"),
+        width = 4 * 2.5,
+        height = 3 * 2.5,
+        units = "in",
+        res = 120
+      )
+      print(egg_correlations(
+        fit = results,
+        period = period,
+        knots = knots
+      ))
+      invisible(grDevices::dev.off())
+
       owd <- getwd()
       on.exit(setwd(owd), add = TRUE)
       setwd(results_directory)

pkgdown/_pkgdown.yml

@@ -19,13 +19,15 @@ reference:
     - plot_aucs
     - compute_slopes
     - plot_slopes
+    - compute_correlations
     - gsp
   - title: Cubic Splines (Random Cubic/Linear Splines) Functions
     desc: Functions dedicated to work with cubic Splines mixed model.
     contents:
     - egg_model
     - egg_aucs
     - egg_slopes
+    - egg_correlations
     - plot_egg_aucs
     - plot_egg_slopes
     - run_eggla