tests/testthat/test.R

In GilChrist19/GA: Perform lm() or glm() Implemented Within a Genetic Algorithm

library(GA)

###############################################################################
testthat::context("Test Mutate()")

testthat::test_that("Mutate does not change the length or type of the chromosome",{
  test_PopChrom <- sample(c(0,1),1000,replace=T)
  testthat::expect_equal(length(Mutate(test_PopChrom,0.01)),length(test_PopChrom))
  testthat::expect_equal(class(Mutate(test_PopChrom,0.01)),class(test_PopChrom))
})


testthat::test_that("Mutates are completely random",{
  test_PopChrom <- sample(c(0,1),100,replace=T)

  mutation_1 <- Mutate(test_PopChrom,0.01)
  mutation_2 <- Mutate(test_PopChrom,0.01)

  testthat::expect_false(identical(mutation_1,mutation_2))
})


testthat::test_that("the probability of mutation can not be too low nor too high",{
  test_PopChrom <- sample(c(0,1),1000,replace=T)
  test_mutation <- Mutate(test_PopChrom, 0.01)
  num_mutation <- sum(xor(test_PopChrom,test_mutation))

  # if probability of mutation is 0.01, we should get between 0 and 0.02 Mutates
  testthat::expect_lt(num_mutation, 20)
  testthat::expect_gt(num_mutation, 0)
})

###############################################################################
testthat::context("Test safetyFunc()")

testthat::test_that("detect the 0 rows and the least used row to insert a 1 in that row of the 0 rows",{

  test_PopChrom <- matrix(c(0,0,0,0,1,0,1,0,1,0,0,0,1,0,0,1), ncol = 4, nrow = 4)
  testthat::expect_equal(matrix(c(0,1,0,0,1,0,1,0,1,0,0,0,1,0,0,1), ncol = 4, nrow = 4),
                         safetyFunc(test_PopChrom))

})


testthat::test_that("can detect all the 0 rows",{

  test_PopChrom <- matrix(c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1), ncol = 4, nrow = 4)
  testthat::expect_equal(matrix(c(1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,1), ncol = 4, nrow = 4),
                         safetyFunc(test_PopChrom))

})


testthat::test_that("does not change the PopChrom if there are no 0 rows",{

  test_PopChrom <- matrix(c(1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1), ncol = 4, nrow = 4)
  testthat::expect_equal(test_PopChrom, safetyFunc(test_PopChrom))

})

###############################################################################
testthat::context("Test PerformModel()")

testthat::test_that("test the functional of PerformModel()",{

  test_data <- mtcars
  tese_eVar <- colnames(test_data)[2:NCOL(test_data)]
  test_dVar <- colnames(test_data)[1]
  test_PopChrom <- matrix(data = c(1,1,1,0,0,1,0,0,1,1), nrow = 1, ncol = ncol(mtcars) - 1)
  test_model <- lm
  testthat::expect_equal(lm(mpg~cyl+disp+hp+qsec+gear+carb,mtcars)[1],
              PerformModel(test_data,tese_eVar,test_dVar,test_PopChrom,test_model)[[1]][1])
})

###############################################################################
testthat::context("Test Crossover()")

testthat::test_that("Crossover does not change the input type nor length", {

  test_PopChrom <- matrix(c(0,1,0,1,0,0,1,1,1,1,0,0,0,1,1,0), ncol = 4, nrow = 4)
  sample1 <- sample(1:4,3,replace=T)
  sample2 <- sample(1:4,3,replace=T)
  cross <- Crossover(test_PopChrom, sample1, sample2, numgenes = 4)

  testthat::expect_equal(length(sample1), dim(cross)[1])
  testthat::expect_equal(class(cross),"matrix")
})

testthat::test_that("Crossover is random",{

  test_PopChrom <- matrix(rep(c(0,1),100), ncol = 100, nrow = 2)
  cross1<- Crossover(test_PopChrom, 1,2, numgenes = 100)
  cross2<- Crossover(test_PopChrom, 1,2, numgenes = 100)

  testthat::expect_false(identical(cross1, cross2))
})

