R/codestocolors.R

In rabi: Generate Codes to Uniquely and Robustly Identify Individuals for Animal Behavior Studies

#' Converting numeric ID codes to listed color name codes
#'
#' This is a helper function that transforms a list numeric ID sequences into a list of human-readable sequences. Sequences of 1s, 2s, and 3s can become sequences of "red"s, "blue"s, and "yellow"s, etc.
#'
#'
#' @param codes a list or matrix of numeric ID sequences generated by \code{\link{rs_IDs}}, \code{\link{brute_IDs}}, etc.
#' @param available.colors a list of strings that contains the names of the unique markings which compose the given 'alphabet' (e.g. "blue", "red", "yellow", etc.). The length of this list must match the 'alphabet size' used to generate the input \code{codes}.
#'
#' @return a list of unique, named codes that fit the provided parameters.
#' @author Andrew Burchill, \email{andrew.burchill@asu.edu}
#' @references Burchill, A. T., & Pavlic, T. P. (2019). Dude, where's my mark? Creating robust animal identification schemes informed by communication theory. \emph{Animal Behaviour}, 154, 203-208. \href{https://doi.org/10.1016/j.anbehav.2019.05.013}{doi:10.1016/j.anbehav.2019.05.013}
#'
#' @examples
#' total.length <- 3  #we have three positions to mark,
#' redundancy <- 1    #we want codes robust to a single erasure,
#' alphabet <- 3      #and we currently have three types of paint in stock
#'
#'  #Create a list of codes
#' codes <- rs_IDs(total.length, redundancy, alphabet)
#'
#'  #Let's make those into human-readable color sequences
#' color.names <- c("blue","red","pink-striped-orange")
#' codes_to_colors(codes, color.names)
#'
#'  #We can also skip the whole function and plug the names straight into the code generator
#' rs_IDs(total.length, redundancy, alphabet, available.colors = color.names)
#'
#'
#' @export
#' @importFrom stringdist seq_distmatrix
#' @importFrom utils capture.output
#' @importFrom methods is


codes_to_colors <- function(codes, available.colors = NULL){

  if (is(codes,"matrix")) {
    codes <- split(codes, 1:nrow(codes))
    names(codes) <- NULL
  } else if (!is(codes, "list")) {
    stop("Error: the variable 'codes' must be either a list of numeric sequences or a matrix, where each row is a unique sequence. See the examples for a better idea.")
  }

  if (!is.null(available.colors)) {

    original.nums <- sort(unique(unlist(codes)))
    if (length(available.colors) != length(original.nums) | length(available.colors) != length(unique(available.colors))) {
      warning(paste0("Error: the supplied list of color names must contain exactly ", length(original.nums), " unique elements. Returning the original numeric codes instead." ))
    } else {
      for (i in 1:length(available.colors)) {
        codes <- rapply(codes, function(x) ifelse(x == original.nums[i],available.colors[i], x), how = "replace")
      }

      mapping <- available.colors
      names(mapping) <- original.nums
      message("Note: The mapping (see below) that was used to assign color names to numeric values is not saved or assigned to a variable. \n The exact mapping may change with repeated function calls. Depending on your circumstances, you may want to record this now. \n")
      message(paste0(utils::capture.output(mapping), collapse = "\n"))
    }
  }
  return(codes)
}