1
#' Eval for `lm` and `glm` model wrappers
2
#'
3
#' Internal function, not called directly. This is in reponse to a long running
4
#' issue of the best way to pass `weights` to `lm()` and `glm()`. See here
5
#' https://stackoverflow.com/questions/54383414/passing-weights-to-glm-using-rlang
6
#'
7
#' @param .
8
#'
9
#' @keywords internal
10
ff_eval <- function(.) {
11 1
	eval(rlang::enexpr(.), rlang::caller_env())
12
}
13

14
#' Print methods for finalfit data frames
15
#'
16
#' @param .data Data frame
17
#' @return Data frame with no line numbers
18
#' 
19
#' @rdname print
20
#' @method print data.frame.ff
21
#' @export
22
#' 
23
#' @keywords internal
24
#'
25
print.data.frame.ff <- function(x, ...){
26 0
	print.data.frame(x, row.names = FALSE, ...)
27
}
28

29
#' Extract model output to dataframe
30
#'
31
#' Internal function, not usually called directly.
32
#'
33
#' @param .data Model output.
34
#' @param explanatory_name Name for this column in output.
35
#' @param estimate_name Name for this column in output.
36
#' @param estimate_suffix Appeneded to estimate name.
37
#' @param p_name Name given to p-value estimate
38
#' @param confint_type One of \code{c("profile", "default")} for GLM
39
#'   models or \code{c("profile", "Wald", "boot")} for \code{glmer/lmer} models.
40
#'   Not implemented for \code{lm, coxph or coxphlist}.
41
#' @param confint_level The confidence level required.
42
#' @param ... Other arguments.
43
#'
44
#' @keywords internal
45
#' @export
46

47
extract_fit = function(...){
48 1
	UseMethod("extract_fit")
49
}
50

51
#' Extract model output to dataframe
52
#'
53
#' @keywords internal
54
#' @rdname extract_fit
55
#' @method extract_fit glm
56
#' @export
57

58
extract_fit.glm = function(.data, explanatory_name="explanatory", estimate_name="OR",
59
													 estimate_suffix = "",  p_name = "p", exp = TRUE,
60
													 confint_type = "profile", confint_level = 0.95, ...){
61 1
	x=.data
62 1
	explanatory = names(coef(x))
63 1
	estimate = coef(x)
64 1
	if (confint_type == "profile"){
65 1
		confint = confint(x, level = confint_level)
66 1
	}else if (confint_type == "default"){
67 0
		confint = confint.default(x, level = confint_level)
68
	}
69 1
	p_col = dimnames(summary(x)$coef)[[2]] %in% c("Pr(>|t|)", "Pr(>|z|)")
70 1
	p = summary(x)$coef[ ,p_col]
71 1
	L_confint_name = paste0("L", confint_level*100)
72 1
	U_confint_name = paste0("U", confint_level*100)
73
	
74 1
	df.out = dplyr::tibble(explanatory, estimate, confint[,1], confint[,2], p)
75 1
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix),
76 1
											 L_confint_name, U_confint_name, p_name)
77 1
	if(exp){
78 1
		df.out[, 2:4] = df.out[, 2:4] %>% exp() # mutate_at not working here
79
	}
80 1
	if(confint_level != 0.95){
81 0
		df.out = df.out %>% dplyr::select(-p_name)
82
	}
83 1
	df.out = data.frame(df.out)
84 1
	return(df.out)
85
}
86

87
#' Extract model output to dataframe
88
#'
89
#' @keywords internal
90
#' @rdname extract_fit
91
#' @method extract_fit glmerMod
92
#' @export
93

