Thursday, January 10, 2013

PMX Crossover (Krzyżowanie PMX )

My implementation of PMX crossover written in R.
 bag.crossover <- function (parent1, parent2) {  
 #Created with inspiration from http://algorytmy-genetyczne.eprace.edu.pl/664,Implementacja.html ,
 # which I think has some errors corrected bellow.  
   if(length(parent1)!=length(parent2))  
           stop("Parents have different lengths")  
      parentLength <- length(parent1)  
      crossLength <- sample(1:parentLength,1,replace=T)#lenght of crossing segment  
      ibeg <- sample(1:(parentLength-crossLength+1),1,replace=T)#index of begining of crossing segment  
      iend <- (ibeg+crossLength-1) #index of end  
      SegmentParent <- matrix(data=c(parent1[ibeg:iend], parent2[ibeg:iend]), byrow = T,nrow=2, ncol=crossLength)#crossing 
   #segment for both parents  
      child <-c()  
      child[ibeg:iend] <-SegmentParent[1,]  
      for(locus in 1:parentLength){  
           soughtAllele <-parent2[locus]  
           saPosParent1 <- which( SegmentParent[1,] == soughtAllele) #soughtAllele position in parent 1  
           saPosParent2 <- which( SegmentParent[2,] == soughtAllele) #soughtAllele position in parent 2  
           if (length(saPosParent1)) {#Number occurred yet in crossing segment  
                next  
           }  
           else if (length(saPosParent2) ){#Occured in skipped segment  
                newSoughtAllele <- soughtAllele  
                while (length(saPosParent2)){  
                     newLocus <- saPosParent2[1]  
                     newSoughtAllele <- SegmentParent[1,newLocus]  
                     saPosParent2 <- which( SegmentParent[2,] == newSoughtAllele)  
                     if(!length(saPosParent2)){  
                          break  
                     }                      
                }  
                saPosParent2 <- which( parent2 == newSoughtAllele)  
                newLocus <- saPosParent2[1]  
                child[newLocus] <- soughtAllele  
           }  
           else{#Doesnt occured in crossing segments. Let it stay, where it is now  
                child[locus] <- soughtAllele  
                }  
      }#for  
      return (child)  
 }  
Raw can be downloaded from http://pastebin.com/7FMfrzfp

No comments:

Post a Comment