aboutsummaryrefslogtreecommitdiff
path: root/R/mkinfit.R
diff options
context:
space:
mode:
authorJohannes Ranke <jranke@uni-bremen.de>2020-05-08 15:22:54 +0200
committerJohannes Ranke <jranke@uni-bremen.de>2020-05-08 15:22:54 +0200
commit636dade692b8eee012004a2740616385333efc48 (patch)
tree4b5d54da6f0ac77526b39ad092dfdaa7f64362bc /R/mkinfit.R
parent2c313bdb12c5fcae8272600021fcedbc99425130 (diff)
Avoid duplicate merge in tc error model fit
This increases the performance in the complete test suite by about 20 secs from 120 to around 100 secs. I tried improving merge speed by using data.table on another branch, but this did not give a noticeable performance gain.
Diffstat (limited to 'R/mkinfit.R')
-rw-r--r--R/mkinfit.R17
1 files changed, 7 insertions, 10 deletions
diff --git a/R/mkinfit.R b/R/mkinfit.R
index f5e7e493..61593ce5 100644
--- a/R/mkinfit.R
+++ b/R/mkinfit.R
@@ -594,23 +594,20 @@ mkinfit <- function(mkinmod, observed,
out_long <- mkin_wide_to_long(out, time = "time")
+ cost_data <- merge(observed[c("name", "time", "value")], out_long,
+ by = c("name", "time"), suffixes = c(".observed", ".predicted"))
+
if (err_mod == "const") {
- observed$std <- if (OLS) NA else cost_errparms["sigma"]
+ cost_data$std <- if (OLS) NA else cost_errparms["sigma"]
}
if (err_mod == "obs") {
- std_names <- paste0("sigma_", observed$name)
- observed$std <- cost_errparms[std_names]
+ std_names <- paste0("sigma_", cost_data$name)
+ cost_data$std <- cost_errparms[std_names]
}
if (err_mod == "tc") {
- tmp <- merge(observed, out_long, by = c("time", "name"))
- tmp$name <- ordered(tmp$name, levels = obs_vars)
- tmp <- tmp[order(tmp$name, tmp$time), ]
- observed$std <- sqrt(cost_errparms["sigma_low"]^2 + tmp$value.y^2 * cost_errparms["rsd_high"]^2)
+ cost_data$std <- sqrt(cost_errparms["sigma_low"]^2 + cost_data$value.predicted^2 * cost_errparms["rsd_high"]^2)
}
- cost_data <- merge(observed[c("name", "time", "value", "std")], out_long,
- by = c("name", "time"), suffixes = c(".observed", ".predicted"))
-
if (OLS) {
# Cost is the sum of squared residuals
cost <- with(cost_data, sum((value.observed - value.predicted)^2))

Contact - Imprint