-
Notifications
You must be signed in to change notification settings - Fork 0
/
tidy_generics.R
90 lines (78 loc) · 3.51 KB
/
tidy_generics.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
#' @importFrom generics tidy
#' @export
generics::tidy
#' @importFrom generics glance
#' @export
generics::glance
#' @title Tidy a CBEAout object
#' @description This function takes in a CBEA type object and collects all values across all
#' sets and samples that were evaluated.
#' @param x A `CBEAout` object.
#' @param ... Unused, included for generic consistency only.
#' @return A tidy [tibble::tibble()] summarizing scores per sample per set.
#'
#' @examples
#' # load the data
#' data(hmp_gingival)
#' mod <- cbea(hmp_gingival$data, hmp_gingival$set, abund_values = "16SrRNA",
#' output = "sig", distr = "norm", adj = FALSE, n_perm = 5, parametric = TRUE)
#' tidy(mod)
#' @importFrom tibble as_tibble add_column
#' @export
tidy.CBEAout <- function(x, ...){
output <- as_tibble(x$R)
colnames(output) <- gsub(" ", "_", colnames(output))
output <- add_column(output, sample_ids = x$call_param$sample_ids, .before = 1)
return(output)
}
#' @title Glance at \code{CBEAout} object
#' @description This function cleans up all diagnostics of the \code{cbea} method
#' (from the \code{CBEAout} object) into a nice [tibble::tibble()]
#' @param x An object of type \code{CBEAout}
#' @param statistic What type of diagnostic to return. Users can choose to return
#' \code{fit_diagnostic} which returns goodness of fit statistics for the
#' different fitted distributions (e.g. log likelihoods) while \code{fit_comparison}
#' returns comparisons across different distributions and raw values (and data) across the
#' 4 l-moments.
#' @param ... Unused, kept for consistency with generics
#' @return A [tibble::tibble()] summarizing diagnostic fits per set (as row)
#' @importFrom tibble tibble as_tibble rownames_to_column
#' @importFrom tidyr pivot_longer unnest nest
#' @importFrom dplyr mutate select rename left_join everything
#' @importFrom magrittr %>%
#' @examples
#' # load the data
#' data(hmp_gingival)
#' mod <- cbea(hmp_gingival$data, hmp_gingival$set, abund_values = "16SrRNA",
#' output = "sig", distr = "norm", adj = FALSE, n_perm = 5, parametric = TRUE)
#' glance(mod, "fit_diagnostic")
#' @export
glance.CBEAout <- function(x, statistic, ...){
# Assign in R CMD CHECK
fit_comparison <- NULL
value <- NULL
statistic <- match.arg(statistic, c("fit_diagnostic", "fit_comparison"))
names(x$diagnostic) <- gsub(" ", "_", names(x$diagnostic))
names(x$parameters) <- gsub(" ", "_", names(x$parameters))
names(x$fit_comparison) <- gsub(" ", "_", names(x$fit_comparison))
parameters <- tibble(set_ids = names(x$parameters),
final_param = x$parameters)
if (statistic == "fit_diagnostic"){
diagnostic <- as_tibble(x$diagnostic) %>%
pivot_longer(everything()) %>%
mutate(type = names(value)) %>%
mutate(value = lapply(value, as_tibble)) %>%
unnest(value) %>%
rename("set_ids" = "name")
output <- left_join(parameters, diagnostic, by = "set_ids")
} else if (statistic == "fit_comparison"){
fit_parameters <- tibble(set_ids = names(x$fit_comparison),
fit_comparison = lapply(x$fit_comparison, function(x) {
as.data.frame(x) %>%
rownames_to_column(var = "distr") %>%
as_tibble()
})) %>% unnest(fit_comparison)
output <- left_join(parameters, fit_parameters, by = "set_ids")
}
return(output)
}