Reproducible example for issue with GA package: position based crossover for permutation type problems not working as expected. Possible bug found.

example_pbx_bug.R

# Testing parents
test_parents <- matrix(c(1:8, c(2, 4, 6, 8, 7, 5, 3, 1)), nrow=2, byrow=T)
# Test 1
cxPoints_test1 <- c(1, 3, 5, 8)
# Test 2
cxPoints_test2 <- c(2, 3, 6)

##########
# gaperm_pbxCrossover_R has been *slightly* modified merely for pbx crossover testing purposes
##########

# Original signature is modified for testing purposes
#gaperm_pbxCrossover_R <- function(object, parents)

# ORIGINAL function with modified signature
gaperm_pbxCrossover_R <- function(parents, cxPoints)
{
    # Original
    #parents <- object@population[parents,,drop = FALSE]
    n <- ncol(parents)
    
    # Original
    #cxPoints <- unique(sample(1:n, size = n, replace = TRUE))
    
    children <- matrix(as.double(NA), nrow = 2, ncol = n)
    children[1,cxPoints] <- parents[2,cxPoints]
    children[2,cxPoints] <- parents[1,cxPoints]
    
    for(j in 1:2)
    { 
        pos <- which(is.na(children[j,]))
        val <- setdiff(parents[-j,], children[j,cxPoints])
        children[j,pos] <- val
    }
    #
    out <- list(children = children, fitness = rep(NA,2))
    return(out)
}

# Modified function with modified signature AND bug fix
gaperm_pbxCrossover_R_MODIFIED <- function(parents, cxPoints)
{
    # Original
    #parents <- object@population[parents,,drop = FALSE]
    n <- ncol(parents)
    
    # Original
    #cxPoints <- unique(sample(1:n, size = n, replace = TRUE))
    
    children <- matrix(as.double(NA), nrow = 2, ncol = n)
    children[1,cxPoints] <- parents[2,cxPoints]
    children[2,cxPoints] <- parents[1,cxPoints]
    
    for(j in 1:2)
    { 
        pos <- which(is.na(children[j,]))
        # Bug fix. CRUCIAL MODIFICATION: the minus in front of j is removed
        #val <- setdiff(parents[-j,], children[j,cxPoints])
        val <- setdiff(parents[j,], children[j,cxPoints])
        children[j,pos] <- val
    }
    #
    out <- list(children = children, fitness = rep(NA,2))
    return(out)
}

#############
#   Test    #
#############

expected_output_cxPoints_test1 <- matrix(c(c(2,3,6,4,7,5,8,1), c(1:8)),
                                         nrow = 2, byrow = T)
expected_output_cxPoints_test2 <- matrix(c(c(1,4,6,2,3,5,7,8), c(4,2,3,8,7,6,5,1)),
                                         nrow = 2, byrow = T)

out1 <- gaperm_pbxCrossover_R(parents = test_parents, cxPoints = cxPoints_test1)$children
out2 <- gaperm_pbxCrossover_R(parents = test_parents, cxPoints = cxPoints_test2)$children

# The two outputs out1 and out2 should not be identical, yet they are as shown here
identical(out1, out2)
# out1 and out2 should be identical to the expected output, yet they are not
identical(out1, expected_output_cxPoints_test1)
identical(out2, expected_output_cxPoints_test2)

# With the modification, the output of the crossover is equal to the expected one
out3 <- gaperm_pbxCrossover_R_MODIFIED(parents = test_parents, cxPoints = cxPoints_test1)$children
out4 <- gaperm_pbxCrossover_R_MODIFIED(parents = test_parents, cxPoints = cxPoints_test2)$children
identical(out3, expected_output_cxPoints_test1)
identical(out4, expected_output_cxPoints_test2)