Temp=0.0001; rate of accepting inferior solutions
decrement_constant=0.95; decay of Temperature
jsize=5; Number of Sequences
length_of_markov_chain =50; length of sequence
SAAiters=50; Number of iterations at which the SAA is run
popSize = 20; Population of solutions size
iters = 200; Number of hEDA solutions
mutationChance = 0.01; Mutation chance
elitism = 0.1; Elitism rate
EDAfreq=1; frequency of EDA
kmax_percent=0.025; rate of accepting large perturbations in first sequence
ProbNewStratum=0.0001; Probability of creating new stratum
cv_experiment<-cv
#install.packages("randomForest")
#install.packages(c("smoof", "jsonlite"))#
library(devtools)
install_github("MervynOLuing/hEDA")
library(hEDA)
library(SamplingStrata)
data("swissmunicipalities")
df <- swissmunicipalities[,c(1,3,6:8,23)]
# df$DOM <- 1
df$HApoly.cat <- var.bin(df$HApoly,15)
table(df$HApoly.cat)
df$POPTOT.cat <- var.bin(df$POPTOT,15)
table(df$POPTOT.cat)
frame <- buildFrameDF(df=df,
id="id",
X=c("HApoly.cat","POPTOT.cat"),
Y=c("Surfacesbois",
"Surfacescult"
),
domainvalue = "REG")
strata <- buildStrataDF(frame)
ndom <- length(unique(frame$domainvalue))
cv <- as.data.frame(list(DOM=rep("DOM1",ndom),
CV1=rep(0.05,ndom),
CV2=rep(0.05,ndom),
domainvalue=c(1:ndom)))
cv
checkInput(errors=cv,strata=strata,sampframe=frame)
dom<-unique(strata$DOM1)
ndom<-length(unique(strata$DOM1))
Kmean<-KmeansSolution(strata,
errors=cv,
nstrata=NA,
minnumstrat=2,
maxclusters = 20,
showPlot=FALSE)
nstrata<-NULL
for(i in 1:ndom){
nstrata[i]<-length(table(Kmean$suggestions[which(Kmean$domainvalue==dom[i])]))
}
nstrata
fuzzy<-fuzzySolution(strata,
cv,
minClusters=2,
maxclusters = 20)
#sample size
sum(fuzzy[[2]])
#adapt so it can be used in hEDA
fuzzySol<-Kmean
for(i in 1:ndom){
fuzzySol$suggestions[which(fuzzySol$domainvalue==dom[i])]<-unlist(fuzzy[[1]][i])
}
fuzzynstrata<-NULL
for(i in 1:ndom){
fuzzynstrata[i]<-length(table(fuzzySol$suggestions[which(fuzzySol$domainvalue==dom[i])]))
}
fuzzynstrata
dom<-unique(strata$DOM1)
ndom<-length(unique(strata$DOM1))
library(mlrMBO)
cv_experiment<-cv
HyperparametersFunction<-function(x){
x1 <- data.frame(sapply(x, function(x) as.numeric(as.character(x))))
jsize <-round(x1[1,],0)
length_of_markov_chain <-round(x1[2,],0)
Temp<-x1[3,]
decrement_constant<-x1[4,]
iters <- x1[5,]
SAAiters <-x1[6,]
mutationChance <- x1[7,]
popSize <-x1[8,]
elitism <-x1[9,]
cat("jsize", jsize,"\n")
cat("length_of_markov_chain", length_of_markov_chain,"\n")
cat("Temp", Temp,"\n")
cat("decrement_constant", decrement_constant,"\n")
cat("iters", iters,"\n")
cat("SAAiters",SAAiters,"\n")
cat("mutationChance", mutationChance,"\n")
cat("popSize",popSize,"\n")
cat("elitism",elitism,"\n")
outpar<-hEDA::parallelhEDA(strata, cv, fuzzySol,
Temp=Temp,initialStrata=fuzzynstrata, decrement_constant=decrement_constant, end_time =Inf,
jsize=jsize,length_of_markov_chain =length_of_markov_chain,
SAArun=TRUE,SAAiters=SAAiters,
popSize = popSize, iters = iters, mutationChance = mutationChance, elitism =elitism,
addStrataFactor=0.000001, EDAfreq=1,
verbose = FALSE, dominio=dom,minnumstrat=2,kmax_percent=0.025,ProbNewStratum=0.0001,
strcens=FALSE,writeFiles=FALSE, showPlot=TRUE, minTemp = 0.000005, realAllocation=TRUE)
cat("sample size", sum(unlist(outpar$SampleSize)), "\n")
return( sum(unlist(outpar$SampleSize)))
}
nvar <- length(grep("CV", names(cv)))
my_data <- strata[,3:(2+nvar)]
objfun2 = makeSingleObjectiveFunction(
name = "mixed_example",
fn = HyperparametersFunction,
par.set = makeParamSet(
makeDiscreteParam("jsize", values = seq(30,50,10)),
makeDiscreteParam("length_of_markov_chain", values =seq(100,300,100)),
makeNumericParam("Temp", lower = 0,upper = 0.001),
makeNumericParam("decrement_constant", lower = 0.5,upper = 1),
makeDiscreteParam("iters", values = seq(50,100,50)),
makeDiscreteParam("SAAiters", values = seq(30,50,10)),
makeNumericParam("mutationChance", lower = 0.0001,upper = 0.025),
makeDiscreteParam("popSize", values = seq(20,40,10)),
makeDiscreteParam("elitism", values = seq(0.1,0.2,0.1))
),
noisy=TRUE,
has.simple.signature = FALSE,
minimize = TRUE
)
#objfun2(design2[1,])
surr.rf = makeLearner("regr.randomForest", predict.type = "se")
control2 = makeMBOControl()
control2 = setMBOControlInfill(
control = control2,
crit = makeMBOInfillCritCB(cb.lambda = 5),
opt.focussearch.points =1000
)
control2 = setMBOControlTermination(
control = control2,
iters = 10
)
design2 = generateDesign(n = 10, par.set = getParamSet(objfun2))
#apply(as.matrix(design2),1,objfun2)
mlr::configureMlr(show.info = FALSE, show.learner.output = FALSE, on.learner.warning = "quiet")
ptm <- proc.time()
run2 = mbo(objfun2, design = design2, learner = surr.rf, control = control2, show.info = TRUE)
proc.time() - ptm
library(readr)
direnew<-getwd()
for(i in 1:length(run2)){
write.csv(data.frame(run2[[i]]), file = paste0(direnew,'/', names(run2)[i], '.csv'))
}
fileConn<-file("final_opt_state.txt")
writeLines(run2$final.opt.state, fileConn)
close(fileConn)
zz <- file("final_opt_state.Rout", open="wt")
sink(zz)
sink(zz, type="message")
run2$final.opt.state
## back to the console
sink(type="message")
sink()
run2$final.opt.state
sink()
sink()
opt_path <- read_csv("opt.path.csv")
HEDATuningTime<- sum(opt_path$exec.time)
zz <- file("control.Rout", open="wt")
sink(zz)
sink(zz, type="message")
run2$control
## back to the console
sink(type="message")
sink()
run2$control
sink()
zz <- file("models.Rout", open="wt")
sink(zz)
sink(zz, type="message")
run2$models
## back to the console
sink(type="message")
sink()
run2$models
sink()
zz <- file("final_State.Rout", open="wt")
sink(zz)
sink(zz, type="message")
run2$final.state
## back to the console
sink(type="message")
sink()
run2$final.state
sink()
write(HEDATuningTime,"HEDATuningTime.csv")