94
extract_fit.glmerMod = function(.data, explanatory_name="explanatory", estimate_name="OR",
95
																estimate_suffix = "",  p_name = "p", exp = TRUE, 
96
																confint_type = "Wald", confint_level = 0.95, ...){
97 1
	x=.data
98 1
	if(confint_type == "default") confint_type = "Wald"
99 1
	explanatory = names(lme4::fixef(x))
100 1
	estimate = lme4::fixef(x)
101 1
	confint = lme4::confint.merMod(x, level = confint_level, method = confint_type)
102 1
	confint = confint[-grep("sig", rownames(confint)),]
103 1
	p = summary(x)$coef[,"Pr(>|z|)"]
104 1
	L_confint_name = paste0("L", confint_level*100)
105 1
	U_confint_name = paste0("U", confint_level*100)
106
	
107 1
	df.out = dplyr::tibble(explanatory, estimate, confint[,1], confint[,2], p)
108 1
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix),
109 1
											 L_confint_name, U_confint_name, p_name)
110
	
111 1
	if(exp){
112 1
		df.out[, 2:4] = df.out[, 2:4] %>% exp() # mutate_at not working here
113
	}
114
	
115 1
	if(confint_level != 0.95){
116 0
		df.out = df.out %>% dplyr::select(-p_name)
117
	}
118 1
	df.out = data.frame(df.out)
119 1
	return(df.out)
120
}
121

122

123
#' Extract model output to dataframe
124
#'
125
#' @keywords internal
126
#' @rdname extract_fit
127
#' @method extract_fit lm
128
#' @export
129

130
extract_fit.lm = function(.data, explanatory_name="explanatory", estimate_name="Coefficient",
131
													estimate_suffix = "",  p_name = "p",
132
													confint_level = 0.95, ...){
133 1
	x=.data
134 1
	explanatory = names(coef(x))
135 1
	estimate = coef(x)
136 1
	confint = confint(x)
137 1
	p = summary(x)$coef[,"Pr(>|t|)"]
138 1
	L_confint_name = paste0("L", confint_level*100)
139 1
	U_confint_name = paste0("U", confint_level*100)
140
	
141 1
	df.out = dplyr::tibble(explanatory, estimate, confint[,1], confint[,2], p)
142 1
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix),
143 1
											 L_confint_name, U_confint_name, p_name)
144 1
	if(confint_level != 0.95){
145 0
		df.out = df.out %>% dplyr::select(-p_name)
146
	}
147 1
	df.out = data.frame(df.out)
148 1
	return(df.out)
149
}
150

151
#' Extract model output to dataframe
152
#'
153
#' @keywords internal
154
#' @rdname extract_fit
155
#' @method extract_fit lmerMod
156
#' @export
157

158
extract_fit.lmerMod = function(.data, explanatory_name="explanatory", estimate_name="OR",
159
															 estimate_suffix = "",  p_name = "p",
160
															 confint_type = "Wald", confint_level = 0.95, ...){
161 1
	x=.data
162 1
	if(confint_type == "default") confint_type = "Wald"
163 1
	explanatory = names(lme4::fixef(x))
164 1
	estimate = lme4::fixef(x)
165 1
	confint = lme4::confint.merMod(x, method = confint_type)
166 1
	confint = confint[-grep("sig", rownames(confint)),]
167 1
	p = 1-pnorm(abs(summary(x)$coefficients[,3]))
168 1
	message("P-value for lmer is estimate assuming t-distribution is normal. Bootstrap for final publication.")
169
	
170 1
	L_confint_name = paste0("L", confint_level*100)
171 1
	U_confint_name = paste0("U", confint_level*100)
172
	
173 1
	df.out = dplyr::tibble(explanatory, estimate, confint[,1], confint[,2], p)
174 1
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix),
175 1
											 L_confint_name, U_confint_name, p_name)
176 1
	if(confint_level != 0.95){
177 0
		df.out = df.out %>% dplyr::select(-p_name)
178
	}
179 1
	df.out = data.frame(df.out)
180 1
	return(df.out)
181
}
182

183
#' Extract model output to dataframe
184
#'
185
#' Internal function, not called directly.
186
#'
187
#' @keywords internal
188
#' @rdname extract_fit
189
#' @method extract_fit coxph
190
#' @export
191

192
extract_fit.coxph = function(.data, explanatory_name="explanatory", estimate_name="HR",
193
														 estimate_suffix = "",
194
														 p_name = "p", ...){
195 1
	x = .data
196 1
	results = summary(x)$conf.int
197
	# Below is required to cope with difference in output when `frailty()` included
198 1
	explanatory = row.names(summary(x)$coefficients)[
199 1
		row.names(summary(x)$coefficients) %in% row.names(summary(x)$conf.int)
200
		]
201 1
	estimate = results[explanatory, 1]
202 1
	confint_L = results[explanatory, 3]
203 1
	confint_U = results[explanatory, 4]
204
	
205 1
	p = summary(x)$coefficients[explanatory,
206 1
															dim(summary(x)$coefficients)[2]]
207
	
208 1
	df.out = dplyr::tibble(explanatory, estimate, confint_L, confint_U, p)
209 1
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix), "L95", "U95", p_name)
210 1
	df.out = data.frame(df.out)
211 1
	return(df.out)
212
}
213

214
#' Extract model output to dataframe
215
#'
216
#' Internal function, not called directly.
217
#'
218
#' @keywords internal
219
#' @rdname extract_fit
220
#' @method extract_fit crr
221
#' @export
222

223
extract_fit.crr = function(.data, explanatory_name="explanatory", estimate_name="HR",
224
													 estimate_suffix = "",
225
													 p_name = "p", ...){
226 1
	x=.data
227 1
	results = summary(x)$conf.int
228 1
	explanatory = row.names(results)
229 1
	estimate = results[,1]
230 1
	confint_L = results[,3]
231 1
	confint_U = results[,4]
232 1
	p = summary(x)$coef[explanatory,
233 1
											max(dim(summary(x)$coef)[2])] # Hack to get p fe and re
234 1
	df.out = dplyr::tibble(explanatory, estimate, confint_L, confint_U, p)
235 1
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix), "L95", "U95", p_name)
236 1
	df.out = data.frame(df.out)
237 1
	return(df.out)
238
}
239

240

241

242
#' Extract model output to dataframe
243
#'
244
#' @keywords internal
245
#' @rdname extract_fit
246
#' @method extract_fit coxme
247
#' @export
248

249
extract_fit.coxme = function(.data, explanatory_name="explanatory", estimate_name="HR",
250
																estimate_suffix = "",  p_name = "p",
251
																confint_level = 0.95, ...){
252
	
253 0
	extract_coxme_table <- function(fit){
254 0
		beta <- fit$coefficients
255 0
		nvar <- length(beta)
256 0
		nfrail <- nrow(fit$variance) - nvar
257 0
		se <- sqrt(bdsmatrix::diag(fit$variance)[nfrail + 1:nvar])
258 0
		z <- round(beta/se, 2)
259 0
		p <- signif(1 - pchisq((beta/se)^2, 1), 2)
260 0
		table = data.frame(cbind(beta,se,z,p))
261 0
		return(table)
262
	}
263
	
264 0
	results = extract_coxme_table(.data)
265 0
	explanatory = row.names(results)
266 0
	estimate = exp(results$beta)
267 0
	confint_results = confint(.data, level = confint_level) %>% exp()
268 0
	confint_L = confint_results[, 1]
269 0
	confint_U = confint_results[, 2]
270 0
	p = results$p
271 0
	df.out = dplyr::tibble(explanatory, estimate, confint_L, confint_U, p)
272 0
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix), "L95", "U95", p_name)
273
	
274 0
	if(confint_level != 0.95){
275 0
		df.out = df.out %>% dplyr::select(-p_name)
276
	}
277 0
	df.out = data.frame(df.out)
278 0
	return(df.out)
279
}
280

281

282
#' Extract model output to dataframe
283
#'
284
#' @param X Design matrix from Stan modelling procedure.
285
#'
286
#' @keywords internal
287
#' @rdname extract_fit
288
#' @method extract_fit stanfit
289
#' @export
290

