R/rank_mates.R

In danagibbon/MultifacitedChoice:

#' Rank Mates
#'
#' Wrapper function to score the mating of a single female to all males. \cr
#' Apply this function to multiple females using the `get_all_rankings` function. \cr
#' This functions sorts the output dataframe by highest scoring male.
#'
#' @param DB RSQLite database generated by `make_database`
#' @param female Sample ID of the female to compare to the males. The Sample ID
#' must match the ones found in the `DB`.
#' @param males Sample IDs of the males to compare to a female. 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 dataframe
#' @export
#' @examples
#' \dontrun{
#' female_mates <- rank_mate(DB = DB, female = females[1],
#'                           males = males, type = "all_alleles",
#'                           bonus=NULL, weighted_alleles=NULL)
#' }
#' @export
#' @import dplyr
#' @import tidyverse

rank_mates <- function(DB, female, males, type = "all_alleles",
                       bonus=NULL, weighted_alleles=NULL){
  comparison <- data.frame(female = female, male = males)
  outs <- lapply(1:nrow(comparison), function(i){
    out <- score_mate(DB = DB, female = comparison$female[i],
                      male = comparison$male[i], type = type,
                      bonus=bonus, weighted_alleles=weighted_alleles) %>%
      data.frame()
    return(out)
  }) %>% do.call(rbind.data.frame, .)
  outs <- outs %>%
    add_column(rank_score = outs$score*outs$alleles_used) %>%
    arrange(desc(rank_score)) %>%
    add_column(rank = row(.)[,1]) %>%
    mutate(rank_score, temp = lag(rank_score, 1)) %>%
    mutate(difference = temp - rank_score) %>%
    select(-temp) %>%
    mutate_if(is.numeric, list(~ifelse(is.na(.), 0, .))) %>%
    mutate(cumulative_dif = cumsum(difference))
  return(outs)
}