如何使用R语言GA库优化带混合参数约束的my_subset_mean函数

测试数据构造 #

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

均值计算函数定义 #

# 先修改函数支持NA参数逻辑
my_subset_mean <- function(r1=NA, r2=NA, r3=NA){  
  if (all(is.na(r1))) r1 <- unique(df$a)
  if (is.na(r2)) r2 <- -Inf
  if (is.na(r3)) r3 <- Inf
  subset <- df %>% filter(a %in% r1, b > r2, d < r3)
  # 空子集返回极小值避免GA进化异常
  if(nrow(subset)==0) return(-Inf)
  return(mean(subset$c))
}

# 测试调用
my_subset_mean(r1 = c("a", "b"), r2 = 5, r3 = 1 ) 
# [1] 5.682513

优化约束条件 #

• r1可取["a","b","c","d","e"]的任意组合，也可设为NA表示取a列所有取值
• r2可取值为0到1之间的数值，也可设为NA表示无b列下界约束
• r3可取值为0到1之间的数值，也可设为NA表示无d列上界约束

原有错误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)

参考用随机网格搜索实现 #

my_subset_mean_grid <- 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_val <- my_subset_mean_grid(r1, r2, r3, r4)
  data.frame(r1 = toString(r1), r4 = toString(r4), r2, r3, my_subset_mean = my_subset_mean_val)
}

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

正确GA实现代码 #

编码逻辑说明 #

将GA染色体编码为长度为9的实数向量，取值范围均为0~1：

• 前5位：阈值0.5转二进制，分别对应a/b/c/d/e是否被纳入r1筛选范围，全为0时视为r1=NA
• 第6位：阈值0.5转0/1，1表示r2启用、取第7位数值，0表示r2=NA
• 第7位：r2的实际取值（0~1）
• 第8位：阈值0.5转0/1，1表示r3启用、取第9位数值，0表示r3=NA
• 第9位：r3的实际取值（0~1）

实现代码 #

library(GA)

# 编码映射表
a_levels <- levels(df$a)

# 适应度函数
fitness_func <- function(x) {
  # 解码r1
  r1_select <- x[1:5] > 0.5
  if(sum(r1_select) == 0) {
    r1 <- NA
  } else {
    r1 <- a_levels[r1_select]
  }
  # 解码r2
  r2 <- ifelse(x[6] > 0.5, x[7], NA)
  # 解码r3
  r3 <- ifelse(x[8] > 0.5, x[9], NA)
  # 计算均值
  return(my_subset_mean(r1, r2, r3))
}

# 运行GA
set.seed(123)
ga_res <- ga(
  type = "real-valued",
  fitness = fitness_func,
  lower = rep(0, 9),
  upper = rep(1, 9),
  popSize = 50,
  maxiter = 1000,
  run = 100,
  maxFitness = max(df$c) # 可选，设置理论上限提前终止
)

# 解码最优解
best_x <- ga_res@solution[1,]
best_r1_select <- best_x[1:5] > 0.5
best_r1 <- if(sum(best_r1_select)==0) NA else a_levels[best_r1_select]
best_r2 <- ifelse(best_x[6]>0.5, best_x[7], NA)
best_r3 <- ifelse(best_x[8]>0.5, best_x[9], NA)
best_mean <- ga_res@fitnessValue

# 输出结果
cat("最优参数：\n")
cat("r1:", toString(best_r1), "\n")
cat("r2:", ifelse(is.na(best_r2), "NA", round(best_r2,4)), "\n")
cat("r3:", ifelse(is.na(best_r3), "NA", round(best_r3,4)), "\n")
cat("最大c列均值：", round(best_mean,4), "\n")

内容的提问来源于stack exchange，提问作者stats_noob