291
extract_fit.stanfit = function(.data, explanatory_name="explanatory", estimate_name="OR",
292
															 estimate_suffix = "",  p_name = "p", digits=c(2,2,3), X, ...){
293 0
	stanfit = .data
294 0
	pars = "beta"
295 0
	quantiles =  c(0.025, 0.50, 0.975)
296
	
297 0
	explanatory = dimnames(X)[[2]]
298 0
	results = rstan::summary(stanfit,
299 0
													 pars = pars,
300 0
													 probs = quantiles)$summary
301 0
	estimate = exp(results[, 1])
302 0
	confint_L = exp(results[, 4])
303 0
	confint_U = exp(results[, 6])
304
	
305
	# Determine a p-value based on two-sided examination of chains
306 0
	chains = rstan::extract(stanfit, pars=pars, permuted = TRUE, inc_warmup = FALSE,
307 0
													include = TRUE)
308 0
	p1.out = apply(chains[[1]], 2, function(x)mean(x<0))
309 0
	p2.out = apply(chains[[1]], 2, function(x)mean(x>0))
310 0
	p1.out = p1.out*2
311 0
	p2.out = p2.out*2
312 0
	p.out = ifelse(p1.out < 1, p1.out, p2.out)
313 0
	p = round(p.out, 3)
314
	
315 0
	df.out = data.frame(explanatory, estimate, confint_L, confint_U, p)
316 0
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix), "L95", "U95", p_name)
317 0
	return(df.out)
318
}
319

320
#' Condense model output dataframe for final tables
321
#'
322
#' Internal function, not called directly. Can only be used in conjunction with
323
#'   extract_fit
324
#'
325
#' @param .data Dataframe of four or five columns, must be this order, (1) explanatory
326
#'   variable names, (2) estimate, (3) confidence interval lower limit, (4)
327
#'   confidence interval upper limit, (5) p-value (optional).
328
#' @param explanatory_name Name for this column in output
329
#' @param estimate_name Name for this column in output
330
#' @param estimate_suffix Appeneded to estimate name
331
#' @param p_name Name given to p-value estimate
332
#' @param digits Number of digits to round to (1) estimate, (2) confidence
333
#'   interval limits, (3) p-value.
334
#' @param confint_sep String to separate confidence intervals, typically "-" or
335
#'   " to ".
336
#'
337
#' @keywords internal
338
#' @export
339

340
condense_fit = function(.data, explanatory_name="explanatory", estimate_name=NA,
341
												estimate_suffix = "", p_name = "p",
342
												digits=c(2,2,3), confint_sep = "-"){
343 1
	x = .data
344 1
	d.estimate = digits[1]
345 1
	d.confint = digits[2]
346 1
	d.p = digits[3]
347 1
	if(is.na(estimate_name)){
348 0
		estimate_name = names(x)[2]
349
	}
350
	
351 1
	explanatory = x[,1]
352 1
	estimate = round_tidy(x[,2], d.estimate)
353 1
	L_confint = round_tidy(x[,3], d.confint)
354 1
	U_confint = round_tidy(x[,4], d.confint)
355 1
	if(dim(x)[2] == 5){  #p-value not included when CI != 95%
356 1
		p = p_tidy(x[,5], d.p)
357
		
358 1
		df.out = data.frame(
359 1
			explanatory,
360 1
			paste0(
361 1
				estimate, " (",
362 1
				L_confint, confint_sep,
363 1
				U_confint, ", ",
364 1
				p_name, p, ")"))
365
	}else{
366 0
		df.out = data.frame(
367 0
			explanatory,
368 0
			paste0(
369 0
				estimate, " (",
370 0
				L_confint, confint_sep,
371 0
				U_confint, ")"))
372
	}
373 1
	colnames(df.out) = c(explanatory_name, paste0(estimate_name, estimate_suffix)
374
	)
375 1
	return(df.out)
376
}
377

378
#' Round values but keep trailing zeros
379
#'
380
#' e.g. for 3 decimal places I want 1.200, not 1.2.
381
#'
382
#' @param x Numeric vector of values to round
383
#' @param digits Integer of length one: value to round to.
384
#' @return Vector of strings.
385
#'
386
#' @export
387
#' 
388
#' @examples
389
#' round_tidy(0.01023, 3)
390

