R/pedigrees.R

In knifecake/forrelgui: Exclusion Power GUI for the forrel package

#' Plot a pedigree (list) for the Exclusion power GUI
#'
#' @param x a \code{\link[pedtools]{ped}} object or a list of such
#' @param available a list of individuals available for genotyping (will be red)
#' @param genotyped a list of individuals that are genotyped (will be shaded)
#'
#' @seealso \code{\link[pedtools]{plotPedList}}
#'
#' @importFrom graphics plot
#'
#' @export
custom_ped_plot <- function(x, available = c(), genotyped = c()) {
  if (is.null(x)) return()
  
  if (pedtools::is.pedList(x)) {
    plot_arg_list <- lapply(x, function(p) {
      list(x = p,
           col = list(red = intersect(available, labels(p))),
           shaded = intersect(genotyped, labels(p)))
    })
    pedtools::plotPedList(plot_arg_list,
                          frames = FALSE)
  } else {
    plot(x,
         col = list(red = intersect(available, labels(x))),
         shaded = intersect(genotyped, labels(x)))
  }
}


#' Get pedigree labels
#'
#' Same as \code{\link[pedtools]{relabel}} but works on pedigree lists
#'
#' @param x a \code{\link[pedtools]{ped}} object or a list of such
#'
#' @return a character vector containing the ID labels of all pedigree members
#'
#' @seealso \code{\link[pedtools]{relabel}}
#'
#' @export
custom_ped_labels <- function(x) {
  if (pedtools::is.pedList(x))
    as.character(unlist(lapply(x, custom_ped_labels)))
  else
    labels(x)
}

#' Get genotyped individuals in a pedigree
#'
#' @param x a \code{\link[pedtools]{ped}} object or a list of such
#'
#' @return a character vector containing the ID labels of all genotyped pedigree
#'   members
#'
#' @export
get_genotyped_ids <- function(x) {
  if (pedtools::is.pedList(x)) {
    as.character(unlist(lapply(x, get_genotyped_ids)))
  } else {
    ids <- labels(x)
    ids[as.vector(lapply(ids, function(id) { is_genotyped(x, id) }),
                  mode = "logical")]
  }
}
is_genotyped <- function(x, id) {
  any(!is.na(pedtools::getAlleles(x, ids = c(id))))
}