R：是否可以优化以下功能？

Question

我正在使用 R 编程语言。

我有以下数据：

library("dplyr")

df <- data.frame(b = rnorm(100,5,5), d = rnorm(100,2,2),
                 c = rnorm(100,10,10))

a <- c("a", "b", "c", "d", "e")
a <- sample(a, 100, replace=TRUE, prob=c(0.3, 0.2, 0.3, 0.1, 0.1))

a<- as.factor(a)
df$a = a

> head(df)
           b          d          c a
1  3.1316480  0.5032860  4.7362991 a
2  4.3111450 -0.1142736 -0.5841322 c
3  2.8291346  3.6107839 16.0684492 a
4 14.2142245  4.9893987 -1.8145138 a
5 -6.7381302  0.0416782 -7.7675387 c
6  0.4481874  0.3370716 17.4260801 a

我还有以下函数 (my_subset_mean)，它在给定特定输入选择的情况下评估“c 列”的平均值：

 my_subset_mean <- function(r1, r2, r3){  
      subset <- df %>% filter(a %in% r1, b > r2, d < r3)
      return(mean(subset$c))
    }
    
    my_subset_mean(r1 = c("a", "b"), r2 = 5, r3 = 1 ) 
    [1] 5.682513

问题：使用 R 中的 GA 库，我正在尝试根据以下约束优化（混合整数规划）my_subset_mean 函数：

• "r1" 可以采用 ("a", "b", "c", "d", "e") 的任意组合，例如"a", "a,c", "b, d, e", "a, b, c, d, e", "e, a" 等

• "r2" 可以取 0 到 1 之间的任何值

• "r3" 可以取 0 到 1 之间的任何值

• 不过，my_subset_mean 也可以使用未指定的“r1”、“r2”或“r3”值进行计算，例如：

my_subset_mean(r1 = c("a", "b"), r2 = 5, r3 = NA)
my_subset_mean(r1 = NA,  r2 = 5, r3 = NA )

等等

我尝试使用 GA 库执行此优化：

library(GA)

GA <- ga(type = "real-valued", 
         fitness = function(x)  my_subset_mean(x[1], x[2], x[3]),
         lower = c(c("a", "b", "c", "d"), 1, 1), upper = c(c("a", "b", "c", "d"), 100, 100), 
         popSize = 50, maxiter = 1000, run = 100)

但我认为这不是正确的做法。

谢谢

我过去的尝试：

在上一个问题（R: Adding "NA" factors to the "levels" function）中，我学习了如何使用“随机网格搜索”优化类似的功能：

my_subset_mean <- function(r1=NA, r2=NA, r3=NA, r4 = NA) {  
  if (all(is.na(r1))) r1 <- unique(df$a)
  if (all(is.na(r4))) r4 <- unique(df$f)
  if (is.na(r2)) r2 <- -Inf
  if (is.na(r3)) r3 <- Inf
  s <- filter(df, a %in% r1 , f %in% r4, b > r2 , d < r3)
  return(mean(s$c))
}

create_output <- function() {
  uv <- levels(df$a)
  r1 <- sample(list(sample(uv, sample(length(uv))), NA), 1)[[1]]
  uv1 <- levels(df$f)
  r4 <-  sample(list(sample(uv1, sample(length(uv1))), NA), 1)[[1]]
  rgb <- range(df$b)
  rgd <- range(df$d)
  r2 <- sample(c(runif(1, rgb[1], rgb[2]), NA), 1)
  r3 <- sample(c(runif(1, rgd[1], rgd[2]), NA), 1)
  my_subset_mean <- my_subset_mean(r1, r2, r3, r4)
  data.frame(r1 = toString(r1), r4 = toString(r4), r2, r3, my_subset_mean)
}

set.seed(123)
out <- do.call(rbind, replicate(100, create_output(), simplify = FALSE))
head(out)

#            r1         r4        r2        r3 my_subset_mean
#1            NA          c        NA 4.2164973      12.095431
#2 a, b, c, d, e    b, a, c        NA 0.4394423       7.130999
#3            NA a, c, e, b  9.285701        NA       8.236054
#4            NA         NA 14.060829 3.8960888      10.562523
#5    c, b, a, d         NA        NA        NA       9.015613
#6            NA    a, c, d  2.251218        NA      10.070425

但是谁能告诉我如何使用 R 中的“GA”函数来做到这一点？

谢谢

参考：

• https://cran.r-project.org/web/packages/GA/vignettes/GA.html
• https://www.rdocumentation.org/packages/GA/versions/3.2.1/topics/ga

Answer 1

本地搜索算法可以处理此类问题的原因是，解决方案只“涉及”两个函数，这两个函数都必须提供。 first 是目标函数。