391
round_tidy = function(x, digits){
392 1
	sprintf.arg = paste0("%.", digits, "f")
393 1
	x.out = do.call(sprintf, list(sprintf.arg, x)) # keep trailing zeros
394 1
	return(x.out)
395
}
396

397
#' Round p-values but keep trailing zeros
398
#'
399
#' Internal function, not called directly
400
#'
401
#' e.g. for 3 decimal places I want 0.100, not 0.1. Note this function with
402
#' convert 0.000 to <0.001. All other values are prefixed with "=" by default
403
#'
404
#' @param x Numeric vector of values to round
405
#' @param digits Integer of length one: value to round to.
406
#' @param prefix Appended in front of values for use with \code{condense_fit}.
407
#' @return Vector of strings.
408
#'
409
#' @export
410

411
p_tidy = function(x, digits, prefix="="){
412 1
	x.out = paste0(prefix, round_tidy(x, digits))
413 1
	all_zeros = paste0(prefix, round_tidy(0, digits))
414 1
	less_than = paste0("<", format(10^-digits, scientific=FALSE))
415 1
	x.out[x.out == all_zeros] = less_than
416 1
	return(x.out)
417
}
418

419

420
#' Format n and percent as a character
421
#'
422
#' Internal, function, not called directly
423
#'
424
#' @param n Value
425
#' @param percent Value
426
#' @param digits Value
427
#'
428
#' @export
429
#'
430
format_n_percent = function(n, percent, digits) {
431 1
	percent = round_tidy(percent, digits)
432 1
	paste0(n, " (", percent, ")")
433
}
434

435
#' Remove intercept from model output
436
#'
437
#' Internal function, not called directly
438
#'
439
#' @param .data Numeric vector of values to round
440
#' @param intercept_name Name given to interept in model. Should never have to
441
#'   change from default.
442
#' @return Vector of strings.
443
#'
444
#' @keywords internal
445
#' @export
446
# Tried to do this with dplyr programming and failed miserably.
447
# quo() enquo() !! all a bit of a nightmare
448
# So let's square bracket away!
449
remove_intercept = function(.data, intercept_name = "(Intercept)"){
450 1
	.data %>% 
451 1
		dplyr::filter_at(.vars = 1, dplyr::any_vars(. != intercept_name))
452
}
453

454
#' Remove duplicate levels within \code{\link{summary_factorlist}}: \code{finalfit} helper function
455
#'
456
#' Not called directly.
457
#'
458
#' @param factorlist A factorlist intermediary.
459
#' @param na_to_missing Logical: convert \code{NA} to 'Missing' when \code{na_include=TRUE}.
460
#' @return Returns a \code{factorlist} dataframe.
461
#'
462
#' @keywords internal
463
#' @export
464

465
rm_duplicate_labels = function(factorlist, na_to_missing = TRUE){
466 1
	x = factorlist
467 1
	duplicate_rows = duplicated(x$label)
468 1
	x$label = as.character(x$label)
469 1
	x$label[duplicate_rows] = ""
470 1
	if (any(names(x) %in% "p")){
471 1
		x$p[duplicate_rows] = ""
472 1
		x$p[x$p == "0.000"] = "<0.001"
473
	}
474 1
	if (na_to_missing){
475 1
		x$levels = as.character(x$levels)
476 1
		x$levels[which(x$levels == "NA")] = "Missing"
477
	}
478 1
	return(x)
479
}
480

