From b76e401a854021eaeda6f8ba262baf37b4ecfac2 Mon Sep 17 00:00:00 2001
From: Johannes Ranke <jranke@uni-bremen.de>
Date: Thu, 13 Oct 2022 03:51:22 +0200
Subject: Select best fit from multistart, use in parhist

- Add 'best' and 'which.best' generics with methods for multistart
objects
- Per default, scale the parameters in parhist plots using the fit with
the highest log likelihood.
---
 R/multistart.R | 40 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 39 insertions(+), 1 deletion(-)

(limited to 'R/multistart.R')

diff --git a/R/multistart.R b/R/multistart.R
index b65c0bee..a788953e 100644
--- a/R/multistart.R
+++ b/R/multistart.R
@@ -47,8 +47,10 @@
 #' f_saem_full <- saem(f_mmkin)
 #' f_saem_full_multi <- multistart(f_saem_full, n = 16, cores = 16)
 #' parhist(f_saem_full_multi, lpos = "bottomright")
+#' illparms(f_saem_full)
 #'
-#' f_saem_reduced <- update(f_saem_full, covariance.model = diag(c(1, 1, 0, 1)))
+#' f_saem_reduced <- update(f_saem_full, no_random_effect = "log_k2")
+#' illparms(f_saem_reduced)
 #' # On Windows, we need to create a cluster first. When working with
 #' # such a cluster, we need to export the mmkin object to the cluster
 #' # nodes, as it is referred to when updating the saem object on the nodes.
@@ -140,3 +142,39 @@ print.multistart <- function(x, ...) {
   cat("<multistart> object with", length(x), "fits:\n")
   print(convergence(x))
 }
+
+#' @rdname multistart
+#' @export
+best <- function(object, ...)
+{
+  UseMethod("best", object)
+}
+
+#' @export
+#' @return The object with the highest likelihood
+#' @rdname multistart
+best.default <- function(object, ...)
+{
+  return(object[[which.best(object)]])
+}
+
+#' @return The index of the object with the highest likelihood
+#' @rdname multistart
+#' @export
+which.best <- function(object, ...)
+{
+  UseMethod("which.best", object)
+}
+
+#' @rdname multistart
+#' @export
+which.best.default <- function(object, ...)
+{
+  llfunc <- function(object) {
+    ret <- try(logLik(object))
+    if (inherits(ret, "try-error")) return(NA)
+    else return(ret)
+  }
+  ll <- sapply(object, llfunc)
+  return(which.max(ll))
+}
-- 
cgit v1.2.1