Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
#' @importFrom parallel mclapply
#'
step_backward <- function(object, data, kseq = NA, prm=list(NA), optimfun = rls_optim, scorefun = rmse, ...){
# Do:
# - Maybe have "cloneit" argument in optimfun, then don't clone inside optim.
# - Add argument controlling how much is kept in each iteration (e.g all fitted models)
#
# - Help: prm <- list(I__degree = c(min=1, max=7), mu_tday__nharmonics = c(min=1, max=7))
# - help: It's not checked that it's the score is calculated on the same values! WARNING should be printed if some models don't forecast same points
#
model <- object
#
m <- model$clone_deep()
# Insert the starting prm reduction values
if(!is.na(prm[1])){
prmMin <- unlist(getse(prm, "min"))
# ??insert_prm should keep only the ones that can be changed
m$insert_prm(unlist(getse(prm, "max")))
}
# For keeping all the results
L <- list()
istep <- 1
# Optimize the reference model
res <- optimfun(m, data, kseq, printout=TRUE, ...)
valRef <- res$value
L[[istep]] <- list(model = m$clone_deep(), result = res)
#
done <- FALSE
while(!done){
#
istep <- istep + 1
# Insert the optimized parameters from last step
m$prmbounds[names(res$par),"init"] <- res$par
#
message("------------------------------------")
message("Reference score value: ",valRef)
# --------
# Generate the reduced models
mReduced <- mclapply(1:length(m$inputs), function(i){
mr <- m$clone_deep()
# Insert the optimized parameters from the reference model
mr$inputs[[i]] <- NULL
return(mr)
})
names(mReduced) <- names(m$inputs)
if(!is.na(prm[1])){
tmp <- mclapply(1:length(prm), function(i){
p <- m$get_prmvalues(names(prm[i]))
# If the input is not in model, then p is NA, so don't include it for fitting
if(!is.na(p)){
# Only the ones with prms above minimum
if(p > prmMin[i]){
p <- p - 1
mr <- m$clone_deep()
mr$insert_prm(p)
return(mr)
}
}
return(NA)
})
names(tmp) <- names(prm)
tmp <- tmp[!is.na(tmp)]
mReduced <- c(mReduced, tmp)
}
resReduced <- lapply(1:length(mReduced), function(i, ...){
res <- optimfun(mReduced[[i]], data, kseq, printout=FALSE, ...)
message(names(mReduced)[[i]], ": ", res$value)
return(res)
}, ...)
names(resReduced) <- names(mReduced)
valReduced <- unlist(getse(resReduced, "value"))
imin <- which.min(valReduced)
# Is one the reduced smaller than the current ref?
if( valReduced[imin] < valRef ){
# Keep the best model
m <- mReduced[[imin]]
res <- resReduced[[imin]]
valRef <- res$value
# Keep for the result
L[[istep]] <- list(model = m$clone_deep(), result = resReduced[[imin]])
}else{
# No improvement obtained from reduction, so return the current model (last in the list)
message("------------------------------------\n\nDone")
done <- TRUE
}
}
invisible(L)
}