Commit 2ff9158f authored by pbac's avatar pbac
Browse files

Fixed conflicts with inherit()

parents f15fbbcd 8136603c
......@@ -74,7 +74,7 @@ bspline <- function(X, Boundary.knots = NA, intercept = FALSE, df = NULL, knots
Boundary.knots <- bknots
}
# If a list, then call on each element
if (inherits(X,"list")) {
if (inherits(X, "list")){
# Call again for each element
val <- lapply(1:length(X), function(i) {
bspline(X[[i]], df = df, knots = knots, degree = degree, intercept = intercept,
......
......@@ -70,14 +70,14 @@ getse <- function(L, inm = NA, depth = 2, useregex = FALSE, fun = NA) {
if(depth == 1){
if(useregex){ inm <- grep(inm, names(L)) }
R <- L[[inm]]
if(class(fun) == "function"){ R <- fun(R) }
if(inherits(fun, "function")){ R <- fun(R) }
}
# Match in the subelements of L?
if(depth == 2){
R <- lapply(L, function(x){
if(useregex){ inm <- grep(inm, names(x)) }
val <- x[[inm]]
if(class(fun) == "function"){ val <- fun(val) }
if(inherits(fun, "function")){ val <- fun(val) }
return(val)
})
}
......
......@@ -130,7 +130,7 @@ lm_fit <- function(prm=NA, model, data, scorefun = NA, returnanalysis = TRUE, pr
#----------------------------------------------------------------
# Calculate the result to return
# If the objective function (scorefun) is given
if(class(scorefun) == "function"){
if(inherits(scorefun, "function")){
# Do some checks
if( !("scoreperiod" %in% names(data)) ){ stop("data$scoreperiod is not set: Must have it set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
if( all(is.na(data$scoreperiod)) ){ stop("data$scoreperiod is not set correctly: It must be set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
......@@ -156,39 +156,4 @@ lm_fit <- function(prm=NA, model, data, scorefun = NA, returnanalysis = TRUE, pr
return(val)
}
## OLD
## # Is an objective function given?
## if(class(scorefun) == "function" & !returnanalysis){
## # Do some checks
## if( !("scoreperiod" %in% names(data)) ){ stop("data$scoreperiod are set: Must have it set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
## if( all(is.na(data$scoreperiod)) ){ stop("data$scoreperiod is not set correctly: It must be set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
## scoreperiod <- data$scoreperiod
## # Return the scorefun values
## scoreval <- sapply(1:ncol(Yhat), function(i){
## scorefun(Resid[scoreperiod,i])
## })
## nams(scoreval) <- nams(Yhat)
## val <- sum(scoreval, na.rm = TRUE)
## if(printout){print(c(scoreval,sum=val))}
## return(val)
## } else if(returnanalysis){
## # The estimated coefficients
## Lfitval <- lapply(model$Lfits, function(model){
## coef <- model$coefficients
## names(coef) <- gsub("(.+?)(\\.k.*)", "\\1", names(coef))
## return(coef)
## })
## # Include score function
## scoreval <- NA
## if(class(scorefun) == "function"){
## # Calculate the objective function for each horizon
## scoreval <- sapply(1:ncol(Yhat), function(i){
## scorefun(Resid[,i])
## })
## nams(scoreval) <- nams(Yhat)
## }
## # Return the model validation data
## return(list(Yhat = Yhat, t = data$t, Resid = Resid, datatr = datatr, Lfitval = Lfitval, scoreval = scoreval, scoreperiod = data$scoreperiod))
## }
## invisible("ok")
}
......@@ -37,7 +37,7 @@
lp <- function(X, a1, usestate = TRUE) {
##
if (class(X) == "list") {
if (inherits(X, "list")) {
## If only one coefficient, then repeat it
if (length(a1) == 1) {
a1 <- rep(a1, length(X))
......
......@@ -183,7 +183,7 @@ rls_fit <- function(prm=NA, model, data, scorefun = NA, returnanalysis = TRUE,
#----------------------------------------------------------------
# Calculate the result to return
# If the objective function (scorefun) is given
if(class(scorefun) == "function"){
if(inherits(scorefun, "function")){
# Do some checks
if( !("scoreperiod" %in% names(data)) ){ stop("data$scoreperiod is not set: Must have it set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
if( all(is.na(data$scoreperiod)) ){ stop("data$scoreperiod is not set correctly: It must be set to an index (int or logical) defining which points to be evaluated in the scorefun().") }
......
......@@ -240,7 +240,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
}
}
# Find the inputs to keep, if any
if(inherits(keepinputs,"logical")){
if(inherits(keepinputs, "logical")){
if(keepinputs){
keepinputs <- nams(mfull$inputs)
}else{
......@@ -266,7 +266,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
# Optimize
res <- optimfun(m, data, printout=printout, scorefun=scorefun, ...)
# Should we forecast only on the complete cases?
if(inherits(fitfun,"function")){
if(inherits(fitfun, "function")){
# Forecast to get the complete cases
mtmp <- m$clone_deep()
# If kseqopt is set, then make sure that it is used when fitting here
......@@ -286,7 +286,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
}
message("Current score: ",format(scoreCurrent,digits=7))
if(inherits(fitfun,"function")){
if(inherits(fitfun, "function")){
message("Current complete cases: ",sum(casesCurrent)," (Diff in score from optim:",L[[istep]]$optimresult$value-scoreCurrent,")")
}
# Next step
......@@ -382,7 +382,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
names(Lstep) <- names(mStep)
# Complete cases considered: Should we forecast and recalculate the score on complete cases from all models?
if(inherits(fitfun,"function")){
if(inherits(fitfun, "function")){
LYhat <- mclapply(1:length(mStep), function(i){
mtmp <- mStep[[i]]$clone_deep()
# If kseqopt is set, then make sure that it is used when fitting here
......@@ -409,7 +409,7 @@ step_optim <- function(modelfull, data, prm=list(NA), direction = c("both","back
tmp[ ,1] <- pst(format(100 * (scoreCurrent - tmp) / scoreCurrent, digits=2),"%")
nams(tmp) <- "Improvement"
}
if(inherits(fitfun,"function")){
if(inherits(fitfun, "function")){
tmp <- cbind(tmp, apply(casesStep != casesCurrent, 2, sum))
nams(tmp)[2] <- "CasesDiff"
}
......
......@@ -6,6 +6,11 @@
using namespace Rcpp;
#ifdef RCPP_USE_GLOBAL_ROSTREAM
Rcpp::Rostream<true>& Rcpp::Rcout = Rcpp::Rcpp_cout_get();
Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
#endif
// lp_vector_cpp
NumericVector lp_vector_cpp(NumericVector x, double a1);
RcppExport SEXP _onlineforecast_lp_vector_cpp(SEXP xSEXP, SEXP a1SEXP) {
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment