R/fillGroupMembers.R

In rmsharp/nprcmanager: Genetic Tools for Colony Management

#' Forms and fills list of animals groups based on provided constraints
#'
## Copyright(c) 2017-2020 R. Mark Sharp
## This file is part of nprcgenekeepr
#'
#' @return A list of animal groups and their member animals
#'
#' @param candidates character vector of IDs of the animals available for
#' use in the group.
#' @param currentGroups list of character vectors of IDs of animals currently
#' assigned
#' to the group. Defaults to character(0) assuming no groups are existent.
#' @param kin list of animals and those animals who are related above a
#' threshold value.
#' @param ped dataframe that is the `Pedigree`. It contains pedigree
#' information including the IDs listed in \code{candidates}.
#' @param harem logical variable when set to \code{TRUE}, the formed groups
#' have a single male at least \code{minAge} old.
#' @param minAge integer value indicating the minimum age to consider in group
#' formation. Pairwise kinships involving an animal of this age or younger will
#'  be ignored. Default is 1 year.
#' @param numGp integer value indicating the number of groups that should be
#' formed from the list of IDs. Default is 1.
#' @param sexRatio numeric value indicating the ratio of females to males x
#' (from 0.5 to 20 by increments of 0.5 within the accompanying Shiny
#' application. A sex ratio of 0 ignores sex in making up groups.
fillGroupMembers <- function(candidates, currentGroups, kin, ped, harem, minAge,
                             numGp, sexRatio) {
  groupMembers <- makeGroupMembers(numGp, currentGroups, candidates, ped, harem,
                                   minAge)
  grpNum <- makeGrpNum(numGp)

  if (harem) { # Sires were added to groupMembers
    candidates <- removePotentialSires(candidates, minAge, ped)
  }
  if (sexRatio != 0) {
    groupMembers <- fillGroupMembersWithSexRatio(
      candidates, groupMembers, grpNum, kin, ped, minAge, numGp, sexRatio)
    return(groupMembers)
  } else {
    available <- makeAvailable(candidates, numGp)
  }

  while (TRUE) {
    if (isEmpty(grpNum)) {
      break
    }

    # Select a group at random
    i <- sample(grpNum, 1)[[1]]

    # Select an animal that can be added to this group and add it
    id <- sample(available[[i]], 1)
    groupMembers[[i]] <- c(groupMembers[[i]], id)
    available <-
      removeSelectedAnimalFromAvailableAnimals(available, id, numGp)

    # Remove all relatives from consideration for the group it was added to
    available[[i]] <- setdiff(available[[i]], kin[[id]])
    grpNum <- removeGroupIfNoAvailableAnimals(grpNum, available)
  }
  groupMembers
}