[[Ｒ備忘録 - 記事一覧]]

!!!genalg
*投稿者： みゅ
*カテゴリ： なし
*優先度： 普通
*状態： 完了
*日時： 2011年06月06日 07時11分24秒
//{{bugstate}}
!!内容
*遺伝的アルゴリズムを使いたいときに「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)
 }



!!コメント
//{{comment}}