GA for the Travelling Salesman Problem

[swaheera]

Suppose I have 20 cities and the Longitude/Latitude for each of these cities :

final_data = data.frame( long = rnorm(20, -74, 1 ), lat = rnorm(20, 40, 1 ))


final_data$names <- paste("Location", 1:20)

final_data$id = 1:nrow(final_data)

       long      lat      names id
1 -74.03229 40.45660 Location 1  1
2 -73.48140 39.97652 Location 2  2
3 -74.61906 40.10667 Location 3  3
4 -74.53106 39.99154 Location 4  4
5 -76.70573 41.09328 Location 5  5
6 -75.04852 39.28754 Location 6  6

I can also make a distance matrix for these cities that contains the distance between each pair of cities:

library(geosphere)

N <- nrow(final_data) 

dists <- outer(seq_len(N), seq_len(N), function(a,b) {
    geosphere::distHaversine(final_data[a,1:2], final_data[b,1:2]) 
})

D <- as.matrix(dists)

rownames(D) <- colnames(D) <- paste("Location", 1:20)

In the end, I would like to use the above matrix as input for a customized Travelling Salesman Problem (R: Customizing the Travelling Salesman Problem) - e.g. Try to find the optimal path when you are forced to start at "city 4" and the third city should be "city 5":

library(GA)


transformMatrix <- function(fixed_points, D){
  
  if(length(fixed_points) == 0) return(D)
  
  p <- integer(nrow(D))
  pos <- match(names(fixed_points), colnames(D))
  p[fixed_points] <- pos 
  p[-fixed_points] <- sample(setdiff(seq_len(nrow(D)), pos))

  D[p, p]
}

fixed_points <- c(
  "Location 1" = 1
)

D_perm <- transformMatrix(fixed_points, D)

feasiblePopulation <- function(n, size, fixed_points){
  
  positions <- setdiff(seq_len(n), fixed_points)
  
  m <- matrix(0, size, n)
  if(length(fixed_points) > 0){
    
    m[, fixed_points] <- rep(fixed_points, each = size)
    
    for(i in seq_len(size))
      m[i, -fixed_points] <- sample(positions)
    
  } else {
    
    for(i in seq_len(size))
      m[i,] <- sample(positions)
  }
  
  m
}

mutation <- function(n, fixed_points){
  
  positions <- setdiff(seq_len(n), fixed_points)
  
  function(obj, parent){
    
    vec <- obj@population[parent,]
    if(length(positions) < 2) return(vec) 
    
    indices <- sample(positions, 2)
    replace(vec, indices, vec[rev(indices)])
  }
}

fitness <- function(tour, distMatrix) {
  
  tour <- c(tour, tour[1])
  route <- embed(tour, 2)[,2:1]
  1/sum(distMatrix[route])
}


popSize = 100

res <- ga(
  type = "permutation",
  fitness = fitness,
  distMatrix = D_perm,
  lower = 1,
  upper = nrow(D_perm),
  mutation = mutation(nrow(D_perm), fixed_points),
  crossover = gaperm_pmxCrossover,
  suggestions = feasiblePopulation(nrow(D_perm), popSize, fixed_points),
  popSize = popSize,
  maxiter = 5000,
  run = 500,
  pmutation = 0.2
)

colnames(D_perm)[res@solution[1,]]

This results in the following error:

GA | iter = 1 | Mean =  NaN | Best = -Inf
GA | iter = 2 | Mean =  NaN | Best = -Inf

Error in if (object@run >= run) break : 
  missing value where TRUE/FALSE needed
In addition: Warning messages:
1: In max(fitness) : no non-missing arguments to max; returning -Inf
2: In max(Fitness, na.rm = TRUE) :
  no non-missing arguments to max; returning -Inf
3: In max(fitness) : no non-missing arguments to max; returning -Inf
4: In max(x, na.rm = TRUE) :
  no non-missing arguments to max; returning -Inf

How can I fix this?

Thanks!

[luca-scr]

The code you provided works on my machine:

> res <- ga(
  type = "permutation",
  fitness = fitness,
  distMatrix = D_perm,
  lower = 1,
  upper = nrow(D_perm),
  mutation = mutation(nrow(D_perm), fixed_points),
  crossover = gaperm_pmxCrossover,
  suggestions = feasiblePopulation(nrow(D_perm), popSize, fixed_points),
  popSize = popSize,
  maxiter = 5000,
  run = 500,
  pmutation = 0.2
)

> summary(res)
── Genetic Algorithm ─────────────────── 

GA settings: 
Type                  =  permutation 
Population size       =  100 
Number of generations =  5000 
Elitism               =  5 
Crossover probability =  0.8 
Mutation probability  =  0.2 
Suggestions = 
      x1 x2 x3 x4 x5 x6 x7 x8 x9 x10  ...  x19 x20
1      1 15 14  3 16  9 13 17  2   7         8  11
2      1  2  9 12 16 10 14  7 17   5        18  15
3      1 12  8 18 14 10 11 13  7  19         9   4
4      1 15 18  7  9 17 16 19  4   2        12  10
5      1  5 18 10 11  3  9  7 19  15         4  13
6      1  8 18 17  3 19  2 20 14   4        15   9
7      1 11  3  7 20  5 17  9  8  13         4   6
8      1 14 11 13  9  4 20 16  7   8        15   3
9      1  2 19 17 11 14  4  3  6  15        12   7
10     1 15  2  5 13  9  3 12 19   8         4   6
 ...                                              
99     1  8  4 16  7 20 13 12 19   6        15  18
100    1 18 16  6 14  3 12 19 13   5         8   9

GA results: 
Iterations             = 1042 
Fitness function value = 0.0000006683507 
Solution = 
     x1 x2 x3 x4 x5 x6 x7 x8 x9 x10  ...  x19 x20
[1,]  1  9  2 15 10  6 19 14  7  17         3   5

> colnames(D_perm)[res@solution[1,]]
 [1] "Location 1"  "Location 6"  "Location 2"  "Location 19" "Location 3"  "Location 20" "Location 17"
 [8] "Location 15" "Location 14" "Location 8"  "Location 10" "Location 18" "Location 5"  "Location 16"
[15] "Location 12" "Location 7"  "Location 4"  "Location 9"  "Location 11" "Location 13"