jranke / mkin
1
#' Create a mixed effects model from an mmkin row object
2
#'
3
#' @param object An [mmkin] row object
4
#' @param method The method to be used
5
#' @param \dots Currently not used
6
#' @examples
7
#' sampling_times = c(0, 1, 3, 7, 14, 28, 60, 90, 120)
8
#' n_biphasic <- 8
9
#' err_1 = list(const = 1, prop = 0.07)
10
#'
11
#' DFOP_SFO <- mkinmod(
12
#'   parent = mkinsub("DFOP", "m1"),
13
#'   m1 = mkinsub("SFO"),
14
#'   quiet = TRUE)
15
#'
16
#' set.seed(123456)
17
#' log_sd <- 0.3
18
#' syn_biphasic_parms <- as.matrix(data.frame(
19
#'   k1 = rlnorm(n_biphasic, log(0.05), log_sd),
20
#'   k2 = rlnorm(n_biphasic, log(0.01), log_sd),
21
#'   g = plogis(rnorm(n_biphasic, 0, log_sd)),
22
#'   f_parent_to_m1 = plogis(rnorm(n_biphasic, 0, log_sd)),
23
#'   k_m1 = rlnorm(n_biphasic, log(0.002), log_sd)))
24
#'
25
#' ds_biphasic_mean <- lapply(1:n_biphasic,
26
#'   function(i) {
27
#'     mkinpredict(DFOP_SFO, syn_biphasic_parms[i, ],
28
#'       c(parent = 100, m1 = 0), sampling_times)
29
#'   }
30
#' )
31
#'
32
#' set.seed(123456L)
33
#' ds_biphasic <- lapply(ds_biphasic_mean, function(ds) {
34
#'   add_err(ds,
35
#'     sdfunc = function(value) sqrt(err_1$const^2 + value^2 * err_1$prop^2),
36
#'     n = 1, secondary = "m1")[[1]]
37
#' })
38
#'
39
#' \dontrun{
40
#' f_mmkin <- mmkin(list("DFOP-SFO" = DFOP_SFO), ds_biphasic, error_model = "tc", quiet = TRUE)
41
#'
42
#' f_mixed <- mixed(f_mmkin)
43
#' print(f_mixed)
44
#' plot(f_mixed)
45
#' }
46
#' @export
47
mixed <- function(object, ...) {
48 1
  UseMethod("mixed")
49
}
50

51
#' @export
52
#' @rdname mixed
53
mixed.mmkin <- function(object, method = c("none"), ...) {
54 0
  if (nrow(object) > 1) stop("Only row objects allowed")
55

56 1
  method <- match.arg(method)
57 0
  if (method == "default") method = c("naive", "nlme")
58

59 1
  ds_names <- colnames(object)
60 1
  res <- list(mmkin = object, mkinmod = object[[1]]$mkinmod)
61

62 1
  if (method[1] == "none") {
63 1
    ds_list <- lapply(object,
64 1
      function(x) x$data[c("variable", "time", "observed", "predicted", "residual")])
65

66 1
    names(ds_list) <- ds_names
67 1
    res$data <- purrr::map_dfr(ds_list, function(x) x, .id = "ds")
68 1
    names(res$data)[1:4] <- c("ds", "name", "time", "value")
69 1
    res$data$name <- as.character(res$data$name)
70 1
    res$data$ds <- ordered(res$data$ds, levels = unique(res$data$ds))
71 1
    standardized <- unlist(lapply(object, residuals, standardized = TRUE))
72 1
    res$data$std <- res$data$residual / standardized
73 1
    res$data$standardized <- standardized
74

75 1
    class(res) <- c("mixed.mmkin")
76 1
    return(res)
77
  }
78
}
79

80
#' @export
81
#' @rdname mixed
82
#' @param x A mixed.mmkin object to print
83
#' @param digits Number of digits to use for printing.
84
print.mixed.mmkin <- function(x, digits = max(3, getOption("digits") - 3), ...) {
85 1
  cat("Kinetic model fitted by nonlinear regression to each dataset" )
86 1
  cat("\nStructural model:\n")
87 1
  diffs <- x$mmkin[[1]]$mkinmod$diffs
88 1
  nice_diffs <- gsub("^(d.*) =", "\\1/dt =", diffs)
89 1
  writeLines(strwrap(nice_diffs, exdent = 11))
90 1
  cat("\nData:\n")
91 1
  cat(nrow(x$data), "observations of",
92 1
    length(unique(x$data$name)), "variable(s) grouped in",
93 1
    length(unique(x$data$ds)), "datasets\n\n")
94

95 1
  print(x$mmkin, digits = digits)
96

97 1
  cat("\nMean fitted parameters:\n")
98 1
  print(mean_degparms(x$mmkin), digits = digits)
99

100 1
  invisible(x)
101
}

Read our documentation on viewing source code .

Loading