Genetic algorythm (GA) to select the optimal n values of a vector

Question

I have to choose 10 elements of a vector to maximizes a function. Since the vector is pretty long there are to many possibilities (~1000 choose 10) to compute them all. So I started to look into the GA package to use a genetic algorithm.

I came up with this MWE:

values <- 1:1000


# Fitness function which I want to maximise
f <- function(x){
  # Choose values
  y <- values[x]
  
  # From the first 10 sum up the odd values. 
  y <- ifelse(y %% 2 != 0, y, 0) 
  y <- y[1:10]
  return(sum(y))
}

# Maximum value of f for this example
y <- ifelse(values %% 2 != 0, values, 0) 
sum(sort(y, decreasing = TRUE)[1:10])
# [1] 9900 

# Genetic algorithm
GA <- ga(type = "permutation", fitness = f, lower = rep(1, 10), upper = rep(1000, 10), maxiter = 100)
summary(GA)

The results are a bit underwhelming. From summary(GA), I get the feeling that the algorithm always permutates all 1000 values (the solution goes from x1 to x1000) which leads to an inefficient optimization. How can I tell the algorithm that it should only should use 10 values (so the solution is x1 .. x10)?

Answer 1

You should read https://www.jstatsoft.org/article/view/v053i04. You don't have permutation problem but selection one hence you should use binary type of genetic algorithm. Because you want to select exclusively 10 (10 ones and 990 zeroes) you should probably write your own genetic operators because that is constraint that will hardly ever be satisfied by default operators (with inclusion of -Inf in fitness function if you have more than 10 zeroes). One approach:

Population (k tells how much ones you want):

myInit <- function(k){
  
  function(GA){
    m <- matrix(0, ncol = GA@nBits, nrow = GA@popSize)
    
    for(i in seq_len(GA@popSize))
      m[i, sample(GA@nBits, k)] <- 1 
  
    m
  }
}

Crossover

myCrossover <- function(GA, parents){
  
  parents <- GA@population[parents,] %>%
    apply(1, function(x) which(x == 1)) %>%
    t()

  parents_diff <- list("vector", 2)
  parents_diff[[1]] <- setdiff(parents[2,], parents[1,])
  parents_diff[[2]] <- setdiff(parents[1,], parents[2,])
  
  children_ind <- list("vector", 2)
  for(i in 1:2){
    k <- length(parents_diff[[i]])
    change_k <- sample(k, sample(ceiling(k/2), 1))
    children_ind[[i]] <- if(length(change_k) > 0){
      c(parents[i, -change_k], parents_diff[[i]][change_k])
    } else {
      parents[i,]
    }
  }
  
  children <- matrix(0, nrow = 2, ncol = GA@nBits)
  for(i in 1:2)
    children[i, children_ind[[i]]] <- 1
  
  list(children = children, fitness = c(NA, NA))
}

Mutation

myMutation <- function(GA, parent){
  
  ind <- which(GA@population[parent,] == 1) 
  n_change <- sample(3, 1)
  ind[sample(length(ind), n_change)] <- sample(setdiff(seq_len(GA@nBits), ind), n_change)
  parent <- integer(GA@nBits)
  parent[ind] <- 1
  
  parent
}

Fitness (your function adapted for binary GA):

f <- function(x, values){
  
  ind <- which(x == 1)
  y <- values[ind]
  y <- ifelse(y %% 2 != 0, y, 0) 
  y <- y[1:10]
  return(sum(y))
}

GA:

GA <- ga(
  type = "binary", 
  fitness = f, 
  values = values,
  nBits = length(values),
  population = myInit(10),
  crossover = myCrossover,
  mutation = myMutation,
  run = 300,
  pmutation = 0.3,
  maxiter = 10000,
  popSize = 100
)

Chosen values

values[which(GA@solution[1,] == 1)]