481
#' Make a label for the dependent variable
482
#'
483
#' Can be add dependent label to final results dataframe.
484
#'
485
#' @param df.out Dataframe (results table) to be altered.
486
#' @param .data Original dataframe.
487
#' @param dependent Character vector of length 1:  quoted name of depdendent
488
#'   variable. Can be continuous, a binary factor, or a survival object of form
489
#'   \code{Surv(time, status)}
490
#' @param prefix Prefix for dependent label
491
#' @param suffix Suffix for dependent label
492
#'
493
#' @return Returns the label for the dependent variable, if specified.
494
#' @export
495
#' @examples
496
#' library(dplyr)
497
#' explanatory = c("age.factor", "sex.factor", "obstruct.factor", "perfor.factor")
498
#' explanatory_multi = c("age.factor", "obstruct.factor")
499
#' random_effect = "hospital"
500
#' dependent = 'mort_5yr'
501
#'
502
#' # Separate tables
503
#' colon_s %>%
504
#' 	summary_factorlist(dependent, explanatory, fit_id=TRUE) -> example.summary
505
#'
506
#' colon_s %>%
507
#' 	glmuni(dependent, explanatory) %>%
508
#' 	fit2df(estimate_suffix=" (univariable)") -> example.univariable
509
#'
510
#' colon_s %>%
511
#' 	 glmmulti(dependent, explanatory) %>%
512
#' 	 fit2df(estimate_suffix=" (multivariable)") -> example.multivariable
513
#'
514
#' colon_s %>%
515
#'   glmmixed(dependent, explanatory, random_effect) %>%
516
#' 	 fit2df(estimate_suffix=" (multilevel") -> example.multilevel
517
#'
518
#' # Pipe together
519
#' example.summary %>%
520
#'   finalfit_merge(example.univariable) %>%
521
#'   finalfit_merge(example.multivariable) %>%
522
#' 	 finalfit_merge(example.multilevel) %>%
523
#' 	 select(-c(fit_id, index)) %>%
524
#' 	 dependent_label(colon_s, dependent) -> example.final
525
#'   example.final
526
dependent_label = function(df.out, .data, dependent, prefix = "Dependent: ", suffix=""){
527 1
	if(any(class(.data) %in% c("tbl_df", "tbl"))) .data = data.frame(.data)
528 1
	d_label = attr(.data[,which(names(.data) %in% dependent)], "label")
529
	
530 1
	if (is.null(d_label)){
531 1
		d_label = dependent
532
	} else {
533 1
		d_label = d_label
534
	}
535 1
	names(df.out)[which(names(df.out) == "label")] = paste0(prefix, d_label, suffix)
536 1
	names(df.out)[which(names(df.out) == "levels")] = " "
537
	
538 1
	return(df.out)
539
}
540

541
#' Label plot title
542
#'
543
#' Not called directly.
544
#'
545
#' @param .data Dataframe.
546
#' @param dependent Character vector of length 1: quoted name of dependent
547
#'   variable. Can be continuous, a binary factor, or a survival object of form
548
#'   \code{Surv(time, status)}
549
#' @param prefix Prefix for dependent label
550
#' @param suffix Suffix for dependent label
551
#'
552
#' @keywords internal
553
#' @export
554
plot_title = function(.data, dependent, dependent_label, prefix = "", suffix=""){
555 1
	if(any(class(.data) %in% c("tbl_df", "tbl"))) .data = data.frame(.data)
556 1
	if (is.null(dependent_label)){
557 1
		d_label = attr(.data[,which(names(.data) %in% dependent)], "label")
558 1
		if (is.null(d_label)){
559 1
			d_label = dependent
560
		} else {
561 1
			d_label = d_label
562
		}
563
	} else {
564 1
		d_label = dependent_label
565
	}
566 1
	out = paste0(prefix, d_label, suffix)
567 1
	return(out)
568
}
569

570

