Skip to content

Instantly share code, notes, and snippets.

@mick001
Last active September 11, 2018 15:50
Show Gist options
  • Save mick001/f320103aabb699df6e218ca211a029c0 to your computer and use it in GitHub Desktop.
Save mick001/f320103aabb699df6e218ca211a029c0 to your computer and use it in GitHub Desktop.
Reproducible example for issue with GA package: position based crossover for permutation type problems not working as expected. Possible bug found.
# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment