Various changes connected to new c++ class article

* New articles explain how to use method on `online()` objects to deploy online learning algorithms in production.
* The `conline` c++ class now exoses `weights` to R.
* A new article on how to interact with the `conline` c++ class was added.
* Various functions are now exported to R to allow for easier interaction with the `conline` c++ class. These functions are: `init_experts_list()`, `make_basis_mats` and `make_hat_mats`
* The code of `online()` was simplified a bit by utilizing the new `init_experts_list()` function.

NAMESPACE

@@ -17,6 +17,9 @@ S3method(update,online)
 export(autoplot)
 export(batch)
 export(conline)
+export(init_experts_list)
+export(make_basis_mats)
+export(make_hat_mats)
 export(make_knots)
 export(online)
 export(oracle)

NEWS.md

@@ -1,3 +1,16 @@
+profoc 1.3.0
+==============
+
+## Improvements
+
+* New articles explain how to use method on `online()` objects to deploy online learning algorithms in production.
+* The `conline` c++ class now exoses `weights` to R.
+* A new article on how to interact with the `conline` c++ class was added.
+* Various functions are now exported to R to allow for easier interaction with the `conline` c++ class. These functions are: `init_experts_list()`, `make_basis_mats` and `make_hat_mats`
+* The code of `online()` was simplified a bit by utilizing the new `init_experts_list()` function.
+
+## Improvements
+
 profoc 1.2.1
 ==============
 

R/misc.R

@@ -2,6 +2,76 @@ get_seed <- function() {
     sample.int(.Machine$integer.max, 1)
 }
 