571
#' Extract variable labels and names
572
#'
573
#' @param .data Data frame.
574
#'
575
#' @return A data frame with three columns: first (vname), variabe names; second
576
#'   (vlabel), variables labels; third (vfill), variable labels and when null
577
#'   variable names.
578
#' @export
579
#' @keywords internal
580
#'
581
#' @examples
582
#' colon_s %>%
583
#'   extract_labels()
584
extract_labels = function(.data){
585
	# Struggled to make this work and look elegant!
586
	# Works but surely there is a better way.
587 1
	df.out = lapply(.data, function(x) {
588 1
		vlabel = attr(x, "label")
589 1
		list(vlabel = vlabel)}) %>%
590 1
		do.call(rbind, .)
591 1
	df.out = data.frame(vname = rownames(df.out), vlabel = unlist(as.character(df.out)),
592 1
											stringsAsFactors = FALSE)
593 1
	df.out$vfill = df.out$vlabel
594 1
	df.out$vfill[df.out$vlabel == "NULL"] = df.out$vname[df.out$vlabel=="NULL"]
595 1
	return(df.out)
596
}
597

598

599
#' Help making stratified summary_factorlist tables
600
#'
601
#' @param df.out Output from \code{summary_factorlist}
602
#' @param .data Original data frame used for \code{summary_factorlist}.
603
#'
604
#' @export
605
#'
606
#' @examples
607
#' library(dplyr)
608
#' explanatory = c("age.factor", "sex.factor")
609
#' dependent = "perfor.factor"
610
#'
611
#' # Pick option below
612
#' split = "rx.factor"
613
#' split = c("rx.factor", "node4.factor")
614
#'
615
#' # Piped function to generate stratified crosstabs table
616
#' colon_s %>%
617
#'   group_by(!!! syms(split)) %>% #Looks awkward, but avoids unquoted var names
618
#'   group_modify(~ summary_factorlist(.x, dependent, explanatory)) %>%
619
#'   ff_stratify_helper(colon_s)
620
ff_stratify_helper <- function(df.out, .data){
621
	# Get df labels
622 0
	lookup = extract_variable_label(.data)
623
	
624
	# Relabel label column
625 0
	df.out$label = df.out$label %>% 
626 0
		purrr::map_chr( ~ lookup[.x])
627
	
628
	# Get groups
629 0
	.cols = attributes(df.out)$groups %>% 
630 0
		names()
631 0
	.cols = .cols[!.cols == ".rows"]
632
	
633
	# Relabel column headings with labels. 
634 0
	names(df.out)[names(df.out) %in% .cols] = 
635 0
		names(df.out)[names(df.out) %in% .cols] %>% 
636 0
		purrr::map_chr( ~ lookup[.x])
637
	
638
	# Remove NAs for neatness
639 0
	df.out = df.out %>%
640 0
		dplyr::ungroup() %>%
641 0
		dplyr::mutate_if(is.factor, as.character) %>% 
642 0
		as.data.frame() %>% 
643 0
		dplyr::mutate_all(.,
644 0
											~ ifelse(is.na(.), "", .)
645
		)
646
	
647 0
	class(df.out) = c("data.frame.ff", class(df.out))
648 0
	return(df.out)
649
}
650

651
#' Generate formula as character string
652
#'
653
#' Useful when passing finalfit dependent and explanatory lists to base R
654
#' functions
655
#'
656
#' @param dependent Optional character vector: name(s) of depdendent
657
#'   variable(s).
658
#' @param explanatory Optional character vector: name(s) of explanatory
659
#'   variable(s).
660
#' @param random_effect Optional character vector: name(s) of random effect
661
#'   variable(s).
662
#'
663
#' @return Character vector
664
#' @export
665
#'
666
#' @examples
667
#' explanatory = c("age", "nodes", "sex.factor", "obstruct.factor", "perfor.factor")
668
#' dependent = "mort_5yr"
669
#' ff_formula(dependent, explanatory)
670
#' 
671
#' explanatory = c("age", "nodes", "sex.factor", "obstruct.factor", "perfor.factor")
672
#' dependent = "mort_5yr"
673
#' random_effect = "(age.factor | hospital)"
674
#' ff_formula(dependent, explanatory)
675
ff_formula = function(dependent, explanatory, random_effect = NULL){
676 1
	if(!is.null(random_effect)){
677 0
		if(!grepl("\\|", random_effect)) random_effect = paste0("(1 | ", random_effect, ")")
678 0
		out = paste0(dependent, "~", paste(explanatory, collapse="+"), " + ", random_effect)
679
	} else {
680 1
		out = paste(dependent, "~", paste(explanatory, collapse = "+"))	
681
	}
682 1
	return(out)
683
}
684
#' @rdname ff_formula
685
#' @export
686
finalfit_formula <- ff_formula
687

