R備忘録 - 記事一覧
- 投稿者: みゅ
- カテゴリ: なし
- 優先度: 普通
- 状態: 完了
- 日時: 2011年06月06日 07時11分24秒
- 遺伝的アルゴリズムを使いたいときに「genalg」パッケージを使うのだが、交配の方法を少し改良してみました.
- 結果を返すときに、populationをソートしてから返すようにしました.
- あとつづりの間違いなども修正.
- 交配で修正したあたりに「←」をつけています.
- evalFuncは以下の形式で値を返す.
- evalFuncの中で引数自体の値を変更することもあるので、目的関数の値と引数を返すようにしました.(たとえばevalFuncの中で最小化などを行う場合)
func <- function(param){
・・・
list(eval=..., param=...))
}
rbga <-
function (stringMin = c(), stringMax = c(), suggestions = NULL,
popSize = 200, iters = 100, mutationChance = NA, elitism = NA,
monitorFunc = NULL, evalFunc = NULL, showSettings = FALSE,
verbose = FALSE)
{
if (is.null(evalFunc)) {
stop("A evaluation function must be provided. See the evalFunc parameter.")
}
vars <- length(stringMin)
if (is.na(mutationChance)) {
mutationChance <- 1/(vars + 1)
}
if (is.na(elitism)) {
elitism <- floor(popSize/5)
}
if (verbose)
cat("Testing the sanity of parameters...\n")
if (length(stringMin) != length(stringMax)) {
stop("The vectors stringMin and stringMax must be of equal length.")
}
if (popSize < 5) {
stop("The population size must be at least 5.")
}
if (iters < 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 (showSettings) {
if (verbose)
cat("The start conditions:\n")
result <- list(stringMin = stringMin, stringMax = stringMax,
suggestions = suggestions, popSize = popSize, iters = iters,
elitism = elitism, mutationChance = mutationChance)
class(result) <- "rbga"
cat(summary(result))
}
else {
if (verbose)
cat("Not showing GA settings...\n")
}
if (vars > 0) {
if (!is.null(suggestions)) {
if (verbose)
cat("Adding suggestions to first population...\n")
population <- matrix(nrow = popSize, ncol = vars)
suggestionCount <- dim(suggestions)[1]
for (i in 1:suggestionCount) {
population[i, ] <- suggestions[i, ]
}
if (verbose)
cat("Filling others with random values in the given domains...\n")
for (var in 1:vars) {
population[(suggestionCount + 1):popSize, var] <- stringMin[var] +
runif(popSize - suggestionCount) * (stringMax[var] - stringMin[var])
}
}
else {
if (verbose)
cat("Starting with random values in the given domains...\n")
population <- matrix(nrow = popSize, ncol = vars)
for (var in 1:vars) {
population[, var] <- stringMin[var] + runif(popSize) * (stringMax[var] - stringMin[var])
}
}
bestEvals <- rep(NA, iters)
meanEvals <- rep(NA, iters)
evalVals <- rep(NA, popSize)
for (iter in 1:iters) {
if (verbose)
cat(paste("Starting iteration", iter, "\n"))
if (verbose)
cat("Calculating evaluation values... ")
for (ii in 1:popSize) {
if (is.na(evalVals[ii])) {
tmp <- evalFunc(population[ii,])
evalVals[ii] <- tmp$eval
population[ii,] <- tmp$param
if (verbose)
cat(".")
}
}
bestEvals[iter] <- min(evalVals)
meanEvals[iter] <- mean(evalVals)
if (verbose)
cat(" done.\n")
newPopulation <- matrix(nrow = popSize, ncol = vars)
newEvalVals <- rep(NA, popSize)
if (verbose)
cat(" sorting results...\n")
sortedEvaluations <- sort(evalVals, index=T)
sortedPopulation <- population[sortedEvaluations$ix,]
result <- list(type = "floats chromosome", stringMin = stringMin,
stringMax = stringMax, popSize = popSize, iter = iter, iters = iters,
suggestions = suggestions, population = sortedPopulation, elitism = elitism,
mutationChance = mutationChance, evaluations = sortedEvaluations,
best = bestEvals, mean = meanEvals)
class(result) <- "rbga"
if (!is.null(monitorFunc)) {
if (verbose)
cat("Sending current state to rbga.monitor()...\n")
monitorFunc(result)
}
if (iter < iters) {
if (verbose)
cat("Creating next generation...\n")
if (elitism > 0) {
if (verbose)
cat(" applying elitism...\n")
newPopulation[1:elitism, ] <- sortedPopulation[1:elitism,]
newEvalVals[1:elitism] <- sortedEvaluations$x[1:elitism]
}
if (vars > 1) {
if (verbose)
cat(" applying crossover...\n")
for(child in (elitism+1):popSize) {
parentIDs <- sample(1:popSize, 2)
parents <- sortedPopulation[parentIDs,]
nCross <- floor(runif(1)*(vars-1)) + 1 ←
crossOverPoints <- sort(sample(1:vars, nCross)) ←
#newPopulation[child,] <- c(parents[1,][1:crossOverPoint],parents[2,][(crossOverPoint + 1):vars])
newPopulation[child,crossOverPoints] <- parents[1,crossOverPoints] ←
newPopulation[child,-crossOverPoints] <- parents[2,-crossOverPoints] ←
}
}
else {
if (verbose)
cat(" cannot crossover (#vars=1), using new randoms...\n")
newPopulation[(elitism + 1):popSize, ] <- sortedPopulation[sample(1:popSize,popSize - elitism),]
}
population <- newPopulation
evalVals <- newEvalVals
if (mutationChance > 0) {
if (verbose)
cat(" applying mutations... ")
mutationCount <- 0
for (object in (elitism + 1):popSize) {
for (var in 1:vars) {
if (runif(1) < mutationChance) {
dempeningFactor <- (iters - iter)/iters
direction <- sample(c(-1, 1), 1)
mutationVal <- (stringMax[var] - stringMin[var]) * 0.67
mutation <- population[object, var] + direction * mutationVal * dempeningFactor
if (mutation < stringMin[var])
mutation <- stringMin[var]
if (mutation > stringMax[var])
mutation <- stringMax[var]
population[object, var] <- mutation
evalVals[object] <- NA
mutationCount <- mutationCount + 1
}
}
}
if (verbose)
cat(paste(mutationCount, "mutations applied\n"))
}
}
}
}
return(result)
}
R備忘録 /状態空間モデリング/donlp2/その他のメモ