+#' Create experts list to be used in conline class
+#'
+#' This function works in conjunction with the conline class.
+#' It takes a matrix of experts and a matrix of outcomes and
+#' returns a list of experts which fulfills all properties
+#' that are needed for passing it to the an instance of conline.
+#' @param experts array of predictions with dimension T x D x P x K
+#' (Observations x Variables x Quantiles x Experts) or T x D x K or T x P x K.
+#' @param y  A matrix of outcomes with dimension T x D.
+#' @param output_with_names Defaults to FALSE. If TRUE, the function
+#' returns a list with
+#' the experts list, the names of the variables (dnames) and the
+#' names of the experts (enames).
+#' @importFrom abind asub adrop
+#' @export
+init_experts_list <- function(experts, y, output_with_names = FALSE) {
+    edim <- dim(experts)
+    if (length(edim) == 3) {
+        enames <- dimnames(experts)[[3]]
+        if (is.null(enames)) {
+            enames <- paste0("E", 1:edim[3])
+        }
+        if (ncol(y) > 1) { # multivariate point
+            if (is.null(dimnames(experts)[[2]])) {
+                dnames <- paste0("D", 1:edim[2])
+            } else {
+                dnames <- dimnames(experts)[[2]]
+            }
+            experts <- array(
+                unlist(experts),
+                dim = c(edim[1], edim[2], 1, edim[3])
+            )
+            experts <- lapply(seq_len(edim[1]),
+                asub,
+                x = experts,
+                dims = 1,
+                drop = FALSE
+            )
+            experts <- lapply(experts, adrop, drop = 1)
+            dim(experts) <- c(edim[1], 1)
+        } else if (ncol(y) == 1) { # univariate probabilistic
+            dnames <- "D1"
+            experts <- lapply(seq_len(edim[1]),
+                asub,
+                x = experts,
+                dims = 1,
+                drop = FALSE
+            )
+            dim(experts) <- c(edim[1], 1)
+        }
+    } else if (length(edim) == 4) { # multivariate probabilistic
+        if (is.null(dimnames(experts)[[2]])) {
+            dnames <- paste0("D", 1:edim[2])
+        } else {
+            dnames <- dimnames(experts)[[2]]
+        }
+        enames <- dimnames(experts)[[4]]
+        if (is.null(enames)) {
+            enames <- paste0("E", 1:edim[4])
+        }
+        experts <- array_to_list(experts)
+    }
+
+    if (output_with_names) {
+        return(list(experts = experts, dnames = dnames, enames = enames))
+    } else {
+        return(experts)
+    }
+}
+
 #' @importFrom abind asub adrop
 array_to_list <- function(x) {
     x <- lapply(seq_len(dim(x)[1]),

R/online.R

@@ -176,14 +176,10 @@ online <- function(y, experts, tau,
                    trace = TRUE) {
     model_instance <- new(conline)
     model_instance$trace <- trace
-    model_instance$tau <- tau
     model_instance$forget_past_performance <- forget_past_performance
     model_instance$save_past_performance <- save_past_performance
     model_instance$save_predictions_grid <- save_predictions_grid
 
-
-    edim <- dim(experts)
-
     if (is.vector(y)) {
         y <- matrix(y)
     }
@@ -192,68 +188,30 @@ online <- function(y, experts, tau,
 
     # preserve names
     names <- list(y = dimnames(y))
-    names$experts <- list(NULL)
 
     # Prepare experts
-    if (length(edim) == 3) {
-        enames <- dimnames(experts)[[3]]
-        if (is.null(enames)) {
-            enames <- paste0("E", 1:edim[3])
-        }
-        if (ncol(y) > 1) { # multivariate point
-            if (is.null(dimnames(experts)[[2]])) {
-                dnames <- paste0("D", 1:edim[2])
-            } else {
-                dnames <- dimnames(experts)[[2]]
-            }
-            experts <- array(
-                unlist(experts),
-                dim = c(edim[1], edim[2], 1, edim[3])
-            )
-            experts <- lapply(seq_len(edim[1]),
-                asub,
-                x = experts,
-                dims = 1,
-                drop = FALSE
-            )
-            experts <- lapply(experts, adrop, drop = 1)
-            dim(experts) <- c(edim[1], 1)
-            model_instance$experts <- experts
-        } else if (ncol(y) == 1) { # univariate probabilistic
-            dnames <- "D1"
-            experts <- lapply(seq_len(edim[1]),
-                asub,
-                x = experts,
-                dims = 1,
-                drop = FALSE
-            )
-            dim(experts) <- c(edim[1], 1)
-            model_instance$experts <- experts
-        }
-    } else if (length(edim) == 4) { # multivariate probabilistic
-        if (is.null(dimnames(experts)[[2]])) {
-            dnames <- paste0("D", 1:edim[2])
-        } else {
-            dnames <- dimnames(experts)[[2]]
-        }
-        enames <- dimnames(experts)[[4]]
-        if (is.null(enames)) {
-            enames <- paste0("E", 1:edim[4])
-        }
-        experts <- array_to_list(experts)
-        model_instance$experts <- experts
-    }
-    names$experts[[2]] <- dnames
+
+    e_list <- init_experts_list(
+        experts = experts,
+        y = y,
+        output_with_names = TRUE
+    )
+    model_instance$experts <- e_list$experts
+
+    names$experts <- list(NULL)
+    names$experts[[2]] <- e_list$dnames
     names$experts[[3]] <- tau
-    names$experts[[4]] <- enames
+    names$experts[[4]] <- e_list$enames
 
+    model_instance$tau <- tau
+
     # Define dimensions for convenience
-    T <- dim(experts)[1]
-    D <- dim(experts[[1]])[1]
-    P <- dim(experts[[1]])[2]
-    K <- dim(experts[[1]])[3]
+    T <- dim(e_list$experts)[1]
+    D <- dim(e_list$experts[[1]])[1]
+    P <- dim(e_list$experts[[1]])[2]
+    K <- dim(e_list$experts[[1]])[3]
 
-    if (nrow(experts) - nrow(y) < 0) {
+    if (nrow(e_list$experts) - nrow(y) < 0) {
         stop("Number of provided expert predictions has to match or exceed observations.")
     }
 

R/splines.R

@@ -37,6 +37,25 @@ make_knots <- function(n, mu = .5, sig = 1, nonc = 0, tailw = 1, deg = 1) {
     return(knots)
 }
 
+#' Create a List of Basis Matrices
+#'
+#' This function creates a list of basis matrices and the corresponding
+#' parameters. It is used in `online()` to create the basis matrices
+#' for basis smoothing.
+#' @param x The predictor variable
+#' @param n Number of knots
+#' @param mu Beta distribution location parameter
+#' @param sigma Beta distribution scale parameter
+#' @param nonc Beta distribution noncentrality parameter
+#' @param tailw Tailweight
+#' @param deg Degree of splines
+#' @param periodic Create periodic basis
+#' @param idx `make_basis_mats()` will create a grid containing all
+#' combinations of the parameters. If idx is set, this grid will
+#' be subsetted to the rows specified by idx.
+#' @param params Instead of the arguments above, a grid (data.frame
+#' or named matrix) of parameters can be passed directly.
+#' @export
 make_basis_mats <- function(x, # Splines basis
                             n = length(x), # (vec of) Number of knots
                             mu = 0.5, # (vec of) Beta dist. mu
@@ -106,6 +125,28 @@ make_basis_mats <- function(x, # Splines basis
     return(out)
 }
 
+#' Create a List of Hat Matrices
+#'
+#' This function creates a list of hat matrices and the corresponding
+#' parameters. It is used in `online()` to create the hat matrices
+#' for penalized smoothing.
+#' @param x The predictor variable
+#' @param n Number of knots
+#' @param mu Beta distribution location parameter
+#' @param sigma Beta distribution scale parameter
+#' @param nonc Beta distribution noncentrality parameter
+#' @param tailw Tailweight
+#' @param deg Degree of splines
+#' @param ndiff Sets the degree of the differencing matrix for creaing
+#' the penalty
+#' @param lambda Penalty parameter (higher values lead to higher penalty)
+#' @param periodic Create periodic penalty
+#' @param idx `make_hat_mats()` will create a grid containing all
+#' combinations of the parameters. If idx is set, this grid will
+#' be subsetted to the rows specified by idx.
+#' @param params Instead of the arguments above, a grid (data.frame
+#' or named matrix) of parameters can be passed directly.
+#' @export
 make_hat_mats <- function(x,
                           n = length(x),
                           mu = 0.5,

src/conline_exports.cpp

@@ -27,6 +27,7 @@ RCPP_MODULE(conlineEx)
       .field("hat_pr", &conline::hat_pr)
       .field("hat_mv", &conline::hat_mv)
       .field("w0", &conline::w0)
+      .field("weights", &conline::weights)
       .field("R0", &conline::R0)
       .field("params", &conline::params)
       .field("params_basis_pr", &conline::params_basis_pr)