/
nmObjHandle.R
174 lines (155 loc) · 4.76 KB
/
nmObjHandle.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
#' Handle Model Object
#'
#' @param model model list should have at least:
#'
#' - `predOnly` -- this is the prediction model with all the left
#' handed equations added so they will be added the table. The
#' model should have `rx_pred_`, the model based prediction, as the
#' first defined lhs component. The second component should be
#' `rx_r_`, the variance of the prediction. These variables may
#' change based on distribution type. In additional all
#' interesting calculated variables should be included.
#'
#' - `predNoLhs` -- This is the prediction model. It only has the
#' prediction and no left handed equations.
#'
#' @return This returns the `$model` object for a fit. It is a s3
#' method because it may be different between different model types
#'
#' @param env Environment for the fit information
nmObjHandleModelObject <- function(model, env) {
on.exit({
if (exists("model", envir=env)){
rm("model", envir=env)
}})
UseMethod("nmObjHandleModelObject")
}
#' @rdname nmObjHandleModelObject
#' @export
nmObjHandleModelObject.saemModelList <- function(model, env) {
assign("saemModel", model, envir=env)
}
#' @rdname nmObjHandleModelObject
#' @export
nmObjHandleModelObject.foceiModelList <- function(model, env) {
assign("foceiModel", model, envir=env)
}
#' @rdname nmObjHandleModelObject
#' @export
nmObjHandleModelObject.default <- function(model, env) {
stop("cannot figure out how to handle the model, add method for `nmObjHandleModelObject.", class(model)[1], "`",
call.=FALSE)
}
#' Handle the control object
#'
#'
#' @param control Control object
#' @param env fit environment
#' @return Nothing, called for side effects
#' @author Matthew L. Fidler
#' @export
nmObjHandleControlObject <- function(control, env) {
on.exit({
if (exists("control", envir=env)) {
rm("control", envir=env)
}
})
UseMethod("nmObjHandleControlObject")
}
#' @rdname nmObjHandleControlObject
#' @export
nmObjHandleControlObject.foceiControl <- function(control, env) {
assign("foceiControl0", control, envir=env)
}
#' @rdname nmObjHandleControlObject
#' @export
nmObjHandleControlObject.saemControl <- function(control, env) {
assign("saemControl", control, envir=env)
}
#' @rdname nmObjHandleControlObject
#' @export
nmObjHandleControlObject.default <- function(control, env) {
stop("cannot figure out how to handle the model, add method for `nmObjHandleControlObject.", class(control)[1], "`",
call.=FALSE)
}
#' Method for getting focei compatible control object from nlmixr object
#'
#' @param x nlmixr composed fit object
#'
#' @param ... Other parameters
#'
#' @return foceiControl translated from current control
#'
#' @export
nmObjGetFoceiControl <- function(x, ...) {
UseMethod("nmObjGetFoceiControl")
}
#' @rdname nmObjGetFoceiControl
#' @export
nmObjGetFoceiControl.default <- function(x, ...) {
.env <- x[[1]]
if (exists("foceiControl0", .env)) {
return(get("foceiControl0", .env))
} else {
stop("cannot figure out how to make/retrieve the focei control\nmissing 'nmObjGetFoceiControl.",
class(x)[1], "'",
call.=FALSE)
}
}
#' Get control object from fit
#'
#' @param x nlmixr fit object
#' @param ... Other parameters
#' @return Control object of estimation method
#' @author Matthew L. Fidler
#' @export
nmObjGetControl <- function(x, ...) {
UseMethod("nmObjGetControl")
}
#' @rdname nmObjGetControl
#' @export
nmObjGetControl.focei <- function(x, ...) {
.env <- x[[1]]
if (exists("foceiControl0", .env)) {
.control <- get("foceiControl0", .env)
if (inherits(.control, "foceiControl")) return(.control)
}
if (exists("control", .env)) {
.control <- get("control", .env)
if (inherits(.control, "foceiControl")) return(.control)
}
stop("cannot find focei related control object", call.=FALSE)
}
#' @rdname nmObjGetControl
#' @export
nmObjGetControl.foce <- nmObjGetControl.focei
#' @rdname nmObjGetControl
#' @export
nmObjGetControl.foi <- nmObjGetControl.focei
#' @rdname nmObjGetControl
#' @export
nmObjGetControl.fo <- nmObjGetControl.focei
#' @rdname nmObjGetControl
#' @export
nmObjGetControl.posthoc <- nmObjGetControl.focei
#' @rdname nmObjGetControl
#' @export
nmObjGetControl.saem <- function(x, ...) {
.env <- x[[1]]
if (exists("saemControl", .env)) {
.control <- get("saemControl", .env)
if (inherits(.control, "saemControl")) return(.control)
}
if (exists("control", .env)) {
.control <- get("control", .env)
if (inherits(.control, "saemControl")) return(.control)
}
stop("cannot find saem related control object", call.=FALSE)
}
#' @rdname nmObjGetControl
#' @export
nmObjGetControl.default <- function(x, ...) {
## stop("cannot figure out get the control, add method for `nmObjHandleControlObject.", class(x)[1], "`",
## call.=FALSE)
NULL
}