R/freq2GenData.R

In strataG: Summaries and Population Structure Analyses of Genetic Data

#' @title Convert Haplotype Frequency Matrices
#' @description Create a data frame of stratified individuals and their 
#'   haplotypes from a frequency table
#' 
#' @param freq.mat a matrix or data.frame containing haplotypic 
#'   frequencies with strata as column names.
#' @param hap.col a number giving the column providing haplotype 
#'   labels or a vector the same length as freq.mat. If \code{NULL} rownames 
#'   are used.
#' @param freq.col a number giving the first column containing 
#'   haplotype frequencies.
#' @param id.label character to label sample IDs with in resulting 
#'   data.frame.
#' @param hap.label character to label haplotypes with in 
#'   resulting data.frame.
#' 
#' @return a data frame with one row per sample and columns for id, strata, 
#'   and haplotype, suitable for use in \link{df2gtypes}.
#' 
#' @author Eric Archer \email{eric.archer@@noaa.gov}
#' 
#' @examples
#' hap.freqs <- data.frame(
#'   haps = c("hap1", "hap2", "hap3"),
#'   pop1 = rmultinom(1, 50, prob = c(0.1, 0.2, 0.7)),
#'   pop2 = rmultinom(1, 25, prob = c(0.5, 0.4, 0.1))
#' )
#' 
#' gen.data <- freq2GenData(hap.freqs, hap.col = 1, freq.col = 2)
#' 
#' x <- df2gtypes(gen.data, ploidy = 1)
#' summary(x)
#' 
#' @export
#' 
freq2GenData <- function(freq.mat, hap.col = NULL, freq.col = 1, 
                         id.label = NULL, hap.label = NULL) {
  haps <- if(is.null(hap.col)) {
    if(is.null(rownames(freq.mat))) 1:nrow(freq.mat) else rownames(freq.mat)
  } else {
    if(length(hap.col) == 1) freq.mat[, hap.col] else hap.col
  }
  
  df <- do.call(rbind, lapply(freq.col:ncol(freq.mat), function(i) {
    freq.sub <- cbind(haps, freq.mat[, i])
    freq.sub <- freq.sub[stats::complete.cases(freq.sub), , drop = FALSE]
    haps <- rep(freq.sub[, 1], times = as.numeric(freq.sub[, 2]))
    if(!is.null(hap.label)) haps <- paste(hap.label, haps, sep = ".")   
    data.frame(
      strata = colnames(freq.mat)[i], 
      haplotype = haps, 
      stringsAsFactors = FALSE
    )
  }))
  ids <- 1:nrow(df)
  if(!is.null(id.label)) ids <- paste(id.label, ids, sep = ".")
  rownames(df) <- ids
  cbind(id = ids, df, stringsAsFactors = FALSE)
}