トップ 差分 一覧 ソース 検索 ヘルプ RSS ログイン

BugTrack-R備忘録/68

R備忘録 /状態空間モデリング/donlp2/その他のメモ

R備忘録 - 記事一覧

genalg

  • 投稿者: みゅ
  • カテゴリ: なし
  • 優先度: 普通
  • 状態: 完了
  • 日時: 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)
}

コメント