Algoritmos Geneticos

Algoritmos de Cross Over

Parte de un algoritmo genetico eficiente es la implementacion de los algoritmos de crossover, la bondad de estos algoritmos es que pueden ser implementados segun la creatividad de la persona que los implementa, ya que no tienen limites. No obstante un algoritmo de crossover efectivo puede ser la diferencia entre que el algoritmo logre converger en una solucion en unas cuantas iteraciones o bien demore varios cientos o miles de iteracionese para converger. Acontinuacion veremos los algoritmos mas famosos para ser implementados:

Order Crossover (OX)

Este algoritmo se descrive de la siguiente manera:

Seleccione un subarreglo del padre de manera aleatoria
Genera una version temprana del hijo al copiar el subarreglo del padre en las mismas posiciones para conformar el arreglo del hijo.
Luego usando las posiciones no abarcadas por el primer padre, obtenga esas del otro padre
Junte las posiciones para conformar en hijo, usuando el subarreglo del padre 1 y el subarreglo del padre 2.

library(dplyr)

order_crossover <- function(parent_1, parent_2, selected_index=sample(1:9, 1)){
  
  child <- rep(0, length(parent_1))
  
  for (i in 1:4){
    child[selected_index] <- parent_1[selected_index]
    selected_index <- selected_index + 1
    if (selected_index > length(child))
      selected_index <- 1
  }
  
  
  p2_child <- parent_2[!parent_2 %in% child]
  j <- 1
  for (i in 1:length(child)){
    if (child[i] == 0){
      child[i] = p2_child[j]  
      j <- j+1
    }
      
  }
  return(child)
}

order_crossover(c(1,2,3,4,5,6,7,8,9), c(5,7,4,9,1,3,6,2,8), 3)

[1] 7 9 3 4 5 6 1 2 8

Position Based Crossover

Este algoritmo se describe de la siguiente manera:

Seleccione un subconjuto desde una posicion aleatoria del padre 1
Produzca un hijo tempronal copiando los valores de las posiciones del subconjunto en las posiciones correspondientes al hijo temporal.
Borre los registros que ya han sido seleccionados del padre 2
Coloque los valroes del padre dos restantes a en las posiciones del hijo temporal de izquierda a derecha.


position_based_crossover <- function(parent_1, parent_2, selected_positions = sample(1:9, 4, replace=FALSE)){
  child <- rep(0, length(parent_1))
  
  for (i in selected_positions){
    child[i] <- parent_1[i]
  }
  p2_child <- parent_2[!parent_2 %in% child]
  j <- 1
  for (i in 1:length(child)){
    if (child[i] == 0){
      child[i] = p2_child[j]  
      j <- j+1
    }
      
  }  
  return(child)
}

position_based_crossover(c(1,2,3,4,5,6,7,8,9), c(5,4,6,3,1,9,2,7,8), c(2,5,6,9))

[1] 4 2 3 1 5 6 7 8 9

Ordered Based Crossover

Este algoritmo es muy similar al de posicion, aqui la diferencia es que se seleccionan las posiciones del padre 1, se filtran los valores del padre 2 y las posiciones que sobran se copian del padre 2 hacia el hijo temporal y luego se copian de izquierda a derecha las del padre 1.

ordered_based_crossover <- function(parent_1, parent_2, selected_positions = sample(1:9, 4, replace=FALSE)){
  selected_positions <- c(2,5,6,9)
  p1_child <- parent_1[selected_positions]
  p2_child_positions <- match(parent_2[!parent_2 %in% p1_child], parent_2)
  p2_child_positions
  
  child <- rep(0, length(parent_1))
  
  for (i in p2_child_positions){
    child[i] <- parent_2[i]
  }
  
   j <- 1
  for (i in 1:length(child)){
    if (child[i] == 0){
      child[i] = p1_child[j]  
      j <- j+1
    }
      
  }  
 
 return(child)
}

ordered_based_crossover(c(1,2,3,4,5,6,7,8,9), c(5,4,6,3,1,9,2,7,8), c(2,5,6,9))

[1] 2 4 5 3 1 6 9 7 8

CX Crossover

Este algoritmo funciona de la siguiente manera:

