Adding ARI and ICL compute

analysis_benchmark_lbm_seq.qmd

@@ -155,22 +155,31 @@ membership_to_df <- function(membership_list, suffix = 1) {
     })
 }
 
-seq_df <- lapply(seq_along(seq_memberships), function(idx) {
+dispatch_membership_to_df <- function(memberships) {
-    membership_to_df(seq_memberships[[idx]], suffix = idx + 1)
+    mdf <- lapply(seq_along(memberships), function(idx) {
-})
+        membership_to_df(memberships[[idx]], suffix = idx + 1)
+    })
 
-seq_df_otu <- lapply(seq_df, function(df) {
+    df_otu <- lapply(mdf, function(df) {
-    df$Z1
+        df$Z1
-}) %>% # Below we join by the ranks
+    }) %>% # Below we join by the ranks
-    reduce(left_join) %>%
+        reduce(left_join) %>%
-    select(sort(names(.)))
+        select(sort(names(.)))
+
+    df_sample <- lapply(mdf, function(df) {
+        df$Z2
+    }) %>% reduce(left_join, by = "Rank1")
 
 
+    return(list(df_otu = df_otu, df_sample = df_sample))
+}
+seq_df_otu_samples <- dispatch_membership_to_df(seq_memberships)
+seq_df_otu <- seq_df_otu_samples$df_otu
+seq_df_sample <- seq_df_otu_samples$df_sample
 
-seq_df_sample <- lapply(seq_df, function(df) {
+notrans_df_otu_samples <- dispatch_membership_to_df(notrans_memberships)
-    df$Z2
+notrans_df_otu <- notrans_df_otu_samples$df_otu
-}) %>% reduce(left_join, by = "Rank1")
+notrans_df_sample <- notrans_df_otu_samples$df_sample
-
 
 seq_df_sample_lodes <- to_lodes_form(seq_df_sample, key = "x", axes = 2:5)
 seq_df_otu_lodes <- to_lodes_form(seq_df_otu, key = "x", axes = 6:9)
@@ -191,4 +200,31 @@ ggplot(seq_df_otu_lodes, aes(x = x, alluvium = alluvium, stratum = stratum, labe
     geom_alluvium(aes(fill = Rank2)) +
     geom_stratum() +
     geom_text(stat = "stratum")
+```
+
+```{r}
+ARI_ranks <- function(df_otu) {
+memb_mat <- df_otu |> select(starts_with("Z"))
+memb_list <- lapply(seq_len(ncol(memb_mat)), function(i) memb_mat[,i] |> unlist() |> as.vector())
+outer(memb_list,memb_list, FUN = Vectorize(ARI))}
+ARI_ranks(seq_df_otu)
+ARI_ranks(notrans_df_otu)
+```
+
+```{r}
+# Extract ICL
+ICL_per_ranks <- function(model_results) {
+    model_rank_list <- lapply(model_results, function(model_per_rank) model_per_rank[[1]]) # Extract first rep per rank
+    return(sapply(model_rank_list, function(model) max(model$ICL, na.rm = TRUE)))
+}
+ICL_df <- data.frame("No trans" = ICL_per_ranks(notrans_results), "Seq" =
+ICL_per_ranks(seq_results)) %>% t() %>% as.data.frame()
+```
+
+```{r}
+library(kableExtra)
+ICL_df %>% mutate_all(cell_spec(., bold = ifelse(is..)))
+
+
+kable(ICL_df)
 ```