R/sim_crossing_block.R

In neyhartj/qgsim: Simulations of Plant Breeding Experiments

#' Create a crossing block from a vector of parents
#' 
#' @description 
#' Create a crossing block based on parent names, with different options for
#' mating scheme.
#' 
#' @param parents A \code{character} of line names to use as parents. If
#' \code{second.parents} is not provided, crosses are assigned from randomly sampling
#' the entries in \code{parents}.
#' @param type The type of crosses to simulate. Can be \code{"2way"} for bi-parental
#' crosses or \code{"4way"} for 4-way crosses.
#' @param n.crosses The number of crosses to generate. Cannot be more than the
#' possible number of crosses. If NULL, the function returns all possible crosses.
#' @param scheme The mating scheme. Can be one of \code{"random"} or \code{"chain"}.
#' See \emph{Details} for more information.
#' @param use.parents.once \code{Logical} - should parents be used only once?
#' 
#' @details  
#' Several options are available to generate crossing blocks from a list of
#' parents. Here are the rules used for generating different crossing blocks.
#' 
#' \describe{
#'   \item{\code{scheme = "random"}}{A \code{data.frame} is first constructed with
#'   all possible pairwise combinations of \code{parents}. Self-crosses and reciprocal
#'   crosses are removed and \code{n.crosses} crosses are randomly sampled. If
#'   \code{use.parents.once = TRUE}, crosses are selected such that any one parent
#'   is used only once.}
#'   \item{\code{scheme = "chain"}}{Crosses are generated by pairing the first element
#'   in \code{parents} with the second element, the second element with the third,
#'   and so on. The \code{n.crosses} and \code{use.parents.once} arguments are ignored.}
#' }
#' 
#' Further rules:
#' 
#' \itemize{
#'   \item{If \code{second.parents = NULL}, then \code{parents} is duplicated.}
#' }
#' 
#' @return 
#' A data.frame with two columns. The first is the names of the first parents, 
#' and the second is the name of the second parents. Each row is a mating pair.
#' 
#' @examples 
#' 
#' parents <- paste("line", seq(10), sep = "")
#' 
#' # Generate 3 crosses randomly
#' cb <- sim_crossing_block(parents = parents, n.crosses = 3)
#' 
#' # Generate 3 crosses randomly, while using parents only once.
#' cb <- sim_crossing_block(parents = parents, n.crosses = 3, use.parents.once = TRUE)
#' 
#' # Generate a chain of crosses
#' cb <- sim_crossing_block(parents = parents, scheme = "chain")
#' 
#' 
#' @importFrom arrangements combinations
#' 
#' @export
#' 
sim_crossing_block <- function(parents, n.crosses = NULL, type = c("2way", "4way"),
                               scheme = c("random", "chain"), use.parents.once = FALSE) {
  
  # Error
  if (!is.character(parents)) 
    stop("The input 'parents' must be a character.")
  
  # Match arguments
  scheme <- match.arg(scheme)
  type <- match.arg(type) 
  
  # Number of unique parents
  n_unique_pars <- length(unique(parents))
  
  # Convert type to numeric
  type <- ifelse(type == "2way", 2, 4)
  # Calculate the total number of possible crosses
  n_possible_crosses <- choose(n_unique_pars, type)
  # Choose what happens if n.crosses is NULL
  n.crosses <- ifelse(is.null(n.crosses), n_possible_crosses, n.crosses)
  
  # Error if the number of requested crosses is greater than what is possible
  if (n.crosses > n_possible_crosses) stop ("The number of requested crosses is greater than the number of
                                            possible crosses.")
  
  # Run depending on scheme 
  if (scheme == "random") {
    
    # Use parents once?
    if (use.parents.once) {
      
      ## First determine the number of unique lines required for using parents once
      n_unique_req <- type * n.crosses
      
      # Stop if n_unique_pars is less than n_unique_req
      if (n_unique_pars < n_unique_req) 
        stop(paste0("You have not provided enough unique parents to use parents only once. For ",
                    n.crosses, " ", type, "-way crosses, you need to provide ", n_unique_req, 
                    " unique parents."))
      
      # Sample the number of unique parents and assemble into a data.frame
      chosen_crosses <- matrix(data = sample(x = parents, size = n_unique_req), nrow = n.crosses, ncol = type,
                               dimnames = list(NULL, paste0("parent", seq_len(type))))
      chosen_crosses <- as.data.frame(chosen_crosses, stringsAsFactors = FALSE)
      
      
    } else {
      
      # Randomly sample crosses
      chosen_crosses <- as.data.frame(x = combinations(x = parents, k = type), stringsAsFactors = FALSE)
      chosen_crosses <- chosen_crosses[sort(sample(nrow(chosen_crosses), n.crosses)),]
      names(chosen_crosses) <- paste0("parent", seq_along(chosen_crosses))
      
    }
    
  } else if (scheme == "chain") {
    
    # Give a warning for use parents once
    if (use.parents.once) warning('use.parents.once is ignored when scheme == "chain".')
    
    # Chain scheme
    chosen_crosses <- cbind(
      parent1 = parents, 
      parent2 = c(tail(parents, 1), head(parents, -1)),
      parent3 = c(tail(parents, 2), head(parents, -2)),
      parent4 = c(tail(parents, 3), head(parents, -3))
    )
    
    chosen_crosses <- as.data.frame(chosen_crosses, stringsAsFactors = FALSE)
    
  }
  
  # Return the crossing_block
  return(chosen_crosses)


} # Close the function