Added functional segmentation configuration

Signed-off-by: Liang Zhang <psychelzh@outlook.com>

R/constants.R

@@ -137,3 +137,4 @@ hypers_cpm <- dplyr::bind_rows(
     thresh_level = c(0.01, 0.025, 0.05, 0.1)
   )
 )
+names_exclude <- c("file_fc", "fd", "file_atlas_dseg")

R/cpm.R

@@ -46,6 +46,36 @@ calc_dice_pairs <- function(result, level) {
     enframe(name = "network", value = "dice")
 }
 
+calc_edges_enrich <- function(result, atlas_dseg, level = 0.5) {
+  cbind(
+    as_tibble(
+      t(combn(atlas_dseg$network_label, 2)),
+      .name_repair = ~ c("row", "col")
+    ),
+    result$edges > level * length(unique(result$folds))
+  ) |>
+    drop_na() |>
+    mutate(
+      label_x = pmin(row, col),
+      label_y = pmax(row, col),
+      .keep = "unused"
+    ) |>
+    pivot_longer(
+      c(pos, neg),
+      names_to = "network",
+      values_to = "val"
+    ) |>
+    summarise(
+      n = sum(val),
+      total = n(),
+      .by = c(label_x, label_y, network)
+    ) |>
+    mutate(
+      prop = n / total,
+      enrich = (n / sum(n)) / (total / sum(total))
+    )
+}
+
 match_confounds <- function(users_confounds, fd_mean) {
   subjs <- intersect(rownames(users_confounds), rownames(fd_mean))
   cbind(users_confounds[subjs, ], fd_mean[subjs, ])

R/tar_factories.R

@@ -330,6 +330,14 @@ tar_prepare_cpm_data <- function(config) {
         ))
       }
     ),
+    tarchetypes::tar_eval(
+      tar_target(
+        file_atlas_dseg,
+        path_obj_from_proj(sprintf("atlas_dseg_%s", atlas), "prepare_neural"),
+        format = "file_fast"
+      ),
+      dplyr::distinct(config, atlas, file_atlas_dseg)
+    ),
     # commonly used targets
     tarchetypes::tar_file_read(
       users_confounds,

R/tar_prepare.R

@@ -16,8 +16,9 @@ prepare_config_cpm_data <- function(...) {
     dplyr::mutate(
       file_fc = rlang::syms(sprintf("file_fc_%s", name_suffix_fc)),
       fd = rlang::syms(sprintf("fd_%s", name_suffix_fd)),
-      .keep = "unused"
-    )
+      file_atlas_dseg = rlang::syms(sprintf("file_atlas_dseg_%s", atlas))
+    ) |>
+    dplyr::select(!tidyselect::starts_with("name_suffix"))
 }
 
 prepare_config_retest <- function(contents, name_suffix = NULL) {

_scripts/bench_cpm.R

@@ -16,7 +16,7 @@ config_cpm <- tidyr::expand_grid(
   hypers_cpm,
   bench_indices
 )
-names_exclude <- c("file_fc", "fd", "scores")
+names_exclude <- c(names_exclude, "scores")
 cpm_branches <- tarchetypes::tar_map(
   config_cpm,
   names = !all_of(names_exclude),

_scripts/g_factor.R

@@ -91,7 +91,7 @@ branches_g <- tarchetypes::tar_map(
           thresh_level == 0.01
         )
     ),
-    names = !c(file_fc, fd),
+    names = !all_of(names_exclude),
     tarchetypes::tar_rep2(
       cpm_result,
       lapply_tar_batches(

_scripts/predict_phenotypes.R

@@ -21,7 +21,7 @@ cpm_branches <- tarchetypes::tar_map(
     config_cpm_data,
     hypers_cpm
   ),
-  names = !c(file_fc, fd),
+  names = !all_of(names_exclude),
   tar_target(
     cpm_result,
     apply(
@@ -46,15 +46,26 @@ cpm_branches <- tarchetypes::tar_map(
       list_rbind(names_to = "latent"),
     retrieval = "worker",
     storage = "worker"
+  ),
+  tar_target(
+    edges_enrich,
+    lapply(
+      cpm_result,
+      calc_edges_enrich,
+      atlas_dseg = qs::qread(file_atlas_dseg)
+    ) |>
+      list_rbind(names_to = "latent"),
+    retrieval = "worker",
+    storage = "worker"
   )
 )
 
 cpm_branches_perms <- tarchetypes::tar_map(
   tidyr::expand_grid(
     config_cpm_data,
     hypers_cpm
-    ),
-  names = !c(file_fc, fd),
+  ),
+  names = !all_of(names_exclude),
   tarchetypes::tar_rep(
     cpm_result_perm,
     apply(
@@ -103,6 +114,16 @@ list(
     ),
     deployment = "main"
   ),
+  tarchetypes::tar_combine(
+    edges_enrich,
+    cpm_branches$edges_enrich,
+    command = bind_rows_meta(
+      !!!.x,
+      .names = c(names(config_fc), names(hypers_cpm)),
+      .prefix = "edges_enrich"
+    ),
+    deployment = "main"
+  ),
   cpm_branches_perms,
   tarchetypes::tar_combine(
     cpm_performance_perm,