R/coincidence_index.R

In TiagoOlivoto/WAASB: Multi Environment Trials Analysis

#' Computes the coincidence index of genotype selection
#'
#' @description
#' `r badge('stable')`
#'
#' Computes the coincidence index (Hamblin and Zimmermann, 1986) as follows:
#'
#' \loadmathjax
#' \mjsdeqn{CI = \frac{A-C}{M-C}\times 100}
#' where *A* is the number of selected genotypes common to different
#' methods; *C* is the number of expected genotypes selected by chance; and
#' *M* is the number of genotypes selected according to the selection
#' intensity.
#'
#' @param ... A comma-separated list of objects of class `mgidi`,
#'   `mtsi` `fai_blup`, or `sh`. When a model is informed, then
#'   the selected genotypes are extracted automatically.
#' @param total The total number of genotypes in the study.
#' @param sel1,sel2 The selected genotypes by the method 1 and 2, respectively. Defaults to `NULL`.
#' @return A list with the following elements:
#'
#' * **coincidence**: A data frame with the coincidence index, number of
#' common genotypes and the list of common genotypes for each model combination.
#' * **coincidence_mat**: A matrix-like containing the coincidence index.
#' * **genotypes**: The number of common genotypes for all models, i.e.,
#' the insersection of the selected genotypes of all models
#'
#' @export
#' @md
#' @references
#' Hamblin, J., and M.J. de O. Zimmermann. 1986. Breeding Common Bean for Yield
#' in Mixtures. p. 245-272. In Plant Breeding Reviews. John Wiley & Sons, Inc.,
#' Hoboken, NJ, USA.\doi{10.1002/9781118061015.ch8}
#'
#' @examples
#' \donttest{
#' sel1 <- paste("G", 1:30, sep = "")
#' sel2 <- paste("G", 16:45, sep = "")
#' coincidence_index(sel1 = sel1, sel2 = sel2, total = 150)
#' }
coincidence_index <- function(..., total, sel1 = NULL, sel2 = NULL){
  comp_coinc <- function(sel1, sel2, total){
    common <- intersect(sel1, sel2)
    si <- round(length(sel1) / total, 2)
    rand <- length(sel1) * si
    coinc_idex <- ((length(common) - rand) / (length(sel1) - rand)) * 100
    return(coinc_idex)
  }
  if(!missing(...)){
    names <-
      as.character(
        sapply(quos(...), function(x){
          rlang::quo_get_expr(x)
        })
      )
    if(length(names)  < 2){
      stop("The coincidence index cannot be computed with only one model.", call. = FALSE)
    }
    models <- list(...)
    if(any(sapply(models, class) %in% c("mgidi", "fai_blup", "sh", "mtsi") == FALSE)){
      stop("Only objects of class 'mgidi', 'mtsi', 'fai_blup', and 'sh' are accepted.")
    }
    selected <- lapply(models, function(x){
      x[["sel_gen"]]
    })
    names(selected) <- names
    ngsel <- sapply(selected, length)
    if(length(unique(as.numeric(ngsel))) > 1){
      stop("The number of selected genotypes must be the same for all the models\n",
           paste(capture.output(print(data.frame(ngsel))), collapse = "\n"), call. = FALSE)
    }
    index <- combn(length(selected), 2)
    ncomb <- ncol(index)
    results <-
      data.frame(Model = combn(names(selected), 2, paste, collapse = "_::_")) %>%
      separate(Model, into = c("V1", "V2"), sep = "_::_")
    values <- NULL
    common <- NULL
    genotypes <- NULL
    common_gen_pairs <- NULL
    for (i in 1:ncomb) {
      V1 <- selected[[index[1, i]]]
      V2 <- selected[[index[2, i]]]
      values[i] <- comp_coinc(V1, V2, total)
      common[i] <- length(intersect(V1, V2))
      genotypes[i] <- list(intersect(sel1, sel2))
      common_gen_pairs[i] <- paste(intersect(V1, V2), collapse = ",")
    }
    results <-
      add_cols(results,
               index = values,
               common = common,
               genotypes = common_gen_pairs)
    final <-
      list(coincidence = results,
           coincidence_mat = make_mat(results, V1, V2, index),
           genotypes = Reduce(intersect, genotypes))
    return(final %>% set_class("coincidence"))
  } else{
    if(length(sel1) != length(sel2)){
      stop("The lenght of 'sel1' and 'sel2' must be equal")
    }
    return(comp_coinc(sel1, sel2, total))
  }
}




#' Print an object of class coincidence
#'
#' Print a `coincidence` object in two ways. By default, the results are shown in
#' the R console. The results can also be exported to the directory.
#'
#'
#' @param x An object of class `coincidence`.
#' @param export A logical argument. If `TRUE`, a *.txt file is exported
#'   to the working directory
#' @param file.name The name of the file if `export = TRUE`
#' @param digits The significant digits to be shown.
#' @param ... Options used by the tibble package to format the output. See
#'   [`tibble::print()`][tibble::formatting] for more details.
#' @author Tiago Olivoto \email{tiagoolivoto@@gmail.com}
#' @method print coincidence
#' @export
#' @examples
#'\donttest{
#' library(metan)
#' sel1 <- paste("G", 1:30, sep = "")
#' sel2 <- paste("G", 16:45, sep = "")
#' coinc <- coincidence_index(sel1 = sel1, sel2 = sel2, total = 150)
#' print(coinc)
#' }
print.coincidence <- function(x, export = FALSE, file.name = NULL, digits = 4, ...) {
  if (export == TRUE) {
    file.name <- ifelse(is.null(file.name) == TRUE, "waasb print", file.name)
    sink(paste0(file.name, ".txt"))
  }
  opar <- options(pillar.sigfig = digits)
  on.exit(options(opar))
  cat("---------------------------------------------------------------------------\n")
  cat("Coincidence index and common genotypes\n")
  cat("---------------------------------------------------------------------------\n")
  print(x$coincidence)
  if (export == TRUE) {
    sink()
  }
}