calib curve fun updates

SLINGhub · Jan 18, 2025 · 1eee68c · 1eee68c
1 parent 50426e5
commit 1eee68c
Show file tree

Hide file tree

Showing 5 changed files with 33 additions and 22 deletions.
diff --git a/R/calc-calibrations.R b/R/calc-calibrations.R
@@ -147,6 +147,7 @@ calc_calibration_results <- function(data = NULL,
 
 
   calc_lm <- function(dt){
+
     tryCatch(
       {
         dt <- dt |>
@@ -162,7 +163,7 @@ calc_calibration_results <- function(data = NULL,
                                   "feature_norm_intensity ~ concentration",
                                   "feature_norm_intensity ~ poly(concentration, 2, raw = TRUE)")
 
-        res <- lm(formula = formula, weights = dt$weight, data = dt, na.action = na.exclude)
+        res <- lm(formula = formula, weights = weight, data = dt, na.action = na.exclude)
 
         r.squared <- summary(res)$r.squared
         sigma <- summary(res)$sigma
@@ -205,14 +206,16 @@ calc_calibration_results <- function(data = NULL,
       },
       error = function(e) {
         if(dt$fit_method[1] == "quadratic"){
-          return(list(feature_id = dt$feature_id[1], curve_id = dt$curve_id[1], fit_model =  dt$fit_method[1], weighting = dt$fit_weighting[1], lowest_cal = sort(dt$concentration[dt$concentration != 0])[1], r.squared = NA_real_ , coef_a = NA_real_, coef_b = NA_real_, coef_c = res$coefficients[[1]], sigma = NA_real_, reg_failed = TRUE, fit = list(NULL)))
+          return(list(feature_id = dt$feature_id[1], curve_id = dt$curve_id[1], fit_model =  dt$fit_method[1], weighting = dt$fit_weighting[1], lowest_cal = sort(dt$concentration[dt$concentration != 0])[1], r.squared = NA_real_ , coef_a = NA_real_, coef_b = NA_real_, coef_c = NA_real_, sigma = NA_real_, reg_failed = TRUE, fit = list(NULL)))
         } else {
           return(list(feature_id = dt$feature_id[1], curve_id = dt$curve_id[1], fit_model =  dt$fit_method[1], weighting = dt$fit_weighting[1], lowest_cal = sort(dt$concentration[dt$concentration != 0])[1], r.squared = NA_real_ , coef_a = NA_real_, coef_b = NA_real_, coef_c = NA_real_, sigma = NA_real_, reg_failed = TRUE, fit = list(NULL)))
         }
       }
     )
   }
 
+
+
   # mult_lowest_calib refert to multiplication factor of the lowest calibration
   # point used when calculate LoD and LoQ with a quadratic model
   # TODO: add reference
@@ -243,13 +246,13 @@ calc_calibration_results <- function(data = NULL,
   if (!overwrite_metadata) {
     d_calib <- d_calib |>
       dplyr::left_join(data@annot_features |> select("feature_id", "curve_fit_method", "curve_fit_weighting"), by = c("feature_id" = "feature_id")) |>
-      mutate(fit_method = if_else(is.na(.data$curve_fit_method), .data$fit_method, .data$curve_fit_method),
-             fit_weighting = if_else(is.na(.data$curve_fit_weighting), .data$fit_weighting, .data$curve_fit_weighting)) |>
+      mutate(fit_method = if_else(is.na(.data$curve_fit_method), fit_method, .data$curve_fit_method),
+             fit_weighting = if_else(is.na(.data$curve_fit_weighting), fit_weighting, .data$curve_fit_weighting)) |>
       select(-"curve_fit_method", -"curve_fit_weighting")
   } else {
     d_calib <- d_calib |>
-      mutate(fit_method = .data$fit_method,
-             fit_weighting = .data$fit_weighting)
+      mutate(fit_method = fit_method,
+             fit_weighting = fit_weighting)
 
   }
 

diff --git a/R/metadata-import.R b/R/metadata-import.R
@@ -218,15 +218,19 @@ import_metadata_qcconcentrations <- function(data = NULL, table = NULL, path = N
 
 
 get_assert_summary_table <- function(list_of_errors, data=NULL, warn = TRUE, ...) {
+
   if (is.null(list_of_errors)) return(NULL)
   res <- as_tibble(do.call(rbind, list_of_errors))
+ # browser()
   res <- res |>
+    rowwise() |>
     select("message", "description", "num.violations") |>
     mutate(message = str_replace_all(unlist(.data$message)[1], fixed('"'), "'")) |>
     mutate(Field = paste0(str_extract(unlist(.data$message), "(?<=\\').+?(?=\\')")) ) |>
     tidyr::separate(col = "description", into = c("Type", "Issue", "Table", "TargetField"), sep = ";", remove = TRUE) |>
     filter(.data$Type != "DX") |>
     mutate(Field = if_else(.data$Field == "NA", .data$TargetField, .data$Field)) |>
+    #mutate(num.violations = if_else(.data$verb == "verify", "", .data$num.violations)) |>
     select("Type", "Table", Column = "Field", "Issue", Count = "num.violations") |> ungroup()
 
   res$Count <- res$Count |> unlist()
@@ -364,12 +368,13 @@ print_assertion_summary <- function(data, metadata_new, data_label, assert_type
       assertr::verify(has_any_name("feature_class","istd_feature_id","quant_istd_feature_id","response_factor","is_quantifier","valid_feature","interference_feature_id"), obligatory=FALSE, description = "E;No metadata field(s) provided;Features; ") |>
       assertr::assert(assertr::is_uniq, "feature_id", obligatory=FALSE, description = "E;IDs duplicated;Features;feature_id") |>
       assertr::assert(assertr::in_set(unique(metadata$annot_features$feature_id)), "istd_feature_id", description = "E;ISTD(s) not defined as feature;Features;feature_id") |>
-      assertr::assert(assertr::in_set(unique(metadata$annot_features$feature_id)), "istd_feature_id", description = "E;ISTD(s) not defined as feature;Features;feature_id") |>
       assertr::assert(assertr::in_set(NA, "linear", "quadratic"), "curve_fit_method", description = "E; Must be NA, 'linear' or 'quadratic';Features;curve_fit_method") |>
-      assertr::assert(assertr::in_set(NA, "1/x", "1/x^2"), "curve_fit_weighting", description = "E; Must be NA, '1/x' or '1/x^2';Features;curve_fit_weighting")
-      #assertr::verify(unique(quant_istd_feature_id) %in% feature_id, description = "E;ISTD(s) not defined as feature;Features") |>
-      #assertr::assert(\(x) {any(metadata$annot_istds$quant_istd_feature_id %in% (x)) & nrow(metadata$annot_istds)>0},quant_istd_feature_id, obligatory=FALSE, description = "W;ISTD(s) not defined;ISTDs") |>
-      #assertr::verify(unique(interference_feature_id) %in% feature_id, description = "Interfering feature(s) not defined under 'feature_id';Features")
+      assertr::assert(assertr::in_set(NA, "1/x", "1/x^2"), "curve_fit_weighting", description = "E; Must be NA, '1/x' or '1/x^2';Features;curve_fit_weighting") |>
+      assertr::assert(assertr::in_set(unique(metadata$annot_features$feature_id)), "interference_feature_id", description = "E;Interfering feature(s) not defined as feature;Features;interference_feature_id") |>
+      assertr::verify(any(!xor(is.na(metadata$annot_features$interference_proportion), is.na(metadata$annot_features$interference_feature_id))), "interference_feature_id", obligatory=FALSE, description = "E;Incomplete interference info;Features;interference_proportion")
+      #assertr::assert(\(x){any(xor(is.na(x), is.na(metadata$annot_features$interference_feature_id)))}, "interference_feature_id", obligatory=FALSE, description = "E;Missing interference proportion(s);Features;interference_proportion")
+
+
 
     if(!is.null(data)){
       metadata$annot_features <- metadata$annot_features |>

diff --git a/R/midar-global-definitions.R b/R/midar-global-definitions.R
@@ -89,8 +89,8 @@ pkg.env$table_templates <- list(
 
 pkg.env$qc_type_annotation <- list(
   qc_type_levels = c(
-    "SBLK", "TBLK", "UBLK", "HQC", "MQC", "LQC", "CAL", "PQC", "TQC", "BQC", "RQC", "EQC", "NIST",
-    "LTR", "PBLK", "SPL", "SST", "MBLK"
+    "SBLK", "TBLK", "UBLK", "HQC", "MQC", "LQC",  "PBLK", "CAL","EQA", "PQC", "TQC", "BQC", "RQC", "EQC", "NIST",
+    "LTR",  "SPL", "SST", "MBLK"
   ),
   qc_type_col = c(
     "SBLK" = "#1854f9",
@@ -107,7 +107,8 @@ pkg.env$qc_type_annotation <- list(
     "EQC" = "#513c3c",
     "NIST" = "#002e6b",
     "LTR" = "#880391",
-    "PBLK" = "#08c105",
+    "EQA" = "#880391",
+    "PBLK" = "#216651",
     "SPL" = "#8e9b9e",
     "SST" = "#bafc03",
     "MBLK" = "black"
@@ -122,12 +123,13 @@ pkg.env$qc_type_annotation <- list(
     "LQC" = "#ffba19",
     "MQC" = "#ffba19",
     "HQC" = "#ffba19",
+    "EQA" = "#de21de",
     "CAL" = "#43e0c7",
     "RQC" = "#688ff9",
     "EQC" = "NA",
     "NIST" = "#cce2ff",
     "LTR" = "#880391",
-    "PBLK" = "#08c105",
+    "PBLK" = "#e4f2c4",
     "SPL" = "NA",
     "SST" = "#aaaeaf",
     "MBLK" = "black"
@@ -142,6 +144,7 @@ pkg.env$qc_type_annotation <- list(
     "LQC" = 25,
     "MQC" = 23,
     "HQC" = 24,
+    "EQA" = 23,
     "CAL" = 21,
     "RQC" = 6,
     "EQC" = 24,

diff --git a/R/plots-calibcurves.R b/R/plots-calibcurves.R
@@ -97,7 +97,7 @@ plot_calibrationcurves <- function(data = NULL,
     dplyr::select(tidyselect::any_of(
       c("analysis_id", "sample_id", "qc_type", "feature_id", variable)
     )) |>
-    filter(str_detect(.data$qc_type, "CAL|[MLH]QC|^QC")) |>
+    filter(str_detect(.data$qc_type, "CAL|[MLH]QC|^QC|EQA")) |>
     dplyr::right_join(data@annot_qcconcentrations, by = c("sample_id" = "sample_id", "feature_id" = "feature_id"))
 
   d_calib$curve_id = 1
@@ -264,7 +264,7 @@ plot_calibcurves_page <- function(data,
 
  d_pred <- d_pred |>
    dplyr::arrange(.data$feature_id, .data$curve_id)
-
+browser()
 
     p <- ggplot(
         data = dat_subset,
@@ -288,11 +288,11 @@ plot_calibcurves_page <- function(data,
                   fill = "#91bfdb", alpha = 0.25, inherit.aes = FALSE) +
 
         #color = ifelse(after_stat(r.squared) < 0.80, "red", "darkgreen")), size = 1.4) +
-        scale_color_manual(values = c("CAL" ="#254f6e", "HQC" = "#f27507", "LQC" = "#f27507")) +
-        scale_fill_manual(values = c("CAL" ="white", "HQC" = "#f5c969", "LQC" = "#f5c969")) +
-        scale_shape_manual(values = c("CAL" = 21, "HQC" = 24, "LQC" = 25)) +
+        scale_color_manual(values = c("CAL" ="#254f6e", "HQC" = "#f27507", "LQC" = "#f27507", "EQA" = "#880391")) +
+        scale_fill_manual(values = c("CAL" ="white", "HQC" = "#f5c969", "LQC" = "#f5c969", "EQA" = "#de21de")) +
+        scale_shape_manual(values = c("CAL" = 21, "HQC" = 24, "LQC" = 25, "EQA" = 24)) +
         scale_y_continuous(limits = c(0, NA)) +
-        scale_x_continuous(limits = c(0, NA), breaks = scales::breaks_extended(6)) +
+        #scale_x_continuous(limits = c(0, NA), breaks = scales::breaks_extended(6)) +
         ggh4x::facet_wrap2(
           vars(.data$feature_id),
           scales = "free",

diff --git a/R/plots-qc-runorder.R b/R/plots-qc-runorder.R
@@ -290,7 +290,7 @@ plot_runscatter <- function(data = NULL,
   }
 
   if(!include_qualifier){
-    d_filt <- d_filt |> filter(!.data$is_qualifier)
+    d_filt <- d_filt |> filter(.data$is_quantifier)
   }
 
   if (!all(is.na(plot_range_indices))) {