R/similarity.R

In modEvA: Model Evaluation and Analysis

similarity <- function(model = NULL, obs = NULL, pred = NULL, thresh, measures = modEvAmethods("similarity"), simplif = FALSE, plot = TRUE, plot.type = "lollipop", plot.ordered = FALSE, verbosity = 2, interval = 0.01, quant = 0, na.rm = TRUE, rm.dup = FALSE, ...) {
  # version 1.0 (10 Nov 2023)

  obspred <- inputMunch(model, obs, pred, na.rm = na.rm, rm.dup = rm.dup)
  obs <- obspred[ , "obs"]
  pred <- obspred[ , "pred"]

  #if (any(pred < 0 | pred > 1)) stop ("'pred' must range between 0 and 1")
  # if (!(thresh == "preval" | is.numeric(thresh)))
  #   stop("'thresh' must be either 'preval' or a numeric value between 0 and 1")
  # if (thresh == "preval")  thresh <- prevalence(obs)
  if (!(is.numeric(thresh) || thresh %in% modEvAmethods("getThreshold")))
    stop("'thresh' must be either a numeric value between 0 and 1, or one of the options obtained with modEvAmethods('getThreshold')")
  if (thresh %in% modEvAmethods("getThreshold"))  thresh <- getThreshold(obs = obs, pred = pred, threshMethod = thresh, interval = interval, quant = quant, na.rm = na.rm)

  if (is.finite(thresh)) {
    pred01 <- pred
    pred01[pred < thresh] <- 0
    pred01[pred >= thresh] <- 1
    N <- length(pred)
  }

  Nmeasures <- length(measures)
  measureValues <- as.vector(rep(NA, Nmeasures), mode = "numeric")
  names(measureValues) <- measures

  A <- sum(obs, na.rm = na.rm)
  B <- sum(pred01, na.rm = na.rm)
  C <- sum(pmin(obs, pred01, na.rm = na.rm), na.rm = na.rm)  # intersection

  for (m in measures) {
    if (m %in% modEvAmethods("similarity") && is.finite(thresh)) {
      if (m == "Jaccard") measureValues[m] <- C / (A + B - C)
      if (m == "Sorensen") measureValues[m] <- 2 * C / (A + B)
    }  # end if m in modEvAmethods("similarity")
    else {
      warning("'", m, "' is not a valid measure;
type modEvAmethods('similarity') for available options.")
      next
    }  # end else
  }  # end for m

  Measures <- matrix(data = measureValues, nrow = Nmeasures, ncol = 1, dimnames = list(measures, "Value"))
  if (simplif) {  # shorter version for use with e.g. optiThresh function
    return(Measures)
  } else {
    if (plot) {
      measures.plot <- measureValues
      if (plot.ordered) {
        measures.plot <- sort(measures.plot, decreasing = TRUE, na.last = TRUE)
      }
      measures.plot[is.infinite(measures.plot)] <- NA
      if (plot.type == "barplot" && any(is.finite(measures.plot))) barplot(measures.plot[is.finite(measures.plot)], las = 3, ...)
      if (plot.type == "lollipop" && any(is.finite(measures.plot))) lollipop(measures.plot[is.finite(measures.plot)], las = 3, ymin = NA, ylab = "", ...)
    }  # end if plot
    return(list(N = N, Threshold = thresh,
                similarity = Measures))
  }  # end else
}