Merge branch 'stephq'

chjackson · Apr 16, 2024 · 6232e16 · 6232e16
2 parents 0675a27 + 3e964ee
commit 6232e16
Show file tree

Hide file tree

Showing 2 changed files with 28 additions and 2 deletions.
diff --git a/R/flexsurvreg.R b/R/flexsurvreg.R
@@ -985,7 +985,7 @@ flexsurvreg <- function(formula, anc=NULL, data, weights, bhazard, rtrunc, subse
                                                 rtrunc=rtrunc, dlist=dlist, inits=inits, dfns=dfns,
                                                 aux=aux, mx=mx, fixedpars=fixedpars)
 
-        if (hessian && all(is.finite(opt$hessian)) && all(eigen(opt$hessian)$values > 0))
+        if (hessian && all(is.finite(opt$hessian)))
         {
             cov <- .hess_to_cov(opt$hessian, hess.control$tol.solve, hess.control$tol.evalues)
             se <- sqrt(diag(cov))
@@ -996,7 +996,7 @@ flexsurvreg <- function(formula, anc=NULL, data, weights, bhazard, rtrunc, subse
         }
         else {
             if (hessian) 
-                warning("Optimisation has probably not converged to the maximum likelihood - Hessian is not positive definite. ")
+                warning("Optimisation has probably not converged to the maximum likelihood - Hessian is not finite. ")
             cov <- lcl <- ucl <- se <- NA
         }
         res <- cbind(est=inits, lcl=NA, ucl=NA, se=NA)

diff --git a/tests/testthat/test_hess.R b/tests/testthat/test_hess.R
@@ -159,3 +159,29 @@ test_that("flexsurvspline fit hessian",{
 })
 
 options(flexsurv.test.analytic.derivatives=FALSE)
+
+
+test_that("nearest positive-definite control",{
+
+  # sub-optimal solution near to optimal solution of:
+  # flexsurvreg(formula=Surv(futime, fustat) ~ 1, dist="gengamma", data=ovarian)
+    perturbed <- c(mu=6.4049977, sigma=1.2217696, Q=-0.6432642)
+    short_optim <- list(maxit=0)
+
+    expect_warning(
+        flexsurvreg(formula=Surv(futime, fustat) ~ 1, data=ovarian,
+                    dist="gengamma", inits=perturbed, control=short_optim,
+                    hess.control=list(tol.evalues=0)),
+        "Hessian not positive definite"
+    )
+    expect_silent(
+        flexsurvreg(formula=Surv(ovarian$futime, ovarian$fustat) ~ 1,
+                    dist="gengamma", inits=perturbed, control=short_optim,
+                    hess.control=list(tol.evalues=1.1E1))
+    )
+    fl_nearPD <- flexsurvreg(formula=Surv(futime, fustat) ~ 1, data=ovarian,
+                             dist="gengamma", inits=perturbed, control=short_optim,
+                             hess.control=list(tol.evalues=1.1E1))
+    expect_gt(min(eigen(vcov(fl_nearPD))$values), 0)
+
+})