R/add.pedigree.r

In synbreed: Framework for the Analysis of Genomic Prediction Data using R

#' Merge \code{pedigree} object
#'
#' This function can be used to add some pedigree information to a existing \code{pedigree} object.
#'
#' Missing values for parents in the pedigree should be coded with 0 for
#' numeric ID or \code{NA} for character ID.
#'
#' @param ped \code{pedigree} object
#' @param IDadd \code{pedigree} object
#' @param add.ancestors \code{logical}. Add ancestors which do not occur in
#' \code{ID} to the pedigree.
#' @return An object of class \code{pedigree}. Column \code{gener} starts from
#' 0 and pedigree is sorted by generation.
#' @author Hans-Juergen Auinger
#' @seealso \code{\link{plot.pedigree}, \link{create.pedigree}}
#' @examples
#'
#' # example with 9 individuals
#' id <- paste("ID", 1:9, sep = "0")
#' par1 <- paste("ID", c("", "", "", "", 1, 1, 1, 4, 7), sep = "0")
#' par2 <- paste("ID", c("", "", "", "", 2, 3, 2, 5, 8), sep = "0")
#' ped1 <- create.pedigree(id, par1, par2, unknown = "ID0")
#'
#' # create 2nd pedigree object
#' Id <- paste("ID", 10:16, sep = "")
#' Par1 <- paste("ID", c("", "", 1, 1, 6, 7, 7), sep = "0")
#' Par2 <- paste("ID", c("", "", 10, "08", "09", 11, 14), sep = "")
#' ped2 <- create.pedigree(Id, Par1, Par2, unknown = c("ID0", "ID"))
#' ped2
#'
#' ped <- add.pedigree(ped1, ped2)
#' ped
#' @export add.pedigree
add.pedigree <- function(ped, IDadd, add.ancestors = FALSE) {
  if (!all.equal(class(ped), c("pedigree", "data.frame"))) stop(paste(substitute(ped), "has to be an object generated by create.pedigree()"))
  if (!all.equal(class(IDadd), c("pedigree", "data.frame"))) stop(paste(substitute(IDadd), "has to be an object generated by create.pedigree()"))

  # only unique IDs
  IDped <- unique(rbind(ped[ped$ID %in% IDadd$ID, c("ID", "Par1", "Par2")], IDadd[IDadd$ID %in% ped$ID, c("ID", "Par1", "Par2")]))
  if (length(unique(IDped[, "ID"])) != nrow(IDped)) stop("IDs are not unique, removing duplicated individuals")
  if (!is.null(ped$sex) & is.null(IDadd$sex)) {
    IDadd$sex <- NA
    warning("No information on sex in ", substitute(IDadd), ". Values will be set to NA")
  }
  if (is.null(ped$sex) & !is.null(IDadd$sex)) {
    ped$sex <- NA
    warning("No information on sex in ", substitute(ped), ". Values will be set to NA")
  }
  ped <- rbind(ped, IDadd[IDadd$gener == 0, ])
  IDadd <- IDadd[!IDadd$ID %in% ped$ID, ]
  gener <- sort(unique(IDadd$gener))
  for (i in gener) {
    geners <- cbind(
      ped$gener[match(IDadd$Par1[IDadd$gener == i], ped$ID)],
      ped$gener[match(IDadd$Par2[IDadd$gener == i], ped$ID)]
    )
    geners <- apply(geners, 1, max) + 1
    ped <- rbind(ped, IDadd[IDadd$gener == i, ])
    ped$gener[ped$ID %in% IDadd$ID[IDadd$gener == i]] <- geners
  }
  ped <- ped[order(ped$gener, ped$ID), ]
  return(ped)
}