testthat::test_that("Crossover only happens at a single point",{

  test_PopChrom <- matrix(rep(c(0,1),100), ncol = 100, nrow = 2)
  cross<- Crossover(test_PopChrom, 1,2, numgenes = 100)

  testthat::expect_equal(sum(diff(cross[1,])),1)
})
###############################################################################
testthat::context("Test Breed()")

#  test that we retain the best parent from first generation
#  and throw out the worst
#  check each method

#  we can't test that it gets rid of the worst because there might be
#  2 of the same one and one would remain
testthat::test_that("Breed retains best parent",
          {
            data <- trees
            eVar <- colnames(data)[2:NCOL(data)]
            genes <- length(eVar)
            Pop = max(ceiling(1.5*genes), 6)
            mutRate = 1/genes

            PopChrom <- matrix(data = sample(x = c(0,1), size = Pop*genes, replace = TRUE),
                               nrow = Pop, ncol = genes)

            PopChrom <- safetyFunc(population = PopChrom)
            ReturnModel <- vector(mode = "list", length = Pop)
            grades <- numeric(length = Pop)
            dVar <- colnames(data)[1]

            ReturnModel <- PerformModel(data=data, expVar=eVar, depVar=dVar, population=PopChrom, mFunc=lm)
            grades <- vapply(X = ReturnModel, FUN = AIC, FUN.VALUE = numeric(1L))

            nextGenOne <- Breed(population=PopChrom, method="oneScore", nPop=Pop, nGenes=genes, scores=grades)
            nextGenTwo <- Breed(population=PopChrom, method="twoScore", nPop=Pop, nGenes=genes, scores=grades)
            nextGenTour <- Breed(population=PopChrom, method="tournament", nPop=Pop, nGenes=genes, scores=grades)

            testthat::expect("The best parent is not in the new generation for oneScore option",
                             x=identical(nextGenOne[1,], PopChrom[which.min(grades),]), TRUE)

            testthat::expect("The best parent is not in the new generation for twoScore option",
                             x=identical(nextGenTwo[1,],PopChrom[which.min(grades),]), TRUE)

            testthat::expect("The best parent is not in the new generation for tournament option",
                             x=identical(nextGenTour[1,],PopChrom[which.min(grades),]), TRUE)

          })

###############################################################################
testthat::context("Test getSecondParents()")

testthat::test_that("we are not pairing 2 of the same parent",
          {
            data <- trees
            eVar <- colnames(data)[2:NCOL(data)]
            genes <- length(eVar)
            Pop = max(ceiling(1.5*genes), 6)
            mutRate = 1/genes

            PopChrom <- matrix(data = sample(x = c(0,1), size = Pop*genes, replace = TRUE), nrow = Pop, ncol = genes)
            PopChrom <- safetyFunc(population = PopChrom)
            ReturnModel <- vector(mode = "list", length = Pop)
            grades <- numeric(length = Pop)
            dVar <- colnames(data)[1]

            ReturnModel <- PerformModel(data=data, expVar=eVar, depVar=dVar, population=PopChrom, mFunc=lm)
            grades <- vapply(X = ReturnModel, FUN = AIC, FUN.VALUE = numeric(1L))


            worst <- which.max(x = grades)
            PopChrom <- PopChrom[-worst,]
            grades <- grades[-worst]

            relscore <- Fitness(scores = grades)

            #  don't care how these are generated for the test
            firstParents <- sample(x=1:(Pop-1), size=(Pop-1), replace=TRUE)
            secondParents <- getSecondParents(firstParents=firstParents, method="oneScore", nPop=Pop, relScore=relscore)
            secondParents2 <- getSecondParents(firstParents=firstParents, method="twoScore", nPop=Pop, relScore=relscore)

            testthat::expect("oneScore matched same parents",
                             x=(any(firstParents==secondParents)==FALSE))

            testthat::expect("twoScore matched same parents",
                             x=(any(firstParents==secondParents2)==FALSE))
          })

