From b5b446b718b15ccaae5b197e147fc1358f0f564e Mon Sep 17 00:00:00 2001
From: Johannes Ranke <jranke@uni-bremen.de>
Date: Fri, 6 Nov 2020 00:03:29 +0100
Subject: Fast analytical solutions for saemix, update.mmkin

Also, use logit transformation for g and for solitary formation
fractions, addressing #10.
---
 R/mmkin.R | 32 ++++++++++++++++++++++++++++++--
 1 file changed, 30 insertions(+), 2 deletions(-)

(limited to 'R/mmkin.R')

diff --git a/R/mmkin.R b/R/mmkin.R
index 6f088de0..f3c07e42 100644
--- a/R/mmkin.R
+++ b/R/mmkin.R
@@ -64,8 +64,9 @@
 #'
 #' @export mmkin
 mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
-  cores = detectCores(), cluster = NULL, ...)
+  cores = parallel::detectCores(), cluster = NULL, ...)
 {
+  call <- match.call()
   parent_models_available = c("SFO", "FOMC", "DFOP", "HS", "SFORB", "IORE", "logistic")
   n.m <- length(models)
   n.d <- length(datasets)
@@ -100,12 +101,14 @@ mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets,
   }
 
   if (is.null(cluster)) {
-    results <- parallel::mclapply(as.list(1:n.fits), fit_function, mc.cores = cores)
+    results <- parallel::mclapply(as.list(1:n.fits), fit_function,
+      mc.cores = cores, mc.preschedule = FALSE)
   } else {
     results <- parallel::parLapply(cluster, as.list(1:n.fits), fit_function)
   }
 
   attributes(results) <- attributes(fit_indices)
+  attr(results, "call") <- call
   class(results) <- "mmkin"
   return(results)
 }
@@ -187,3 +190,28 @@ print.mmkin <- function(x, ...) {
   }
 
 }
+
+#' @export
+update.mmkin <- function(object, ..., evaluate = TRUE)
+{
+  call <- attr(object, "call")
+
+  update_arguments <- match.call(expand.dots = FALSE)$...
+
+  if (length(update_arguments) > 0) {
+    update_arguments_in_call <- !is.na(match(names(update_arguments), names(call)))
+  }
+
+  for (a in names(update_arguments)[update_arguments_in_call]) {
+    call[[a]] <- update_arguments[[a]]
+  }
+
+  update_arguments_not_in_call <- !update_arguments_in_call
+  if(any(update_arguments_not_in_call)) {
+    call <- c(as.list(call), update_arguments[update_arguments_not_in_call])
+    call <- as.call(call)
+  }
+
+  if(evaluate) eval(call, parent.frame())
+  else call
+}
-- 
cgit v1.2.1