/
model-fits.R
115 lines (111 loc) · 4.77 KB
/
model-fits.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
#' List of `formula` objects
#'
#' Combine [formula][stats::formula] or [formula_list] object into a
#' [formula_list] object.
#'
#' @param ... Objects of class [formula][stats::formula], which can be named.
#' @return An object of class `formula_list`.
#' @keywords internal
#' @examples
#' # Create from "formula" objects
#' flist_wei <- formula_list(shape = formula(~ 1), scale = formula(~ x))
#' class(flist_wei)
#'
#' # Create from "formula_list" objects
#' flist <- formula_list(exponential = formula_list(rate = formula(~1)),
#' weibull = flist_wei)
#'
#' @export
formula_list <- function(...){
if (inherits(create_object_list(...)[[1]], "formula")){
return(object_list(..., inner_class = "formula", new_class = "formula_list"))
} else {
return(object_list(..., inner_class = "formula_list", new_class = "formula_list"))
}
}
#' List of `lm` objects
#'
#' Combine [`lm`][stats::lm] objects into a list
#' @param ... Objects of class [`lm`][stats::lm], which can be named.
#' @return Returns an object of class `lm_list`.
#' @keywords internal
#' @export
#' @examples
#' dat <- psm4_exdata$costs$medical
#' lm_fits <- lm_list(fit1 = stats::lm(costs ~ 1, data = dat),
#' fit2 = stats::lm(costs ~ female, data = dat))
#' class(lm_fits)
lm_list <- function(...){
return(object_list(..., inner_class = "lm", new_class = "lm_list"))
}
#' List of `flexsurvreg` objects
#'
#' Combine [`flexsurvreg`][flexsurv::flexsurvreg] objects into a list.
#' @param ... Objects of class [`flexsurvreg`][flexsurv::flexsurvreg], which can be named.
#' @return An object of class `flexsurvreg_list`.
#' @examples
#' library("flexsurv")
#' fit1 <- flexsurv::flexsurvreg(formula = Surv(futime, fustat) ~ 1, data = ovarian, dist = "weibull")
#' fit2 <- flexsurv::flexsurvreg(formula = Surv(futime, fustat) ~ 1, data = ovarian, dist = "exp")
#' fsreg_list <- flexsurvreg_list(wei = fit1, exp = fit2)
#' class(fsreg_list)
#' @export
flexsurvreg_list <- function(...){
return(object_list(..., inner_class = "flexsurvreg", new_class = "flexsurvreg_list"))
}
#' List of `multinom` objects
#'
#' Combine `multinom` objects into a list.
#' @param ... Objects of class [`multinom`][nnet::multinom], which can be named.
#' @return An object of class `multinom_list`.
#' @examples
#' library("nnet")
#' library("data.table")
#' trans_data <- data.table(multinom3_exdata$transitions)
#' dat_healthy <- trans_data[state_from == "Healthy"]
#' fit_healthy <- multinom(state_to ~ strategy_name + female + age_cat + year_cat,
#' data = dat_healthy)
#' dat_sick <- trans_data[state_from == "Sick"]
#' dat_sick$state_to <- droplevels(dat_sick$state_to)
#' fit_sick <- multinom(state_to ~ strategy_name + female + age_cat + year_cat,
#' data = dat_sick)
#' fits <- multinom_list(healthy = fit_healthy, sick = fit_sick)
#' class(fits)
#' @export
multinom_list <- function(...){
return(object_list(..., inner_class = "multinom", new_class = "multinom_list"))
}
#' Partitioned survival regression object
#'
#' Create a partitioned survival regression object of class `partsurvfit`. The object contains a list
#' of fitted survival models fit using either \code{\link{flexsurvreg}} or \code{\link{flexsurvspline}} (i.e.,
#' an object of class \code{\link{flexsurvreg_list}}) and the data frame used to perform the fit of each model.
#' The same data frame must have been used for each fit.
#' @param object An object of class \code{\link{flexsurvreg_list}}.
#' @param data The data frame used to fit each survival model in \code{object}.
#' \code{\link{flexsurvreg}}.
#' @return Returns an object of class `partsurvfit`, which is a list containing two elements.
#' The first element, "models", contains the survival models passed to \code{object}, and the second
#' element, "data" contains the data frame passed to \code{data}.
#' @examples
#' library("flexsurv")
#' fit1 <- flexsurv::flexsurvreg(formula = Surv(endpoint1_time, endpoint1_status) ~ age,
#' data = psm4_exdata$survival,
#' dist = "weibull")
#' fit2 <- flexsurv::flexsurvreg(formula = Surv(endpoint2_time, endpoint2_status) ~ age,
#' data = psm4_exdata$survival,
#' dist = "weibull")
#' fsreg_list <- flexsurvreg_list(endpoint1 = fit1, endpoint2 = fit2)
#' fits <- partsurvfit(fsreg_list, data = psm4_exdata$survival)
#' class(fits)
#' @export
#' @keywords internal
partsurvfit <- function(object, data){
if(!inherits(object, "flexsurvreg_list")){
stop("'Object' must be of class 'flexsurvreg_list'.")
}
stopifnot(is.data.frame(data) | is.data.table(data) | is.null(data))
res <- list(models = object, data = data)
class(res) <- "partsurvfit"
return(res)
}