R/get_all_rankings.R

In danagibbon/MultifacitedChoice:

#' Rank Mates
#'
#' Wrapper function to score the mating of all females to all males. \cr
#' This function is a wrapper function for `rank_mates`. \cr
#' It is not recommended to use more than 10x10 samples.
#'
#' @param DB RSQLite database generated by `make_database`
#' @param females Vector of sample IDs of the females to compare to the males. The Sample IDs
#' must match the ones found in the `DB`.
#' @param males Vector of sample IDs of the males to compare to the females. The Sample IDs
#' must match the ones found in the `DB`.
#' @param type The type of mating that is advantageous.
#' 1. `all_alleles`: the user specifies for each locus what is advantageous.
#' 2. `assortive`: Assortive (same alleles) is advantageous for all loci
#' 3. `disassortive`: Disassortive (different alleles) is advantageous for all loci
#' @param bonus Numeric value to increase mating score if the state of alleles
#' specified in `weighted_alleles` are met. If you specify .15 as your bonus,
#' and 2/3 of your loci match the advantageous, then .10 will be used as the bonus.
#' The final score will be increased by 10%. Must specify `weighted_alleles`.
#' @param weighted_alleles vector listing allele IDs to calculate the bonus. Must
#' specify `bonus`.
#' @return List of dataframes - dataframe for each female ranked by best mating
#' score.
#' @export
#' @examples
#' \dontrun{
#' all_mates <- get_all_rankings(DB = DBs, female = females,
#'                               males = males, type = "all_alleles",
#'                               bonus=NULL, weighted_alleles=NULL)
#' }
#' @export
#' @import dplyr
#' @import tidyverse


get_all_rankings <- function(DB, females, males,
                             type = "all_alleles",
                             bonus=NULL, weighted_alleles=NULL){
  tt <- lapply(1:length(females), function(i){
    rank_mates(DB = DB, female = females[i],
               males = males, type = type,
               bonus=bonus, weighted_alleles=weighted_alleles)
  }) %>% `names<-`(females)
  return(tt)
}