R/gl.recode.ind.r

In dartR.base: Analysing 'SNP' and 'Silicodart' Data - Basic Functions

#' @name gl.recode.ind
# Preliminaries -- Parameter specifications -------------- 
#' @title Recodes individual (=specimen = sample) labels in a genlight object
#' @family data manipulation

#' @description
#' This function recodes individual labels and/or deletes individuals from a DaRT
#' genlight SNP file based on a lookup table provided as a csv file.

#' @param x Name of the genlight object  [required].
#' @param ind.recode Name of the csv file containing the individual relabelling
#'  [required].
#' @param recalc If TRUE, recalculate the locus metadata statistics if any 
#' individuals are deleted in the filtering [default FALSE].
#' @param mono.rm If TRUE, remove monomorphic loci [default FALSE].
#' @param verbose Verbosity: 0, silent or fatal errors; 1, begin and end; 2, 
#' progress log; 3, progress and results summary; 5, full report 
#' [default 2 or as specified using gl.set.verbosity].
#' 
#' @details
#' Renaming individuals may be required when there have been errors in labeling
#' arising in the process from sample to sequence files. There may be occasions
#' where renaming individuals is required for preparation of figures. When
#' caution needs to be exercised because of the potential for breaking the
#' 'chain of evidence' associated with the samples, recoding individuals using
#' a recode table (csv) can provide a durable record of the changes.

#' The function works with genlight objects
#' containing SNP genotypes and Tag P/A data (SilicoDArT).

#' For SNP genotype data, the function, having deleted individuals, optionally 
#' identifies resultant monomorphic loci or loci with all values missing 
#' and deletes them. The script also optionally recalculates the
#' locus metadata as appropriate. The optional deletion of monomorphic loci
#' and the optional recalculation of locus statistics is not available for
#' Tag P/A data (SilicoDArT).

#' The script returns a dartR genlight object with the new individual names  
#' and the recalculated locus metadata. 

#' @author Custodian: Arthur Georges -- Post to
#' \url{https://groups.google.com/d/forum/dartr}

# Examples --------------
#' @examples
#'   file <- system.file('extdata','testset_ind_recode.csv', package='dartR.data')
#'   gl <- gl.recode.ind(testset.gl, ind.recode=file, verbose=3)
#'   
# See also ----------------
#' @seealso \code{\link{gl.filter.monomorphs}} for filtering monomorphs,
#'  \code{\link{gl.recalc.metrics}} for recalculating locus metrics,
#' \code{\link{gl.recode.pop}} for recoding populations
#' 
#' @import dartR.data
#' @export
#' @return A genlight or genind object with the recoded and reduced data.

# --------------
# Function 
gl.recode.ind <- function(x,
                          ind.recode,
                          recalc = FALSE,
                          mono.rm = FALSE,
                          verbose = NULL) {
  # Preliminaries -------------
    # SET VERBOSITY
    verbose <- gl.check.verbosity(verbose)
    
    # FLAG SCRIPT START
    funname <- match.call()[[1]]
    utils.flag.start(func = funname,
                     build = "v.2023.2",
                     verbose = verbose)
    
    # CHECK DATATYPE
    datatype <- utils.check.datatype(x, verbose = verbose)
    
    # SCRIPT SPECIFIC ERROR CHECKING change stringsAsFactors=FALSE due to the new default in r
    recode.table <-
        read.csv(ind.recode,
                 header = FALSE,
                 stringsAsFactors = FALSE)
    
    v1 <- unique(indNames(x))
    v2 <- unique(recode.table[, 1])
    v1_v2 <- v1[!(v1 %in% v2)]
    l1 <- length(v1)
    l2 <- length(v2)
    
    if (l1 != l2) {
        stop(
            error(
                "Fatal Error: Individuals do not agree in number with those listed in the recode table\n"
            )
        )
    }
    if (!(length(v1_v2) == 0)) {
        stop(
            error(
                "Fatal Error: Some individuals have no reassignment specified in the recode table:",
                v1_v2,
                "\n"
            )
        )
    }
    
    # DO THE JOB ---------------
    
    if (verbose >= 2) {
        cat(report(
            "  Relabelling individuals (=specimens) as per ",
            ind.recode,
            "\n"
        ))
        cat(report("    Reading lookup table\n"))
    }
    
    # Store variables
    hold.nLoc <- nLoc(x)
    hold.nInd <- nInd(x)
    hold.nPop <- nPop(x)
    
    # Apply the recode to the individuals
    if (verbose >= 2) {
        cat(report("    Applying the recoding\n"))
    }
    ind.list <- as.character(indNames(x))
    ntr <- length(recode.table[, 1])
    for (i in 1:nInd(x)) {
        for (j in 1:ntr) {
            if (ind.list[i] == recode.table[j, 1]) {
                ind.list[i] <- recode.table[j, 2]
            }
        }
    }
    indNames(x) <- ind.list

    if ("delete" %in% x$ind.names | "Delete" %in% x$ind.names) {
        # Remove rows flagged for deletion
        if (verbose >= 2) {
            cat(report(
                "    Deleting individuals/samples flagged for deletion\n"
            ))
        }
        deletions <-
            indNames(x)[tolower(recode.table[, 2]) == "delete"]
        if (verbose == 3) {
            cat("  Dropping\n",
                paste(deletions, collapse = ", "),
                "\n")
            cat("  A total of",
                length(deletions),
                "individuals dropped\n")
        }
        x <-
            gl.drop.ind(x,
                        ind.list = c("Delete", "delete"),
                        verbose = 0)
    }
    
    # Remove monomorphic loci ------------------
    if(datatype=="SNP"){
      if (mono.rm) {
        if (verbose >= 2) {
          cat(report("  Deleting monomorphic loc\n"))
        }
        x <- gl.filter.monomorphs(x, verbose = 0)
      }
      # Check monomorphs have been removed
      if (x@other$loc.metrics.flags$monomorphs == FALSE) {
        if (verbose >= 2) {
          cat(warn(
            "  Warning: Resultant dataset may contain monomorphic loci\n"
          ))
        }
      }
    }
    
    # Recalculate statistics ---------------
    if(datatype=="SNP"){
    if (recalc) {
        x <- gl.recalc.metrics(x, verbose = 0)
        if (verbose >= 2) {
            cat(report("  Recalculating locus metrics\n"))
        }
    } else {
        if (verbose >= 2) {
            cat(warn("  Locus metrics not recalculated\n"))
            x <- utils.reset.flags(x, verbose = 0)
        }
    }
    }
    
    # REPORT A SUMMARY ---------------
    
    if (verbose >= 2) {
        cat("  Summary of recoded dataset\n")
        cat(paste("  Original No. of loci:", hold.nLoc, "\n"))
        cat(paste("    New No. of loci:", nLoc(x), "\n"))
        cat(paste("  Original No. of individuals:", hold.nInd, "\n"))
        cat(paste("    New No. of individuals:", nInd(x), "\n"))
        cat(paste("  Original No. of populations:", hold.nPop, "\n"))
        cat(paste("    New No. of populations:", nPop(x), "\n"))
        if (!recalc) {
            cat(report("  Note: Locus metrics not recalculated\n"))
        }
        if (!mono.rm) {
            cat(report("  Note: Resultant monomorphic loci not deleted\n"))
        }
    }
    
    # ADD TO HISTORY ----------------------
    nh <- length(x@other$history)
    x@other$history[[nh + 1]] <- match.call()
    
    # FLAG SCRIPT END -------------
    
    if (verbose > 0) {
        cat(report("Completed:", funname, "\n"))
    }
    # End block ----------------
    
    return(x)
}