library(BreedingSchemeLanguage)
objFunc <- function(sEnv){
cross(sEnv, nProgeny=200) # popID 4
scheme_out <- outputResults(sEnv)
return(mean(scheme_out[nrow(scheme_out), 1:length(sEnv$sims)]))
}
fileFounderData <- system.file("extdata", "optimizationSchemeData.RData", package = "BreedingSchemeLanguage")
# Take ".RData" off because it gets added
fileFounderData <- substr(fileFounderData, 1, nchar(fileFounderData)-6)
schemeScriptPath <- system.file("extdata", "optimizationScheme.R", package = "BreedingSchemeLanguage")
allowableBudget <- 1000
bestObjective <- -1e6
bestParms <- NULL
allParms <- NULL
Notice that sEnv
has to be used explicitly in the breeding scheme
sampleParmList <- function(){
return(list(nRepC0=sample(2, 1), nRepC1=sample(2, 1), nFounder=sample(350, 1) + 50, nProg=sample(350, 1) + 50, yesGeno=runif(1) < 0.5))
}
Note that this is a very suboptimal approach to optimization
nIter <- 10
for (i in 1:nIter){
# Set up a fresh simulation
if (exists("simEnv")){
rm(list=names(simEnv), envir=simEnv)
rm(simEnv)
}
simEnv <- defineSpecies(loadData=fileFounderData)
defineVariances(plotTypeErrVars = c(Standard = 2))
defineCosts(phenoCost = c(Standard = 1), genoCost = 0.25)
parmList <- sampleParmList()
# Get objective value for the scheme
schemeOut <- testParameterOptimality(schemeFileName = schemeScriptPath, parmList=parmList, objectiveFunc=objFunc, budget=allowableBudget)
# If over budget, adjust number of progeny, nProg, to keep within budget
if (is.na(schemeOut$objective)){
adjust <- allowableBudget / schemeOut$totalCost
parmList$nFounder <- floor(parmList$nFounder * adjust)
parmList$nProg <- floor(parmList$nProg * adjust)
if (exists("simEnv")){
rm(list=names(simEnv), envir=simEnv)
rm(simEnv)
}
simEnv <- defineSpecies(loadData=fileFounderData)
defineVariances(plotTypeErrVars = c(Standard = 2))
defineCosts(phenoCost = c(Standard = 1), genoCost = 0.25)
schemeOut <- testParameterOptimality(schemeFileName = schemeScriptPath, parmList=parmList, objectiveFunc=objFunc, budget=allowableBudget)
if (is.na(schemeOut$objective)) stop("Budget allocation problem")
}
# If objective better than anything before, save the parmList
if (schemeOut$objective > bestObjective){
bestObjective <- schemeOut$objective
bestParms <- parmList
}
allParms <- rbind(allParms, c(i, unlist(parmList), unlist(schemeOut)))
}
print(paste("Best Reponse", bestObjective))
#> [1] "Best Reponse 1.9457170407781"
print("Parameter List")
#> [1] "Parameter List"
print(parmList)
#> $nRepC0
#> [1] 2
#>
#> $nRepC1
#> [1] 1
#>
#> $nFounder
#> [1] 58
#>
#> $nProg
#> [1] 334
#>
#> $yesGeno
#> [1] TRUE
print(head(allParms[order(allParms[,"objective"], decreasing=T),]))
#> nRepC0 nRepC1 nFounder.Standard nProg.Standard yesGeno objective
#> [1,] 9 1 1 326 278 0 1.945717
#> [2,] 4 1 2 213 225 1 1.766991
#> [3,] 8 1 2 107 247 0 1.721471
#> [4,] 3 1 2 196 267 0 1.699690
#> [5,] 7 1 1 334 229 1 1.582317
#> [6,] 2 1 1 194 311 0 1.573015
#> totalCost.Standard
#> [1,] 882.00
#> [2,] 997.50
#> [3,] 848.00
#> [4,] 997.00
#> [5,] 932.75
#> [6,] 816.00