distr6 fix

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: mlr3learners.flexsurv
 Title: Learners from the {flexsurv} package for 'mlr3'
-Version: 0.1.1.9000
+Version: 0.1.2
 Authors@R:
     person(given = "Raphael",
            family = "Sonabend",

NEWS.md

@@ -1,3 +1,7 @@
+# mlr3learners.flexsurv 0.1.2
+
+- distr6 patch
+
 # mlr3learners.flexsurv 0.1.1
 
 - Removed remotes dependencies

R/predict_flexsurvreg.R

@@ -38,35 +38,31 @@ predict_flexsurvreg <- function(object, task, ...) {
   # Define the d/p/q/r methods using the d/p/q/r methods that are automatically generated in the
   # fitted object. The parameters referenced are defined below and are based on the gamma
   # parameters above.
-  pdf = function(x1) {
-  }
+  pdf = function(x) {} # nolint
   body(pdf) = substitute({
     fn = func
     args = as.list(subset(as.data.table(self$parameters()), select = "value"))$value
     names(args) = unname(unlist(as.data.table(self$parameters())[, 1]))
-    do.call(fn, c(list(x = x1), args))
+    do.call(fn, c(list(x = x), args))
   }, list(func = object$dfns$d))
 
-  cdf = function(x1) {
-  }
+  cdf = function(x) {} # nolint
   body(cdf) = substitute({
     fn = func
     args = as.list(subset(as.data.table(self$parameters()), select = "value"))$value
     names(args) = unname(unlist(as.data.table(self$parameters())[, 1]))
-    do.call(fn, c(list(q = x1), args))
+    do.call(fn, c(list(q = x), args))
   }, list(func = object$dfns$p))
 
-  quantile = function(p) {
-  }
+  quantile = function(p) {} # nolint
   body(quantile) = substitute({
     fn = func
     args = as.list(subset(as.data.table(self$parameters()), select = "value"))$value
     names(args) = unname(unlist(as.data.table(self$parameters())[, 1]))
     do.call(fn, c(list(p = p), args))
   }, list(func = object$dfns$q))
 
-  rand = function(n) {
-  }
+  rand = function(n) {} # nolint
   body(rand) = substitute({
     fn = func
     args = as.list(subset(as.data.table(self$parameters()), select = "value"))$value
@@ -94,18 +90,6 @@ predict_flexsurvreg <- function(object, task, ...) {
   pargs = data.table::data.table(matrix(args, ncol = ncol(pars), nrow = length(args)))
   pars = rbind(pars, pargs)
 
-  params = lapply(pars, function(x) {
-    x = as.list(x)
-    names(x) = c(object$dlist$pars, names(args))
-    yparams = parameters$clone(deep = TRUE)
-    ind = match(yparams$.__enclos_env__$private$.parameters$id, names(x))
-    yparams$.__enclos_env__$private$.parameters$value = x[ind]
-
-    yparams
-  })
-
-  params = lapply(params, function(x) list(parameters = x))
-
   shared_params = list(
     name = "Flexible Parameteric",
     short_name = "Flexsurv",
@@ -115,13 +99,21 @@ predict_flexsurvreg <- function(object, task, ...) {
     variateForm = "univariate",
     description = "Royston/Parmar Flexible Parametric Survival Model",
     .suppressChecks = TRUE,
-    suppressMoments = TRUE,
     pdf = pdf, cdf = cdf, quantile = quantile, rand = rand
   )
 
-  distr = distr6::VectorDistribution$new(
-    distribution = "Distribution", params = params,
-    shared_params = shared_params, decorators = c("CoreStatistics", "ExoticStatistics"))
+  distlist = lapply(pars, function(x) {
+    x = as.list(x)
+    names(x) = c(object$dlist$pars, names(args))
+    yparams = parameters$clone(deep = TRUE)
+    ind = match(yparams$.__enclos_env__$private$.parameters$id, names(x))
+    yparams$.__enclos_env__$private$.parameters$value = x[ind]
+
+    do.call(distr6::Distribution$new, c(list(parameters = yparams), shared_params))
+  })
+
+  distr = distr6::VectorDistribution$new(distlist,
+                                         decorators = c("CoreStatistics", "ExoticStatistics"))
 
   return(list(distr = distr, lp = lp))
 }

tests/testthat/test_surv_flexible.R

@@ -1,17 +1,18 @@
 context("surv.flexible")
 
-task = tsk("rats")
+
 test_that("autotest", {
   set.seed(200)
   learner = lrn("surv.flexible", k = 0, scale = "normal", inits = c(1, 1, 1))
   expect_learner(learner)
   # there's no reason why sanity in particular is excluded except that because of multiple
   # experiments and changing seeds, I've found it isn't possible to remove the "`vnmin` is
   # not finite" error
-  result = run_autotest(learner, exclude = "sanity")
+  result = run_autotest(learner, exclude = "sanity", check_replicable = FALSE)
   expect_true(result, info = result$error)
 })
 
+task = tsk("rats")
 test_that("manualtest", {
   set.seed(15)
   learn = lrn("surv.flexible")