diff options
author | Johannes Ranke <jranke@uni-bremen.de> | 2015-06-25 11:32:34 +0200 |
---|---|---|
committer | Johannes Ranke <jranke@uni-bremen.de> | 2015-06-25 11:32:34 +0200 |
commit | c3d6dde60cb368f403ffe0285db27e218f669990 (patch) | |
tree | 0d356630c1a74aa468c3d941a0bc861ec495b3a6 /R/mmkin.R | |
parent | 5a58193c861c9b8e19f211db8711f432a3a93d85 (diff) |
Add mmkin for testing
Diffstat (limited to 'R/mmkin.R')
-rw-r--r-- | R/mmkin.R | 46 |
1 files changed, 46 insertions, 0 deletions
diff --git a/R/mmkin.R b/R/mmkin.R new file mode 100644 index 00000000..fe9db194 --- /dev/null +++ b/R/mmkin.R @@ -0,0 +1,46 @@ +mmkin <- function(models = c("SFO", "FOMC", "DFOP"), datasets, + cores = round(detectCores()/2), cluster = NULL, ...) +{ + parent_models_available = c("SFO", "FOMC", "DFOP", "HS", "SFORB", "IORE") + n.m <- length(models) + n.d <- length(datasets) + n.fits <- n.m * n.d + fit_indices <- matrix(1:n.fits, ncol = n.d) + + # Check models and define their names + if (!all(sapply(models, function(x) inherits(x, "mkinmod")))) { + if (!all(models %in% parent_models_available)) { + stop("Please supply models as a list of mkinmod objects or a vector combined of\n ", + paste(parent_models_available, collapse = ", ")) + } else { + names(models) <- models + } + } else { + if (is.null(names(models))) names(models) <- as.character(1:n.m) + } + + # Check datasets and define their names + if (is.null(names(datasets))) names(datasets) <- as.character(1:n.d) + + # Define names for fit index + dimnames(fit_indices) <- list(model = names(models), + dataset = names(datasets)) + + + fit_function <- function(fit_index) { + w <- which(fit_indices == fit_index, arr.ind = TRUE) + model_index <- w[1] + dataset_index <- w[2] + mkinfit(models[[model_index]], datasets[[dataset_index]], ...) + } + + if (is.null(cluster)) { + results <- mclapply(as.list(1:n.fits), fit_function, mc.cores = cores) + } else { + results <- parLapply(cluster, list(1:n.fit), fit_function) + } + + attributes(results) <- attributes(fit_indices) + class(results) <- "mmkin" + return(results) +} |