688

689
#' Determine type/class of a variable
690
#'
691
#' @param .var A vector, data frame column, or equivalent. 
692
#'
693
#' @return One of "factor", "character", "numeric", "logical", "date". 
694
#' @export
695
#' @keywords internal
696
#'
697
#' @examples
698
#' var_d = as.Date("12.03.18", "%d.%m.%y")
699
#' var_f = factor(c("yes", "no"))
700
#' var_c = c("yes", "no")
701
#' var_n = 1:10
702
#' var_l = as.logical(c("true", "false"))
703
#' variable_type(var_d)
704
#' variable_type(var_f)
705
#' variable_type(var_c)
706
#' variable_type(var_n)
707
#' variable_type(var_l)
708
variable_type <- function(.var){
709 1
	if(is.factor(.var)){
710 1
		out = "factor"
711 1
	}else if(is.character(.var)){
712 1
		out = "character"
713 1
	}else if(is.numeric(.var)){
714 1
		out = "numeric"
715 1
	}else if(is.logical(.var)){
716 1
		out = "logical"
717 1
	}else if(inherits(.var, 'Date')){
718 1
		out = "date"
719
	}
720 1
	return(out)
721
}
722

723

724
#' Test character describes survival object
725
#'
726
#' @param .name Character string to test
727
#'
728
#' @return Logical
729
#' @export
730
#' @keywords internal
731
#'
732
#' @examples
733
#' var_s = "Surv(mort, time)"
734
#' is.survival(var_s) #TRUE
735
#' var_s = "Sur(mort, time)"
736
#' is.survival(var_s) #FALSE
737
is.survival <- function(.name){
738 1
	grepl("^Surv[(].*[)]", .name)
739
}
740

741

742
# Specify global variables
743
globalVariables(c("L95", "U95", "fit_id", "Total", "dependent",
744
									"OR", "HR", "Coefficient", ".", ".id", "var", "value",
745
									":=", "Mean", "SD", "Median", "Q3", "Q1", "IQR", "Formatted", 
746
									"w", "Freq", "g", "total_prop", "Prop", "index_total", "vname", "Combined",
747
									"2.5 %", "97.5 %", "p.value", "estimate", "index", "n", "missing_n", "var_type",
748
									"missing_percent", "var1", "var2", "keep", "label", "rowid", "term",
749
									"confint_L", "confint_U", "explanatory", "p"))
750

751

752
# Workaround ::: as summary.formula not (yet) exported from Hmisc
753
`%:::%` = function (pkg, name){
754 0
	pkg <- as.character(substitute(pkg))
755 0
	name <- as.character(substitute(name))
756 0
	get(name, envir = asNamespace(pkg), inherits = FALSE)
757
}
758

759

760
#' Call to mice:::summary.mipo
761
#'
762
#' Not called directly.
763
#'
764
#' @keywords internal
765
#' @import mice
766
summary_mipo = 'mice' %:::% 'summary.mipo'
767

768

769
#' Errors: colon in factor levels
770
#'
771
#' @param .data Data frame.
772
#'
773
#' @return Logical
774
#' @keywords internal
775
error_colon_fct_levels <- function(.data){
776 1
	.data %>% 
777 1
		purrr::map(~ levels(.x)) %>%
778 1
		purrr::map(~ grepl(":", .x)) %>% 
779 1
		purrr::map(~ any(.x)) %>% 
780 1
		unlist() %>% 
781 1
		any()
782
}
783

784
#' Deprecated catTest from Hmisc for reverse dependencies
785
#'
786
#' @param . Null
787
#' @keywords internal
788
#' @export
789
catTestfisher = function(.){}
790

Read our documentation on viewing source code .

Loading