GeneticAlg.int <- function(genomeLen, codonMin, codonMax,
genomeMin=rep.int(codonMin, genomeLen), genomeMax=rep.int(codonMax, genomeLen),
suggestions=NULL,
popSize=50,
iterations=100, terminationCost=NA,
mutationChance=1/(genomeLen+1),
elitism=floor(popSize/10),
geneCrossoverPoints=NULL,
monitorFunc=NULL,
evalFunc,
allowrepeat = TRUE,
showSettings=FALSE, verbose=FALSE,
plapply = lapply) {
# Optimizes an Integer chromosome using a genetic algorithm.
#
# popSize = the population size
# iterations = number of generations
# terminationCost = The cost (error) that if reached, the GA should termiante
# mutationChance = chance that a var in the string gets mutated
# geneCrossoverPoints = An array determining the genes to be swapped in crossover
#
# Partially based on "R Based Genetic Algorithm (genalg package)""
# https://cran.r-project.org/web/packages/genalg/
is.verbose = verbose
verbose = function(...) { if (is.verbose) cat(...)}
if (is.null(evalFunc)) {
stop("A evaluation function must be provided. See the evalFunc parameter.");
}
stopifnot(genomeLen > 1)
# do a variaty of sanity checks first
verbose("Testing the sanity of parameters...\n");
if (length(genomeMin) != length(genomeMax)) {
stop("The vectors genomeMin and genomeMax must be of equal length.");
}
if (popSize < 5) {
stop("The population size must be at least 5.");
}
if (iterations < 1) {
stop("The number of iterations must be at least 1.");
}
if (!(elitism < popSize)) {
stop("The population size must be greater than the elitism.");
}
if (elitism < 0) {
stop("elitism must be at least 0.");
}
if ((mutationChance < 0) | (mutationChance > 1)) {
stop("mutationChance must be between 0 and 1.");
}
if (!is.null(geneCrossoverPoints)) {
if (!is.numeric(geneCrossoverPoints) | length(geneCrossoverPoints) != genomeLen) {
stop("Invalid geneCrossoverPoints.");
}
}
if (showSettings) {
verbose("The start conditions:\n");
result = list(genomeMin=genomeMin, genomeMax=genomeMax, suggestions=suggestions,
popSize=popSize, iterations=iterations,
elitism=elitism, mutationChance=mutationChance);
class(result) = "rbga";
cat(summary(result));
} else {
verbose("Not showing GA settings...\n");
}
##########
# Creation
population = matrix(nrow=popSize, ncol=genomeLen);
if (!is.null(suggestions)) {
verbose("Adding suggestions to first population...\n");
if ("list" %in% class(suggestions)) {
verbose("Suggestions given as a list.\n");
suggestions = do.call(rbind, suggestions)
}
if (ncol(suggestions) != genomeLen) {
stop("suggestions must be a list of chromosomes or a matrix of 'nrow=numSuggestions X ncol=genomeLen'")
}
suggestionCount = nrow(suggestions)
population[1:suggestionCount, ] <- suggestions
verbose("Filling others with random values in the given domains...\n");
} else {
verbose("Starting with random values in the given domains...\n");
suggestionCount = 0
}
for (i in (suggestionCount+1):popSize) {
population[i,] = ga.new.chromosome(genomeLen, genomeMin, genomeMax, allowrepeat)
}
############################################################################
# do iterations
bestEvals = rep(NA, iterations);
meanEvals = rep(NA, iterations);
evalVals = rep(NA, popSize);
for (iter in 1:iterations) {
verbose(paste("Starting iteration", iter, "\n"));
##########
# Evaluation
verbose("Calucating evaluation values... ");
to.eval.Ids = which(is.na(evalVals))
evalVals[to.eval.Ids] = unlist(plapply(to.eval.Ids,
function(i, population, evalFunc) evalFunc(population[i, ]),
population, evalFunc))
# check for invalid items
if ((!all(is.numeric(evalVals))) |
any(is.na(evalVals)) |
any(is.nan(evalVals))) {
stop("Invalid cost function return value (NA or NaN).")
}
# extract statistics about generation
bestEvals[iter] = min(evalVals);
meanEvals[iter] = mean(evalVals);
bestInd = which.min(evalVals)
verbose(" done.\n");
collect.results <- function() {
settings = list(genomeMin=genomeMin, genomeMax=genomeMax,
popSize=popSize, elitism=elitism, geneCrossoverPoints = geneCrossoverPoints,
iterations=iterations, suggestions=suggestions,
mutationChance=mutationChance)
pop.info = list(population=population, evaluations=evalVals, best=bestEvals, mean=meanEvals, currentIteration=iter)
best = list(genome=population[bestInd,], cost = evalVals[bestInd]);
ret = list(settings = settings, population = pop.info, best = best)
class(ret) = "GeneticAlg.int";
return (ret)
}
if (!is.null(monitorFunc)) {
verbose("Sending current state to rgba.monitor()...\n");
# report on GA results
monitorFunc(collect.results());
}
##########
# check termination conditions
if (iter == iterations) {
verbose("End of generations iteration reached.\n");
break
}
if (!is.na(terminationCost)) {
if (bestEvals[iter] <= terminationCost) {
verbose("Cost better than termination cost reached.\n");
break
}
}
##########
# Selection
verbose("Creating next generation...\n");
newPopulation = matrix(nrow=popSize, ncol=genomeLen);
newEvalVals = rep(NA, popSize);
verbose(" sorting results...\n");
sortedEvaluations = sort(evalVals, index=TRUE);
sortedPopulation = matrix(population[sortedEvaluations$ix,], ncol=genomeLen);
# save the best
if (elitism > 0) {
verbose(" applying elitism...\n");
newPopulation[1:elitism,] = sortedPopulation[1:elitism,];
newEvalVals[1:elitism] = sortedEvaluations$x[1:elitism]
} # ok, save nothing
##########
# Crossover
# fill the rest by doing crossover
verbose(" applying crossover...\n");
for (child in (elitism+1):popSize) {
# ok, pick two random parents using roulette wheel probability
parentProb = dnorm(1:popSize, mean=0, sd=(popSize/3))
parentIDs = sample(1:popSize, 2, prob=parentProb)
parents = sortedPopulation[parentIDs,]
# default cross-over swaps genomes from a random point
if (is.null(geneCrossoverPoints)) {
crossOverPoint = sample(0:genomeLen,1)
if (crossOverPoint == 0) {
newPopulation[child, ] = parents[2,]
newEvalVals[child] = sortedEvaluations$x[parentIDs[2]]
} else if (crossOverPoint == genomeLen) {
newPopulation[child, ] = parents[1,]
newEvalVals[child] = sortedEvaluations$x[parentIDs[1]]
} else {
newPopulation[child, ] =
c(parents[1, 1:crossOverPoint],
parents[2, (crossOverPoint+1):genomeLen])
}
} else {
# swap genes based on the location of gene crossoverPoints
p2.indices = which(geneCrossoverPoints %% 2 != 0)
newPopulation[child, ] = parents[1,]
newPopulation[child, p2.indices] = parents[2, p2.indices]
}
}
if (!allowrepeat) {
for (i in (elitism+1):popSize) {
population[i,] = ga.unique.maker(population[i,], genomeMin, genomeMax)
}
}
population = newPopulation;
evalVals = newEvalVals;
##########
# Mutation
if (mutationChance > 0) {
verbose(" applying mutations... ");
mutationCount = 0;
mutatedChromosomes = 0;
for (object in (elitism+1):popSize) { # don't mutate the best
dampeningFactor = (iterations-iter)/iterations
mutResult <- ga.mutation(population[object,], mutationChance, genomeLen,
genomeMin, genomeMax, allowrepeat,
dampeningFactor)
population[object, ] = mutResult$newGenome;
evalVals[object] = NA;
mutationCount = mutationCount + mutResult$numMutations;
mutatedChromosomes = mutatedChromosomes + 1;
}
verbose(paste(mutationCount, "mutations applied (chromosomes mutated: ", mutatedChromosomes, ")\n"));
}
}
# report on GA results
result = collect.results()
return(result);
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.