R/fittingQC_assessment.R

In anabel: Analysis of Binding Events + l

# Copyright (C) 2025  Stefan Kraemer
#   
#   This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation as version 3 of the License
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

############### Fitting Quality ###############

# Revising KD fitting results
# description the function checks the validity of KD and Kass
# details KD and Kass values are checked and corrected in case were negative. In the tables it
#   will replaced by NA while in the plot it will be represented with '-'

remove_Neg_Kds <- function(kntks) {
  kntks$KD[!is.na(kntks$KD)] <-
    ifelse(kntks$KD[!is.na(kntks$KD)] < 0, NA, as.numeric(kntks$KD[!is.na(kntks$KD)]))

  kntks$kass[!is.na(kntks$kass)] <-
    ifelse(kntks$kass[!is.na(kntks$kass)] < 0, NA, as.numeric(kntks$kass[!is.na(kntks$kass)]))

  kntks$kdiss[!is.na(kntks$kdiss)] <-
    ifelse(kntks$kdiss[!is.na(kntks$kdiss)] < 0, NA, as.numeric(kntks$kdiss[!is.na(kntks$kdiss)]))

  kntks %>% return()
}

# Checks the overall quality of the fitting
#
# param kntks the data frame containing kinetics results generated by \code{\link{fit_bindingCurves}}
# param lbs numeric vector of lower boundaries obtained from \code{initParams}
# param ubs numeric vector of upper boundaries obtained from \code{initParams}
# param to_check vector of parameters to be checked, these will be determined when initiating the models
# !!! to_check should NOT be a factor, otherwise the check list will be on the level rather the actual value !!!

assess_fittingQuality <- function(kntks, lbs, ubs, to_check, isLog) {
  . <- NULL
  names(lbs) <- to_check
  names(ubs) <- to_check
  names(isLog) <- to_check

  kntks$ParamsQualitySummary <- sapply(to_check, check_fitting_params, lbs = lbs, ubs = ubs, kntks = kntks, isLog) %>%
    paste0(., collapse = ",") %>%
    as.character() %>%
    gsub("\\,+", "\\,", .) %>%
    gsub("^\\,|\\,$", "", .)

  kntks[, grep("^param", colnames(kntks), ignore.case = FALSE)] <- NULL
  kntks$FittingQ <- "Warning"
  kntks$FittingQ[is.na(kntks$ParamsQualitySummary) | all(nchar(kntks$ParamsQualitySummary) == 0)] <- ""

  kntks
}

# the function check_fitting_params checks the quality of
# the fitting according to ubs and lbs, thus, the plot coloring will follow this
# assessment. One parameter and one spot a time will be checked

check_fitting_params <- function(kntks, to_check, lbs, ubs, isLog) {
  log_kntk <- as.numeric(kntks[[to_check]])
  if (is.na(log_kntk)) {
    return(NA)
  }

  isLog <- isLog[to_check]
  log_kntk <- ifelse(isLog, log_kntk <- log10(log_kntk), log_kntk) %>% as.numeric()

  x <- ifelse(log_kntk <= lbs[to_check], paste0("lbs_", to_check), "")
  y <- ifelse(log_kntk >= ubs[to_check], paste0("ubs_", to_check), "")

  val <- ifelse(nchar(x) > 0 | nchar(y) > 0, paste(x, y, sep = ":"), "")
  return(gsub("^\\:|\\:$", "", val))
}