Try simpler df joining

qhtcp-workflow/apps/r/calculate_interaction_zscores.R

@@ -281,7 +281,7 @@ calculate_interaction_scores <- function(df, max_conc) {
 
   interactions <- stats %>%
     group_by(across(all_of(group_vars))) %>%
-    summarise(
+    mutate(
       OrfRep = first(OrfRep),
       Gene = first(Gene),
       num = first(num),
@@ -294,33 +294,47 @@ calculate_interaction_scores <- function(df, max_conc) {
       Z_Shift_L = first(Z_Shift_L),
       Z_Shift_K = first(Z_Shift_K),
       Z_Shift_r = first(Z_Shift_r),
-      Z_Shift_AUC = first(Z_Shift_AUC),
+      Z_Shift_AUC = first(Z_Shift_AUC)
+    )
+
+  # Summarise the data to calculate summary statistics
+  summary_stats <- interactions %>%
+    summarise(
       Sum_Zscore_L = sum(Zscore_L, na.rm = TRUE),
       Sum_Zscore_K = sum(Zscore_K, na.rm = TRUE),
       Sum_Zscore_r = sum(Zscore_r, na.rm = TRUE),
       Sum_Zscore_AUC = sum(Zscore_AUC, na.rm = TRUE),
-      lm_Score_L = max_conc * coef(lm_L)[2] + coef(lm_L)[1],
-      lm_Score_K = max_conc * coef(lm_K)[2] + coef(lm_K)[1],
-      lm_Score_r = max_conc * coef(lm_r)[2] + coef(lm_r)[1],
-      lm_Score_AUC = max_conc * coef(lm_AUC)[2] + coef(lm_AUC)[1],
-      R_Squared_L = summary(lm_L)$r.squared,
-      R_Squared_K = summary(lm_K)$r.squared,
-      R_Squared_r = summary(lm_r)$r.squared,
-      R_Squared_AUC = summary(lm_AUC)$r.squared,
-      lm_intercept_L = coef(lm_L)[1],
-      lm_slope_L = coef(lm_L)[2],
-      lm_intercept_K = coef(lm_K)[1],
-      lm_slope_K = coef(lm_K)[2],
-      lm_intercept_r = coef(lm_r)[1],
-      lm_slope_r = coef(lm_r)[2],
-      lm_intercept_AUC = coef(lm_AUC)[1],
-      lm_slope_AUC = coef(lm_AUC)[2],
+      lm_Score_L = max(conc_num) * coef(lm(Zscore_L ~ conc_num))[2] + coef(lm(Zscore_L ~ conc_num))[1],
+      lm_Score_K = max(conc_num) * coef(lm(Zscore_K ~ conc_num))[2] + coef(lm(Zscore_K ~ conc_num))[1],
+      lm_Score_r = max(conc_num) * coef(lm(Zscore_r ~ conc_num))[2] + coef(lm(Zscore_r ~ conc_num))[1],
+      lm_Score_AUC = max(conc_num) * coef(lm(Zscore_AUC ~ conc_num))[2] + coef(lm(Zscore_AUC ~ conc_num))[1],
+      R_Squared_L = summary(lm(Zscore_L ~ conc_num))$r.squared,
+      R_Squared_K = summary(lm(Zscore_K ~ conc_num))$r.squared,
+      R_Squared_r = summary(lm(Zscore_r ~ conc_num))$r.squared,
+      R_Squared_AUC = summary(lm(Zscore_AUC ~ conc_num))$r.squared,
+      lm_intercept_L = coef(lm(Zscore_L ~ conc_num))[1],
+      lm_slope_L = coef(lm(Zscore_L ~ conc_num))[2],
+      lm_intercept_K = coef(lm(Zscore_K ~ conc_num))[1],
+      lm_slope_K = coef(lm(Zscore_K ~ conc_num))[2],
+      lm_intercept_r = coef(lm(Zscore_r ~ conc_num))[1],
+      lm_slope_r = coef(lm(Zscore_r ~ conc_num))[2],
+      lm_intercept_AUC = coef(lm(Zscore_AUC ~ conc_num))[1],
+      lm_slope_AUC = coef(lm(Zscore_AUC ~ conc_num))[2],
       NG = sum(NG, na.rm = TRUE),
       DB = sum(DB, na.rm = TRUE),
       SM = sum(SM, na.rm = TRUE),
       .groups = "keep"
     )
 
+  # Join the summary data back to the original data
+  cleaned_interactions <- interactions %>%
+    select(-any_of(intersect(names(interactions), names(summary_stats))))
+  interactions_joined <- left_join(cleaned_interactions, summary_stats, by = group_vars)
+  interactions_joined <- interactions_joined %>% distinct()
+
+  # Remove duplicate rows if necessary
+  interactions <- interactions %>% distinct()
+
   num_non_removed_concs <- total_conc_num - sum(stats$DB, na.rm = TRUE) - 1
   
   interactions <- interactions %>%
@@ -353,10 +367,12 @@ calculate_interaction_scores <- function(df, max_conc) {
       "Zscore_L", "Zscore_K", "Zscore_r", "Zscore_AUC",
       "NG", "SM", "DB")
     
-  calculations_joined <- df %>% select(-any_of(setdiff(names(calculations), c("OrfRep", "Gene", "num", "conc_num", "conc_num_factor"))))
+  calculations_joined <- df %>%
+    select(-any_of(intersect(names(df), names(calculations))))
   calculations_joined <- left_join(calculations_joined, calculations, by = c("OrfRep", "Gene", "num", "conc_num", "conc_num_factor"))
 
-  interactions_joined <- df %>% select(-any_of(setdiff(names(interactions), c("OrfRep", "Gene", "num", "conc_num", "conc_num_factor"))))
+  interactions_joined <- df %>%
+    select(-any_of(intersect(names(df), names(interactions))))
   interactions_joined <- left_join(interactions_joined, interactions, by = c("OrfRep", "Gene", "num", "conc_num", "conc_num_factor"))
 
   return(list(calculations = calculations, interactions = interactions, interactions_joined = interactions_joined,
@@ -1234,7 +1250,7 @@ main <- function() {
 
     # TODO trying out some parallelization
     # future::plan(future::multicore, workers = parallel::detectCores())
-    future::plan(future::multicore, workers = 3)
+    future::plan(future::multisession, workers = 3)
 
     plot_configs <- list(
       list(out_dir = out_dir_qc, filename = "L_vs_K_before_quality_control",
@@ -1257,19 +1273,10 @@ main <- function() {
         plot_configs = delta_bg_outside_2sd_k_plot_configs)
     )
 
-    furrr::future_map(plot_configs, function(config) {
-      generate_and_save_plots(config$out_dir, config$filename, config$plot_configs)
-    }, .options = furrr_options(seed = TRUE))
-
-    # generate_and_save_plots(out_dir_qc, "L_vs_K_before_quality_control", l_vs_k_plots)
-    # generate_and_save_plots(out_dir_qc, "frequency_delta_background", frequency_delta_bg_plots)
-    # generate_and_save_plots(out_dir_qc, "L_vs_K_above_threshold", above_threshold_plots)
-    # generate_and_save_plots(out_dir_qc, "plate_analysis", plate_analysis_plot_configs)
-    # generate_and_save_plots(out_dir_qc, "plate_analysis_boxplots", plate_analysis_boxplot_configs)
-    # generate_and_save_plots(out_dir_qc, "plate_analysis_no_zeros", plate_analysis_no_zeros_plot_configs)
-    # generate_and_save_plots(out_dir_qc, "plate_analysis_no_zeros_boxplots", plate_analysis_no_zeros_boxplot_configs)
-    # generate_and_save_plots(out_dir_qc, "L_vs_K_for_strains_2SD_outside_mean_K", l_outside_2sd_k_plots)
-    # generate_and_save_plots(out_dir_qc, "delta_background_vs_K_for_strains_2sd_outside_mean_K", delta_bg_outside_2sd_k_plots)
+    # Generating quality control plots in parallel
+    # furrr::future_map(plot_configs, function(config) {
+    #   generate_and_save_plots(config$out_dir, config$filename, config$plot_configs)
+    # }, .options = furrr_options(seed = TRUE))
 
     # Process background strains
     bg_strains <- c("YDL227C")
@@ -1435,7 +1442,7 @@ main <- function() {
       message("Filtering and reranking plots")
       # Formerly X_NArm
       zscores_interactions_filtered <- zscores_interactions_joined %>%
-        filter(!is.na(Z_lm_L) | !is.na(Avg_Zscore_L)) %>%
+        filter(!is.na(Z_lm_L) & !is.na(Avg_Zscore_L)) %>%
         mutate(
           Overlap = case_when(
             Z_lm_L >= 2 & Avg_Zscore_L >= 2 ~ "Deletion Enhancer Both",