Merge pull request #36 from palatej/develop

Bug in SA decomposition with backcasts

R/arima.R

@@ -17,7 +17,7 @@ NULL
 #' @export
 sarima_model<-function(name="sarima", period, phi=NULL, d=0, theta=NULL, bphi=NULL, bd=0, btheta=NULL){
   return (structure(
-    list(name=name, period=period, phi = phi, d=d, theta=theta,
+    list(name = name, period = period, phi = phi, d = d, theta = theta,
                          bphi = bphi, bd = bd, btheta = btheta), class="JD3_SARIMA"))
 }
 
@@ -353,7 +353,7 @@ sarima_estimate<-function(x, order=c(0,0,0), seasonal = list(order=c(0,0,0), per
   if (length(res$b) > 0) {
 
     names_xreg <- colnames(xreg)
-    if (is.null (names_xreg) & !is.null (xreg)){
+    if (is.null (names_xreg) && !is.null (xreg)){
       if (is.matrix(xreg)) {
         # unnamed matrix regressors
         names_xreg <- sprintf("xreg_%i", seq_len(ncol(xreg)))
@@ -394,7 +394,7 @@ sarima_estimate<-function(x, order=c(0,0,0), seasonal = list(order=c(0,0,0), per
 #' sarima_hannan_rissanen(y, order = c(0,1,1), seasonal = c(0,1,1))
 sarima_hannan_rissanen<-function(x, order=c(0,0,0), seasonal = list(order=c(0,0,0), period=NA), initialization=c("Ols", "Levinson", "Burg"), biasCorrection=TRUE, finalCorrection=TRUE){
   if (!is.list(seasonal) && is.numeric(seasonal) && length(seasonal) == 3) {
-    initialization=match.arg(initialization)
+    initialization<-match.arg(initialization)
     seasonal <- list(order = seasonal,
                      period = NA)
   }

R/calendars.R

@@ -4,24 +4,24 @@
 #' @include protobuf.R jd2r.R
 NULL
 
-HOLIDAY='JD3_HOLIDAY'
-FIXEDDAY='JD3_FIXEDDAY'
-FIXEDWEEKDAY='JD3_FIXEDWEEKDAY'
-EASTERDAY='JD3_EASTERDAY'
-SPECIALDAY='JD3_SPECIALDAY'
-SINGLEDAY='JD3_SINGLEDAY'
+HOLIDAY<-'JD3_HOLIDAY'
+FIXEDDAY<-'JD3_FIXEDDAY'
+FIXEDWEEKDAY<-'JD3_FIXEDWEEKDAY'
+EASTERDAY<-'JD3_EASTERDAY'
+SPECIALDAY<-'JD3_SPECIALDAY'
+SINGLEDAY<-'JD3_SINGLEDAY'
 
 .r2p_validityPeriod<-function(start, end){
     vp<-jd3.ValidityPeriod$new()
     if (is.null(start)) {
-        pstart=DATE_MIN
-    } else{
-        pstart=parseDate(start)
+        pstart<-DATE_MIN
+    }else{
+        pstart<-parseDate(start)
     }
     if (is.null(end)){
-        pend=DATE_MAX
-    } else{
-        pend=parseDate(end)
+        pend<-DATE_MAX
+    }else{
+        pend<-parseDate(end)
     }
     vp$start<-pstart
     vp$end<-pend
@@ -50,7 +50,7 @@ SINGLEDAY='JD3_SINGLEDAY'
 .length_ts <- function(s){
     if(is.mts(s)){
         nrow(s)
-    } else{
+    }else{
         length(s)
     }
 }
@@ -336,9 +336,9 @@ special_day<-function(event, offset=0, weight=1, validity=NULL){
 #' regs_wd<- td(4,c(2020,1),60, groups = c(1, 1, 1, 1, 1, 0, 0), contrasts = TRUE)
 td<-function(frequency, start, length, s, groups=c(1,2,3,4,5,6,0), contrasts=TRUE){
     if (!missing(s) && is.ts(s)) {
-        frequency = stats::frequency(s)
-        start = stats::start(s)
-        length = .length_ts(s)
+        frequency <- stats::frequency(s)
+        start <- stats::start(s)
+        length <- .length_ts(s)
     }
     jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length)
     igroups<-as.integer(groups)
@@ -736,9 +736,9 @@ national_calendar <- function(days, mean_correction=TRUE){
 calendar_td<-function(calendar,frequency, start, length, s, groups=c(1,2,3,4,5,6,0), holiday=7, contrasts=TRUE){
     if(! is(calendar, 'JD3_CALENDAR')) stop('Invalid calendar')
     if (!missing(s) && is.ts(s)) {
-        frequency = stats::frequency(s)
-        start = stats::start(s)
-        length = .length_ts(s)
+        frequency <- stats::frequency(s)
+        start <- stats::start(s)
+        length <- .length_ts(s)
     }
     jdom<-.r2jd_tsdomain(frequency, start[1], start[2], length)
     pcal<-.r2p_calendar(calendar)
@@ -776,7 +776,7 @@ print.JD3_FIXEDDAY<-function(x, ...){
     if (!is.null(x$validity$end))
         cat(sprintf(' , to=%s', x$validity$end))
 }
-DAYS=c('Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday', 'Sunday')
+DAYS<-c('Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday', 'Sunday')
 
 #' @export
 #' @rdname print.calendars

R/decomposition.R

@@ -10,19 +10,19 @@ sadecomposition<-function(y, sa, t, s, i, mul){
   if (! is.logical(mul))stop("Invalid SA decomposition")
   if (is.null(y))stop("Invalid SA decomposition")
   if (! is.ts(y))stop("Invalid SA decomposition")
-  n=length(y)
+  n<-length(y)
   if (is.null(s)){
     if (mul){
-      s=ts(rep(1,1,n), start = start(y), frequency = frequency(y))
-    } else{
+      s<-ts(rep(1,1,n), start = start(y), frequency = frequency(y))
+    }else{
       s=ts(rep(0,1,n), start = start(y), frequency = frequency(y))
     }
   } else if (! is.ts(s))stop("Invalid SA decomposition")
   if (is.null(i)){
     if (mul){
-      i=ts(rep(1,1,n), start = start(y), frequency = frequency(y))
-    } else{
-      i=ts(rep(0,1,n), start = start(y), frequency = frequency(y))
+      i<-ts(rep(1,1,n), start = start(y), frequency = frequency(y))
+    }else{
+      i<-ts(rep(0,1,n), start = start(y), frequency = frequency(y))
     }
   } else if (! is.ts(i))stop("Invalid SA decomposition")
 
@@ -70,7 +70,7 @@ plot.JD3_SADECOMPOSITION <- function(x, first_date = NULL, last_date = NULL,
 
     lty <- rep(1, length(series_graph))
     # lty[grep("_f$", series_graph)] <- 1
-    col <- colors[gsub("_.*$", "", series_graph)]
+    # col <- colors[gsub("_.*$", "", series_graph)]
     # par(mar = c(5, 4, 4, 2) + 0.1)
     ts.plot(data_plot[, series_graph],
             col = colors[series_graph],

R/differencing.R

@@ -36,7 +36,7 @@ NULL
 #' @examples
 #' do_stationary(log(ABS$X0.2.09.10.M),12)
 do_stationary<-function(data, period){
-  if (is.ts(data) & missing(period))
+  if (is.ts(data) && missing(period))
     period <- frequency(data)
   jst<-.jcall("jdplus/toolkit/base/r/modelling/Differencing", "Ljdplus/toolkit/base/core/modelling/StationaryTransformation;", "doStationary",
               as.numeric(data), as.integer(period))
@@ -71,7 +71,7 @@ do_stationary<-function(data, period){
 #' differencing_fast(log(ABS$X0.2.09.10.M),12)
 #'
 differencing_fast<-function(data, period, mad=TRUE, centile=90, k=1.2){
-  if (is.ts(data) & missing(period))
+  if (is.ts(data) && missing(period))
     period <- frequency(data)
   jst<-.jcall("jdplus/toolkit/base/r/modelling/Differencing", "Ljdplus/toolkit/base/core/modelling/StationaryTransformation;", "fastDifferencing",
               as.numeric(data), as.integer(period), as.logical(mad), centile, k)
@@ -177,7 +177,7 @@ differences.data.frame<-function(data, lags=1, mean=TRUE){
 #' pt(rm_t_log, period - 2, lower.tail = FALSE)
 #' @export
 rangemean_tstat<-function(data, period=0, groupsize = 0, trim = 0){
-  if (is.ts(data) & missing(period))
+  if (is.ts(data) && missing(period))
     period <- frequency(data)
   return (.jcall("jdplus/toolkit/base/r/modelling/AutoModelling", "D", "rangeMean",
                  as.numeric(data), as.integer(period), as.integer(groupsize), as.integer(trim)))

R/display.R

@@ -50,8 +50,8 @@ print.JD3_SARIMA<-function(x, ...){
 #' @rdname jd3_print
 #' @export
 print.JD3_SARIMA_ESTIMATION<-function(x, digits = max(3L, getOption("digits") - 3L), ...){
-  tables = .sarima_coef_table(x, ...)
-  orders = tables$sarima_orders
+  tables <- .sarima_coef_table(x, ...)
+  orders <- tables$sarima_orders
 
   cat("SARIMA model: ",
       .arima_node(orders$p, orders$d, orders$q),
@@ -116,17 +116,17 @@ print.summary.JD3_SARIMA_ESTIMATION<-function(x, digits = max(3L, getOption("dig
   if (! is.null(m$btheta)) bq<-dim(m$btheta)[2]else bq<-0
   sarima_orders = list(p = p, d = m$d, q = q, bp = bp, bd = m$bd, bq = bq)
   names<-NULL
-  if (p > 0){names=c(names,paste0("phi(", 1:p, ')')) }
-  if (q > 0){names=c(names,paste0("theta(", 1:q, ')')) }
-  if (bp > 0){names=c(names,paste0("bphi(", 1:bp, ')')) }
-  if (bq > 0){names=c(names,paste0("btheta(", 1:bq,')')) }
+  if (p > 0){names<-c(names,paste0("phi(", 1:p, ')')) }
+  if (q > 0){names<-c(names,paste0("theta(", 1:q, ')')) }
+  if (bp > 0){names<-c(names,paste0("bphi(", 1:bp, ')')) }
+  if (bq > 0){names<-c(names,paste0("btheta(", 1:bq,')')) }
   if (! is.null(names)){
     all<-t(cbind(m$phi, m$theta, m$bphi, m$btheta))
     fr<-as.data.frame(all, row.names = names)
     for(i in colnames(fr)){
       fr[,i] <- unlist(fr[,i])
     }
-    if(!is.null(cov) & !is.null(ndf)){
+    if(!is.null(cov) && !is.null(ndf)){
       fr$pvalue <- fr$t <- fr$stde <- NA
       stde<-sqrt(diag(cov))
       sel<-fr$type=='ESTIMATED'
@@ -151,7 +151,7 @@ print.summary.JD3_SARIMA_ESTIMATION<-function(x, digits = max(3L, getOption("dig
 }
 .sarima_coef_table.JD3_SARIMA_ESTIMATE <- function(x,...){
   ndf<-x$likelihood$neffectiveobs-x$likelihood$nparams+1
-  sarima_orders = list(p = x$orders$order[1],
+  sarima_orders <- list(p = x$orders$order[1],
                        d = x$orders$order[2],
                        q = x$orders$order[3],
                        bp = x$orders$seasonal$order[1],
@@ -255,7 +255,7 @@ print.JD3_REGARIMA_RSLTS<-function(x, digits = max(3L, getOption("digits") - 3L)
         ndf = ndf,
         digits = digits,
         ...)
-  xregs = .regarima_coef_table(x, ...)
+  xregs <- .regarima_coef_table(x, ...)
   cat("\n")
   if (!is.null(xregs)){
     cat("Regression model:\n")
@@ -359,14 +359,13 @@ summary.JD3_REGARIMA_RSLTS<-function(object, ...){
 summary.JD3_SARIMA_ESTIMATE <-function(object, ...){
   sarima_sum = .sarima_coef_table(object, ...)
   class(sarima_sum) <- "summary.JD3_SARIMA_ESTIMATION"
-  xregs = .regarima_coef_table(object, ...)
-  likelihood = summary(object$likelihood)
-  res = list(log = NULL,
+  likelihood <- summary(object$likelihood)
+  res <- list(log = NULL,
              sarima = sarima_sum,
              xregs = .regarima_coef_table(object, ...),
              likelihood = likelihood)
   class(res) <- "summary.JD3_REGARIMA_RSLTS"
-  res
+  return (res)
 }
 #' @export
 print.summary.JD3_REGARIMA_RSLTS <- function(x,  digits = max(3L, getOption("digits") - 3L), signif.stars = getOption("show.signif.stars"), ...){

R/protobuf.R

@@ -34,7 +34,8 @@ NULL
 #' @export
 #' @rdname jd3_utilities
 .enum_of<-function(type, code, prefix){
-  i<-type$value(name=paste(prefix, code, sep='_'))$number()
+    i<-type$value(name=paste(prefix, code, sep='_'))$number()
+    return (i)
 }
 
 #' @export
@@ -312,7 +313,6 @@ NULL
 #' @rdname jd3_utilities
 .r2p_outliers<-function(r){
   if (length(r) == 0){return (list())}
-  l<-list()
   return (lapply(r, function(z){.r2p_outlier(z)}))
 }
 

R/regarima_generic.R

@@ -7,14 +7,14 @@ coef.JD3_REGARIMA_RSLTS <- function(object, component = c("regression", "arima",
 
   component <- match.arg(component)
   if (component == "regression") {
-    coefs = .regarima_coef_table(object)
+    coefs <- .regarima_coef_table(object)
   } else if (component == "arima") {
-    coefs = .sarima_coef_table(object)$coef_table
+    coefs <- .sarima_coef_table(object)$coef_table
   } else{
-    coefs = rbind(.sarima_coef_table(object)$coef_table[,1:2],
+    coefs <- rbind(.sarima_coef_table(object)$coef_table[,1:2],
                   .regarima_coef_table(object)[,1:2])
   }
-  res = coefs[,1]
+  res <- coefs[,1]
   names(res) <- rownames(coefs)
   res
 }

R/regarima_rslts.R

@@ -38,4 +38,5 @@ NULL
   tlist<-lapply(p$residuals_tests, function(z){.p2r_test(z$value)})
   tnames<-lapply(p$residuals_tests, function(z){z$key})
   testonresiduals<-`names<-`(tlist, tnames)
+  return (testonresiduals)
 }