1
#' Permuate explanatory variables to produce multiple output tables for common
2
#' regression models
3
#'
4
#' @param .data Data frame or tibble.
5
#' @param dependent Character vector of length 1:  quoted name of dependent
6
#'   variable. Can be continuous, a binary factor, or a survival object of form
7
#'   \code{Surv(time, status)}.
8
#' @param explanatory_base Character vector of any length: quoted name(s) of
9
#'   base model explanatory variables.
10
#' @param explanatory_permute Character vector of any length: quoted name(s) of
11
#'   explanatory variables to permute through models.
12
#' @param multiple_tables Logical. Multiple model tables as a list, or a single
13
#'   table including multiple models.
14
#' @param include_base_model Logical. Include model using \code{explanatory_base}
15
#' variables only.
16
#' @param include_full_model Logical. Include model using all \code{explanatory_base}
17
#' and \code{explanatory_permute} variables.
18
#' @param base_on_top Logical. Base variables at top of table, or bottom of
19
#'   table.
20
#' @param ... Other arguments to \code{\link{finalfit}}
21
#'
22
#' @return Returns a list of data frame with the final model table.
23
#' @export
24
#'
25
#' @examples
26
#' explanatory_base = c("age.factor", "sex.factor")
27
#' explanatory_permute = c("obstruct.factor", "perfor.factor", "node4.factor")
28
#'
29
#' # Linear regression
30
#' colon_s %>%
31
#'   finalfit_permute("nodes", explanatory_base, explanatory_permute)
32
#'
33
#' # Cox proportional hazards regression
34
#' colon_s %>%
35
#'   finalfit_permute("Surv(time, status)", explanatory_base, explanatory_permute)
36
#'
37
#' # Logistic regression
38
#' colon_s %>%
39
#'   finalfit_permute("mort_5yr", explanatory_base, explanatory_permute)
40
#'
41
#' # Logistic regression with random effect (glmer)
42
#' # colon_s %>%
43
#' #   finalfit_permute("mort_5yr", explanatory_base, explanatory_permute,
44
#' #     random_effect = "hospital")
45
ff_permute <- function(.data, dependent = NULL, 
46
											 explanatory_base = NULL, explanatory_permute = NULL,
47
											 multiple_tables = FALSE, 
48
											 include_base_model = TRUE,
49
											 include_full_model = TRUE,
50
											 base_on_top = TRUE, ...){
51 1
	args = list(...)
52
	
53 1
	if(base_on_top){
54 1
		explanatory = explanatory_permute %>% 
55 1
			purrr::map(~ c(explanatory_base, .x))
56
	} else {
57 1
		explanatory = explanatory_permute %>% 
58 1
			purrr::map(c, explanatory_base)
59
	}
60
	
61 1
	if(include_base_model){
62 1
		explanatory = c(list(explanatory_base), explanatory)
63
	}
64
	
65 1
	fits = explanatory %>% 
66 1
		purrr::map(~ do.call(finalfit, c(list(.data, dependent, explanatory = .x, keep_fit_id = TRUE), 
67 1
																		 args)))
68
	
69 1
	if(base_on_top){
70 1
		explanatory = c(explanatory_base, explanatory_permute)
71
	} else {
72 1
		explanatory = c(explanatory_permute, explanatory_base)
73
	}
74
	
75 1
	if(include_full_model){
76 1
		fits = c(fits,
77 1
						 list(
78 1
						 	finalfit(.data, dependent, explanatory, keep_fit_id = TRUE, ...)
79
						 )
80
		)
81
	}
82
	
83
	# Multiple tables ----
84 1
	if(multiple_tables){
85 1
		out = fits %>% 
86 1
			purrr::map(dplyr::select, -fit_id)
87 1
		return(out)
88
	}
89
	
90
	# Single table ----
91 1
	uni = finalfit(.data, dependent, explanatory, keep_fit_id = TRUE, 
92 1
								 add_dependent_label = FALSE, ...) %>% 
93 1
		dplyr::select(-length(.)) # remove last column
94
	
95
	## multivariable only
96 1
	fits = fits %>% 
97 1
		purrr::map(dplyr::select, c(1, length(.[[1]]))) # first and last columns
98
	
99
	## number of models
100 1
	n_fits = 1:length(fits)
101
	
102
	## paste incremental integer to model name
103 1
	fits = fits %>% 
104 1
		purrr::map(~ names(.x)[2]) %>% 
105 1
		purrr::map2(n_fits, ~ paste(.x, .y)) %>% 
106 1
		purrr::map2(fits, ~ dplyr::rename(.y, !!.x := 2))
107
	
108
	## create final table
109 1
	out = fits %>% 
110 1
		purrr::reduce(dplyr::full_join, by = "fit_id") %>% 
111 1
		dplyr::left_join(uni, ., by = "fit_id") %>% 
112 1
		dplyr::mutate_all(~ ifelse(is.na(.), "-", .)) %>% 
113 1
		dplyr::select(-fit_id, -index) %>% 
114 1
		dependent_label(.data = .data, dependent = dependent)
115 1
	return(out)
116
}
117

118
#' @rdname ff_permute
119
#' @export
120
finalfit_permute = ff_permute

Read our documentation on viewing source code .

Loading