R/EBD_parent_sampler.R

In Don-Li/CAB_original:

#### EBD parental selection ####

#' @include EBD_pop.R EBD_sample.R EBD_fitness_def.R EBD_fitness_fx.R
NULL

#' Evolutionary Behaviour Parental Selection class
#'
#' Do this later
#'
#' @exportMethod EBD_parent_sampler

setGeneric( "EBD_parent_sampler", function( pop, fitness = NULL, weights = NULL ) standardGeneric( "EBD_parent_sampler" ) )

setMethod( "EBD_parent_sampler", signature( pop = "EBD_pop", fitness = "numeric", weights = "numeric" ),
    function(pop, fitness, weights){
        EBD_get_parents( pop, fitness, weights )
    }
)

setMethod( "EBD_parent_sampler", signature( pop = "EBD_pop", fitness = "missing", weights = "missing" ),
    function(pop){
        EBD_random_parents( pop )
    }
)


EBD_get_parents = function( pop, fitness, weights ){
    size = pop@info$size
    mother_vapply_value = ( 1:ceiling( log( max( pop@info$domain ), 2 ) ) )*1.0
    unique_fitnesses = !duplicated( fitness )
    father_fitnesses = sample( unique(fitness), size = size, replace = T, prob = weights[unique_fitnesses] )
    father_index = match( father_fitnesses, fitness )
    fathers = pop@genotype$genotype[ ,father_index ]

    mothers = vapply( father_index, function(x){
        candidate_fitnesses = fitness[-x]
        unique_candidates = !duplicated( candidate_fitnesses )
        mother_fitness = sample( unique( candidate_fitnesses ), 1, prob = weights[-x][unique_candidates] )
        mother_index = match( mother_fitness, candidate_fitnesses )
        pop@genotype$genotype[,-x][,mother_index]
    }, FUN.VALUE = mother_vapply_value )

    cbind( fathers, mothers )
}

EBD_random_parents = function( pop ){
    z = vapply( 1:pop@info$size, function(x){
        sample( 1:pop@info$size, 2, replace = F )
    }, FUN.VALUE = 1:2*1.0 )

    cbind( pop@genotype$genotype[, z[1,] ], pop@genotype$genotype[, z[2,] ] )
}