###############################################################################
testthat::context("Test matchParents()")

testthat::test_that("two of the same parent cannnot breed and all are being matched",
          {
            data <- trees
            eVar <- colnames(data)[2:NCOL(data)]
            genes <- length(eVar)
            Pop = max(ceiling(1.5*genes), 6)
            mutRate = 1/genes

            PopChrom <- matrix(data = sample(x = c(0,1), size = Pop*genes, replace = TRUE),
                               nrow = Pop, ncol = genes)
            PopChrom <- safetyFunc(population = PopChrom)
            ReturnModel <- vector(mode = "list", length = Pop)
            grades <- numeric(length = Pop)
            dVar <- colnames(data)[1]

            ReturnModel <- PerformModel(data=data, expVar=eVar, depVar=dVar, population=PopChrom, mFunc=lm)
            grades <- vapply(X = ReturnModel, FUN = AIC, FUN.VALUE = numeric(1L))


            worst <- which.max(x = grades)
            PopChrom <- PopChrom[-worst,]
            grades <- grades[-worst]

            relscore <- Fitness(scores = grades)

            parents <- tournamentSelection(population=PopChrom, scores=grades,nPop=Pop)
            matched <- matchParents(parents=parents, nPop=Pop)
            firstParents <- matched[[1]]
            secondParents <- matched[[2]]

            testthat::expect("Same parents were matched",
                             x=all(firstParents==secondParents)==FALSE)

            testthat::expect("nothing new was added",
                             x=all(is.element(c(firstParents, secondParents), parents)))
          })

###############################################################################
testthat::context("Test select()")

#  We enumerate all cases so we know the minimum
#  then test that we found the right one.

testthat::test_that("We are finding the minimum",
  {
  #  test without interaction
  AICTest <- min(AIC(lm(Girth~Height, data=trees)),
               AIC(lm(Girth~Volume, data=trees)),
               AIC(lm(Girth~Volume+Height, data=trees)))
  AICNonInt_oneScore <- select(data=trees,  model=lm, methodBreed="oneScore",
                                            interaction=FALSE, Pop=NULL, mutRate=0.4,
                                            scoreFunc=AIC, generations=100)[[2]]

  AICNonInt_twoScore <- select(data=trees,  model=lm, methodBreed="twoScore",
                                            interaction=FALSE, Pop=NULL, mutRate=0.4,
                                            scoreFunc=AIC, generations=100)[[2]]

  AICNonInt_tournament <- select(data=trees,  model=lm, methodBreed="tournament",
                                              interaction=FALSE, Pop=NULL, mutRate=0.4,
                                              scoreFunc=AIC, generations=100)[[2]]

  #  test with interaction
  AICInt_oneScore <- select(data=trees,  model=lm, methodBreed="oneScore",
                                         interaction=TRUE, Pop=NULL, mutRate=0.4,
                                         scoreFunc=AIC, generations=100)[[2]]

  AICInt_twoScore <- select(data=trees,  model=lm, methodBreed="twoScore",
                                         interaction=TRUE, Pop=NULL, mutRate=0.4,
                                         scoreFunc=AIC, generations=100)[[2]]

  AICInt_tournament <- select(data=trees,  model=lm, methodBreed="tournament",
                                           interaction=TRUE, Pop=NULL, mutRate=0.4,
                                           scoreFunc=AIC, generations=100)[[2]]

  AICIntTest <- min(AICTest, AIC(lm(Girth~Height+Volume+Height*Volume, data=trees)),
                    AIC(lm(Girth~Height*Volume, data=trees)),
                    AIC(lm(Girth~Volume+Height*Volume, data=trees)),
                    AIC(lm(Girth~Height+Height*Volume, data=trees))
                    )

  testthat::expect(message="Non interaction model did not match true value using oneScore breeding",
                   x=all.equal(AICNonInt_oneScore, AICTest))

  testthat::expect(message="Non interaction model did not match true value using twoScore breeding",
                   x=all.equal(AICNonInt_twoScore, AICTest))

  testthat::expect(message="Non interaction model did not match true value using tournament breeding",
                   x=all.equal(AICNonInt_tournament, AICTest))

  testthat::expect(message="Interaction model did not match true value using oneScore breeding",
                   x=all.equal(AICInt_oneScore, AICIntTest))

  testthat::expect(message="Interaction model did not match true value using twoScore breeding",
                   x=all.equal(AICInt_twoScore, AICIntTest))

  testthat::expect(message="Interaction model did not match true value using tournament breeding",
                   x=all.equal(AICInt_tournament, AICIntTest))

})


