R/basis.R

In nschaefer1211/OSE: Orthogonal Series Density Estimation

#' Basis 
#'
#' This class creates a basis of length d, which generates a d-dimensional linear subspace of \eqn{L^2[0,1]}. Specifically, 
#' a trigonometric basis and a histogramm basis are provided as options. 
#'
#' @section Usage:
#' \preformatted{trig_bas <- Trig_Basis$new(d)
#' hist_bas <- Hist_Basis$new(d)
#'
#'
#' trig_bas$get_function(j)
#' trig_bas$dimension
#' hist_bas$get_function(j)
#' hist_bas$dimension
#' }
#'
#' @section Arguments:
#' \describe{
#'   \item{d}{a natural number which specifies the dimension of the subsapce generated by the object of class basis.}
#'   \item{j}{a natural number smaller or equal to \code{d} which specifies which basis function is returned.}  
#' }
#'
#' @section Methods:
#' \code{$new()} generates a new \code{Basis} object dependent on the input \code{d}.
#'
#' \code{$get_function()} returns the jth basis function \code{j}.
#' 
#' \code{$dimension} returns the dimension of the vector space generated by the object of the class.
#' 
#' @details Note that the parent class \code{Basis} is merely there for construction purposes. An object generated by 
#' \eqn{Basis$new(d)} is not of much use to the user. Therefore one should always generat an object of a subclass of \code{Basis},
#' i.e. an object of class \code{Trig_Basis} or \code{Hist_Basis}
#'
#' @importFrom R6 R6Class
#' @name Basis 
#' @examples
#' trig_bas <- Trig_Basis$new(10)
#' trig_bas$get_function(4)
#' trig_bas
#' 
#' hist_bas <- Hist_Basis$new(10)
#' hist_bas$get_function(5)
#' hist_bas
NULL

#' @export
Basis <- R6Class("Basis",
                 public = list(
                   initialize = function(d){
                     if(missing(d) | !is.numeric(d) | !length(d) == 1){
                       stop("Dimension of the subspace not set")
                     }
                     private$.dimension <- d
                   },
                   get_function = function(j) {
                     return(private$build_function(j))
                   }
                 ),
                 private = list(
                   build_function = function(j){
                     res <- function()
                       return(res)
                   },
                   .dimension = NULL,
                   .lower_int = 0,
                   .upper_int = 1
                 ),
                 active = list(
                   dimension = function(d) {
                     if (missing(d)) private$.dimension
                     else {
                       message("Dimension is read only")
                     }
                   }
                 )
)
#'Trigonometric Basis
#'
#'This class creates a trigonometric basis of length d, which generates a d-dimensional linear subspace of \eqn{L^2[0,1]}
#'@details For a detailed documentation please see the documentation of class \code{\link{Basis}}, which is the parent class.
#'@export
Trig_Basis <- R6Class("Trig_Basis",
                      inherit = Basis,
                      private = list(
                        build_function = function(j) {
                          # One
                          if (j == 1) {
                            bas_f <- function(x) {
                              return(1)
                            }
                          } else if (j %% 2 == 0) { # Even:
                            bas_f <- function(x) {
                              return(sqrt(2) * cos(pi * x * j))
                            }
                          } else { # Uneven
                            bas_f <- function(x) {
                              return(sqrt(2) * sin(pi * (j - 1) * x))
                            }
                          }
                          return(bas_f)
                        }
                      )
)

#'Histogram Basis
#'
#'This class creates a trigonometric basis of length d, which generates a d-dimensional linear subspace of \eqn{L^2[0,1]}
#'@details For a detailed documentation please see the documentation of class \code{\link{Basis}}, which is the parent class.
#'@export
Hist_Basis <- R6Class("Hist_Basis",
                      inherit = Basis,
                      private = list(
                        build_function = function(j) {
                          D <- private$.dimension
                          hist_f <- function(x) {
                            return(ifelse(x >= (j - 1) / D && x < j / D, sqrt(D), 0))
                          }
                          hist_f <- Vectorize(hist_f)
                          return(hist_f)
                        }
                      )
)