Encuentre el ciclo definido con la posicion correspondiente de los vectores entre los padres.
Copie las ciudades en el ciclo hacia el hijo con las posiciones correspondientes de un padre.
Determine las valores restantes de los hijos borrando los valores que ya estan en el hijo del otro padre.
Termine de llenar el hijo con los valores restantes.



cx_crossover <- function(parent_1, parent_2, start_index = 1){
  index <- start_index
  cycle <- c()
  first_value <- parent_1[index]
  value <- 0
  while (first_value != value){
    cycle <- append(cycle, index)
    index <- match(parent_2[index], parent_1)
    value <- parent_1[index]
    
  }
  
  position_cycle <- match(cycle, parent_1)
  child <- rep(0, length(parent_1))
  for (i in position_cycle){
    child[i] = parent_1[i]
  }
  
  p2_child <- parent_2[!parent_2 %in% child]
  j <- 1
  for (i in 1:length(child)){
    if (child[i] == 0){
      child[i] = p2_child[j]  
      j <- j+1
    }
      
  }
  return(child)
}

cx_crossover(c(1,2,3,4,5,6,7,8,9), c(5,4,6,9,2,3,7,8,1))

[1] 1 2 6 4 5 3 7 8 9

LS0tCnRpdGxlOiAiQWxnb3JpdG1vcyBHZW5ldGljb3MiCm91dHB1dDogaHRtbF9ub3RlYm9vawotLS0KIAojIyBBbGdvcml0bW9zIGRlIENyb3NzIE92ZXIKClBhcnRlIGRlIHVuIGFsZ29yaXRtbyBnZW5ldGljbyBlZmljaWVudGUgZXMgbGEgaW1wbGVtZW50YWNpb24gZGUgbG9zIGFsZ29yaXRtb3MgZGUgY3Jvc3NvdmVyLCBsYSBib25kYWQgZGUgZXN0b3MgYWxnb3JpdG1vcyBlcyBxdWUgcHVlZGVuIHNlciBpbXBsZW1lbnRhZG9zIHNlZ3VuIGxhIGNyZWF0aXZpZGFkIGRlIGxhIHBlcnNvbmEgcXVlIGxvcyBpbXBsZW1lbnRhLCB5YSBxdWUgbm8gdGllbmVuIGxpbWl0ZXMuIE5vIG9ic3RhbnRlIHVuIGFsZ29yaXRtbyBkZSBjcm9zc292ZXIgZWZlY3Rpdm8gcHVlZGUgc2VyIGxhIGRpZmVyZW5jaWEgZW50cmUgcXVlIGVsIGFsZ29yaXRtbyBsb2dyZSBjb252ZXJnZXIgZW4gdW5hIHNvbHVjaW9uIGVuIHVuYXMgY3VhbnRhcyBpdGVyYWNpb25lcyBvIGJpZW4gZGVtb3JlIHZhcmlvcyBjaWVudG9zIG8gbWlsZXMgZGUgaXRlcmFjaW9uZXNlIHBhcmEgY29udmVyZ2VyLiBBY29udGludWFjaW9uIHZlcmVtb3MgbG9zIGFsZ29yaXRtb3MgbWFzIGZhbW9zb3MgcGFyYSBzZXIgaW1wbGVtZW50YWRvczoKCgojIyMgT3JkZXIgQ3Jvc3NvdmVyIChPWCkKCkVzdGUgYWxnb3JpdG1vIHNlIGRlc2NyaXZlIGRlIGxhIHNpZ3VpZW50ZSBtYW5lcmE6CgoxLiBTZWxlY2Npb25lIHVuIHN1YmFycmVnbG8gZGVsIHBhZHJlIGRlIG1hbmVyYSBhbGVhdG9yaWEKMi4gR2VuZXJhIHVuYSB2ZXJzaW9uIHRlbXByYW5hIGRlbCBoaWpvIGFsIGNvcGlhciBlbCBzdWJhcnJlZ2xvIGRlbCBwYWRyZSBlbiBsYXMgbWlzbWFzIHBvc2ljaW9uZXMgcGFyYSBjb25mb3JtYXIgZWwgYXJyZWdsbyBkZWwgaGlqby4KMy4gTHVlZ28gdXNhbmRvIGxhcyBwb3NpY2lvbmVzIG5vIGFiYXJjYWRhcyBwb3IgZWwgcHJpbWVyIHBhZHJlLCBvYnRlbmdhIGVzYXMgZGVsIG90cm8gcGFkcmUKNC4gSnVudGUgbGFzIHBvc2ljaW9uZXMgcGFyYSBjb25mb3JtYXIgZW4gaGlqbywgdXN1YW5kbyBlbCBzdWJhcnJlZ2xvIGRlbCBwYWRyZSAxIHkgZWwgc3ViYXJyZWdsbyBkZWwgcGFkcmUgMi4KCmBgYHtyfQpsaWJyYXJ5KGRwbHlyKQoKb3JkZXJfY3Jvc3NvdmVyIDwtIGZ1bmN0aW9uKHBhcmVudF8xLCBwYXJlbnRfMiwgc2VsZWN0ZWRfaW5kZXg9c2FtcGxlKDE6OSwgMSkpewogIAogIGNoaWxkIDwtIHJlcCgwLCBsZW5ndGgocGFyZW50XzEpKQogIAogIGZvciAoaSBpbiAxOjQpewogICAgY2hpbGRbc2VsZWN0ZWRfaW5kZXhdIDwtIHBhcmVudF8xW3NlbGVjdGVkX2luZGV4XQogICAgc2VsZWN0ZWRfaW5kZXggPC0gc2VsZWN0ZWRfaW5kZXggKyAxCiAgICBpZiAoc2VsZWN0ZWRfaW5kZXggPiBsZW5ndGgoY2hpbGQpKQogICAgICBzZWxlY3RlZF9pbmRleCA8LSAxCiAgfQogIAogIAogIHAyX2NoaWxkIDwtIHBhcmVudF8yWyFwYXJlbnRfMiAlaW4lIGNoaWxkXQogIGogPC0gMQogIGZvciAoaSBpbiAxOmxlbmd0aChjaGlsZCkpewogICAgaWYgKGNoaWxkW2ldID09IDApewogICAgICBjaGlsZFtpXSA9IHAyX2NoaWxkW2pdICAKICAgICAgaiA8LSBqKzEKICAgIH0KICAgICAgCiAgfQogIHJldHVybihjaGlsZCkKfQoKb3JkZXJfY3Jvc3NvdmVyKGMoMSwyLDMsNCw1LDYsNyw4LDkpLCBjKDUsNyw0LDksMSwzLDYsMiw4KSwgMykKYGBgCgojIyMgUG9zaXRpb24gQmFzZWQgQ3Jvc3NvdmVyCgpFc3RlIGFsZ29yaXRtbyBzZSBkZXNjcmliZSBkZSBsYSBzaWd1aWVudGUgbWFuZXJhOgoKMS4gU2VsZWNjaW9uZSB1biBzdWJjb25qdXRvIGRlc2RlIHVuYSBwb3NpY2lvbiBhbGVhdG9yaWEgZGVsIHBhZHJlIDEKMi4gUHJvZHV6Y2EgdW4gaGlqbyB0ZW1wcm9uYWwgY29waWFuZG8gbG9zIHZhbG9yZXMgZGUgbGFzIHBvc2ljaW9uZXMgZGVsIHN1YmNvbmp1bnRvIGVuIGxhcyBwb3NpY2lvbmVzIGNvcnJlc3BvbmRpZW50ZXMgYWwgaGlqbyB0ZW1wb3JhbC4KMy4gQm9ycmUgbG9zIHJlZ2lzdHJvcyBxdWUgeWEgaGFuIHNpZG8gc2VsZWNjaW9uYWRvcyBkZWwgcGFkcmUgMgo0LiBDb2xvcXVlIGxvcyB2YWxyb2VzIGRlbCBwYWRyZSBkb3MgcmVzdGFudGVzIGEgZW4gbGFzIHBvc2ljaW9uZXMgZGVsIGhpam8gdGVtcG9yYWwgZGUgaXpxdWllcmRhIGEgZGVyZWNoYS4KCmBgYHtyfQoKcG9zaXRpb25fYmFzZWRfY3Jvc3NvdmVyIDwtIGZ1bmN0aW9uKHBhcmVudF8xLCBwYXJlbnRfMiwgc2VsZWN0ZWRfcG9zaXRpb25zID0gc2FtcGxlKDE6OSwgNCwgcmVwbGFjZT1GQUxTRSkpewogIGNoaWxkIDwtIHJlcCgwLCBsZW5ndGgocGFyZW50XzEpKQogIAogIGZvciAoaSBpbiBzZWxlY3RlZF9wb3NpdGlvbnMpewogICAgY2hpbGRbaV0gPC0gcGFyZW50XzFbaV0KICB9CiAgcDJfY2hpbGQgPC0gcGFyZW50XzJbIXBhcmVudF8yICVpbiUgY2hpbGRdCiAgaiA8LSAxCiAgZm9yIChpIGluIDE6bGVuZ3RoKGNoaWxkKSl7CiAgICBpZiAoY2hpbGRbaV0gPT0gMCl7CiAgICAgIGNoaWxkW2ldID0gcDJfY2hpbGRbal0gIAogICAgICBqIDwtIGorMQogICAgfQogICAgICAKICB9ICAKICByZXR1cm4oY2hpbGQpCn0KCnBvc2l0aW9uX2Jhc2VkX2Nyb3Nzb3ZlcihjKDEsMiwzLDQsNSw2LDcsOCw5KSwgYyg1LDQsNiwzLDEsOSwyLDcsOCksIGMoMiw1LDYsOSkpCgpgYGAKCiMjIyBPcmRlcmVkIEJhc2VkIENyb3Nzb3ZlcgoKRXN0ZSBhbGdvcml0bW8gZXMgbXV5IHNpbWlsYXIgYWwgZGUgcG9zaWNpb24sIGFxdWkgbGEgZGlmZXJlbmNpYSBlcyBxdWUgc2Ugc2VsZWNjaW9uYW4gbGFzIHBvc2ljaW9uZXMgZGVsIHBhZHJlIDEsIHNlIGZpbHRyYW4gbG9zIHZhbG9yZXMgZGVsIHBhZHJlIDIgeSBsYXMgcG9zaWNpb25lcyBxdWUgc29icmFuIHNlIGNvcGlhbiBkZWwgcGFkcmUgMiBoYWNpYSBlbCBoaWpvIHRlbXBvcmFsIHkgbHVlZ28gc2UgY29waWFuIGRlIGl6cXVpZXJkYSBhIGRlcmVjaGEgbGFzIGRlbCBwYWRyZSAxLgoKYGBge3J9Cm9yZGVyZWRfYmFzZWRfY3Jvc3NvdmVyIDwtIGZ1bmN0aW9uKHBhcmVudF8xLCBwYXJlbnRfMiwgc2VsZWN0ZWRfcG9zaXRpb25zID0gc2FtcGxlKDE6OSwgNCwgcmVwbGFjZT1GQUxTRSkpewogIHNlbGVjdGVkX3Bvc2l0aW9ucyA8LSBjKDIsNSw2LDkpCiAgcDFfY2hpbGQgPC0gcGFyZW50XzFbc2VsZWN0ZWRfcG9zaXRpb25zXQogIHAyX2NoaWxkX3Bvc2l0aW9ucyA8LSBtYXRjaChwYXJlbnRfMlshcGFyZW50XzIgJWluJSBwMV9jaGlsZF0sIHBhcmVudF8yKQogIHAyX2NoaWxkX3Bvc2l0aW9ucwogIAogIGNoaWxkIDwtIHJlcCgwLCBsZW5ndGgocGFyZW50XzEpKQogIAogIGZvciAoaSBpbiBwMl9jaGlsZF9wb3NpdGlvbnMpewogICAgY2hpbGRbaV0gPC0gcGFyZW50XzJbaV0KICB9CiAgCiAgIGogPC0gMQogIGZvciAoaSBpbiAxOmxlbmd0aChjaGlsZCkpewogICAgaWYgKGNoaWxkW2ldID09IDApewogICAgICBjaGlsZFtpXSA9IHAxX2NoaWxkW2pdICAKICAgICAgaiA8LSBqKzEKICAgIH0KICAgICAgCiAgfSAgCiAKIHJldHVybihjaGlsZCkKfQoKb3JkZXJlZF9iYXNlZF9jcm9zc292ZXIoYygxLDIsMyw0LDUsNiw3LDgsOSksIGMoNSw0LDYsMywxLDksMiw3LDgpLCBjKDIsNSw2LDkpKQpgYGAKCiMjIyBDWCBDcm9zc292ZXIKCkVzdGUgYWxnb3JpdG1vIGZ1bmNpb25hIGRlIGxhIHNpZ3VpZW50ZSBtYW5lcmE6CgoxLiBFbmN1ZW50cmUgZWwgY2ljbG8gZGVmaW5pZG8gY29uIGxhIHBvc2ljaW9uIGNvcnJlc3BvbmRpZW50ZSBkZSBsb3MgdmVjdG9yZXMgZW50cmUgbG9zIHBhZHJlcy4KMi4gQ29waWUgbGFzIGNpdWRhZGVzIGVuIGVsIGNpY2xvIGhhY2lhIGVsIGhpam8gY29uIGxhcyBwb3NpY2lvbmVzIGNvcnJlc3BvbmRpZW50ZXMgZGUgdW4gcGFkcmUuCjMuIERldGVybWluZSBsYXMgdmFsb3JlcyByZXN0YW50ZXMgZGUgbG9zIGhpam9zIGJvcnJhbmRvIGxvcyB2YWxvcmVzIHF1ZSB5YSBlc3RhbiBlbiBlbCBoaWpvIGRlbCBvdHJvIHBhZHJlLgo0LiBUZXJtaW5lIGRlIGxsZW5hciBlbCBoaWpvIGNvbiBsb3MgdmFsb3JlcyByZXN0YW50ZXMuCgpgYGB7cn0KCgpjeF9jcm9zc292ZXIgPC0gZnVuY3Rpb24ocGFyZW50XzEsIHBhcmVudF8yLCBzdGFydF9pbmRleCA9IDEpewogIGluZGV4IDwtIHN0YXJ0X2luZGV4CiAgY3ljbGUgPC0gYygpCiAgZmlyc3RfdmFsdWUgPC0gcGFyZW50XzFbaW5kZXhdCiAgdmFsdWUgPC0gMAogIHdoaWxlIChmaXJzdF92YWx1ZSAhPSB2YWx1ZSl7CiAgICBjeWNsZSA8LSBhcHBlbmQoY3ljbGUsIGluZGV4KQogICAgaW5kZXggPC0gbWF0Y2gocGFyZW50XzJbaW5kZXhdLCBwYXJlbnRfMSkKICAgIHZhbHVlIDwtIHBhcmVudF8xW2luZGV4XQogICAgCiAgfQogIAogIHBvc2l0aW9uX2N5Y2xlIDwtIG1hdGNoKGN5Y2xlLCBwYXJlbnRfMSkKICBjaGlsZCA8LSByZXAoMCwgbGVuZ3RoKHBhcmVudF8xKSkKICBmb3IgKGkgaW4gcG9zaXRpb25fY3ljbGUpewogICAgY2hpbGRbaV0gPSBwYXJlbnRfMVtpXQogIH0KICAKICBwMl9jaGlsZCA8LSBwYXJlbnRfMlshcGFyZW50XzIgJWluJSBjaGlsZF0KICBqIDwtIDEKICBmb3IgKGkgaW4gMTpsZW5ndGgoY2hpbGQpKXsKICAgIGlmIChjaGlsZFtpXSA9PSAwKXsKICAgICAgY2hpbGRbaV0gPSBwMl9jaGlsZFtqXSAgCiAgICAgIGogPC0gaisxCiAgICB9CiAgICAgIAogIH0KICByZXR1cm4oY2hpbGQpCn0KCmN4X2Nyb3Nzb3ZlcihjKDEsMiwzLDQsNSw2LDcsOCw5KSwgYyg1LDQsNiw5LDIsMyw3LDgsMSkpCgpgYGAK