我稍微改写了你的：

my_subset_mean <- function(x){  
    subset <- df %>% filter(a %in% names(x$r1)[x$r1],
                            b > x$r2,
                            d < x$r3)
    ans <- -mean(subset$c)
    if (!is.finite(ans))
        ans <- 100
    ans
}

而不是三个参数，它只需要一个：原始参数列表。另外，我假设你想最大化，所以我在平均值前面加了一个减号。 （我稍后将使用的算法默认最小化。）如果平均值不是有限的（NA，NaN），我只需返回一个大值作为“坏”解决方案的标记。只需根据您的需要进行调整即可。

从任意但有效的解决方案开始。

tmp <- !logical(length(sort(unique(a))))
names(tmp) <- sort(unique(a))

x <- list(r1 = tmp,
          r2 = 0.5,
          r3 = 0.5)

x
## $r1
##    a    b    c    d    e 
## TRUE TRUE TRUE TRUE TRUE 
## 
## $r2
## [1] 0.5
## 
## $r3
## [1] 0.5

我重新创建了您的数据。 （我不使用因子，而是使用字符串。）

library("dplyr")
df <- data.frame(b = rnorm(100,5,5), d = rnorm(100,2,2),
                 c = rnorm(100,10,10))

a <- c("a", "b", "c", "d", "e")
a <- sample(a, 100, replace=TRUE, prob=c(0.3, 0.2, 0.3, 0.1, 0.1))
df$a <- a

评估x：

my_subset_mean(x)
## [1] -11.34132

当然，这个结果取决于随机数据。你的数字会有所不同。

现在，第二个功能：邻里。它需要一个解决方案并返回一个稍微修改过的版本。同样，由于您必须提供此功能，因此您拥有完全的控制权，因此任何数据结构都可以用作输入。这是一个例子。

nb <- function(x) {
    i <- sample(c("r1", "r2", "r3"), 1)
    if (i == "r1") {
        j <- sample(length(x[[i]]), 1)
        x[[i]][j] <- !x[[i]][j]        
    } else {
        x[[i]] <- x[[i]] + runif(1, min = -0.1, max = 0.1)
        x[[i]] <- max(min(1, x[[i]]), 0)        
    }
    x
}

邻域函数 (i) 随机选择一个 解的组成部分，以及 (ii) 随机变化 那个组件。由于r2 和r3 的行为相同， 该函数使用相同的代码来处理两者。这 邻里还处理r2 和 r3 说max(min(1, x[[i]]), 0)：值更小 大于 0 则增加到零；大于 1 的值是 减少到 1。如果您想要不同的限制，请单独处理组件（即添加更多 else if 子句）。

x  ## original solution
## $r1
##    a    b    c    d    e 
## TRUE TRUE TRUE TRUE TRUE 
## 
## $r2
## [1] 0.5
## 
## $r3
## [1] 0.5

nb(x)   ## ... and a neighbour
## $r1
##    a    b    c    d    e 
## TRUE TRUE TRUE TRUE TRUE 
## 
## $r2
## [1] 0.5
## 
## $r3
## [1] 0.42586

nb(x)   ## ... and another neighbour
## $r1
##     a     b     c     d     e 
##  TRUE FALSE  TRUE  TRUE  TRUE 
## 
## $r2
## [1] 0.5
## 
## $r3
## [1] 0.5

就是这样。使用这两个函数（objective 和 neighbourhood），您可以运行实际的算法。在这里，我使用阈值接受。

library("NMOF")
ans <- TAopt(my_subset_mean, list(x0 = x, neighbour = nb, nI = 1000))

-my_subset_mean(ans$xbest)

我希望这能让您开始使用TAopt。 有关本地搜索方法的更多信息，请参阅tutorial。 由于您显然想要过滤数据框，因此这个答案也许也有帮助：Finding ideal filter setting to maximize target function。 披露：我是包NMOF的维护者。

---

在评论后更新：扩展nb 以获得更多组件很简单。假设您希望r2 的步数更大，它应该在 -5 和 5 之间。那么您可以这样编写函数：

nb <- function(x) {
    i <- sample(c("r1", "r2", "r3"), 1)
    if (i == "r1") {
        j <- sample(length(x[[i]]), 1)
        x[[i]][j] <- !x[[i]][j]
    } else if (i == "r2") {
        x[[i]] <- x[[i]] + runif(1, min = -0.5, max = 0.5)
        x[[i]] <- max(min(5, x[[i]]), -5)        
    } else if (i == "r3"){
        x[[i]] <- x[[i]] + runif(1, min = -0.1, max = 0.1)
        x[[i]] <- max(min(1, x[[i]]), 0)        
    }
    x
}