R/LearnerDensPenalized.R

In mlr3learners/mlr3learners.pendensity: Learners from the {pendensity} package for 'mlr3'

#' @title Density Penalized Learner
#'
#' @name mlr_learners_dens.pen
#'
#' @description
#' A [mlr3proba::LearnerDens] implementing penalized estimation from package
#'   \CRANpkg{pendensity}.
#' Calls [pendensity::pendensity()].
#'
#' @templateVar id dens.pen
#' @template section_dictionary_learner
#'
#' @references
#' Density Estimation with a Penalized Mixture Approach, Schellhase C. and Kauermann G. (2012),
#' Computational Statistics 27 (4), p. 757-777.
#'
#' @template seealso_learner
#' @template example
#' @export
LearnerDensPenalized = R6Class("LearnerDensPenalized",
  inherit = LearnerDens,

  public = list(
    #' @description
    #' Creates a new instance of this [R6][R6::R6Class] class.
    initialize = function() {
      ps = ParamSet$new(
        params = list(
          ParamFct$new(
            id = "base", default = "bspline",
            levels = c("bspline", "gaussian"), tags = "train"),
          ParamDbl$new(id = "no.base", default = 41, tags = "train"),
          ParamDbl$new(id = "max.iter", default = 20, tags = "train"),
          ParamDbl$new(id = "lambda0", default = 500, tags = "train"),
          ParamDbl$new(id = "q", default = 3, tags = "train"),
          ParamLgl$new(id = "sort", default = TRUE, tags = "train"),
          ParamUty$new(id = "with.border", tags = "train"),
          ParamDbl$new(id = "m", default = 3, tags = "train"),
          ParamDbl$new(id = "eps", default = 0.01, tags = "train")
        )
      )

      super$initialize(
        id = "dens.pen",
        packages = "pendensity",
        feature_types = c("logical", "integer", "numeric", "character", "factor", "ordered"),
        predict_types = c("pdf", "cdf"),
        param_set = ps,
        man = "mlr3learners.pendensity::mlr_learners_dens.pen"
      )
    }
  ),

  private = list(
    .train = function(task) {

      pars = self$param_set$get_values(tag = "train")
      fit = mlr3misc::invoke(pendensity::pendensity,
                             form = task$truth() ~ 1,
                             .args = pars)

      pdf = function(x) {} # nolint
      body(pdf) = substitute({
        mlr3misc::invoke(pendensity::dpendensity,
          x = fit,
          val = x)
      })

      cdf = function(x) {} # nolint
      body(cdf) = substitute({
        mlr3misc::invoke(pendensity::ppendensity,
          x = fit,
          val = x)
      })

      base = if (is.null(pars$base)) {
        "gaussian"
      } else {
        pars$base
      }
      distr6::Distribution$new(
        name = paste("Penalized Density", base),
        short_name = paste0("PenDens_", base),
        pdf = pdf, cdf = cdf, type = set6::Reals$new())
    },

    .predict = function(task) {
      newdata = task$truth()
      mlr3proba::PredictionDens$new(task = task,
                                    pdf = self$model$pdf(newdata),
                                    cdf = self$model$pdf(newdata))
    }
  )
)