###############################################################################
testthat::context("Test select() on categorical predictors")

testthat::test_that("We are finding the minimum",
          {

            Oranges <- data.frame(Orange[2:3], Orange[1])
            #  test without interaction
            AICTest <- min(AIC(lm(age~circumference, data=Oranges)),
                           AIC(lm(age~Tree, data=Oranges)),
                           AIC(lm(age~circumference+Tree, data=Oranges)))
            AICNonInt_oneScore <- select(data=Oranges,  model=lm, methodBreed="oneScore",
                                         interaction=FALSE, Pop=NULL, mutRate=0.4,
                                         scoreFunc=AIC, generations=100)[[2]]

            AICNonInt_twoScore <- select(data=Oranges,  model=lm, methodBreed="twoScore",
                                         interaction=FALSE, Pop=NULL, mutRate=0.4,
                                         scoreFunc=AIC, generations=100)[[2]]

            AICNonInt_tournament <- select(data=Oranges,  model=lm, methodBreed="tournament",
                                           interaction=FALSE, Pop=NULL, mutRate=0.4,
                                           scoreFunc=AIC, generations=100)[[2]]

            #  test with interaction
            AICInt_oneScore <- select(data=Oranges,  model=lm, methodBreed="oneScore",
                                      interaction=TRUE, Pop=NULL, mutRate=0.4,
                                      scoreFunc=AIC, generations=100)[[2]]

            AICInt_twoScore <- select(data=Oranges,  model=lm, methodBreed="twoScore",
                                      interaction=TRUE, Pop=NULL, mutRate=0.4,
                                      scoreFunc=AIC, generations=100)[[2]]

            AICInt_tournament <- select(data=Oranges,  model=lm, methodBreed="tournament",
                                        interaction=TRUE, Pop=NULL, mutRate=0.4,
                                        scoreFunc=AIC, generations=100)[[2]]

            AICIntTest <- min(AICTest, AIC(lm(age~circumference+Tree+circumference*Tree, data=Oranges)),
                              AIC(lm(age~circumference*Tree, data=Oranges)),
                              AIC(lm(age~circumference+Tree*circumference, data=Oranges)),
                              AIC(lm(age~Tree+circumference*Tree, data=Oranges))
            )

            testthat::expect(message="Non interaction model did not match true value using oneScore breeding",
                   x=all.equal(AICNonInt_oneScore, AICTest))

            testthat::expect(message="Non interaction model did not match true value using twoScore breeding",
                   x=all.equal(AICNonInt_twoScore, AICTest))

            testthat::expect(message="Non interaction model did not match true value using tournament breeding",
                   x=all.equal(AICNonInt_tournament, AICTest))

            testthat::expect(message="Interaction model did not match true value using oneScore breeding",
                   x=all.equal(AICInt_oneScore, AICIntTest))

            testthat::expect(message="Interaction model did not match true value using twoScore breeding",
                   x=all.equal(AICInt_twoScore, AICIntTest))

            testthat::expect(message="Interaction model did not match true value using tournament breeding",
                   x=all.equal(AICInt_tournament, AICIntTest))


          })