From cfa89d412514273c3a35370919752bf1a32049bc Mon Sep 17 00:00:00 2001 From: GuyliannEngels Date: Fri, 21 Jun 2024 14:52:35 +0200 Subject: [PATCH 01/22] reaplce RSE by sigma --- R/tabularise.glm.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tabularise.glm.R b/R/tabularise.glm.R index 60eaee9..bfcc4a5 100644 --- a/R/tabularise.glm.R +++ b/R/tabularise.glm.R @@ -509,7 +509,7 @@ infos_en.glm <- list( conf.high = "Upper bound (CI)", std.error = "Standard Error", t.value = "*t* value", - sigma = "RSE", + sigma = "Sigma",# The misnomer “Residual standard error” r.squared = "R^2^", adj.r.squared = "Adj.R^2^", AIC = "AIC", @@ -559,7 +559,7 @@ infos_fr.glm <- list( std.error = "Ecart type", t.value = "Valeur de *t*", p.value = "Valeur de *p*", - sigma = "RSE", + sigma = "Sigma", # The misnomer “Residual standard error” r.squared = "R^2^", adj.r.squared = "R^2^ ajust\u00e9", deviance = "D\u00e9viance", From 580fe1f0fba05efba12d7ed8be9086846eb6f8c0 Mon Sep 17 00:00:00 2001 From: GuyliannEngels Date: Fri, 9 Aug 2024 17:34:45 +0200 Subject: [PATCH 02/22] adding lm_() function which is similar to lm() --- DESCRIPTION | 4 +- NAMESPACE | 2 + NEWS.md | 6 + R/lm_.R | 63 ++++ R/tabularise.lm.R | 517 +++++++++++++++++---------- R/utils.R | 1 + man/lm_.Rd | 28 ++ man/modelit-package.Rd | 19 + man/summary.lm_.Rd | 22 ++ man/tabularise_default.summary.lm.Rd | 3 + 10 files changed, 465 insertions(+), 200 deletions(-) create mode 100644 R/lm_.R create mode 100644 man/lm_.Rd create mode 100644 man/summary.lm_.Rd diff --git a/DESCRIPTION b/DESCRIPTION index f21da14..7f1876e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: modelit Type: Package -Version: 1.4.6 +Version: 1.4.7 Title: Statistical Models for 'SciViews::R' Description: Create and use statistical models (linear, general, nonlinear...) with extensions to support rich-formatted tables, equations and plots for the @@ -48,7 +48,7 @@ License: MIT + file LICENSE URL: https://github.com/SciViews/modelit, https://www.sciviews.org/modelit/ BugReports: https://github.com/SciViews/modelit/issues Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 VignetteBuilder: knitr Encoding: UTF-8 Language: en-US diff --git a/NAMESPACE b/NAMESPACE index eb80960..f01ef5a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,7 @@ S3method(nobs,model_fit) S3method(plot,model_fit) S3method(residuals,model_fit) S3method(rstandard,model_fit) +S3method(summary,lm_) S3method(summary,model_fit) S3method(tabularise_coef,glm) S3method(tabularise_coef,lm) @@ -54,6 +55,7 @@ export(autoplot.lm) export(autoplot.nls) export(fit_model) export(geom_ref_line) +export(lm_) export(mae) export(qae) export(rmse) diff --git a/NEWS.md b/NEWS.md index 777562f..391cdff 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# modelit 1.4.7 + +- Refactor all tabularise\_\*\*\* functions for lm object like tabularise_glance.lm(), tabularise_default.lm(), tabularise_tidy.lm(),... + +- Adding the lm\_() function which is similar to lm() but adds useful attributes like labels and units of the variables used. + # modelit 1.4.6 - Bug correction in `tabularise()` for **lm** and **glm** object. Managing a conflict between auto.labs= and equation=. diff --git a/R/lm_.R b/R/lm_.R new file mode 100644 index 0000000..0ab153a --- /dev/null +++ b/R/lm_.R @@ -0,0 +1,63 @@ +#' Fitting Linear Models by SciViews +#' +#' @description +#'The lm_() function is used like the lm() function from the {stats} package. It allows adding additional elements such as labels and units. +#' +#' @param data A data frame +#' @param formula An object of class formula +#' @param ... All the arguments of the lm() function +#' +#' @return an lm_ object if attribute additions have been made. Otherwise, the object will be of class lm +#' @export +#' +#' @examples +#' data(iris) +#' res <- lm_(iris, formula = Petal.Length ~ Sepal.Length + Species) +#' res +#' class(res) +#' +lm_ <- function(data, formula, ...) { + res <- stats::lm(data = data, formula = formula,...) + + # Extract labels ---- + labs_auto <- tabularise:::.labels(data) + vars <- rownames(attr(res$terms, "factors")) + labs_auto <- labs_auto[names(labs_auto) %in% vars] + attr(res, "labs") <- labs_auto + + # Adding a new class if attribute additions have been made + if (!is.null(attr(res, "labs"))) { + class(res) <- c("lm_", class(res)) + } + + res +} + +#' Summarizing Linear Model Fits by SciViews +#' +#' @description +#' summary method for class lm_ +#' +#' @param object an object of class lm_ +#' @param ... additional argument to stats:::summary.lm() +#' +#' @return an object of class summary.lm_ object, similar to summary.lm +#' @export +#' +#' @examples +#' #TODO +summary.lm_ <- function(object, ...) { + res <- stats::summary.lm(object = object, ...) + + if(!is.null(attr(object, "labs"))) { + attr(res, "labs") <- attr(object, "labs") + } + + # Adding a new class if attribute additions have been made + if (is.null(attr(res, "labs"))) { + class(res) <- c("summary.lm_", class(res), "lm") + } + res +} + + diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index d3b28d2..e58b10d 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -37,9 +37,9 @@ #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$coef(iris_lm) tabularise_coef.lm <- function(data, header = TRUE, title = NULL, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", "en"), ..., kind = "ft", + env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -53,57 +53,16 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL, info_lang <- .infos_lang.lm(lang = lang) # Extract coefficients - co <- coef(data) - co <- data.frame(term = names(co), estimate = co) - # co <- as.data.frame(rbind(coef(data))) - - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) - } - - # Create the flextable object - ft <- flextable(co) |> - colformat_sci() - ft <- .header_labels(ft, info_lang = info_lang) - - # Header and equation - if (isTRUE(equation)) { - if (!is.null(labs)) { - equa <- equation(data, swap_var_names = labs, ...) - } else { - equa <- equation(data, auto.labs = FALSE, ...) - } - - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equa) - } else { - equa <- NULL - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equation) - } + df <- coef(data) + df <- data.frame(term = names(df), estimate = df) - if (isTRUE(auto.labs) && any(co$term %in% "(Intercept)")) { - ft <- mk_par(ft, i = "(Intercept)", j = 1, part = "body", - value = as_paragraph(info_lang[["(Intercept)"]])) - } - - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% co$term] - - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = "term", - value = para_md(labs_red[i]), part = "body") - } - - if (isTRUE(equation) & !is.null(equa)) { - params <- .params_equa(equa,...) - if (length(params) == length(co$term)) - ft <- mk_par(ft, j = "term", value = para_md(params), part = "body") - } + df <- extract_infos(df, + show.signif.stars = FALSE, info_lang = info_lang, + auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, + equation = equation, title = title) - autofit(ft, part = c("header", "body")) + # formatted table ---- + formate_table(df, kind = kind, header = header) } #' Create a rich-formatted table from an lm object @@ -174,10 +133,10 @@ tabularise_default.lm <- function(data, ..., kind = "ft", env = parent.frame()) #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$tidy(iris_lm) tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - conf.int = FALSE, conf.level = 0.95, lang = getOption("data.io_lang", "en"), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", - env = parent.frame()) { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + conf.int = FALSE, conf.level = 0.95, lang = getOption("data.io_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", + env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -190,78 +149,23 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, # Choose the language info_lang <- .infos_lang.lm(lang = lang) - # Extract labels off data or origdata - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) - } - - # Turn an object into a tidy tibble - data_t <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, + # Extract coefficients with broom::tidy() ---- + df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, conf.level = conf.level)) - rownames(data_t) <- data_t$term + rownames(df) <- df$term if (isTRUE(conf.int)) { - data_t <- data_t[, c("term", "estimate", "conf.low", "conf.high", + df <- df[, c("term", "estimate", "conf.low", "conf.high", "std.error", "statistic", "p.value")] } - # Use flextable - if (isTRUE(show.signif.stars)) { - ft <- flextable(data_t, col_keys = c(names(data_t), "signif")) - } else { - ft <- flextable(data_t) - } - ft <- colformat_sci(ft) - ft <- colformat_sci(ft, j = "p.value", lod = 2e-16) - - # Rename headers labels - ft <- .header_labels(ft, info_lang = info_lang) - - # Headers - if (isTRUE(equation)) { - if (!is.null(labs)) { - equa <- equation(data, swap_var_names = labs, ...) - } else { - equa <- equation(data, auto.labs = FALSE, ...) - } - - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equa) - } else { - equa <- NULL - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equation) - } - - if (isTRUE(auto.labs) && any(data_t$term %in% "(Intercept)")) { - ft <- mk_par(ft, i = "(Intercept)", j = 1, part = "body", - value = as_paragraph(info_lang[["(Intercept)"]])) - } - - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% data_t$term] - - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = 1, - value = para_md(labs_red[i]), part = "body") - } - - if (isTRUE(equation) && !is.null(equa)) { - params <- .params_equa(equa) - if (length(params) == length(data_t$term)) - ft <- mk_par(ft, j = "term", value = para_md(params), part = "body") - } - - # Add information on the p.value - if (ncol_keys(ft) > ncol(data_t)) - ft <- .add_signif_stars(ft, j = "signif") + df <- extract_infos(df, + show.signif.stars = show.signif.stars, info_lang = info_lang, + auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, + equation = equation, title = title) - ft <- autofit(ft, part = c("header", "body")) - if (isTRUE(show.signif.stars)) - ft <- width(ft, j = "signif", width = 0.4) - ft + # formatted table ---- + formate_table(df, kind = kind, header = header) } #' Glance version of the lm object into a flextable object @@ -300,10 +204,9 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$glance(iris_lm) tabularise_glance.lm <- function(data, header = TRUE, title = NULL, - equation = TRUE, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { - + equation = TRUE, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", "en"), ..., kind = "ft", + env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... @@ -311,60 +214,23 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL, if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } - # Choose the language info_lang <- .infos_lang.lm(lang = lang) - # Extract labels of data or origdata - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) - } - - # Turn an object into a tidy tibble - data_t <- as.data.frame(broom::glance(x = data)) - rownames(data_t) <- data_t$term - - # Use flextable - ft <- flextable(data_t) - ft <- colformat_sci(ft) - #ft <- colformat_sci(ft, j = "p.value", lod = 2e-16) - - # Rename headers labels - ft <- .header_labels(ft, info_lang = info_lang) - - # Headers - if (isTRUE(equation)) { - if (!is.null(labs)) { - equa <- equation(data, swap_var_names = labs, ...) - } else { - equa <- equation(data, auto.labs = FALSE, ...) - } - - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - equation = equa) - } else { - equa <- NULL - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - equation = equation) - } - - if (isTRUE(auto.labs) && any(data_t$term %in% "(Intercept)")) - ft <- mk_par(ft, i = "(Intercept)", j = 1, part = "body", - value = as_paragraph(info_lang[["(Intercept)"]])) + # Extract coefficients with broom::tidy() ---- + df <- as.data.frame(broom::glance(x = data)) + rownames(df) <- df$term - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% data_t$term] - - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = 1, - value = para_md(labs_red[i]), part = "body") - } + df <- extract_infos(df, + show.signif.stars = FALSE, info_lang = info_lang, + auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, + equation = equation, title = title) - autofit(ft, part = c("header", "body")) + # formatted table ---- + formate_table(df, kind = kind, header = header) } + #' Create a rich-formatted table using the table of coefficients of the summary.lm object #' #' @param data A **summary.lm** object @@ -396,6 +262,7 @@ tabularise_coef.summary.lm <- function(data, ..., kind = "ft", #' Create a rich-formatted table from an summary.lm object #' #' @param data A **summary.lm** object +#' @param header If `TRUE` (by default), add a header to the table #' @param footer If `TRUE` (by default), add a footer to the table #' @param lang The natural language to use. The default value can be set with, #' e.g., `options(data.io_lang = "fr")` for French. @@ -415,39 +282,19 @@ tabularise_coef.summary.lm <- function(data, ..., kind = "ft", #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' iris_lm_sum <- summary(iris_lm) #' tabularise::tabularise(iris_lm_sum) -tabularise_default.summary.lm <- function(data, footer = TRUE, +tabularise_default.summary.lm <- function(data, header = TRUE, footer = TRUE, lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame()) { - ft <- tabularise_coef.summary.lm(data = data, lang = lang, ..., env = env) + + df <- tabularise_coef.summary.lm(data = data, lang = lang, header = header , + kind = "df", ..., env = env) if (isTRUE(footer)) { info_lang <- .infos_lang.lm(lang = lang) - - digits <- max(3L, getOption("digits") - 3L) - footer <- info_lang[["footer"]] - vals <- c( - paste0(footer[["resid.range"]], " [", - format(signif(min(data$residuals, na.rm = TRUE), digits)), ", ", - format(signif(max(data$residuals, na.rm = TRUE), digits)), "] "), - paste(footer[["resid.std.err"]], - format(signif(data$sigma, digits)), footer[["on"]], - max(data$df), footer[["df2"]]), - paste(footer[["R2"]], format(signif(data$r.squared, digits)), " - ", - footer[["adj.R2"]], format(signif(data$adj.r.squared, digits))), - paste(footer[["f.stat"]], format(signif(data$fstatistic[1L], digits)), - footer[["on"]], format(signif(data$fstatistic[2L], digits)), - footer[["and"]], format(signif(data$fstatistic[3L], digits)), - footer[["df"]], " - ", footer[["p"]], - format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], - data$fstatistic[3L], lower.tail = FALSE))) - # TODO: nicely format this last p value! - ) - ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) - ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", - part = "footer") + df <- extract_footer(df, data = data, info_lang = info_lang) } - autofit(ft, part = c("header", "body")) + formate_table(df, kind= kind, header = header) } # Choose the lang and the infos_lang @@ -485,6 +332,7 @@ infos_en.lm <- list( df = "Model df", df.residual = "Residuals df", nobs = "N", + signif = "", "(Intercept)" = "Intercept"), "(Intercept)" = "Intercept", "summary" = "Model summary", @@ -523,6 +371,7 @@ infos_fr.lm <- list( df = "Ddl mod\u00e8le", df.residual = "Ddl r\u00e9sidus", nobs = "N", + signif = "", "(Intercept)" = "Ordonn\u00e9e \u00e0 l'origine" ), "(Intercept)" = "Ordonn\u00e9e \u00e0 l'origine", @@ -541,3 +390,275 @@ infos_fr.lm <- list( "p" = "valeur de *p* :" ) ) + + +# A list of functions ------ + +extract_significance_stars <- function(x, show.signif.stars) { + if (isTRUE(show.signif.stars)) { + x[["signif"]] <- .pvalue_format(x[["p.value"]]) + attr(x, "signif.stars") <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" + attr(x, "show.signif.stars") <- show.signif.stars + } + return(x) +} + +extract_column_names <- function(x, info_lang) { + hlabs <- info_lang[["labs"]] + attr(x, "col.names") <- hlabs[names(hlabs) %in% names(x)] + return(x) +} + +replace_intercept_term <- function(x, info_lang) { + if (any(x$term %in% "(Intercept)")) { + x$term[x$term == "(Intercept)"] <- info_lang[["(Intercept)"]] + } + return(x) +} + +extract_labels <- function(x, auto.labs, data, origdata, labs) { + if (isTRUE(auto.labs)) { + labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) + } else { + labs <- tabularise:::.labels2(x = NULL, labs = labs) + } + attr(x, "labs") <- labs + return(x) +} + +extract_equation <- function(x, equation, data, labs, ...) { + if (isTRUE(equation)) { + if (!is.null(labs)) { + equa <- equation(data, swap_var_names = labs, ...) + } else { + equa <- equation(data, auto.labs = FALSE, ...) + } + attr(x, "equation") <- equa + attr(x, "equation_params") <- .params_equa(equa) + } + + if (is.character(equation)) { + attr(x, "equation") <- equation + } + + return(x) +} + +extract_title <- function(x, title, info_lang) { + if (isTRUE(title)) { + attr(x, "title") <- info_lang[["header"]] + } + + if (is.character(title)) { + attr(x, "title") <- title + } + + return(x) +} + +extract_footer <- function(x, data, info_lang) { + digits <- max(3L, getOption("digits") - 3L) + footer <- info_lang[["footer"]] + vals <- c( + paste0(footer[["resid.range"]], " [", + format(signif(min(data$residuals, na.rm = TRUE), digits)), ", ", + format(signif(max(data$residuals, na.rm = TRUE), digits)), "] "), + paste(footer[["resid.std.err"]], + format(signif(data$sigma, digits)), footer[["on"]], + max(data$df), footer[["df2"]]), + paste(footer[["R2"]], format(signif(data$r.squared, digits)), " - ", + footer[["adj.R2"]], format(signif(data$adj.r.squared, digits))), + paste(footer[["f.stat"]], format(signif(data$fstatistic[1L], digits)), + footer[["on"]], format(signif(data$fstatistic[2L], digits)), + footer[["and"]], format(signif(data$fstatistic[3L], digits)), + footer[["df"]], " - ", footer[["p"]], + format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], + data$fstatistic[3L], lower.tail = FALSE))) + # TODO: nicely format this last p value! + ) + attr(x, "footer") <- vals + return(x) +} + +extract_infos <- function(x, show.signif.stars, info_lang, auto.labs, data, origdata, labs, equation, title) { + # stars ---- + x <- extract_significance_stars(x, show.signif.stars = show.signif.stars) + + # colnames ----- + x <- extract_column_names(x, info_lang = info_lang) + + # specific case : (Intercept) -> Intercept ---- + x <- replace_intercept_term(x, info_lang = info_lang) + + # labels ---- + x <- extract_labels(x = x, auto.labs = auto.labs, + data = data, origdata = origdata, labs = labs) + + # equation ---- + x <- extract_equation(x, equation = equation, data = data, + labs = attr(x, "labs")) + + # title ---- + x <- extract_title(x, title = title, info_lang = info_lang) + + return(x) +} + +.add_signif <- function(x, signif) { + + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_signif_stars()"))} + + ft <- x + s <- signif + + ft <- add_footer_lines(ft, + values = s) + align(ft, i = 1, align = "right", part = "footer") +} + +.extract_labels <- function(x, info_lang) { + hlabs <- info_lang[["labs"]] + hlabs[names(hlabs) %in% names(x)] +} + +.add_header2 <- function(x, title, equation) { + + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_header2()")) } + + ft <- x + + if (is.character(equation)) { + ft <- add_header_lines(ft, + values = as_paragraph(as_equation(equation))) + ft <- align(ft, i = 1, align = "right", part = "header") + } + + if (is.character(title)) { + ft <- add_header_lines(ft, + values = as_paragraph(title)) + ft <- align(ft, i = 1, align = "right", part = "header") + } + + h_nrow <- nrow_part(ft, part = "header") + + if (h_nrow > 2) { + ft |> + border_inner_h(border = officer::fp_border(width = 0), part = "header") |> + hline(i = nrow_part(ft, "header") - 1, + border = officer::fp_border(width = 1.5, color = "#666666"), + part = "header") -> + ft + } + + ft +} + +.add_colnames <- function(x, labs) { + + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_colnames()")) } + + ft <- x + + for (i in seq_along(labs)) + ft <- mk_par(ft, i = 1, j = names(labs)[i], + value = para_md(labs[i]), part = "header") + + ft +} + +.add_labs <- function(x, labs) { + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_colnames()")) } + + ft <- x + + labs_red <- labs[names(labs) %in%ft$body$dataset$term] + + for (i in seq_along(labs_red)) + ft <- mk_par(ft, i = names(labs_red)[i], j = "term", + value = para_md(labs_red[i]), part = "body") + + ft +} + +.add_params <- function(x, params) { + + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_colnames()")) } + + ft <- x + + if (length(params) == length(ft$body$dataset$term)) + ft <- mk_par(ft, j = "term", value = para_md(params), part = "body") + + ft +} + +create_flextable <- function(x, header = TRUE) { + ft <- flextable(x) |> + colformat_sci() + + if ("p.value" %in% colnames(x)) { + ft <- ft |> + colformat_sci(j = "p.value", lod = 2e-16) + } + + if (!is.null(attr(x, "col.names"))) { + ft <- .add_colnames(ft, attr(x, "col.names")) + } + + if (!is.null(attr(x, "labs"))) { + ft <- .add_labs(ft, attr(x, "labs")) + } + + if (!is.null(attr(x,"equation")) & !is.null(attr(x, "equation_params"))) { + ft <- .add_params(ft, attr(x, "equation_params")) + } + + if (isTRUE(header)) { + ft <- .add_header2(ft, title = attr(x, "title"), equation = attr(x, "equation")) + } + + if (!is.null(attr(x,"signif.stars"))) { + ft <- .add_signif(ft, attr(x, "signif.stars")) + } + + if (!is.null(attr(x, "footer"))) { + vals <- attr(x, "footer") + ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) + ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", + part = "footer") + } + + ft <- autofit(ft, part = c("header", "body")) + + sss <- attr(x,"show.signif.stars") + if (!is.null(sss) && isTRUE(sss)) { + ft <- width(ft, j = "signif", width = 0.4) + } + + return(ft) +} + +formate_table <- function(df, kind, header) { + switch(kind, + df = {df}, + tt = { + stop("Not implemented yet") + }, + ft = { + create_flextable(df, header = header) + }, + gt = { + stop("Not implemented yet") + } + ) +} diff --git a/R/utils.R b/R/utils.R index 019f250..ea5f8a1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,6 +8,7 @@ z } + # Add pvalue signif .add_signif_stars <- function(x, i = NULL, j = NULL, part = "body", align = "right", ...) { diff --git a/man/lm_.Rd b/man/lm_.Rd new file mode 100644 index 0000000..f2fd8e7 --- /dev/null +++ b/man/lm_.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lm_.R +\name{lm_} +\alias{lm_} +\title{Fitting Linear Models by SciViews} +\usage{ +lm_(data, formula, ...) +} +\arguments{ +\item{data}{A data frame} + +\item{formula}{An object of class formula} + +\item{...}{All the arguments of the lm() function} +} +\value{ +an lm_ object if attribute additions have been made. Otherwise, the object will be of class lm +} +\description{ +The lm_() function is used like the lm() function from the {stats} package. It allows adding additional elements such as labels and units. +} +\examples{ +data(iris) +res <- lm_(iris, formula = Petal.Length ~ Sepal.Length + Species) +res +class(res) + +} diff --git a/man/modelit-package.Rd b/man/modelit-package.Rd index 2dd2bcc..0bfa6c9 100644 --- a/man/modelit-package.Rd +++ b/man/modelit-package.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/modelit-package.R \docType{package} \name{modelit-package} +\alias{modelit} \alias{modelit-package} \title{Statistical Models for 'SciViews::R'} \description{ @@ -21,3 +22,21 @@ can be plotted using \code{stat_function()}. } } +\seealso{ +Useful links: +\itemize{ + \item \url{https://github.com/SciViews/modelit} + \item \url{https://www.sciviews.org/modelit/} + \item Report bugs at \url{https://github.com/SciViews/modelit/issues} +} + +} +\author{ +\strong{Maintainer}: Philippe Grosjean \email{phgrosjean@sciviews.org} (\href{https://orcid.org/0000-0002-2694-9471}{ORCID}) + +Authors: +\itemize{ + \item Guyliann Engels \email{guyliann.engels@umons.ac.be} (\href{https://orcid.org/0000-0001-9514-1014}{ORCID}) +} + +} diff --git a/man/summary.lm_.Rd b/man/summary.lm_.Rd new file mode 100644 index 0000000..34f7a1e --- /dev/null +++ b/man/summary.lm_.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lm_.R +\name{summary.lm_} +\alias{summary.lm_} +\title{Summarizing Linear Model Fits by SciViews} +\usage{ +\method{summary}{lm_}(object, ...) +} +\arguments{ +\item{object}{an object of class lm_} + +\item{...}{additional argument to stats:::summary.lm()} +} +\value{ +an object of class summary.lm_ object, similar to summary.lm +} +\description{ +summary method for class lm_ +} +\examples{ +#TODO +} diff --git a/man/tabularise_default.summary.lm.Rd b/man/tabularise_default.summary.lm.Rd index 69d6720..14b4da3 100644 --- a/man/tabularise_default.summary.lm.Rd +++ b/man/tabularise_default.summary.lm.Rd @@ -6,6 +6,7 @@ \usage{ \method{tabularise_default}{summary.lm}( data, + header = TRUE, footer = TRUE, lang = getOption("data.io_lang", "en"), ..., @@ -16,6 +17,8 @@ \arguments{ \item{data}{A \strong{summary.lm} object} +\item{header}{If \code{TRUE} (by default), add a header to the table} + \item{footer}{If \code{TRUE} (by default), add a footer to the table} \item{lang}{The natural language to use. The default value can be set with, From e7602a971d2f9c5dd781a95ed1c5dc31f0c2ec9b Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 9 Jul 2025 17:30:08 +0200 Subject: [PATCH 03/22] Revision of internal code with creation of new internal functions. Use of gettext(), gettextf() functions to obtain the French version of tables. --- DESCRIPTION | 27 +- NAMESPACE | 2 + R/lm_.R | 6 +- R/modelit-package.R | 14 +- R/tabularise.lm.R | 751 ++++++++++++++--------- inst/po/en@quot/LC_MESSAGES/R-modelit.mo | Bin 0 -> 4072 bytes man/tabularise_coef.lm.Rd | 2 +- man/tabularise_coef.summary.lm.Rd | 57 +- man/tabularise_default.summary.lm.Rd | 22 +- modelit.Rproj | 1 + po/R-modelit.pot | 113 ++++ po/fr.mo | Bin 0 -> 505 bytes po/fr.po | 124 ++++ 13 files changed, 791 insertions(+), 328 deletions(-) create mode 100644 inst/po/en@quot/LC_MESSAGES/R-modelit.mo create mode 100644 po/R-modelit.pot create mode 100644 po/fr.mo create mode 100644 po/fr.po diff --git a/DESCRIPTION b/DESCRIPTION index 7f1876e..1b82666 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -17,18 +17,19 @@ Depends: R (>= 4.2.0), broom (>= 1.0.4) Imports: - chart (>= 1.5.0), - data.io (>= 1.5.0), - flextable (>= 0.9.1), - generics (>= 0.1.3), - ggplot2 (>= 3.4.2), - knitr (>= 1.42), - modelr (>= 0.1.11), - officer (>= 0.6.2), - rlang (>= 1.1.1), - stats (>= 4.2.0), - svFlow (>= 1.2.0), - tabularise (>= 0.6.0) + chart (>= 1.5.0), + data.io (>= 1.5.0), + flextable (>= 0.9.1), + generics (>= 0.1.3), + ggplot2 (>= 3.4.2), + knitr (>= 1.42), + modelr (>= 0.1.11), + officer (>= 0.6.2), + rlang (>= 1.1.1), + stats (>= 4.2.0), + svFlow (>= 1.2.0), + svMisc, + tabularise (>= 0.6.0) Suggests: broom.mixed (>= 0.2.9.4), datasets (>= 4.2.0), @@ -48,7 +49,7 @@ License: MIT + file LICENSE URL: https://github.com/SciViews/modelit, https://www.sciviews.org/modelit/ BugReports: https://github.com/SciViews/modelit/issues Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 VignetteBuilder: knitr Encoding: UTF-8 Language: en-US diff --git a/NAMESPACE b/NAMESPACE index f01ef5a..47d3ff1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -126,6 +126,8 @@ importFrom(stats,rstandard) importFrom(stats,variable.names) importFrom(stats,vcov) importFrom(svFlow,"%>.%") +importFrom(svMisc,gettext) +importFrom(svMisc,gettextf) importFrom(tabularise,colformat_sci) importFrom(tabularise,equation) importFrom(tabularise,para_md) diff --git a/R/lm_.R b/R/lm_.R index 0ab153a..27d4a70 100644 --- a/R/lm_.R +++ b/R/lm_.R @@ -1,13 +1,15 @@ #' Fitting Linear Models by SciViews #' #' @description -#'The lm_() function is used like the lm() function from the {stats} package. It allows adding additional elements such as labels and units. +#'This function is used like the [stats::lm()] function. It allows adding +#'additional elements such as labels and units. #' #' @param data A data frame #' @param formula An object of class formula #' @param ... All the arguments of the lm() function #' -#' @return an lm_ object if attribute additions have been made. Otherwise, the object will be of class lm +#' @return an lm_ object if attribute additions have been made. Otherwise, the +#' object will be of class lm #' @export #' #' @examples diff --git a/R/modelit-package.R b/R/modelit-package.R index b8d3ee1..4ba8763 100644 --- a/R/modelit-package.R +++ b/R/modelit-package.R @@ -20,13 +20,8 @@ #' @name modelit-package ## usethis namespace: start -#' @importFrom stats AIC anova BIC coef confint cooks.distance deviance family fitted formula hatvalues nobs predict residuals rstandard variable.names vcov -#' @importFrom chart chart combine_charts -#' @importFrom ggplot2 aes aes_string geom_abline geom_bar geom_histogram geom_hline geom_point geom_qq geom_qq_line geom_smooth geom_vline ggtitle labs stat_function stat_smooth theme -#' @importFrom svFlow %>.% #' @importFrom broom augment glance tidy -#' @importFrom modelr add_predictions add_residuals geom_ref_line mae qae rmse rsquare -#' @importFrom generics fit +#' @importFrom chart chart combine_charts #' @importFrom data.io label #' @importFrom flextable add_footer_lines #' @importFrom flextable add_header_lines @@ -42,8 +37,15 @@ #' @importFrom flextable ncol_keys #' @importFrom flextable nrow_part #' @importFrom flextable width +#' @importFrom generics fit +#' @importFrom ggplot2 aes aes_string geom_abline geom_bar geom_histogram geom_hline geom_point geom_qq geom_qq_line geom_smooth geom_vline ggtitle labs stat_function stat_smooth theme +#' @importFrom modelr add_predictions add_residuals geom_ref_line mae qae rmse rsquare #' @importFrom officer fp_border +#' @importFrom stats AIC anova BIC coef confint cooks.distance deviance family fitted formula hatvalues nobs predict residuals rstandard variable.names vcov #' @importFrom stats coef pf +#' @importFrom svFlow %>.% +#' @importFrom svMisc gettext +#' @importFrom svMisc gettextf #' @importFrom tabularise colformat_sci equation #' @importFrom tabularise para_md ## usethis namespace: end diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index e58b10d..47ed7c3 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -38,8 +38,8 @@ #' tabularise::tabularise$coef(iris_lm) tabularise_coef.lm <- function(data, header = TRUE, title = NULL, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), + ..., kind = "ft", env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -49,20 +49,17 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Choose the language - info_lang <- .infos_lang.lm(lang = lang) - # Extract coefficients - df <- coef(data) - df <- data.frame(term = names(df), estimate = df) + df <- .coef_lm(data) - df <- extract_infos(df, - show.signif.stars = FALSE, info_lang = info_lang, + df_list <- .extract_infos(df, + show.signif.stars = FALSE, auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, - equation = equation, title = title) + equation = equation, title = title, colnames = colnames_lm, footer = FALSE, + lang = lang) # formatted table ---- - formate_table(df, kind = kind, header = header) + formate_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from an lm object @@ -146,26 +143,17 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Choose the language - info_lang <- .infos_lang.lm(lang = lang) - - # Extract coefficients with broom::tidy() ---- - df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, - conf.level = conf.level)) - rownames(df) <- df$term - - if (isTRUE(conf.int)) { - df <- df[, c("term", "estimate", "conf.low", "conf.high", - "std.error", "statistic", "p.value")] - } + # Extract coefficients + df <- .tidy_lm(data, conf.int = conf.int, + conf.level = conf.level, signif.stars = show.signif.stars) - df <- extract_infos(df, - show.signif.stars = show.signif.stars, info_lang = info_lang, - auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, - equation = equation, title = title) + df_list <- .extract_infos(df, show.signif.stars = show.signif.stars, + auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, + equation = equation, title = title, colnames = colnames_lm, + footer = FALSE, lang = lang) # formatted table ---- - formate_table(df, kind = kind, header = header) + formate_table(df_list, kind = kind, header = header) } #' Glance version of the lm object into a flextable object @@ -214,30 +202,49 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL, if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } - # Choose the language - info_lang <- .infos_lang.lm(lang = lang) - # Extract coefficients with broom::tidy() ---- - df <- as.data.frame(broom::glance(x = data)) - rownames(df) <- df$term + # Extract coefficients with broom::glance() + df <- .glance_lm(data) - df <- extract_infos(df, - show.signif.stars = FALSE, info_lang = info_lang, + df_list <- .extract_infos(df, show.signif.stars = FALSE, auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, - equation = equation, title = title) + equation = equation, title = title, colnames = colnames_lm, + footer = FALSE, lang = lang) # formatted table ---- - formate_table(df, kind = kind, header = header) + formate_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table using the table of coefficients of the summary.lm object #' -#' @param data A **summary.lm** object -#' @param ... Additional arguments passed to [tabularise_tidy.lm()] +#' @param data An **summary.lm** object +#' @param header If `TRUE` (by default), add a header to the table +#' @param title If `TRUE`, add a title to the table header. Default to the same +#' value than header, except outside of a chunk where it is `FALSE` if a table +#' caption is detected (`tbl-cap` YAML entry). +#' @param equation If `TRUE` (by default), add a equation to the table header. +#' The equation can also be passed in the form of a character string. +#' @param footer If `TRUE` (by default, it is FALSE), add a footer to the table. +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used. +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. +#' @param conf.int If `TRUE`, add the confidence interval. The default is +#' `FALSE`. +#' @param conf.level The confidence level to use for the confidence interval if +#' `conf.int = TRUE`. The default is 0.95. +#' @param lang The natural language to use. The default value can be set with, +#' e.g., `options(data.io_lang = "fr")` for French. +#' @param show.signif.stars If `TRUE`, add the significance stars to the table. +#' The default is `getOption("show.signif.stars")` +#' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate the model. +#' @param env The environment where to evaluate lazyeval expressions (unused for +#' now). #' #' @return A **flextable** object you can print in different formats (HTML, #' LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} functions. @@ -250,26 +257,39 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL, #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' iris_lm_sum <- summary(iris_lm) #' tabularise::tabularise$coef(iris_lm_sum) -tabularise_coef.summary.lm <- function(data, ..., kind = "ft", +tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, + equation = header, footer = FALSE, auto.labs = TRUE, origdata = NULL, + labs = NULL, conf.int = FALSE, conf.level = 0.95, + lang = getOption("data.io_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", env = parent.frame()) { - lm_original <- data$call - data <- eval(lm_original, envir = env) + # If title is not provided, determine if we have to use TRUE or FALSE + if (missing(title)) { + title <- header # Default to same as header, but... + # if a caption is defined in the chunk, it defauts to FALSE + if (!is.null(knitr::opts_current$get('tbl-cap'))) + title <- FALSE + } + + # Extract coefficients + df <- .tidy_lm(data, conf.int = conf.int, + conf.level = conf.level, signif.stars = show.signif.stars) + + df_list <- .extract_infos(df, show.signif.stars = show.signif.stars, + auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, + equation = equation, title = title, colnames = colnames_lm, + footer = footer, lang = lang) - tabularise_tidy.lm(data = data, ..., kind = kind, env = env) + # formatted table ---- + formate_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from an summary.lm object #' #' @param data A **summary.lm** object -#' @param header If `TRUE` (by default), add a header to the table -#' @param footer If `TRUE` (by default), add a footer to the table -#' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. #' @param ... Additional arguments passed to [tabularise_coef.summary.lm()] -#' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for -#' flextable (default). -#' @param env The environment where to evaluate the model. +#' @param footer If `TRUE` (by default), add a footer to the table. #' #' @return A **flextable** object you can print in different formats (HTML, #' LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} functions. @@ -282,226 +302,396 @@ tabularise_coef.summary.lm <- function(data, ..., kind = "ft", #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' iris_lm_sum <- summary(iris_lm) #' tabularise::tabularise(iris_lm_sum) -tabularise_default.summary.lm <- function(data, header = TRUE, footer = TRUE, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { +tabularise_default.summary.lm <- function(data, ..., footer = TRUE) { + tabularise_coef.summary.lm(data = data, ..., footer = footer) +} - df <- tabularise_coef.summary.lm(data = data, lang = lang, header = header , - kind = "df", ..., env = env) - if (isTRUE(footer)) { - info_lang <- .infos_lang.lm(lang = lang) - df <- extract_footer(df, data = data, info_lang = info_lang) - } +# A list of internals functions ------ - formate_table(df, kind= kind, header = header) +.pvalue_format <- function(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), + labels = c("***", " **", " *", " .", " ")) { + #x <- get(as.character(substitute(x)), inherits = TRUE) + z <- cut(x, breaks = breaks, + labels = labels) + z <- as.character(z) + z[is.na(x)] <- "" + z } -# Choose the lang and the infos_lang -.infos_lang.lm <- function(lang) { - lang <- tolower(lang) +.coef_lm <- function(x) { + df <- coef(x) + df <- data.frame(term = names(df), estimate = df) + df +} - if (lang != "fr") lang <- "en" # Only en or fr for now +.glance_lm <- function(x) { + df <- as.data.frame(broom::glance(x = x)) + rownames(df) <- df$term + df +} - if (lang == "fr") { - info_lang <- infos_fr.lm - } else { - info_lang <- infos_en.lm +.tidy_lm <- function(x, conf.int = FALSE, conf.level = 0.95, + signif.stars = getOption("show.signif.stars", TRUE)) { + + # extract coefficients and statistics from a model object + # TODO remove broom::tidy() + df <- as.data.frame(broom::tidy(x = x, conf.int = conf.int, + conf.level = conf.level)) + rownames(df) <- df$term + + # change order of columns + if (isTRUE(conf.int)) { + df <- df[, c("term", "estimate", "conf.low", "conf.high", + "std.error", "statistic", "p.value")] } - info_lang + # add a signif column with significance stars + if (isTRUE(signif.stars)){ + df$signif <- .pvalue_format(df$p.value) + } + + df } -infos_en.lm <- list( - labs = c( - term = "Term", - estimate = "Estimate", - conf.low = "Lower bound (CI)", - conf.high = "Upper bound (CI)", - std.error = "Standard Error", - t.value = "t value", - sigma = "RSE", - r.squared = "R^2^", - adj.r.squared = "Adj.R^2^", - AIC = "AIC", - BIC = "BIC", - deviance = "Deviance", - logLik = "Log-likelihood", - statistic = "*t* value", - p.value = "*p* value", - df = "Model df", - df.residual = "Residuals df", - nobs = "N", - signif = "", - "(Intercept)" = "Intercept"), - "(Intercept)" = "Intercept", - "summary" = "Model summary", - "header" = "Linear model", - footer = c( - "resid.range" = "Residuals range:", - "resid.std.err" = "Residuals standard error:", - "on" = "on", - "and" = "and", - "df" = "df", - "df2" = "degrees of freedom", - "R2" = "Multiple *R*^2^:", - "adj.R2" = "adjusted *R*^2^:", - "f.stat" = "*F*-statistic:", - "p" = "*p* value:" - ) -) - -infos_fr.lm <- list( - labs = c( - term = "Terme", - estimate = "Valeur estim\u00e9e", - conf.low = "Limite basse (IC)", - conf.high = "Limite haute (IC)", - std.error = "Ecart type", - t.value = "Valeur de *t*", - p.value = "Valeur de *p*", - sigma = "RSE", - r.squared = "R^2^", - adj.r.squared = "R^2^ ajust\u00e9", - AIC = "AIC", - BIC = "BIC", - statistic = " Valeur de *t*", - deviance = "D\u00e9viance", - logLik = "Log-vraisemblance", - df = "Ddl mod\u00e8le", - df.residual = "Ddl r\u00e9sidus", - nobs = "N", - signif = "", - "(Intercept)" = "Ordonn\u00e9e \u00e0 l'origine" - ), - "(Intercept)" = "Ordonn\u00e9e \u00e0 l'origine", - "summary" = "R\u00e9sum\u00e9 du mod\u00e8le", - "header" = "Mod\u00e8le lin\u00e9aire", - footer = c( - "resid.range" = "Etendue des r\u00e9sidus :", - "resid.std.err" = "Ecart type des r\u00e9sidus :", - "on" = "pour", - "and" = "et", - "df" = "ddl", - "df2" = "degr\u00e9s de libert\u00e9", - "R2" = "*R*^2^ multiple :", - "adj.R2" = "*R*^2^ ajust\u00e9 :", - "f.stat" = "Statistique *F* :", - "p" = "valeur de *p* :" - ) -) +colnames_lm <- c( + term = "Term", + estimate = "Estimate", + conf.low = "Lower bound (CI)", + conf.high = "Upper bound (CI)", + std.error = "Standard Error", + t.value = "t value", + sigma = "RSE", + r.squared = "R^2^", + adj.r.squared = "Adj.R^2^", + AIC = "AIC", + BIC = "BIC", + deviance = "Deviance", + logLik = "Log-likelihood", + statistic = "*t* value", + p.value = "*p* value", + df = "Model df", + df.residual = "Residuals df", + nobs = "N", + signif = "", + "(Intercept)" = "Intercept") + +.extract_colnames <- function(df, labs, ...) { + vec <- labs[names(labs) %in% names(df)] + vec1 <- svMisc::gettext(vec,...) + names(vec1) <- names(vec) + vec +} +.labels_factor <- function(df) { + if (!is.data.frame(df)) { + # warning("No dataframe found.") + return(NULL) + # stop("Input must be a data frame.") + } + + factor_cols <- which(sapply(df, is.factor)) + if (length(factor_cols) == 0) { + # warning("No factor columns found in the data frame.") + return(NULL) + } + + if (!requireNamespace("data.io", quietly = TRUE)) { + stop("Package 'data.io' is required but not installed.") + } + #class(df) + df <- as.data.frame(df) + #class(df) + labels <- vapply(df[,factor_cols, drop = FALSE], data.io::label, character(1), units = FALSE) + valid_vars <- names(labels)[labels != ""] + if (length(valid_vars) == 0) { + #warning("No labeled factor variables found.") + return(NULL) + } -# A list of functions ------ + # Fusion of result and names generation + result <- vector("character") + result_names <- vector("character") -extract_significance_stars <- function(x, show.signif.stars) { - if (isTRUE(show.signif.stars)) { - x[["signif"]] <- .pvalue_format(x[["p.value"]]) - attr(x, "signif.stars") <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" - attr(x, "show.signif.stars") <- show.signif.stars + for (var in valid_vars) { + levs <- levels(df[[var]]) + result <- c(result, paste0(labels[[var]], " [", levs, "]")) + result_names <- c(result_names, paste0(var, levs)) } - return(x) + + names(result) <- result_names + return(result) } -extract_column_names <- function(x, info_lang) { - hlabs <- info_lang[["labs"]] - attr(x, "col.names") <- hlabs[names(hlabs) %in% names(x)] - return(x) +.labels2 <- function (x, origdata = NULL, labs = NULL) { + if (is.null(origdata)) { + labs_auto <- c(tabularise:::.labels(x$model), .labels_factor(x$model)) + } + else { + labs_auto <- c(tabularise:::.labels(origdata), .labels_factor(origdata)) + } + if (!is.null(labs)) { + if (!is.character(labs)) + stop("labs is not character vector") + if (is.null(names(labs))) + stop("labs must be named character vector") + if (any(names(labs) %in% "")) + stop("all element must be named") + labs_res <- c(labs, labs_auto[!names(labs_auto) %in% + names(labs)]) + } + else { + labs_res <- labs_auto + } + labs_res } -replace_intercept_term <- function(x, info_lang) { - if (any(x$term %in% "(Intercept)")) { - x$term[x$term == "(Intercept)"] <- info_lang[["(Intercept)"]] +.extend_labs_with_interactions <- function(labs, terms) { + if (!is.character(labs) || is.null(names(labs))) { + #stop("Le vecteur 'labs' doit être un vecteur nommé de chaînes de caractères.") + return(NULL) + } + if (!is.character(terms)) { + #stop("Le vecteur 'terms' doit être un vecteur de chaînes de caractères.") + return(labs) } - return(x) + + for (term in terms) { + if (grepl(":", term)) { + parts <- unlist(strsplit(term, ":")) + missing_parts <- parts[!parts %in% names(labs)] + + if (length(missing_parts) > 0) { + warning(sprintf( + "Les termes suivants sont manquants dans 'labs' pour l'interaction '%s' : %s", + term, paste(missing_parts, collapse = ", ") + )) + next + } + + # Construire le label de l'interaction + interaction_label <- paste(labs[parts], collapse = " x ") + labs[term] <- interaction_label + } + } + + return(labs) } -extract_labels <- function(x, auto.labs, data, origdata, labs) { +.extract_labels <- function(df, data, auto.labs, origdata, labs) { if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) + labs <- .labels2(x = data, origdata = origdata, labs = labs) + # Compare the names of labs with the rownames + labs <- .extend_labs_with_interactions(labs = labs, terms = df[["term"]]) } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) + labs <- .labels2(x = NULL, labs = labs) } - attr(x, "labs") <- labs - return(x) + + labs } -extract_equation <- function(x, equation, data, labs, ...) { +.extract_terms <- function(df, labs,...) { + vals <- df[["term"]] + terms <- labs[names(labs) %in% vals] + + if(any(vals == "(Intercept)")) + #terms <- c("(Intercept)"= svMisc::gettext("Intercept",...), terms) + #ss <- "Intercept" + #terms <- c("(Intercept)"= gettext(ss,...), terms) + terms <- c("(Intercept)"= gettext("Intercept",...), terms) + + terms +} + +.extract_equation <- function(data, equation, labs, ...) { if (isTRUE(equation)) { if (!is.null(labs)) { - equa <- equation(data, swap_var_names = labs, ...) + equa <- tabularise::equation(data, swap_var_names = labs, ...) } else { - equa <- equation(data, auto.labs = FALSE, ...) + equa <- tabularise::equation(data, auto.labs = FALSE, ...) } - attr(x, "equation") <- equa - attr(x, "equation_params") <- .params_equa(equa) + return(equa) + #attr(x, "equation_params") <- .params_equa(equa) } if (is.character(equation)) { - attr(x, "equation") <- equation + return(equation) + } +} + +.params_equa <- function(x, intercept = "alpha", greek = "beta") { + vals <- NULL + + if (intercept != greek && grepl(intercept, x)) { + it <- paste0("\\\\", intercept) + res <- regmatches(x, gregexpr(it, x))[[1]] + vals <- paste0("$",res, "$") + } + + if (grepl(greek, x)) { + g <- paste0("\\\\", greek,"_\\{\\d*\\}") + res <- regmatches(x, gregexpr(g, x))[[1]] + res1 <- paste0("$",res, "$") + vals <- c(vals, res1) } - return(x) + vals } -extract_title <- function(x, title, info_lang) { +.extract_title <- function(title, ...) { + res <- NULL + if (isTRUE(title)) { - attr(x, "title") <- info_lang[["header"]] + res <- svMisc::gettext("Linear model", ...) } if (is.character(title)) { - attr(x, "title") <- title + res <- title } - return(x) + return(res) } -extract_footer <- function(x, data, info_lang) { +# footer_lm <- c( +# "resid.range" = "Residuals range:", +# "resid.std.err" = "Residuals standard error:", +# "on" = "on", +# "and" = "and", +# "df" = "df", +# "df2" = "degrees of freedom", +# "R2" = "Multiple *R*^2^:", +# "adj.R2" = "adjusted *R*^2^:", +# "f.stat" = "*F*-statistic:", +# "p" = "*p* value:" +# ) + +.extract_footer <- function(data, ...) { digits <- max(3L, getOption("digits") - 3L) - footer <- info_lang[["footer"]] - vals <- c( - paste0(footer[["resid.range"]], " [", - format(signif(min(data$residuals, na.rm = TRUE), digits)), ", ", - format(signif(max(data$residuals, na.rm = TRUE), digits)), "] "), - paste(footer[["resid.std.err"]], - format(signif(data$sigma, digits)), footer[["on"]], - max(data$df), footer[["df2"]]), - paste(footer[["R2"]], format(signif(data$r.squared, digits)), " - ", - footer[["adj.R2"]], format(signif(data$adj.r.squared, digits))), - paste(footer[["f.stat"]], format(signif(data$fstatistic[1L], digits)), - footer[["on"]], format(signif(data$fstatistic[2L], digits)), - footer[["and"]], format(signif(data$fstatistic[3L], digits)), - footer[["df"]], " - ", footer[["p"]], - format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], - data$fstatistic[3L], lower.tail = FALSE))) - # TODO: nicely format this last p value! + svMisc::gettextf( + paste0( + "Residuals range: [%.*g, %.*g]\n", + "Residuals standard error: %.*g on %.*g degrees of freedom\n", + "Multiple *R*^2^: %.*g - adjusted *R*^2^: %.*g\n", + "*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s" + ), + digits, min(data$residuals, na.rm = TRUE), + digits, max(data$residuals, na.rm = TRUE), + digits, data$sigma, + digits, max(data$df), + digits, data$r.squared, + digits, data$adj.r.squared, + digits, data$fstatistic[1L], + digits, data$fstatistic[2L], + digits, data$fstatistic[3L], + format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], + data$fstatistic[3L], lower.tail = FALSE)), ...) +} + +.extract_infos <- function(df, + show.signif.stars = getOption("show.signif.stars", TRUE), + auto.labs = TRUE, data , origdata = NULL , labs = NULL, equation = TRUE, + title = TRUE, colnames = colnames_lm , footer = FALSE, lang, ...) { + + if(isTRUE(show.signif.stars)) { + psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" + } else { + psignif <- NULL + } + + cols <- .extract_colnames(df, labs = colnames_lm) + + labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, + origdata = origdata, labs = labs) + + equa <- .extract_equation(data, equation = equation, labs = labels) + + if(isTRUE(equation)){ + terms <- .params_equa(equa) + } else { + terms <- .extract_terms(df, labs = labels) + } + + title <- .extract_title(title) + + if(isTRUE(footer)) { + footer <- .extract_footer(data, lang = lang) + } else { + footer <- NULL + } + + + list( + df = df, + title = title, + cols = cols, + equa = equa, + terms = terms, + psignif = psignif, + footer = footer ) - attr(x, "footer") <- vals - return(x) } -extract_infos <- function(x, show.signif.stars, info_lang, auto.labs, data, origdata, labs, equation, title) { - # stars ---- - x <- extract_significance_stars(x, show.signif.stars = show.signif.stars) +.create_flextable <- function(x, header = TRUE) { + df <- x$df + + ft <- flextable(df) |> + colformat_sci() + + if ("p.value" %in% colnames(df)) { + ft <- ft |> + colformat_sci(j = "p.value", lod = 2e-16) + } + + if (!is.null(x$cols)) { + ft <- .add_colnames(ft, x$cols) + } - # colnames ----- - x <- extract_column_names(x, info_lang = info_lang) + if (!is.null(x$terms)) { + vec <- x$terms + if(is.character(vec) && !is.null(names(vec)) && all(nzchar(names(vec)))) { + ft <- .add_labs(ft, vec) + } else { + ft <- .add_params(ft, vec) + } + } - # specific case : (Intercept) -> Intercept ---- - x <- replace_intercept_term(x, info_lang = info_lang) + if (isTRUE(header)) { + ft <- .add_header2(ft, title = x$title, equation = x$equa) + } - # labels ---- - x <- extract_labels(x = x, auto.labs = auto.labs, - data = data, origdata = origdata, labs = labs) + if (!is.null(x$psignif)) { + ft <- .add_signif(ft, x$psignif) + } - # equation ---- - x <- extract_equation(x, equation = equation, data = data, - labs = attr(x, "labs")) + if (!is.null(x$footer)) { + vals <- x$footer + ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) + ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", + part = "footer") + } - # title ---- - x <- extract_title(x, title = title, info_lang = info_lang) + ft <- autofit(ft, part = c("header", "body")) - return(x) + if (!is.null(df$signif)) { + ft <- width(ft, j = "signif", width = 0.4) + } + + return(ft) +} + +formate_table <- function(df, kind, header) { + switch(kind, + df = {df}, + tt = { + stop("Not implemented yet") + }, + ft = { + .create_flextable(df, header = header) + }, + gt = { + stop("Not implemented yet") + } + ) } .add_signif <- function(x, signif) { @@ -518,11 +708,6 @@ extract_infos <- function(x, show.signif.stars, info_lang, auto.labs, data, orig align(ft, i = 1, align = "right", part = "footer") } -.extract_labels <- function(x, info_lang) { - hlabs <- info_lang[["labs"]] - hlabs[names(hlabs) %in% names(x)] -} - .add_header2 <- function(x, title, equation) { if (!inherits(x, "flextable")) { @@ -534,13 +719,13 @@ extract_infos <- function(x, show.signif.stars, info_lang, auto.labs, data, orig if (is.character(equation)) { ft <- add_header_lines(ft, values = as_paragraph(as_equation(equation))) - ft <- align(ft, i = 1, align = "right", part = "header") + ft <- align(ft, i = 1, align = "center", part = "header") } if (is.character(title)) { ft <- add_header_lines(ft, values = as_paragraph(title)) - ft <- align(ft, i = 1, align = "right", part = "header") + ft <- align(ft, i = 1, align = "center", part = "header") } h_nrow <- nrow_part(ft, part = "header") @@ -602,63 +787,65 @@ extract_infos <- function(x, show.signif.stars, info_lang, auto.labs, data, orig ft } -create_flextable <- function(x, header = TRUE) { - ft <- flextable(x) |> - colformat_sci() - - if ("p.value" %in% colnames(x)) { - ft <- ft |> - colformat_sci(j = "p.value", lod = 2e-16) - } - - if (!is.null(attr(x, "col.names"))) { - ft <- .add_colnames(ft, attr(x, "col.names")) - } - - if (!is.null(attr(x, "labs"))) { - ft <- .add_labs(ft, attr(x, "labs")) - } - - if (!is.null(attr(x,"equation")) & !is.null(attr(x, "equation_params"))) { - ft <- .add_params(ft, attr(x, "equation_params")) - } - - if (isTRUE(header)) { - ft <- .add_header2(ft, title = attr(x, "title"), equation = attr(x, "equation")) - } - - if (!is.null(attr(x,"signif.stars"))) { - ft <- .add_signif(ft, attr(x, "signif.stars")) - } - - if (!is.null(attr(x, "footer"))) { - vals <- attr(x, "footer") - ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) - ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", - part = "footer") - } - - ft <- autofit(ft, part = c("header", "body")) - - sss <- attr(x,"show.signif.stars") - if (!is.null(sss) && isTRUE(sss)) { - ft <- width(ft, j = "signif", width = 0.4) - } - - return(ft) -} - -formate_table <- function(df, kind, header) { - switch(kind, - df = {df}, - tt = { - stop("Not implemented yet") - }, - ft = { - create_flextable(df, header = header) - }, - gt = { - stop("Not implemented yet") - } - ) -} +# create_flextable <- function(x, header = TRUE) { +# df <- x$df +# +# ft <- flextable(df) |> +# colformat_sci() +# +# if ("p.value" %in% colnames(df)) { +# ft <- ft |> +# colformat_sci(j = "p.value", lod = 2e-16) +# } +# +# if (!is.null(x$cols))) { +# ft <- .add_colnames(ft, attr(x, "col.names")) +# } +# +# if (!is.null(attr(x, "labs"))) { +# ft <- .add_labs(ft, attr(x, "labs")) +# } +# +# if (!is.null(attr(x,"equation")) & !is.null(attr(x, "equation_params"))) { +# ft <- .add_params(ft, attr(x, "equation_params")) +# } +# +# if (isTRUE(header)) { +# ft <- .add_header2(ft, title = attr(x, "title"), equation = attr(x, "equation")) +# } +# +# if (!is.null(attr(x,"signif.stars"))) { +# ft <- .add_signif(ft, attr(x, "signif.stars")) +# } +# +# if (!is.null(attr(x, "footer"))) { +# vals <- attr(x, "footer") +# ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) +# ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", +# part = "footer") +# } +# +# ft <- autofit(ft, part = c("header", "body")) +# +# sss <- attr(x,"show.signif.stars") +# if (!is.null(sss) && isTRUE(sss)) { +# ft <- width(ft, j = "signif", width = 0.4) +# } +# +# return(ft) +# } + +# #formate_table <- function(df, kind, header) { +# switch(kind, +# df = {df}, +# tt = { +# stop("Not implemented yet") +# }, +# ft = { +# create_flextable(df, header = header) +# }, +# gt = { +# stop("Not implemented yet") +# } +# ) +# } diff --git a/inst/po/en@quot/LC_MESSAGES/R-modelit.mo b/inst/po/en@quot/LC_MESSAGES/R-modelit.mo new file mode 100644 index 0000000000000000000000000000000000000000..5580340f8940a0ad6684a57bca9d22069a0d1a66 GIT binary patch literal 4072 zcmeH|O^g&p6vsaD77 zcGVazB*cpcV}gku^yE=vqVcHlMDXOvgPL&g=tUFb#rS{KGqbw{Axb=GsHEmM_0d(Y z{_j=2AJ(sVhoNjkeGGN?EsX5~kKBqMl(n}prog*E3^5Dd50>D);5qO<@NMux@I$Z- zeg-}d{tC9hXV+kD@HH?3KL#hjAHj#f&9`F@unE$4&w#Yvd2kGT58MQP1Jd_DfhWL? zcQE!cn1XMC7r~w2OLsE16+8z%0Dc5M0)7EL3VsXHIerG$gMWZ@{&j0>Eh2CW+Q-1{ zpaY)*-v>89h_As6?eAbT>GE8oUT+E{T~30eOBbYbRNy4|CP?SI1d=YB?yhy20qI=l zLDJ=OkaYP4BwZT!Fg62j0BOA*NP4~wk}jWs^!-JUbom`z0Hkn;N6zP(mr;X~WT%ogacwA**o?Vc2gG^<<9LDQ;k zt~ztp2}2)D=3E+s?R6ZN#=yigJqaVtlFGZ>X)YIGf9$+DeRFxo=!^%80XraIPYz=< zaawZS;hi#%ozi(dMbrm{)s;>wS}-p&X;jQBVU(CprI&!``b@OER*`C`_m4guNp2$MtCwD_jcz|vvO)Lw?jz9?fhYw+hszeS$tj6q2(d8(Nu2doi;?3DY#(k~nE-0LzLYm@T@VF=Fn9^|T40edv@!ZH*BamN(`LzCM zz3e=WSl_Kt9vEpm%0YqvjfDkrSuon*z63TFsZ4b&NWFmer1?E%U2p@d^DEZH#VOR+kLpk)_UxK7&CgWgj3%fvAyBg zem>r8J-xqiL|7Nj(xaaW9JR$K;m8buhLFQk*_AnB0AY!VdACF~gtJm)E!?zR4*ObM z=8dCMM-MF(qApNVRXcgT{pjBW|OnOgHGLvmLei`3{p-WjvAxPhkBmWj%CUEARb{9cj@k_wrWOnQ&m@iflOOTA2|C ief_NHn?r;9nGu~goEu?muZ@NJYE<<9W{$j8j{Fmcm+0I8 literal 0 HcmV?d00001 diff --git a/man/tabularise_coef.lm.Rd b/man/tabularise_coef.lm.Rd index 501c7f8..06c4fd2 100644 --- a/man/tabularise_coef.lm.Rd +++ b/man/tabularise_coef.lm.Rd @@ -12,7 +12,7 @@ auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE", unset = "en")), ..., kind = "ft", env = parent.frame() diff --git a/man/tabularise_coef.summary.lm.Rd b/man/tabularise_coef.summary.lm.Rd index 8c4c2fa..d77a35c 100644 --- a/man/tabularise_coef.summary.lm.Rd +++ b/man/tabularise_coef.summary.lm.Rd @@ -4,17 +4,66 @@ \alias{tabularise_coef.summary.lm} \title{Create a rich-formatted table using the table of coefficients of the summary.lm object} \usage{ -\method{tabularise_coef}{summary.lm}(data, ..., kind = "ft", env = parent.frame()) +\method{tabularise_coef}{summary.lm}( + data, + header = TRUE, + title = header, + equation = header, + footer = FALSE, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, + conf.int = FALSE, + conf.level = 0.95, + lang = getOption("data.io_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), + ..., + kind = "ft", + env = parent.frame() +) } \arguments{ -\item{data}{A \strong{summary.lm} object} +\item{data}{An \strong{summary.lm} object} -\item{...}{Additional arguments passed to \code{\link[=tabularise_tidy.lm]{tabularise_tidy.lm()}}} +\item{header}{If \code{TRUE} (by default), add a header to the table} + +\item{title}{If \code{TRUE}, add a title to the table header. Default to the same +value than header, except outside of a chunk where it is \code{FALSE} if a table +caption is detected (\code{tbl-cap} YAML entry).} + +\item{equation}{If \code{TRUE} (by default), add a equation to the table header. +The equation can also be passed in the form of a character string.} + +\item{footer}{If \code{TRUE} (by default, it is FALSE), add a footer to the table.} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used.} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} + +\item{conf.int}{If \code{TRUE}, add the confidence interval. The default is +\code{FALSE}.} + +\item{conf.level}{The confidence level to use for the confidence interval if +\code{conf.int = TRUE}. The default is 0.95.} + +\item{lang}{The natural language to use. The default value can be set with, +e.g., \code{options(data.io_lang = "fr")} for French.} + +\item{show.signif.stars}{If \code{TRUE}, add the significance stars to the table. +The default is \code{getOption("show.signif.stars")}} + +\item{...}{Additional arguments} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} -\item{env}{The environment where to evaluate the model.} +\item{env}{The environment where to evaluate lazyeval expressions (unused for +now).} } \value{ A \strong{flextable} object you can print in different formats (HTML, diff --git a/man/tabularise_default.summary.lm.Rd b/man/tabularise_default.summary.lm.Rd index 14b4da3..8a0d8e7 100644 --- a/man/tabularise_default.summary.lm.Rd +++ b/man/tabularise_default.summary.lm.Rd @@ -4,32 +4,14 @@ \alias{tabularise_default.summary.lm} \title{Create a rich-formatted table from an summary.lm object} \usage{ -\method{tabularise_default}{summary.lm}( - data, - header = TRUE, - footer = TRUE, - lang = getOption("data.io_lang", "en"), - ..., - kind = "ft", - env = parent.frame() -) +\method{tabularise_default}{summary.lm}(data, ..., footer = TRUE) } \arguments{ \item{data}{A \strong{summary.lm} object} -\item{header}{If \code{TRUE} (by default), add a header to the table} - -\item{footer}{If \code{TRUE} (by default), add a footer to the table} - -\item{lang}{The natural language to use. The default value can be set with, -e.g., \code{options(data.io_lang = "fr")} for French.} - \item{...}{Additional arguments passed to \code{\link[=tabularise_coef.summary.lm]{tabularise_coef.summary.lm()}}} -\item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for -flextable (default).} - -\item{env}{The environment where to evaluate the model.} +\item{footer}{If \code{TRUE} (by default), add a footer to the table.} } \value{ A \strong{flextable} object you can print in different formats (HTML, diff --git a/modelit.Rproj b/modelit.Rproj index a4dc148..2a1a166 100644 --- a/modelit.Rproj +++ b/modelit.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: 820bdb37-4760-4e6e-8ea0-a09ee1f2e817 RestoreWorkspace: No SaveWorkspace: No diff --git a/po/R-modelit.pot b/po/R-modelit.pot new file mode 100644 index 0000000..bbd14ec --- /dev/null +++ b/po/R-modelit.pot @@ -0,0 +1,113 @@ +msgid "" +msgstr "" +"Project-Id-Version: modelit 1.4.7\n" +"POT-Creation-Date: 2025-07-09 12:39\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"Language: \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=CHARSET\n" +"Content-Transfer-Encoding: 8bit\n" + +msgid "Can only transform a model with 2 variables for now." +msgstr "" + +msgid "Can only make of function from a model involving numeric variables for now." +msgstr "" + +msgid "You cannot use one-sided formula, like ~x." +msgstr "" + +msgid "Impossible to plot in 2D a model with more than 2 variables" +msgstr "" + +msgid "Can only plot a model involving numeric variables for now." +msgstr "" + +msgid "Independent variable '" +msgstr "" + +msgid "' must appear untransformed in the model's formula, or you must supply the original dataset in origdata=." +msgstr "" + +msgid "Unrecognized type, must be 'model', 'resfitted', 'qqplot', 'scalelocation', 'cooksd', 'resleverage', 'cookleverage', 'reshist', or 'resautocor'" +msgstr "" + +msgid "Unrecognized type, must be 'model', 'resfitted', 'qqplot',\n 'scalelocation' or 'reshist'" +msgstr "" + +msgid "The type= argument must provide a model_spec object or its name in a character string." +msgstr "" + +msgid "You must give either 'h=' or 'v='." +msgstr "" + +msgid "Package 'data.io' is required but not installed." +msgstr "" + +msgid "labs is not character vector" +msgstr "" + +msgid "labs must be named character vector" +msgstr "" + +msgid "all element must be named" +msgstr "" + +msgid "Les termes suivants sont manquants dans 'labs' pour l'interaction '%s' : %s" +msgstr "" + +msgid "," +msgstr "" + +msgid "Intercept" +msgstr "" + +msgid "Not implemented yet" +msgstr "" + +msgid "Function `%s` supports only flextable objects." +msgstr "" + +msgid ".add_signif_stars()" +msgstr "" + +msgid ".add_header2()" +msgstr "" + +msgid ".add_colnames()" +msgstr "" + +msgid "x must be an nls or summary.nls object" +msgstr "" + +msgid "An error occurred when trying to extract the formula from 'x'" +msgstr "" + +msgid "The formula is not a Self-Starting nls formula" +msgstr "" + +msgid "The %s is not available." +msgstr "" + +msgid "var_names is not character vector" +msgstr "" + +msgid "var_names must be named character vector" +msgstr "" + +msgid "all elements must be named" +msgstr "" + +msgid "add_header_nls()" +msgstr "" + +msgid "header_labels()" +msgstr "" + +msgid "header_labels_lm()" +msgstr "" + +msgid ".add_header()" +msgstr "" diff --git a/po/fr.mo b/po/fr.mo new file mode 100644 index 0000000000000000000000000000000000000000..1770ab8db5c07aad9688dde15c9fabe8696f0e3f GIT binary patch literal 505 zcmYk&v2GMG5C&ieLcx}#2@=J02t~f^ErEnhsKS9x;>anwL=-g6?PM|X+8f&!C8FUC zsIH)+U5dQKK0w|e1#Mm;|K^IzXg`fSwmjasdA2$ih*fw2d+-FlK^HYVg)>-#pYR-h z!!0zh4)YZu2>A;674kJQKJf@1Ll<2SF|?8WlL6;nbGKP3jp=uT) zoiJHdaUsUu{orYo!$Kaj58BzBDp#=4k@~%@-gYuRkcWJ(yDj-aMb0Tpvo|u`mgzg{ zXZcpTk!ER{d{!aKiB~ol6`jus6PCf%YN~QvEu^2^1Amn z5eL3-*0v2(` Date: Mon, 14 Jul 2025 15:06:38 +0200 Subject: [PATCH 04/22] use poedit for the translations --- inst/po/en@quot/LC_MESSAGES/R-modelit.mo | Bin 4072 -> 5294 bytes inst/po/fr/LC_MESSAGES/R-modelit.mo | Bin 0 -> 2668 bytes po/R-fr.mo | Bin 0 -> 2668 bytes po/{fr.po => R-fr.po} | 97 +++++++++++++++++++---- po/R-modelit.pot | 75 +++++++++++++++++- po/fr.mo | Bin 505 -> 0 bytes 6 files changed, 155 insertions(+), 17 deletions(-) create mode 100644 inst/po/fr/LC_MESSAGES/R-modelit.mo create mode 100644 po/R-fr.mo rename po/{fr.po => R-fr.po} (55%) delete mode 100644 po/fr.mo diff --git a/inst/po/en@quot/LC_MESSAGES/R-modelit.mo b/inst/po/en@quot/LC_MESSAGES/R-modelit.mo index 5580340f8940a0ad6684a57bca9d22069a0d1a66..a9fb0b627557da6544cfa756c3a40eb2254309cf 100644 GIT binary patch literal 5294 zcmeH~O^h5z6~`+O0<1$Eg2Q)6nXu{gGCkQH*4T`hh>g7~EwN*>-UJZDo7(Q0nYR05 z+}$&~>jQEmBqXE=;6N;b9 zkR_{6La}!m-UUAoKL#&BvHwFT<9-I;4X?sw_!}sG&fwG|@YC>7_+9uFc+D zvzUbT0wRf?--HskU)B6Al(_r>%6xx>{Bw(y_1?xGiPv3F;xrFgsyYl8;r(_0W%wZN zFGA7tc_@1B!>Ek^M9mf0q`eA7&&Q$Y`BNx<{Q^q-uR%c#!tTq3C%I zik@GBvR+w(*zvgU=3d~QyksqM9jf58{0P69#>MZxx?g+{zey8ywC-!b_tn2;4RRf> z;Qng=ss zP)DgQ`&K7eXk)L?(mRYzLua|(&W6>C#c(i)x81lbk9tvRVjY^&6tzrClwas(Zl?A~t&sqCs-?I9A zJ4$=H%(UGiFhS|oS;s+l^DNQcmZu)T)N#XNQzDU=3sz@c-5sVu8L>b&%v4b%B%>@I ziP3bJ*gOhYXdao3*t+=YG}~rS?&!Gl{$^D6b?cwacfyV$lLl5TAx&aR ztCq*kKQ>)FrbXi{FNXhWF4!i2qFfOA34$ZF4qHvvWzBb``@*ROE`zdV?5$P!5g#<@#`cS^NmIM4cUvUy{^SYc@~R8vAv+5I@B=Gcr*uQZ?O! zZWhPcrpsu?7TTak5+NMvh+ZB;3s1JWOY=w+Am=5Az3IYpn^EkK^M5>vK5OHyk2iVg z5}Q@mL)@(8_P}2 zP4#e^+aO~*UqT15->A%PpjB0^8rsWk(Tz&9^k`hXC|T(>rnI}fA~3Oyvw(7xrJl?w zmJn>NFnQt>}jvZ33esD#+kXR>4*|S_PU48Q$%#LP3T^akpjV2 zK~XZ-UETke)^St6r> delta 1061 zcma*lOGs2v9LMo9HICzqH9BfpW^+?)%4jmHg;SDJ6g?I(LQoJindHEDP3J*SFm419 zBJdCx)uL$8rWXTAP*BlIj25k0^uR^5YEw~dqVMlc?OJr;KcD-Ud(Qv<&b_^qZ z>c4Cl?bI4-yU&;{cz6jvjNnpZGFXG$GC7Q30hi$70@rb#!VQ?m^>`f{iQ)y0aQ=p_mCXK7C7A=L zWR9VdIfHtUBKG4n>ID}t$@-=_T#04?^=4B@G-eK!%okKLp;}`Gun{%kFe=gusAL|X zo}Wi0^ApGL2;G$NId)=^uH+3YDVhZi6wO;yG~ZEs9OXyJw4svOf$f+=B~wHtGmA>* z87he;N)2l0f0~0`_6DJu7{xBBX}y1CQt42v?Y*rUVn@88rnHwDjg-Dkw%;49=?yig zwANCsR6V6__&W&0`wn#8LJ_J7>6Z`GtfY+n=6CJAs=YITUfUmdY*Ueo2ZwS_erS9I za)nGW?dCZcb@R?h+8rx+r>E0y&WUH!r*d)U>}X-!$;LA-&!h+QnNin?cW^!FbmV4& z`)s5>R!-EoK6@wh!@dfK>|FR(u&c+}+MV3iQy#3{?W?TcQ@uDbdv0;!itP(LQ6H)Q v?1RVD2~Ym37w&d=_bUCg+LLvg)ss!sT(#5DO?FT81FiMhe8bZ}?G671()^xtZyiJ6vU6UaC;PN`}rJr0Q2+y{YRcRz!2|m zf+Xh$a1;15_$2rT_!RgjNb)vpWGnzTfl!Gxz-Pc?U=5rF@ni4fMshv?w}YR8N5F4D zl6wclkNu6?R`4H?^w|1PdEQCzMa(aNWWNDl2R{KH0lx*`0KWt8fGgnJ;ExY8_5`>Y zn~2*%sLuBK`F=m21W)1paggl(5Znyj02|;}AnElx_%wLevjQj3d>i;U7=omC10;Va zkb{@ON$_Kk?ED@ifBXcJ9lwIdKsvkvOoA|hodRD5PlFTSB1q@m1owbngH`Ysko>(7 zACsL2!QEgJBt0l*B!>psf$dITnv*`S;-c@K!$pH)NP~2sL1&Ub#>Z=Z@;u1>^GhJb zm&OaYw&2=a42g;lv#-3H$oR{K2F zC54X4hp5K`Ud^g}NyLT3uAGf#tZMyxcD&tW$D_q??&8En_6{aZp&=|@=GF+E_fnH^ z!ILzSF~6$p0-u0DqeLf`Imas3>D7>(kV{JFu4FB!ln5)?RH3_8L90tU^GiH0vMe<= zFD3V4dCigpo^}>x*XAK>Yb#AxW|mDWErlshWYcLsh}C5otA#X;Fuf`b@1zBc+}&*N zVKYvzsK;iC*s2T?t8-OY;++z35iJ(EmC?HQ>@+)_TCNg&kVu>y@nvb*tms}AeaUx4 z!irF(ySU1^kyi?3u%lC0*ov<-Tp!0W3YqiSoXk~Jh&bm^V{HQG_2Kn*DLDIFMBW=) zg$Nx96LD!wYVHYPB>P6fyJ?U2@DQa5JG;8SMf=&jGzptukO(U2NNR~Cp$k9TS+?G(u#U^pGdzL!ct>(A5*aZZFgmciAdKiDYJ3SH zgi>yC-F|-G9$RK3yEYPxY$IimNO_SY!Yqew>hglknw0V*Xh*?$X>z1fqf88Cc|AN3 z9;(cq3FeS{v=p2`-Zl6{ZQ@{1I~3IGyne7zKeD$rQL9y^MQ($6%IH`?*#^fO-7gUC zU|x!3Y~Fy=D>Lnx*4mNvuvTfN$P*12%NY)_NZ|chER;U#jLfB-JU2fT9A4Y!sz;ij zrMqbapEvm7jLOb5Od{7u<&Owo zDX^)~4*I4sY8QUNd&$QD?V^ba*af3_CUPzjQ6pXZ7!JsQ;ebuUYrcJ~T>rv1kd^B< zIep}MNX`=|I3~t7lHtHN5>n6%2h>e+)Px7zuAQ{HsAg`FkoRtL{|FgH z*F8}~fnds(SaqZ!h1WiI-2^^#-DJ(mNab0omFp-jiqufX-B2J?${r%`?=EQLE&vOn zKp0#AY+B@;{xyb!xbzz|O4Sl&!0@((M|GMYX>ueD+KfiTS3Qo@qbB1s9%iHQ3~w3f ew?fLQi2vQ`h2K*b*GPl0Z(SCa4XGG!NbFx-O~UK| literal 0 HcmV?d00001 diff --git a/po/R-fr.mo b/po/R-fr.mo new file mode 100644 index 0000000000000000000000000000000000000000..c29a7bfca1c58948cb91725566a24f2e50846a47 GIT binary patch literal 2668 zcmZ{lO^g&p6vs=!uMtJ@3l+4)ATZF)%nAYnn~1|KOtK4`Wg#R+Ld|r|Y%Sf@O?CCc z-tgixtZyiJ6vU6UaC;PN`}rJr0Q2+y{YRcRz!2|m zf+Xh$a1;15_$2rT_!RgjNb)vpWGnzTfl!Gxz-Pc?U=5rF@ni4fMshv?w}YR8N5F4D zl6wclkNu6?R`4H?^w|1PdEQCzMa(aNWWNDl2R{KH0lx*`0KWt8fGgnJ;ExY8_5`>Y zn~2*%sLuBK`F=m21W)1paggl(5Znyj02|;}AnElx_%wLevjQj3d>i;U7=omC10;Va zkb{@ON$_Kk?ED@ifBXcJ9lwIdKsvkvOoA|hodRD5PlFTSB1q@m1owbngH`Ysko>(7 zACsL2!QEgJBt0l*B!>psf$dITnv*`S;-c@K!$pH)NP~2sL1&Ub#>Z=Z@;u1>^GhJb zm&OaYw&2=a42g;lv#-3H$oR{K2F zC54X4hp5K`Ud^g}NyLT3uAGf#tZMyxcD&tW$D_q??&8En_6{aZp&=|@=GF+E_fnH^ z!ILzSF~6$p0-u0DqeLf`Imas3>D7>(kV{JFu4FB!ln5)?RH3_8L90tU^GiH0vMe<= zFD3V4dCigpo^}>x*XAK>Yb#AxW|mDWErlshWYcLsh}C5otA#X;Fuf`b@1zBc+}&*N zVKYvzsK;iC*s2T?t8-OY;++z35iJ(EmC?HQ>@+)_TCNg&kVu>y@nvb*tms}AeaUx4 z!irF(ySU1^kyi?3u%lC0*ov<-Tp!0W3YqiSoXk~Jh&bm^V{HQG_2Kn*DLDIFMBW=) zg$Nx96LD!wYVHYPB>P6fyJ?U2@DQa5JG;8SMf=&jGzptukO(U2NNR~Cp$k9TS+?G(u#U^pGdzL!ct>(A5*aZZFgmciAdKiDYJ3SH zgi>yC-F|-G9$RK3yEYPxY$IimNO_SY!Yqew>hglknw0V*Xh*?$X>z1fqf88Cc|AN3 z9;(cq3FeS{v=p2`-Zl6{ZQ@{1I~3IGyne7zKeD$rQL9y^MQ($6%IH`?*#^fO-7gUC zU|x!3Y~Fy=D>Lnx*4mNvuvTfN$P*12%NY)_NZ|chER;U#jLfB-JU2fT9A4Y!sz;ij zrMqbapEvm7jLOb5Od{7u<&Owo zDX^)~4*I4sY8QUNd&$QD?V^ba*af3_CUPzjQ6pXZ7!JsQ;ebuUYrcJ~T>rv1kd^B< zIep}MNX`=|I3~t7lHtHN5>n6%2h>e+)Px7zuAQ{HsAg`FkoRtL{|FgH z*F8}~fnds(SaqZ!h1WiI-2^^#-DJ(mNab0omFp-jiqufX-B2J?${r%`?=EQLE&vOn zKp0#AY+B@;{xyb!xbzz|O4Sl&!0@((M|GMYX>ueD+KfiTS3Qo@qbB1s9%iHQ3~w3f ew?fLQi2vQ`h2K*b*GPl0Z(SCa4XGG!NbFx-O~UK| literal 0 HcmV?d00001 diff --git a/po/fr.po b/po/R-fr.po similarity index 55% rename from po/fr.po rename to po/R-fr.po index a6c7615..9e4fba0 100644 --- a/po/fr.po +++ b/po/R-fr.po @@ -1,8 +1,8 @@ msgid "" msgstr "" "Project-Id-Version: modelit 1.4.7\n" -"POT-Creation-Date: 2025-07-09 12:16\n" -"PO-Revision-Date: 2025-07-09 12:40+0200\n" +"POT-Creation-Date: 2025-07-14 12:27\n" +"PO-Revision-Date: 2025-07-11 15:19+0200\n" "Last-Translator: \n" "Language-Team: \n" "Language: fr\n" @@ -12,7 +12,7 @@ msgstr "" "X-Generator: Poedit 3.6\n" msgid "Can only transform a model with 2 variables for now." -msgstr "" +msgstr "Pour l’instant, on ne peut transformer qu’un modèle à 2 variables." msgid "" "Can only make of function from a model involving numeric variables for now." @@ -53,33 +53,102 @@ msgstr "" msgid "You must give either 'h=' or 'v='." msgstr "" +msgid "Term" +msgstr "Terme" + +msgid "Estimate" +msgstr "Valeur estimée" + +msgid "Lower bound (CI)" +msgstr "Limite basse (IC)" + +msgid "Upper bound (CI)" +msgstr "Limite haute (IC)" + +msgid "Standard Error" +msgstr "Ecart type" + +msgid "t value" +msgstr "Valeur de *t*" + +#, fuzzy +msgid "RSE" +msgstr "RSE" + +msgid "R^2^" +msgstr "R^2^" + +msgid "Adj.R^2^" +msgstr "R^2^ ajustée" + +msgid "AIC" +msgstr "AIC" + +msgid "BIC" +msgstr "BIC" + +msgid "Deviance" +msgstr "Déviance" + +msgid "Log-likelihood" +msgstr "Log-vraisemblance" + +msgid "*t* value" +msgstr "Valeur de *t*" + +msgid "*p* value" +msgstr "Valeur de *p*" + +msgid "Model df" +msgstr "Ddl modèle" + +msgid "Residuals df" +msgstr "Ddl résidus" + +msgid "N" +msgstr "N" + +msgid "Intercept" +msgstr "Ordonnée à l’origine" + msgid "Package 'data.io' is required but not installed." -msgstr "" +msgstr "Le package “data.io” est requis mais n'est pas installé." msgid "labs is not character vector" -msgstr "" +msgstr "Labs n’est pas un vecteur de caractères" msgid "labs must be named character vector" -msgstr "" +msgstr "Labs doit être un vecteur de caractères nommé" msgid "all element must be named" msgstr "tous les éléments doivent être nommés" -msgid "" -"Les termes suivants sont manquants dans 'labs' pour l'interaction '%s' : %s" +msgid "The following terms are missing in 'labs' for the interaction '%s': %s" msgstr "" msgid "," msgstr "" -msgid "Intercept" -msgstr "Ordonnée à l’origine" +msgid "Linear model" +msgstr "Modèle linéaire" + +msgid "Residuals range: [%.*g, %.*g]" +msgstr "Etendue des résidus : [%.*g, %.*g]" + +msgid "Residuals standard error: %.*g on %.*g degrees of freedom" +msgstr "Ecart type des résidus : %.*g pour %.*g degrés de liberté" + +msgid "Multiple *R*^2^: %.*g - adjusted *R*^2^: %.*g" +msgstr "*R*^2^ multiple : %.*g - *R*^2^ ajusté : %.*g" + +msgid "*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s" +msgstr "Statistique *F* : %.*g sur %.*g et %.*g ddl - valeur de *p* : %s" msgid "Not implemented yet" msgstr "Ce n'est pas encore implémenté" msgid "Function `%s` supports only flextable objects." -msgstr "" +msgstr "La fonction `%s` supporte uniquement des objets flextable." msgid ".add_signif_stars()" msgstr "" @@ -91,16 +160,16 @@ msgid ".add_colnames()" msgstr "" msgid "x must be an nls or summary.nls object" -msgstr "" +msgstr "x doit être un objet nls ou summary.nls" msgid "An error occurred when trying to extract the formula from 'x'" msgstr "" msgid "The formula is not a Self-Starting nls formula" -msgstr "" +msgstr "La formule n'est pas une formule Self-Starting nls" msgid "The %s is not available." -msgstr "" +msgstr "Le %s n'est pas disponible." msgid "var_names is not character vector" msgstr "" diff --git a/po/R-modelit.pot b/po/R-modelit.pot index bbd14ec..1275b2d 100644 --- a/po/R-modelit.pot +++ b/po/R-modelit.pot @@ -1,7 +1,7 @@ msgid "" msgstr "" "Project-Id-Version: modelit 1.4.7\n" -"POT-Creation-Date: 2025-07-09 12:39\n" +"POT-Creation-Date: 2025-07-14 12:27\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -43,6 +43,63 @@ msgstr "" msgid "You must give either 'h=' or 'v='." msgstr "" +msgid "Term" +msgstr "" + +msgid "Estimate" +msgstr "" + +msgid "Lower bound (CI)" +msgstr "" + +msgid "Upper bound (CI)" +msgstr "" + +msgid "Standard Error" +msgstr "" + +msgid "t value" +msgstr "" + +msgid "RSE" +msgstr "" + +msgid "R^2^" +msgstr "" + +msgid "Adj.R^2^" +msgstr "" + +msgid "AIC" +msgstr "" + +msgid "BIC" +msgstr "" + +msgid "Deviance" +msgstr "" + +msgid "Log-likelihood" +msgstr "" + +msgid "*t* value" +msgstr "" + +msgid "*p* value" +msgstr "" + +msgid "Model df" +msgstr "" + +msgid "Residuals df" +msgstr "" + +msgid "N" +msgstr "" + +msgid "Intercept" +msgstr "" + msgid "Package 'data.io' is required but not installed." msgstr "" @@ -55,13 +112,25 @@ msgstr "" msgid "all element must be named" msgstr "" -msgid "Les termes suivants sont manquants dans 'labs' pour l'interaction '%s' : %s" +msgid "The following terms are missing in 'labs' for the interaction '%s': %s" msgstr "" msgid "," msgstr "" -msgid "Intercept" +msgid "Linear model" +msgstr "" + +msgid "Residuals range: [%.*g, %.*g]" +msgstr "" + +msgid "Residuals standard error: %.*g on %.*g degrees of freedom" +msgstr "" + +msgid "Multiple *R*^2^: %.*g - adjusted *R*^2^: %.*g" +msgstr "" + +msgid "*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s" msgstr "" msgid "Not implemented yet" diff --git a/po/fr.mo b/po/fr.mo deleted file mode 100644 index 1770ab8db5c07aad9688dde15c9fabe8696f0e3f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 505 zcmYk&v2GMG5C&ieLcx}#2@=J02t~f^ErEnhsKS9x;>anwL=-g6?PM|X+8f&!C8FUC zsIH)+U5dQKK0w|e1#Mm;|K^IzXg`fSwmjasdA2$ih*fw2d+-FlK^HYVg)>-#pYR-h z!!0zh4)YZu2>A;674kJQKJf@1Ll<2SF|?8WlL6;nbGKP3jp=uT) zoiJHdaUsUu{orYo!$Kaj58BzBDp#=4k@~%@-gYuRkcWJ(yDj-aMb0Tpvo|u`mgzg{ zXZcpTk!ER{d{!aKiB~ol6`jus6PCf%YN~QvEu^2^1Amn z5eL3-*0v2(` Date: Mon, 14 Jul 2025 15:10:19 +0200 Subject: [PATCH 05/22] To enhance code readability, group multiple importFrom directives from the same package into a single statement. --- R/modelit-package.R | 23 +++++------------------ 1 file changed, 5 insertions(+), 18 deletions(-) diff --git a/R/modelit-package.R b/R/modelit-package.R index 4ba8763..ff12ffc 100644 --- a/R/modelit-package.R +++ b/R/modelit-package.R @@ -23,20 +23,9 @@ #' @importFrom broom augment glance tidy #' @importFrom chart chart combine_charts #' @importFrom data.io label -#' @importFrom flextable add_footer_lines -#' @importFrom flextable add_header_lines -#' @importFrom flextable align -#' @importFrom flextable as_equation -#' @importFrom flextable as_paragraph -#' @importFrom flextable autofit -#' @importFrom flextable border_inner_h -#' @importFrom flextable flextable -#' @importFrom flextable hline -#' @importFrom flextable italic -#' @importFrom flextable mk_par -#' @importFrom flextable ncol_keys -#' @importFrom flextable nrow_part -#' @importFrom flextable width +#' @importFrom flextable add_footer_lines add_header_lines align as_equation +#' @importFrom flextable as_paragraph autofit border_inner_h flextable +#' @importFrom flextable hline italic mk_par ncol_keys nrow_part width #' @importFrom generics fit #' @importFrom ggplot2 aes aes_string geom_abline geom_bar geom_histogram geom_hline geom_point geom_qq geom_qq_line geom_smooth geom_vline ggtitle labs stat_function stat_smooth theme #' @importFrom modelr add_predictions add_residuals geom_ref_line mae qae rmse rsquare @@ -44,9 +33,7 @@ #' @importFrom stats AIC anova BIC coef confint cooks.distance deviance family fitted formula hatvalues nobs predict residuals rstandard variable.names vcov #' @importFrom stats coef pf #' @importFrom svFlow %>.% -#' @importFrom svMisc gettext -#' @importFrom svMisc gettextf -#' @importFrom tabularise colformat_sci equation -#' @importFrom tabularise para_md +#' @importFrom svMisc gettext gettextf +#' @importFrom tabularise colformat_sci equation para_md ## usethis namespace: end NULL From 106f25e9a1f5da904f754ad288e35e2004da1f0e Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Mon, 14 Jul 2025 15:13:31 +0200 Subject: [PATCH 06/22] Replace .extract_infos() with .extract_infos_lm() and removal of unnecessary argument --- R/tabularise.lm.R | 291 ++++++++++++++++-------------- man/tabularise_coef.lm.Rd | 6 +- man/tabularise_coef.summary.lm.Rd | 6 +- man/tabularise_glance.lm.Rd | 6 +- man/tabularise_tidy.lm.Rd | 6 +- 5 files changed, 157 insertions(+), 158 deletions(-) diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index 47ed7c3..fa7efcd 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -23,8 +23,6 @@ #' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @return A **flextable** object that you can print in different formats #' (HTML, LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} @@ -39,7 +37,7 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), - ..., kind = "ft", env = parent.frame()) { + ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -49,14 +47,11 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Extract coefficients - df <- .coef_lm(data) - - df_list <- .extract_infos(df, - show.signif.stars = FALSE, - auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, - equation = equation, title = title, colnames = colnames_lm, footer = FALSE, - lang = lang) + df_list <- .extract_infos_lm( + data, type = "coef", conf.int = FALSE, conf.level = 0.95, + show.signif.stars = FALSE, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_lm, footer = FALSE) # formatted table ---- formate_table(df_list, kind = kind, header = header) @@ -117,8 +112,6 @@ tabularise_default.lm <- function(data, ..., kind = "ft", env = parent.frame()) #' @param ... Additional arguments passed to [tabularise::equation()] #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @return A **flextable** object that you can print in different formats (HTML, #' LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} functions. @@ -132,8 +125,7 @@ tabularise_default.lm <- function(data, ..., kind = "ft", env = parent.frame()) tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, conf.int = FALSE, conf.level = 0.95, lang = getOption("data.io_lang", "en"), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", - env = parent.frame()) { + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -143,14 +135,12 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Extract coefficients - df <- .tidy_lm(data, conf.int = conf.int, - conf.level = conf.level, signif.stars = show.signif.stars) + df_list <- .extract_infos_lm( + data, type = "tidy", conf.int = conf.int, conf.level = 0.95, + show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_lm, footer = FALSE) - df_list <- .extract_infos(df, show.signif.stars = show.signif.stars, - auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, - equation = equation, title = title, colnames = colnames_lm, - footer = FALSE, lang = lang) # formatted table ---- formate_table(df_list, kind = kind, header = header) @@ -180,8 +170,6 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, #' @param ... Additional arguments passed to [tabularise::equation()] #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @return A **flextable** object that you can print in different form or #' rearrange with the \{flextable\} functions. @@ -193,8 +181,7 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, #' tabularise::tabularise$glance(iris_lm) tabularise_glance.lm <- function(data, header = TRUE, title = NULL, equation = TRUE, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { + lang = getOption("data.io_lang", "en"), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... @@ -203,19 +190,16 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Extract coefficients with broom::glance() - df <- .glance_lm(data) - - df_list <- .extract_infos(df, show.signif.stars = FALSE, - auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, - equation = equation, title = title, colnames = colnames_lm, - footer = FALSE, lang = lang) + df_list <- .extract_infos_lm( + data, type = "glance", conf.int = FALSE, conf.level = 0.95, + show.signif.stars = FALSE, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_lm, footer = FALSE) # formatted table ---- formate_table(df_list, kind = kind, header = header) } - #' Create a rich-formatted table using the table of coefficients of the summary.lm object #' #' @param data An **summary.lm** object @@ -243,8 +227,6 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL, #' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @return A **flextable** object you can print in different formats (HTML, #' LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} functions. @@ -261,8 +243,7 @@ tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, equation = header, footer = FALSE, auto.labs = TRUE, origdata = NULL, labs = NULL, conf.int = FALSE, conf.level = 0.95, lang = getOption("data.io_lang", "en"), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", - env = parent.frame()) { + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -272,14 +253,11 @@ tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, title <- FALSE } - # Extract coefficients - df <- .tidy_lm(data, conf.int = conf.int, - conf.level = conf.level, signif.stars = show.signif.stars) - - df_list <- .extract_infos(df, show.signif.stars = show.signif.stars, - auto.labs = auto.labs, data = data, origdata = origdata, labs = labs, - equation = equation, title = title, colnames = colnames_lm, - footer = footer, lang = lang) + df_list <- .extract_infos_lm( + data, type = "tidy", conf.int = conf.int, conf.level = conf.level, + show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_lm, footer = FALSE) # formatted table ---- formate_table(df_list, kind = kind, header = header) @@ -319,41 +297,6 @@ tabularise_default.summary.lm <- function(data, ..., footer = TRUE) { z } -.coef_lm <- function(x) { - df <- coef(x) - df <- data.frame(term = names(df), estimate = df) - df -} - -.glance_lm <- function(x) { - df <- as.data.frame(broom::glance(x = x)) - rownames(df) <- df$term - df -} - -.tidy_lm <- function(x, conf.int = FALSE, conf.level = 0.95, - signif.stars = getOption("show.signif.stars", TRUE)) { - - # extract coefficients and statistics from a model object - # TODO remove broom::tidy() - df <- as.data.frame(broom::tidy(x = x, conf.int = conf.int, - conf.level = conf.level)) - rownames(df) <- df$term - - # change order of columns - if (isTRUE(conf.int)) { - df <- df[, c("term", "estimate", "conf.low", "conf.high", - "std.error", "statistic", "p.value")] - } - - # add a signif column with significance stars - if (isTRUE(signif.stars)){ - df$signif <- .pvalue_format(df$p.value) - } - - df -} - colnames_lm <- c( term = "Term", estimate = "Estimate", @@ -376,11 +319,68 @@ colnames_lm <- c( signif = "", "(Intercept)" = "Intercept") -.extract_colnames <- function(df, labs, ...) { +# .make_traduction <- function() { +# .trad <- list() +# traduction_fun <- function(lang = "en") { +# res <- .trad[[lang]] +# if(is.null(res)) { +# message("langue ", lang, " pas en cache") +# res <- gettext(term = "Term", +# estimate = "Estimate", +# conf.low = "Lower bound (CI)", +# conf.high = "Upper bound (CI)", +# std.error = "Standard Error", +# t.value = "t value", +# sigma = "RSE", +# r.squared = "R^2^", +# adj.r.squared = "Adj.R^2^", +# AIC = "AIC", +# BIC = "BIC", +# deviance = "Deviance", +# logLik = "Log-likelihood", +# statistic = "*t* value", +# p.value = "*p* value", +# df = "Model df", +# df.residual = "Residuals df", +# nobs = "N", +# "(Intercept)" = "Intercept", lang = lang, +# domain = "R-modelit") +# .trad2 <- .trad +# .trad2[[lang]] <- res +# .trad <<- .trad2 # super assignation +# } +# res +# } +# traduction_fun +# } +# +# .traduction <- .make_traduction() + +.trad <- gettext(term = "Term", + estimate = "Estimate", + conf.low = "Lower bound (CI)", + conf.high = "Upper bound (CI)", + std.error = "Standard Error", + t.value = "t value", + sigma = "RSE", + r.squared = "R^2^", + adj.r.squared = "Adj.R^2^", + AIC = "AIC", + BIC = "BIC", + deviance = "Deviance", + logLik = "Log-likelihood", + statistic = "*t* value", + p.value = "*p* value", + df = "Model df", + df.residual = "Residuals df", + nobs = "N", + "(Intercept)" = "Intercept") + +.extract_colnames <- function(df, labs, lang) { vec <- labs[names(labs) %in% names(df)] - vec1 <- svMisc::gettext(vec,...) + vec1 <- gettext(vec, lang = lang) names(vec1) <- names(vec) - vec + vec1 } .labels_factor <- function(df) { @@ -423,7 +423,7 @@ colnames_lm <- c( return(result) } -.labels2 <- function (x, origdata = NULL, labs = NULL) { +.labels3 <- function (x, origdata = NULL, labs = NULL) { if (is.null(origdata)) { labs_auto <- c(tabularise:::.labels(x$model), .labels_factor(x$model)) } @@ -448,11 +448,9 @@ colnames_lm <- c( .extend_labs_with_interactions <- function(labs, terms) { if (!is.character(labs) || is.null(names(labs))) { - #stop("Le vecteur 'labs' doit être un vecteur nommé de chaînes de caractères.") return(NULL) } if (!is.character(terms)) { - #stop("Le vecteur 'terms' doit être un vecteur de chaînes de caractères.") return(labs) } @@ -463,7 +461,7 @@ colnames_lm <- c( if (length(missing_parts) > 0) { warning(sprintf( - "Les termes suivants sont manquants dans 'labs' pour l'interaction '%s' : %s", + "The following terms are missing in 'labs' for the interaction '%s': %s", term, paste(missing_parts, collapse = ", ") )) next @@ -480,25 +478,22 @@ colnames_lm <- c( .extract_labels <- function(df, data, auto.labs, origdata, labs) { if (isTRUE(auto.labs)) { - labs <- .labels2(x = data, origdata = origdata, labs = labs) + labs <- .labels3(x = data, origdata = origdata, labs = labs) # Compare the names of labs with the rownames labs <- .extend_labs_with_interactions(labs = labs, terms = df[["term"]]) } else { - labs <- .labels2(x = NULL, labs = labs) + labs <- .labels3(x = NULL, labs = labs) } labs } -.extract_terms <- function(df, labs,...) { +.extract_terms <- function(df, labs, lang) { vals <- df[["term"]] terms <- labs[names(labs) %in% vals] if(any(vals == "(Intercept)")) - #terms <- c("(Intercept)"= svMisc::gettext("Intercept",...), terms) - #ss <- "Intercept" - #terms <- c("(Intercept)"= gettext(ss,...), terms) - terms <- c("(Intercept)"= gettext("Intercept",...), terms) + terms <- c("(Intercept)"= gettext("Intercept", lang = lang), terms) terms } @@ -538,59 +533,79 @@ colnames_lm <- c( vals } -.extract_title <- function(title, ...) { +.extract_title <- function(title, lang = "en") { res <- NULL if (isTRUE(title)) { - res <- svMisc::gettext("Linear model", ...) + res <- gettext("Linear model", lang = lang) } if (is.character(title)) { res <- title } - return(res) } -# footer_lm <- c( -# "resid.range" = "Residuals range:", -# "resid.std.err" = "Residuals standard error:", -# "on" = "on", -# "and" = "and", -# "df" = "df", -# "df2" = "degrees of freedom", -# "R2" = "Multiple *R*^2^:", -# "adj.R2" = "adjusted *R*^2^:", -# "f.stat" = "*F*-statistic:", -# "p" = "*p* value:" -# ) - -.extract_footer <- function(data, ...) { +.extract_footer_lm <- function(data, lang) { digits <- max(3L, getOption("digits") - 3L) - svMisc::gettextf( - paste0( - "Residuals range: [%.*g, %.*g]\n", - "Residuals standard error: %.*g on %.*g degrees of freedom\n", - "Multiple *R*^2^: %.*g - adjusted *R*^2^: %.*g\n", - "*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s" - ), - digits, min(data$residuals, na.rm = TRUE), - digits, max(data$residuals, na.rm = TRUE), - digits, data$sigma, - digits, max(data$df), - digits, data$r.squared, - digits, data$adj.r.squared, - digits, data$fstatistic[1L], - digits, data$fstatistic[2L], - digits, data$fstatistic[3L], - format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], - data$fstatistic[3L], lower.tail = FALSE)), ...) + domain <- "R-modelit" + res <- paste(gettextf("Residuals range: [%.*g, %.*g]", + digits, min(data$residuals, na.rm = TRUE), + digits, max(data$residuals, na.rm = TRUE), + domain = domain, lang = lang), + gettextf("Residuals standard error: %.*g on %.*g degrees of freedom", + digits, data$sigma, digits, max(data$df), + domain = domain, lang = lang), + gettextf("Multiple *R*^2^: %.*g - adjusted *R*^2^: %.*g", + digits, data$r.squared, digits, data$adj.r.squared, + domain = domain, lang = lang), + gettextf("*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s", + digits, data$fstatistic[1L], + digits, data$fstatistic[2L], + digits, data$fstatistic[3L], + format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], + data$fstatistic[3L], lower.tail = FALSE)), + domain = domain, lang = lang), + sep = "\n") + res } -.extract_infos <- function(df, - show.signif.stars = getOption("show.signif.stars", TRUE), - auto.labs = TRUE, data , origdata = NULL , labs = NULL, equation = TRUE, - title = TRUE, colnames = colnames_lm , footer = FALSE, lang, ...) { +.extract_infos_lm <- function(data, type = "coef", + conf.int = TRUE, conf.level = 0.95, show.signif.stars = getOption("show.signif.stars", TRUE), + lang, auto.labs = TRUE, origdata = NULL , labs = NULL, equation = TRUE, + title = TRUE, colnames = colnames_lm , footer = FALSE, ...) { + + + type <- match.arg(type, choices = c("coef", "glance", "tidy")) + + + if (inherits(data, "summary.lm") && type == "coef") { + message(".extract_infos_lm() cannot apply type = 'coef' to a summary.lm + object. Use type = 'tidy' instead to extract a detailed coefficient table.") + type <- "tidy" + } + + df <- switch(type, + coef = {df <- coef(data) + data.frame(term = names(df), estimate = df)}, + glance = {df <- as.data.frame(broom::glance(x = data)) + rownames(df) <- df$term + df + }, + tidy = {df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, + conf.level = conf.level)) + rownames(df) <- df$term + + if (isTRUE(conf.int)) { + df <- df[, c("term", "estimate", "conf.low", "conf.high", + "std.error", "statistic", "p.value")] + } + if (isTRUE(show.signif.stars)) { + df$signif <- .pvalue_format(df$p.value) + } + df} + ) + if(isTRUE(show.signif.stars)) { psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" @@ -598,7 +613,7 @@ colnames_lm <- c( psignif <- NULL } - cols <- .extract_colnames(df, labs = colnames_lm) + cols <- .extract_colnames(df, labs = colnames_lm, lang = lang) labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, origdata = origdata, labs = labs) @@ -608,13 +623,13 @@ colnames_lm <- c( if(isTRUE(equation)){ terms <- .params_equa(equa) } else { - terms <- .extract_terms(df, labs = labels) + terms <- .extract_terms(df, labs = labels, lang = lang) } - title <- .extract_title(title) + title <- .extract_title(title, lang = lang) if(isTRUE(footer)) { - footer <- .extract_footer(data, lang = lang) + footer <- .extract_footer_lm(data, lang = lang) } else { footer <- NULL } diff --git a/man/tabularise_coef.lm.Rd b/man/tabularise_coef.lm.Rd index 06c4fd2..00a1206 100644 --- a/man/tabularise_coef.lm.Rd +++ b/man/tabularise_coef.lm.Rd @@ -14,8 +14,7 @@ labs = NULL, lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE", unset = "en")), ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ @@ -46,9 +45,6 @@ e.g., \code{options(data.io_lang = "fr")} for French.} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different formats diff --git a/man/tabularise_coef.summary.lm.Rd b/man/tabularise_coef.summary.lm.Rd index d77a35c..40402d1 100644 --- a/man/tabularise_coef.summary.lm.Rd +++ b/man/tabularise_coef.summary.lm.Rd @@ -18,8 +18,7 @@ lang = getOption("data.io_lang", "en"), show.signif.stars = getOption("show.signif.stars", TRUE), ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ @@ -61,9 +60,6 @@ The default is \code{getOption("show.signif.stars")}} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object you can print in different formats (HTML, diff --git a/man/tabularise_glance.lm.Rd b/man/tabularise_glance.lm.Rd index bb4efe0..83bd5a5 100644 --- a/man/tabularise_glance.lm.Rd +++ b/man/tabularise_glance.lm.Rd @@ -14,8 +14,7 @@ labs = NULL, lang = getOption("data.io_lang", "en"), ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ @@ -46,9 +45,6 @@ e.g., \code{options(data.io_lang = "fr")} for French.} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different form or diff --git a/man/tabularise_tidy.lm.Rd b/man/tabularise_tidy.lm.Rd index 4d5484a..ce7f3f9 100644 --- a/man/tabularise_tidy.lm.Rd +++ b/man/tabularise_tidy.lm.Rd @@ -17,8 +17,7 @@ lang = getOption("data.io_lang", "en"), show.signif.stars = getOption("show.signif.stars", TRUE), ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ @@ -58,9 +57,6 @@ The default is \code{getOption("show.signif.stars")}} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different formats (HTML, From a13b0fa85b736b9e6f33e214054d86968d807287 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Mon, 14 Jul 2025 15:16:35 +0200 Subject: [PATCH 07/22] Add several tests for the .extract_infos_lm() function --- tests/testthat/test-.extract_infos_lm.R | 155 ++++++++++++++++++++++++ tests/testthat/test-general.R | 8 +- 2 files changed, 161 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-.extract_infos_lm.R diff --git a/tests/testthat/test-.extract_infos_lm.R b/tests/testthat/test-.extract_infos_lm.R new file mode 100644 index 0000000..7d9c1cd --- /dev/null +++ b/tests/testthat/test-.extract_infos_lm.R @@ -0,0 +1,155 @@ + +data(mtcars) +mod <- lm(mpg ~ wt + hp, data = mtcars) +mod1 <- lm(mpg ~ wt + hp + 0, data = mtcars) +mod3 <- lm(petal_length ~ sepal_length , data = data.io::read("iris", package = "datasets")) + +test_that("output is a list contains all expected named elements", { + # Verifies that the returned list + expect_type(.extract_infos_lm(mod), "list") +}) + +test_that("output contains all expected named elements of the list", { + # Verifies that the returned list includes all expected components + res <- .extract_infos_lm(mod, type = "tidy") + expect_true(all(c("df", "title", "cols", "equa", "terms", "psignif", "footer") %in% names(res))) +}) + +# df ---------------------------------------------------------------------- + +test_that("invalid type throws an error", { + # Ensures an error is thrown for an unsupported type + expect_error(.extract_infos_lm(mod, type = "unknown")) +}) + +test_that("type = 'coef' returns expected columns in df", { + # Checks that the 'coef' type returns a data frame with 'term' and 'estimate' + res <- .extract_infos_lm(mod, type = "coef") + expect_equal(colnames(res$df), c("term", "estimate")) +}) + +test_that("type = 'glance' returns a one-row data frame", { + # Checks that the 'glance' type returns a summary with one row + res <- .extract_infos_lm(mod, type = "glance") + expect_true("df" %in% names(res)) + expect_equal(nrow(res$df), 1) +}) + +test_that("type = 'tidy' returns expected columns with conf.int = TRUE", { + # Checks that confidence intervals are included when conf.int = TRUE + res <- .extract_infos_lm(mod, type = "tidy", conf.int = TRUE) + expect_true(all(c("term", "estimate", "conf.low", "conf.high", "std.error", + "statistic", "p.value") %in% colnames(res$df))) +}) + +test_that("type = 'tidy' without conf.int omits CI columns", { + # Ensures confidence interval columns are not present when conf.int = FALSE + res <- .extract_infos_lm(mod, type = "tidy", conf.int = FALSE) + expect_false("conf.low" %in% colnames(res$df)) +}) + +test_that("signif.stars = TRUE adds 'signif' column", { + # Checks that significance stars are added when enabled + res <- .extract_infos_lm(mod, type = "tidy", show.signif.stars = TRUE) + expect_true("signif" %in% colnames(res$df)) +}) + +test_that("signif.stars = FALSE omits 'signif' column in df", { + # Ensures 'signif' column is not added when disabled + res <- .extract_infos_lm(mod, type = "tidy", show.signif.stars = FALSE) + expect_false("signif" %in% colnames(res$df)) +}) + + +# title ------------------------------------------------------------------- + +test_that("x$title is NULL when title = FALSE/TRUE/chr", { + res <- .extract_infos_lm(mod, type = "tidy", title = FALSE) + expect_null(res$title) + + res <- .extract_infos_lm(mod, type = "tidy", title = TRUE) + expect_equal(res$title, "Linear model") + res <- .extract_infos_lm(mod, type = "tidy", title = TRUE, lang = "fr") + expect_equal(res$title, "Modèle linéaire") + + res <- .extract_infos_lm(mod, type = "tidy", title = "blablabla") + expect_type(res$title, "character") + expect_equal(res$title, "blablabla") +}) + +# cols -------------------------------------------------------------------- + +test_that("x$cols is a named character vector", { + res <- .extract_infos_lm(mod, type = "tidy") + + # Check that 'cols' exists and is a character vector + expect_true("cols" %in% names(res)) + expect_type(res$cols, "character") + + # Check that it has names + expect_true(any(nzchar(names(res$cols)))) # names are not empty +}) + +# equation ---------------------------------------------------------------- + +test_that("x$equa is an equation ", { + res <- .extract_infos_lm(mod, type = "coef") + + # Check that 'equa' exists and is a character vector + expect_true("equa" %in% names(res)) + expect_true(all(class(res$equa) == c("equation", "character"))) + + res <- .extract_infos_lm(mod, type = "coef", equation = "tada") + expect_type(res$equa, "character") +}) + + +# terms ------------------------------------------------------------------- +test_that("res$terms is a character vector with or without names depending on + equation argument", { + res <- .extract_infos_lm(mod, equation = TRUE) + expect_type(res$terms, "character") + # .params_equation returns an unnamed character vector + expect_null(names(res$terms)) + + # .params_equation returns a vector of the same length as the number of rows in df + expect_true(length(res$terms) == nrow(res$df)) + + res <- .extract_infos_lm(mod, equation = FALSE) + expect_type(res$terms, "character") + expect_true(any(nzchar(names(res$terms)))) + + res <- .extract_infos_lm(mod1, equation = FALSE) + expect_null(res$terms) + + res <- .extract_infos_lm(mod3, equation = FALSE) + expect_true(length(res$terms) == nrow(res$df)) + expect_true(any(nzchar(names(res$terms)))) +}) + +# psignif ----------------------------------------------------------------- + +test_that("x$signif is an equation ", { + res <- .extract_infos_lm(mod, show.signif.stars = FALSE) + expect_null(res$psignif) + + res <- .extract_infos_lm(mod, show.signif.stars = TRUE) + expect_type(res$psignif, "character") +}) + +# footer ------------------------------------------------------------------ + +test_that("x$footer is NULL when footer = FALSE", { + # Checks that footer is NULL when not requested + res <- .extract_infos_lm(mod, type = "tidy", footer = FALSE) + expect_null(res$footer) + + # footer is generated when footer = TRUE and a summary.lm object + res <- .extract_infos_lm(summary(mod), type = "tidy", footer = TRUE) + expect_true(!is.null(res$footer)) + + # footer is not generated when footer = TRUE and a lm object + expect_error(extract_infos_lm(mod, type = "tidy", footer = TRUE)) + }) + + diff --git a/tests/testthat/test-general.R b/tests/testthat/test-general.R index 8849056..7613874 100644 --- a/tests/testthat/test-general.R +++ b/tests/testthat/test-general.R @@ -1,3 +1,7 @@ -test_that("multiplication works", { - expect_equal(2 * 2, 4) +test_that("Update .po and .mo files", { + # Update .po and .mo files (only test in the source package, not R CMD check) + if (file.exists("../../DESCRIPTION")) {# This is the source of the package + cat("\nCompiling .po files...\n") + res <- try(tools::update_pkg_po("../.."), silent = TRUE) + } }) From 081af78a8ff306f60f2dd654ab5ecf9405438b15 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 16 Jul 2025 16:52:46 +0200 Subject: [PATCH 08/22] update format --- R/modelit-package.R | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/R/modelit-package.R b/R/modelit-package.R index ff12ffc..c8a7140 100644 --- a/R/modelit-package.R +++ b/R/modelit-package.R @@ -16,9 +16,6 @@ #' - [as.function()] transforms an **lm** or **nls** model into a function that #' can be plotted using `stat_function()`. #' -#' @docType package -#' @name modelit-package - ## usethis namespace: start #' @importFrom broom augment glance tidy #' @importFrom chart chart combine_charts @@ -36,4 +33,4 @@ #' @importFrom svMisc gettext gettextf #' @importFrom tabularise colformat_sci equation para_md ## usethis namespace: end -NULL +"_PACKAGE" From aebab64cefa0bcaca3c4dbec6859397bec3c9fc1 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 16 Jul 2025 16:53:27 +0200 Subject: [PATCH 09/22] update translation with poedit --- inst/po/en@quot/LC_MESSAGES/R-modelit.mo | Bin 5294 -> 8218 bytes inst/po/fr/LC_MESSAGES/R-modelit.mo | Bin 2668 -> 5504 bytes po/R-fr.mo | Bin 2668 -> 5504 bytes po/R-fr.po | 102 +++++++++++++++++++++-- po/R-modelit.pot | 83 +++++++++++++++++- 5 files changed, 178 insertions(+), 7 deletions(-) diff --git a/inst/po/en@quot/LC_MESSAGES/R-modelit.mo b/inst/po/en@quot/LC_MESSAGES/R-modelit.mo index a9fb0b627557da6544cfa756c3a40eb2254309cf..153327a1d145e3b08afc77f636a1f07485f41684 100644 GIT binary patch literal 8218 zcmeH~TZ|-C8OM(T3WIFgfyR$It&a%$VB5Gi$={ntAY;{#n zRdw$SiHMg(OiWBPqDU}2h(QdA24jd1K0!i=AsS-{UO@2{I|p2R<%&2Kg)fTM6bybGQJe^&C> z@C@>Qf^UE?l=&CoY2;5i*_hMex$tf95~vQx;UxSCyaJw1qu0T`@C0}-ycm8PQp7wC zRsM?VI69ET2Wf%m|3;LoAzJzMgxutxsxZ~~5;YRubV3(}_NT16P^d}hv&nGAyP6=mwX1& zr1=9p3qB8}x0A_S1P7tUJpGUC}dXJZU0%|^f1Ete5m@KNA-B9CMgz`%W zW$#MK+o9&+t5EIT2dnUVP~&|XN{7FNn)g$ftZi^#$IsvbT zpMuiqFQEMNCPX8ho)0yyolt&RfzsP2AVV>qhSKTRq3nOC%s&DzC;vOB@mzo?RBr@g zsu_iQ;Wbcp-3cjb9);Jz-@_$1LE{g?2cZ1my}Qt9Qu1!7_m4t`W}bu$!8`}0)6?Hm z@JuM3oDGqbxfs%g*$$=Cd8lzOL+SJjP~-VBluqw~7sC6Xbov;SPM?FC2bGmxL4knJMZ$*C}ZDz@ECGwXFa&P!}J$`UV18*$Qhz6~OqwVZ9o zz6&d<)!T09jo3J`D{;4|n07mza3wDnCqXlaywLhy=A|xEeZ5n5vSx;N4Oi35%Yrlu z>f?5>Hr%vvRM3n3;)ma`RXf}nwmmQGI!dKxHD`vi^1XiD8ZV}`TZ?jL#MC_BU#Q1n zG!`%^$t$>J#$L}Bf~XOv3t@ZHkga=B6z9&-5LY_R zPTER6c8!Y7V(Zzo+irWwN-b;;*mY05c(bc#HG3d+tF^MgU#Z}cG{Yv@Ak90~i z^rE^u%q=waa(*#WGds*wy%o4#KIo|DlBT0NZV4Uwt83zshnezkuFc&zcB7e!tVIdsBKXb!r<)+_shFin)^hcHpzzTW#;4vvI>Vx=}p~5MW-+ zD^$(|_2RInMx$=qB|#m5C4uH5*T0S8L$$TGI-%6@FI8P#XRGxO1zF3Ey=;H+%ectw zbiF{nGSe)mwwF1xt3RZh2Gg6+L#Gob8M7&oG(wc5ag>vr*33-16Q^mQcjz%63oCYP z=SGX#al-c&?ptS@nTdSYar{H7eGl0RuQQj_T_-bpf=B@+j~!-D+^p^i4!SUC#j&4f z!}ZxiF0qSo7ZGpTF*9Ul6>zNIFtgn-3p&_0JU5IC%AirTo_{kz3l*$?&%U~sp%(py z&LgU&OI0P;YrmL0X-~ z7FN%zTk{bYEOx{2D5Z{#!(OeGtd+#wW^3IJ^Ezf?F>uSBIAXj3`%-_v>`ZM`r71x} zD=ss8yX{3hPFM)=JbP3erCJpAwUt+fqP#KiOztt@o|MWw}VMu^bP z$F>p@(`#mK|Fp?t*qjS#xaTaNBHv5=BBYr)mj-?p^9bP8xKS-dTlUxgnrc0)Wr&hZ zqU6UFCP(sMdBeJ|8+$01O@FWTC2SUjVjw^KxNY|LEt*!4HS;cMn|UJXV5-sO(Z0tP zRcuN6(1^n@K9t8^%CdnFBiaG0g}_M+sZcbnC=ln<7APvPwQ4O@2Ga@#rFr}PNZs$m z?ss9MiZw}=hhVm%vPfRMSciU$@v^BuIr%s3&Xd^DBy4M?=}^;2;$Gmpemq-9JFZ@a zKb>I$Vxx`=ve>gM4%vtb(k!9(nmG_9t{!tpxP_Tj`y)lOi_Cs*N@c`Wh!Kq-Lr2Oi zEh&mtM#^2UlGeS@g>gL>R7HKNe2Z0G`8Qg(hqX(`^*BD5<|fd7$iAAOQCXx9>+}8Y z^Fy4B@w!=Dj}z?S1h^pzf0QF$c>wBikYN>75h|`Ir)0z`hTB`0Yeq$Lk2j@n$3{j| zmDXf2v;c7@90knro*svoDEt%&gA%)$3fMjcUAza6x8AYg=mD z2licCo#T+8Pt~0q5XSA;=CQ5S&D*P^+wAC;@vU12_OMM>=XK^MIK|1hok9;BCIXbp zsexme!lCmi$k-88b>4aHan@htR^N@|j)B>k+37VyMr)e~cEs9dXr84rZZpmwmv%xg zh$eDxb3vFqFu$vM*;={$>fw^=bX1Rhmf*O(Y%$0N_J!TV3#+@hex&r=$+PL?*aT-5 zeVN=8*$XG_=+MM~dFHmS72Z4Qh31*t?p%#7|L0d4oTjS>9?_ondagCp)Wt?M|5vXz z46(S}9O0h-gzF8~Eo0d6E6(vN&haabJ$}VGmRB5NOL@u3YKRkV$^@N{&LiRS6-0v?5e@#C5e~E{+fjKtw~xg-P6;` z4XuG*NdN9IrW0Q#aG)(E8qI$*o3(_h$?IZ({L13z!OZzDbzSo ztiZSEV1Bd4i7IsPv>J0zm9`;^Hpfr{cA^K*;2|7DP4Eo$x!0JFQEbCcs6u^Ibqc%i zEKcAZOiQ6K<~I*G*^A@26W{9ruHZIIOEqRYmZG*efSGs#6Fk6^apCfMdUBGT&>u}K|AI_?Nkl2SW|}qY_jiP z!w#;mqavL{MViW>`h2sS{ntr5H!ATYD$^lUrms+iy+cK?fQ(_jp?2sm>iel&RA4r$ z@S~^#TTv69Min}YifRNk-aYNVGJV7iWjc+TV8#AmN=7_WHy-D{4^`+DRHl!yA6GGg zm&k>$ni6JLq<-6O)cu>NNJmkTJ`Z!kBFr2r(~qc3f1xr>&yHv6$6~IJpbyWXGQELX zu@<3m_Rx#ye)`6yRjZZ7iN(2}bIl*y!YccLicsaeE9RhmZyy%e=URnYU7Xm_%kcnR z8Skd6sn}Y&isd~v)EO%n48P>q{}Lk5`yby5ZHsd1iU@Zj!Yu**HLWSMdvb)cUddee1p5gUz2mb*^TbyD5 diff --git a/inst/po/fr/LC_MESSAGES/R-modelit.mo b/inst/po/fr/LC_MESSAGES/R-modelit.mo index c29a7bfca1c58948cb91725566a24f2e50846a47..c2d514d959d955b288f92dd3a20a98e24b14b3b7 100644 GIT binary patch literal 5504 zcmb`KTWlOx8GsKZl-4a2!lhi=atH}dHkpm%=2n*!630#~*@&?9SQsq;px% z#fcG$f&>y$g_M^{g*Fm>sEBz0K}95}^1{CHhCsZ4K#E%R0f7LiNT4F|{WE9mb>qbr zFv|GbGjryg|9<}be(RR!71tBo4{_grmr}Fv?RWEs>*RZsIs_-+z3^+6&%p;6KM&sp zUx7#9_u%K@8}J<5ako;k)K}qlcop6QU$M`B0QWQgG5iR8)4uLF7m7UF;3wf3D0+tQ*7 z6#OI1;1}S9_bJ6c^|Iv;q3C-Hiamb`Pr_eWK7{boj13fj--LVM&mdFOoA&uzP`>*I z6#0)4M3_!}8A?30_%i|*q3Hi3_(Av!%imf4*;0&wN@^>t!$+XVHw8t{({L0nK#Aj@ zK=JpVpoZI7T>Li%WgJ79e+`Pie+|Wc&ern%8CYYSK#BM3Q1tyR6u6eGiho~*!|)aqzy1Xxg1Ya+rJN62o`Aek3sC(24JdMb z6Ar;wq1gR(xEKBn?uXk*GV%M9Q0ye{?!(-olUxqB_@}xs zXR)v7D*K2nG`GYYCQxi&Tp#7H=>2FpEPN#P5S=CeMP|9gCUV`wE%ue%q$CtEE%x2c zE&e173jM{Wa*0pmBD~ZAZn3$<*=}y}vs|LT#JpUOlqmj6{D`gPl9-e@6q|})B*x_W z6u0=Lx+JG1e^qU~=A@aM`Dx}iNA!+*t*zszq#JqV53i*iUF+2Jq8sFfS*cnXsaj^A z%dabOBduR4=i!vPxtt|#Gdu4`tvEd&1?kRRy6HyR?R0`AHsVhZYS}2w!_ZBZ>I~z? zMbpgcoBEn1*L*JHjlPfK%nFb#b&Niu2it)gHO-*TV(qR-!cqge=c<-HIx(t_Hs^h_ zXguAFqeYXn4WILMU=mrVw4*xeU98VMGyIG?#uuY#UFeHJqO=t!sI9};Gl9P3XY+a( zqb0uE2u!MZtE2c*U5&1{x;kzaec48h;k3}rj2h3QX6EC!3p>&aDA4J|NroZBzO4W! z$hy`pX%!v~Zy_#(8CRu2rY@^*< zah^C#c0+?1br83Uy&Ul`QlM;$A6^`)*-E0ZLZUg7glZ0Z??^?vqN**rejvGCFJ4HM$pd%gt)4YO%VC)$ z^P{$wT4|>g)5`?%Vs@3qDyyoq9kQ}F^RbyWrDt?VitC2a5$WKmo;T?`USXJ4qL6My zS^`}T2i9Js-ecq9<(dWc9dj~!xKJ(6%bxvLTb;4Nl9yK`rA8MANYZ-<*t)5vlUU9r zXTo#NnM6v?NSStiruWtN*AER$pLS-b&GO1QPF)_+!$ZRdoS{R`zJq$-fsx_Ib`K2? z4Gm0E^_)352Z*&e8PPn6+BpI1%o#WA8IR!nfvJh9vDGd2)rST+7bp#^!TB|!GYb6P zPT=~{omZSWCUM51X6)hn5q-GfX9G_;Crl)nBtlHb#zU1y>jwuU z)QXm1A*ZU3*R&1JG*8Noz+|>F@B&%`+5*EHkGV7n%uUs~-bcNothRPkb`1S`1s#!y zx37L%`UPKvS;%FS7d|10iC{#jdIyGey?)#9-z>CV^MX7bL;0u#O0hi*FBCll z(&_GZb|<(s^!$_mG+cI6c9E}No_nC9@& z0lO5nE6Vmrw^j+Y(pr#Gg`p6Gr0(9}Y-W$17K8e*DhGb+*;^g&F5CXXI?+g*Ap%Ug z)QfdG4THYoo#OQLq-crm6ql;?sH@Y77e^6`6v`rhc}N)PA`1EF2)fHI<+qB8bFu z)sgg{k#v_=I*^qEQX=)v4u;6nSj>s>_Pg^wCzX#3IDTs5U1}N9A3>Tqy}w3ZQAZVO@|58C@0t; zfsO?!DO5>}DeXshS)9^crU45ZJo5&9Mpf_8k!-ATC#m9TQv6W%AGfc*WIK@CSFdYX zzi2`@8;S3p9c?GlUGC{b#+sbdMRg$(>0Y|a(t)IEHV#7s;Sm$$>6+J-5RwlopNw%@ zcmzuCI!s*Cm-N}ruBQuCi~k-=i?jGIOi>Ev-JF6@l!7eIQ!W3G>MmRVVWOCxj^4ie zeMyrD6QTk|aC0;3{GaPirNIjcg4iYv{GJq~dY4Nmulq+>A^F)A7Q&a~34 lJtoy^H?wv-v;KZP^Ea_)wdG~8Q;&e<8CJAJdG9H!{td&;M}PnT delta 876 zcmYk)!D|yi6vy!wlWuLYHg%h7)mD=VVjFEuu!w1bmLN72i+ZpgLQfvF;>CX;dJ$2f zhgXle^)Awbh&PWS>PZkpLB&fwd8&fw_qScaVP`%w!|u$RH+#GMz0mm>WgZ!2j5XK1!#D;ZzHf*w#dSP{&v64k<7s>ynC-wkFUe6Pb}J|2sbt*1Ip$|kC%=z*T*Vsu z+Zr83_6c|5W@45!Xgq>BoJ2)lLuKST7V!o)@FD7?FHsqJgF46utfO|%LIXL2&0%LB zodr5oTt;o!#c_O$6ZjsL@(f?=q|tSKW?-iDPacKN6LuXUA diff --git a/po/R-fr.mo b/po/R-fr.mo index c29a7bfca1c58948cb91725566a24f2e50846a47..c2d514d959d955b288f92dd3a20a98e24b14b3b7 100644 GIT binary patch literal 5504 zcmb`KTWlOx8GsKZl-4a2!lhi=atH}dHkpm%=2n*!630#~*@&?9SQsq;px% z#fcG$f&>y$g_M^{g*Fm>sEBz0K}95}^1{CHhCsZ4K#E%R0f7LiNT4F|{WE9mb>qbr zFv|GbGjryg|9<}be(RR!71tBo4{_grmr}Fv?RWEs>*RZsIs_-+z3^+6&%p;6KM&sp zUx7#9_u%K@8}J<5ako;k)K}qlcop6QU$M`B0QWQgG5iR8)4uLF7m7UF;3wf3D0+tQ*7 z6#OI1;1}S9_bJ6c^|Iv;q3C-Hiamb`Pr_eWK7{boj13fj--LVM&mdFOoA&uzP`>*I z6#0)4M3_!}8A?30_%i|*q3Hi3_(Av!%imf4*;0&wN@^>t!$+XVHw8t{({L0nK#Aj@ zK=JpVpoZI7T>Li%WgJ79e+`Pie+|Wc&ern%8CYYSK#BM3Q1tyR6u6eGiho~*!|)aqzy1Xxg1Ya+rJN62o`Aek3sC(24JdMb z6Ar;wq1gR(xEKBn?uXk*GV%M9Q0ye{?!(-olUxqB_@}xs zXR)v7D*K2nG`GYYCQxi&Tp#7H=>2FpEPN#P5S=CeMP|9gCUV`wE%ue%q$CtEE%x2c zE&e173jM{Wa*0pmBD~ZAZn3$<*=}y}vs|LT#JpUOlqmj6{D`gPl9-e@6q|})B*x_W z6u0=Lx+JG1e^qU~=A@aM`Dx}iNA!+*t*zszq#JqV53i*iUF+2Jq8sFfS*cnXsaj^A z%dabOBduR4=i!vPxtt|#Gdu4`tvEd&1?kRRy6HyR?R0`AHsVhZYS}2w!_ZBZ>I~z? zMbpgcoBEn1*L*JHjlPfK%nFb#b&Niu2it)gHO-*TV(qR-!cqge=c<-HIx(t_Hs^h_ zXguAFqeYXn4WILMU=mrVw4*xeU98VMGyIG?#uuY#UFeHJqO=t!sI9};Gl9P3XY+a( zqb0uE2u!MZtE2c*U5&1{x;kzaec48h;k3}rj2h3QX6EC!3p>&aDA4J|NroZBzO4W! z$hy`pX%!v~Zy_#(8CRu2rY@^*< zah^C#c0+?1br83Uy&Ul`QlM;$A6^`)*-E0ZLZUg7glZ0Z??^?vqN**rejvGCFJ4HM$pd%gt)4YO%VC)$ z^P{$wT4|>g)5`?%Vs@3qDyyoq9kQ}F^RbyWrDt?VitC2a5$WKmo;T?`USXJ4qL6My zS^`}T2i9Js-ecq9<(dWc9dj~!xKJ(6%bxvLTb;4Nl9yK`rA8MANYZ-<*t)5vlUU9r zXTo#NnM6v?NSStiruWtN*AER$pLS-b&GO1QPF)_+!$ZRdoS{R`zJq$-fsx_Ib`K2? z4Gm0E^_)352Z*&e8PPn6+BpI1%o#WA8IR!nfvJh9vDGd2)rST+7bp#^!TB|!GYb6P zPT=~{omZSWCUM51X6)hn5q-GfX9G_;Crl)nBtlHb#zU1y>jwuU z)QXm1A*ZU3*R&1JG*8Noz+|>F@B&%`+5*EHkGV7n%uUs~-bcNothRPkb`1S`1s#!y zx37L%`UPKvS;%FS7d|10iC{#jdIyGey?)#9-z>CV^MX7bL;0u#O0hi*FBCll z(&_GZb|<(s^!$_mG+cI6c9E}No_nC9@& z0lO5nE6Vmrw^j+Y(pr#Gg`p6Gr0(9}Y-W$17K8e*DhGb+*;^g&F5CXXI?+g*Ap%Ug z)QfdG4THYoo#OQLq-crm6ql;?sH@Y77e^6`6v`rhc}N)PA`1EF2)fHI<+qB8bFu z)sgg{k#v_=I*^qEQX=)v4u;6nSj>s>_Pg^wCzX#3IDTs5U1}N9A3>Tqy}w3ZQAZVO@|58C@0t; zfsO?!DO5>}DeXshS)9^crU45ZJo5&9Mpf_8k!-ATC#m9TQv6W%AGfc*WIK@CSFdYX zzi2`@8;S3p9c?GlUGC{b#+sbdMRg$(>0Y|a(t)IEHV#7s;Sm$$>6+J-5RwlopNw%@ zcmzuCI!s*Cm-N}ruBQuCi~k-=i?jGIOi>Ev-JF6@l!7eIQ!W3G>MmRVVWOCxj^4ie zeMyrD6QTk|aC0;3{GaPirNIjcg4iYv{GJq~dY4Nmulq+>A^F)A7Q&a~34 lJtoy^H?wv-v;KZP^Ea_)wdG~8Q;&e<8CJAJdG9H!{td&;M}PnT delta 876 zcmYk)!D|yi6vy!wlWuLYHg%h7)mD=VVjFEuu!w1bmLN72i+ZpgLQfvF;>CX;dJ$2f zhgXle^)Awbh&PWS>PZkpLB&fwd8&fw_qScaVP`%w!|u$RH+#GMz0mm>WgZ!2j5XK1!#D;ZzHf*w#dSP{&v64k<7s>ynC-wkFUe6Pb}J|2sbt*1Ip$|kC%=z*T*Vsu z+Zr83_6c|5W@45!Xgq>BoJ2)lLuKST7V!o)@FD7?FHsqJgF46utfO|%LIXL2&0%LB zodr5oTt;o!#c_O$6ZjsL@(f?=q|tSKW?-iDPacKN6LuXUA diff --git a/po/R-fr.po b/po/R-fr.po index 9e4fba0..14333c7 100644 --- a/po/R-fr.po +++ b/po/R-fr.po @@ -1,8 +1,8 @@ msgid "" msgstr "" "Project-Id-Version: modelit 1.4.7\n" -"POT-Creation-Date: 2025-07-14 12:27\n" -"PO-Revision-Date: 2025-07-11 15:19+0200\n" +"POT-Creation-Date: 2025-07-16 14:55\n" +"PO-Revision-Date: 2025-07-16 15:29+0200\n" "Last-Translator: \n" "Language-Team: \n" "Language: fr\n" @@ -53,6 +53,15 @@ msgstr "" msgid "You must give either 'h=' or 'v='." msgstr "" +msgid "lang is not defined" +msgstr "" + +msgid "langue" +msgstr "" + +msgid "pas en cache" +msgstr "" + msgid "Term" msgstr "Terme" @@ -71,7 +80,6 @@ msgstr "Ecart type" msgid "t value" msgstr "Valeur de *t*" -#, fuzzy msgid "RSE" msgstr "RSE" @@ -111,6 +119,9 @@ msgstr "N" msgid "Intercept" msgstr "Ordonnée à l’origine" +msgid "fr" +msgstr "Fr" + msgid "Package 'data.io' is required but not installed." msgstr "Le package “data.io” est requis mais n'est pas installé." @@ -127,7 +138,7 @@ msgid "The following terms are missing in 'labs' for the interaction '%s': %s" msgstr "" msgid "," -msgstr "" +msgstr "," msgid "Linear model" msgstr "Modèle linéaire" @@ -144,6 +155,15 @@ msgstr "*R*^2^ multiple : %.*g - *R*^2^ ajusté : %.*g" msgid "*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s" msgstr "Statistique *F* : %.*g sur %.*g et %.*g ddl - valeur de *p* : %s" +msgid ".extract_infos_nls() can apply only lm and summary.lm object." +msgstr ".extract_infos_nls() ne s’applique qu’au objet nls et summary.nls. " + +msgid "" +".extract_infos_lm() cannot apply type = 'coef' to a summary.lm\n" +" object. Use type = 'tidy' instead to extract a detailed " +"coefficient table." +msgstr "" + msgid "Not implemented yet" msgstr "Ce n'est pas encore implémenté" @@ -172,13 +192,83 @@ msgid "The %s is not available." msgstr "Le %s n'est pas disponible." msgid "var_names is not character vector" -msgstr "" +msgstr "var_names n’est pas une vecteur de caractère" msgid "var_names must be named character vector" -msgstr "" +msgstr "var_names doit être un vecteur de caractère nommé" msgid "all elements must be named" +msgstr "Tous les éléments doivent être nommé." + +msgid "*t*~obs.~ value" +msgstr "Valeur de *t*~obs.~" + +msgid "Relative standard error" +msgstr "Ecart type des résidus" + +msgid "Convergence tolerance" +msgstr "Tolérance de convergence" + +msgid "Log-Likelihood" +msgstr "Log-vraisemblance" + +msgid "df" +msgstr "Degrés de liberté" + +msgid "Nonlinear least squares asymptotic regression model (von Bertalanffy)" +msgstr "Modèle non linéaire de régression asymptotique (von Bertalanffy)" + +msgid "Nonlinear least squares asymptotic regression model (von Bertalanffy)" +msgstr "Modèle non linéaire de régression asymptotique (von Bertalanffy)" + +msgid "" +"Nonlinear least squares asymptotic regression model through the origin (von " +"Bertalanffy)" +msgstr "" +"Modèle non linéaire de régression asymptotique forcée à l'origine (von " +"Bertalanffy)" + +msgid "Nonlinear least squares biexponential model" +msgstr "Modèle non linéaire biexponentiel" + +msgid "Nonlinear least squares first-order compartment model" +msgstr "Modèle non linéaire à compartiments du premier ordre" + +msgid "Nonlinear least squares four-parameter logistic model" +msgstr "Modèle non linéaire logistique à quatre paramètres" + +msgid "Nonlinear least squares Gompertz model" +msgstr "Modèle non linéaire de Gompertz" + +msgid "Nonlinear least squares logistic model" +msgstr "Modèle non linéaire logistique" + +msgid "Nonlinear least squares Michaelis-Menten model" +msgstr "Modèle non linéaire de Michaelis-Menten" + +msgid "Nonlinear least squares Weibull model" +msgstr "Modèle non linéaire de Weibull" + +msgid "Residual sum-of-squares: %.*g" +msgstr "Somme des carrés des résidus : %.*g" + +msgid "Number of iterations to convergence: %.*g" +msgstr "Nombre d'itérations pour converger : %.*g" + +msgid "Achieved convergence tolerance: %.*g" +msgstr "Tolérance atteinte à la convergence : %.*g" + +msgid "The model does not converge" +msgstr "Le modèle ne converge pas" + +msgid ".extract_infos_nls() can apply only nls and summary.nls object." +msgstr ".extract_infos_nls() ne s’applique qu’au objet nls et summary.nls. " + +msgid "" +".extract_infos_nls() cannot apply type = 'glance' to a summary.nls\n" +" object." msgstr "" +"extract_infos_nls() ne peut appliquer type=‘lance’ à un objet summary.nls." msgid "add_header_nls()" msgstr "" diff --git a/po/R-modelit.pot b/po/R-modelit.pot index 1275b2d..b85432a 100644 --- a/po/R-modelit.pot +++ b/po/R-modelit.pot @@ -1,7 +1,7 @@ msgid "" msgstr "" "Project-Id-Version: modelit 1.4.7\n" -"POT-Creation-Date: 2025-07-14 12:27\n" +"POT-Creation-Date: 2025-07-16 14:55\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -43,6 +43,15 @@ msgstr "" msgid "You must give either 'h=' or 'v='." msgstr "" +msgid "lang is not defined" +msgstr "" + +msgid "langue" +msgstr "" + +msgid "pas en cache" +msgstr "" + msgid "Term" msgstr "" @@ -100,6 +109,9 @@ msgstr "" msgid "Intercept" msgstr "" +msgid "fr" +msgstr "" + msgid "Package 'data.io' is required but not installed." msgstr "" @@ -133,6 +145,12 @@ msgstr "" msgid "*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s" msgstr "" +msgid ".extract_infos_nls() can apply only lm and summary.lm object." +msgstr "" + +msgid ".extract_infos_lm() cannot apply type = 'coef' to a summary.lm\n object. Use type = 'tidy' instead to extract a detailed coefficient table." +msgstr "" + msgid "Not implemented yet" msgstr "" @@ -169,6 +187,69 @@ msgstr "" msgid "all elements must be named" msgstr "" +msgid "*t*~obs.~ value" +msgstr "" + +msgid "Relative standard error" +msgstr "" + +msgid "Convergence tolerance" +msgstr "" + +msgid "Log-Likelihood" +msgstr "" + +msgid "df" +msgstr "" + +msgid "Nonlinear least squares asymptotic regression model (von Bertalanffy)" +msgstr "" + +msgid "Nonlinear least squares asymptotic regression model (von Bertalanffy)" +msgstr "" + +msgid "Nonlinear least squares asymptotic regression model through the origin (von Bertalanffy)" +msgstr "" + +msgid "Nonlinear least squares biexponential model" +msgstr "" + +msgid "Nonlinear least squares first-order compartment model" +msgstr "" + +msgid "Nonlinear least squares four-parameter logistic model" +msgstr "" + +msgid "Nonlinear least squares Gompertz model" +msgstr "" + +msgid "Nonlinear least squares logistic model" +msgstr "" + +msgid "Nonlinear least squares Michaelis-Menten model" +msgstr "" + +msgid "Nonlinear least squares Weibull model" +msgstr "" + +msgid "Residual sum-of-squares: %.*g" +msgstr "" + +msgid "Number of iterations to convergence: %.*g" +msgstr "" + +msgid "Achieved convergence tolerance: %.*g" +msgstr "" + +msgid "The model does not converge" +msgstr "" + +msgid ".extract_infos_nls() can apply only nls and summary.nls object." +msgstr "" + +msgid ".extract_infos_nls() cannot apply type = 'glance' to a summary.nls\n object." +msgstr "" + msgid "add_header_nls()" msgstr "" From 8c6e4317a70b358621bfb1e1ef2a4de49dc5338e Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 16 Jul 2025 16:55:08 +0200 Subject: [PATCH 10/22] new version for nls object and progress on make_translation --- R/tabularise.lm.R | 119 +++-- R/tabularise.nls.R | 742 +++++++++++++----------------- man/equation.nls.Rd | 9 +- man/tabularise_coef.summary.lm.Rd | 3 +- man/tabularise_glance.lm.Rd | 4 +- man/tabularise_glance.nls.Rd | 22 +- man/tabularise_tidy.nls.Rd | 46 +- 7 files changed, 463 insertions(+), 482 deletions(-) diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index fa7efcd..42f43bb 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -179,8 +179,8 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, #' @examples #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$glance(iris_lm) -tabularise_glance.lm <- function(data, header = TRUE, title = NULL, - equation = TRUE, auto.labs = TRUE, origdata = NULL, labs = NULL, +tabularise_glance.lm <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", "en"), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -227,6 +227,7 @@ tabularise_glance.lm <- function(data, header = TRUE, title = NULL, #' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). +#' #' @param footer If `FALSE` (by default), add a footer to the table. #' #' @return A **flextable** object you can print in different formats (HTML, #' LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} functions. @@ -257,7 +258,7 @@ tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, data, type = "tidy", conf.int = conf.int, conf.level = conf.level, show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, title = title, - colnames = colnames_lm, footer = FALSE) + colnames = colnames_lm, footer = footer) # formatted table ---- formate_table(df_list, kind = kind, header = header) @@ -319,44 +320,40 @@ colnames_lm <- c( signif = "", "(Intercept)" = "Intercept") -# .make_traduction <- function() { -# .trad <- list() -# traduction_fun <- function(lang = "en") { -# res <- .trad[[lang]] -# if(is.null(res)) { -# message("langue ", lang, " pas en cache") -# res <- gettext(term = "Term", -# estimate = "Estimate", -# conf.low = "Lower bound (CI)", -# conf.high = "Upper bound (CI)", -# std.error = "Standard Error", -# t.value = "t value", -# sigma = "RSE", -# r.squared = "R^2^", -# adj.r.squared = "Adj.R^2^", -# AIC = "AIC", -# BIC = "BIC", -# deviance = "Deviance", -# logLik = "Log-likelihood", -# statistic = "*t* value", -# p.value = "*p* value", -# df = "Model df", -# df.residual = "Residuals df", -# nobs = "N", -# "(Intercept)" = "Intercept", lang = lang, -# domain = "R-modelit") -# .trad2 <- .trad -# .trad2[[lang]] <- res -# .trad <<- .trad2 # super assignation -# } -# res -# } -# traduction_fun -# } -# -# .traduction <- .make_traduction() +library(svMisc) +# Migrer dans svMisc +.make_translation <- function() { + .trad <- list() + translation_fun <- structure(function(expr, lang = NULL, type = "lm", clear_cache = FALSE) { + if (isTRUE(clear_cache)) { + .trad <<- list() + if (missing(expr)) + return() + } + + if (is.null(lang)) { + lang <- substitute(expr)[["lang"]] + if (is.null(lang)) + stop("lang is not defined") + } -.trad <- gettext(term = "Term", + slot <- paste(lang, type[[1]], sep = "-") + res <- .trad[[slot]] + if (is.null(res)) { + message("langue ", lang, " pas en cache") + res <- eval(expr) + .trad2 <- .trad + .trad2[[slot]] <- res + .trad <<- .trad2 # super assignation + } + res + }, class = c("function", "subsettable_type")) + translation_fun +} + +.translation <- .make_translation() + +.translation$lm(gettext(term = "Term", estimate = "Estimate", conf.low = "Lower bound (CI)", conf.high = "Upper bound (CI)", @@ -374,7 +371,34 @@ colnames_lm <- c( df = "Model df", df.residual = "Residuals df", nobs = "N", - "(Intercept)" = "Intercept") + "(Intercept)" = "Intercept", lang = "fr")) + +.translation(clear_cache = TRUE) +environment(.translation)$.trad +environment(.translation)$.trad -> s + +s$`fr-lm` + +.trads <- gettext(term = "Term", + estimate = "Estimate", + conf.low = "Lower bound (CI)", + conf.high = "Upper bound (CI)", + std.error = "Standard Error", + t.value = "t value", + sigma = "RSE", + r.squared = "R^2^", + adj.r.squared = "Adj.R^2^", + AIC = "AIC", + BIC = "BIC", + deviance = "Deviance", + logLik = "Log-likelihood", + statistic = "*t* value", + p.value = "*p* value", + df = "Model df", + df.residual = "Residuals df", + nobs = "N", + "(Intercept)" = "Intercept", lang = "fr") +.trads .extract_colnames <- function(df, labs, lang) { vec <- labs[names(labs) %in% names(df)] @@ -533,7 +557,7 @@ colnames_lm <- c( vals } -.extract_title <- function(title, lang = "en") { +.extract_title_lm <- function(title, lang = "en") { res <- NULL if (isTRUE(title)) { @@ -575,10 +599,11 @@ colnames_lm <- c( lang, auto.labs = TRUE, origdata = NULL , labs = NULL, equation = TRUE, title = TRUE, colnames = colnames_lm , footer = FALSE, ...) { + if (!inherits(data, c("lm", "summary.lm"))) + stop(".extract_infos_nls() can apply only lm and summary.lm object.") type <- match.arg(type, choices = c("coef", "glance", "tidy")) - if (inherits(data, "summary.lm") && type == "coef") { message(".extract_infos_lm() cannot apply type = 'coef' to a summary.lm object. Use type = 'tidy' instead to extract a detailed coefficient table.") @@ -626,7 +651,7 @@ colnames_lm <- c( terms <- .extract_terms(df, labs = labels, lang = lang) } - title <- .extract_title(title, lang = lang) + title <- .extract_title_lm(title, lang = lang) if(isTRUE(footer)) { footer <- .extract_footer_lm(data, lang = lang) @@ -674,14 +699,18 @@ colnames_lm <- c( ft <- .add_header2(ft, title = x$title, equation = x$equa) } + # footer and psignif + n <- 0 # use to define align right and left + if (!is.null(x$psignif)) { ft <- .add_signif(ft, x$psignif) + n <- 1 } if (!is.null(x$footer)) { vals <- x$footer ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) - ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", + ft <- align(ft, i = seq_len(length(vals)) + n , align = "left", part = "footer") } diff --git a/R/tabularise.nls.R b/R/tabularise.nls.R index 38b6941..7aadaab 100644 --- a/R/tabularise.nls.R +++ b/R/tabularise.nls.R @@ -5,24 +5,29 @@ #' of [print.summary.nls()] but richly formatted. The [tabularise_coef()] #' function offers more customization options for this object. #' -#' @param data A **summary.nls** object. -#' @param header If `TRUE` (by default), add a header to the table +#' @param data An **nls** object. +#' @param header If `TRUE` (by default), add a title to the table. #' @param title If `TRUE`, add a title to the table header. Default to the same #' value than header, except outside of a chunk where it is `FALSE` if a table #' caption is detected (`tbl-cap` YAML entry). #' @param equation Add equation of the model to the table. If `TRUE`, #' [equation()] is used. The equation can also be passed in the form of a -#' character string (LaTeX equation). -#' @param footer If `TRUE` (by default), add a footer to the table. -#' @param lang The language to use. The default value can be set with, e.g. +#' character string (LaTeX). +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used (only the name of the variables). +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. +#' @param lang The language to use. The default value can be set with, e.g., #' `options(data.io_lang = "fr")` for French. -#' @param show.signif.stars If `TRUE` (by default), add the significance stars -#' to the table. -#' @param ... Additional arguments (Not used). +#' @param footer If `TRUE` (by default), add a footer to the table. +#' @param show.signif.stars If `TRUE`, add the significance stars to the table. +#' The default is `getOption("show.signif.stars")` +#' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). +#' #' @importFrom tabularise tabularise_default colformat_sci #' @importFrom rlang .data #' @method tabularise_default summary.nls @@ -43,10 +48,11 @@ #' #' tabularise::tabularise(chick1_logis_sum) #' tabularise::tabularise(chick1_logis_sum, footer = FALSE) -tabularise_default.summary.nls <- function(data, header = TRUE, title = NULL, - equation = header, footer = TRUE, lang = getOption("data.io_lang", "en"), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", - env = parent.frame()) { +tabularise_default.summary.nls <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", "en"), footer = TRUE, + show.signif.stars = getOption("show.signif.stars", TRUE), ..., + kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -56,45 +62,14 @@ tabularise_default.summary.nls <- function(data, header = TRUE, title = NULL, title <- FALSE } - ft <- tabularise_coef.summary.nls(data, header = header, title = title, - equation = equation, lang = lang, show.signif.stars = show.signif.stars, - kind = kind, env = env) - - # Choose the language - lang <- tolower(lang) - - if (lang != "fr") lang <- "en" # Only en or fr for now - - if (lang == "fr") { - info_lang <- infos_fr.nls - } else { - info_lang <- infos_en.nls - } - - if (isTRUE(footer)) { - footer <- info_lang[["footer"]] - - # Use the same rule of print.summary.nls - digs <- max(3L, getOption("digits") - 3L) + df_list <- .extract_infos_nls( + data, type = "coef", show.signif.stars = show.signif.stars, lang = lang, + auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, + title = title, colnames = colnames_nls, footer = footer) + # print(df_list) # use only for development - val <- paste(footer[["rse"]], ":", format(signif(data$sigma, - digits = digs)), footer[["on"]], data$df[2], footer["df"]) - - conv <- data$convInfo - if (isTRUE(conv$isConv)) { - convinfo <- c( - paste(footer[["nbc"]], ":", conv$finIter), - paste(footer[["ctol"]], ":", format(conv$finTol, - digits = digs))) - val <- c(val, convinfo) - } else { - val <- c(val, footer[["stop"]]) - } - ft <- add_footer_lines(ft, top = FALSE, values = val) - ft <- align(ft, i = seq_len(length(val)) + 1 , align = "left", - part = "footer") - } - ft + # formatted table ---- + formate_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table using the table of coefficients of the summary.nls object @@ -103,23 +78,28 @@ tabularise_default.summary.nls <- function(data, header = TRUE, title = NULL, #' This function extracts and formats the table of coefficients from a #' **summary.nls** object, similar to [stats::coef()], but in flextable object. #' -#' @param data A **summary.nls** object. +#' @param data An **nls** object. #' @param header If `TRUE` (by default), add a title to the table. #' @param title If `TRUE`, add a title to the table header. Default to the same #' value than header, except outside of a chunk where it is `FALSE` if a table #' caption is detected (`tbl-cap` YAML entry). #' @param equation Add equation of the model to the table. If `TRUE`, #' [equation()] is used. The equation can also be passed in the form of a -#' character string (LaTeX equation). +#' character string (LaTeX). +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used (only the name of the variables). +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., #' `options(data.io_lang = "fr")` for French. -#' @param show.signif.stars If `TRUE` (by default), add the significance stars -#' to the table. -#' @param ... Additional arguments passed to [equation()] +#' @param footer If `FALSE` (by default), add a footer to the table. +#' @param show.signif.stars If `TRUE`, add the significance stars to the table. +#' The default is `getOption("show.signif.stars")` +#' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @return A **flextable** object that you can print in different forms or #' rearrange with the \{flextable\} functions. @@ -136,10 +116,11 @@ tabularise_default.summary.nls <- function(data, header = TRUE, title = NULL, #' #' tabularise::tabularise$coef(chick1_logis_sum) #' tabularise::tabularise$coef(chick1_logis_sum, header = FALSE, equation = TRUE) -tabularise_coef.summary.nls <- function(data, header = TRUE, title = NULL, - equation = header, lang = getOption("data.io_lang", "en"), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", - env = parent.frame()) { +tabularise_coef.summary.nls <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", "en"), footer = FALSE, + show.signif.stars = getOption("show.signif.stars", TRUE), ..., + kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -149,51 +130,14 @@ tabularise_coef.summary.nls <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Extract the coef and rework it to obtain a data.frame - co <- as.data.frame(coef(data)) - res <- cbind(term = rownames(co), co) - names(res) <- c("term", "estimate", "std.error", "statistic", "p.value") - - # Choose the language - lang <- tolower(lang) - - if (lang != "fr") - lang <- "en" # Only en or fr for now - - if (lang == "fr") { - info_lang <- infos_fr.nls - } else { - info_lang <- infos_en.nls - } - - # Use flextable - if (isTRUE(show.signif.stars)) { - ft <- flextable(res, col_keys = c(names(res), "signif")) - } else { - ft <- flextable(res) - } - ft <- colformat_sci(ft) - ft <- colformat_sci(ft, j = "p.value", lod = 2e-16) - - # Change labels - ft <- header_labels(ft, lang = lang) - - # Add information on the p.value - if (ncol_keys(ft) > ncol(res)) - ft <- add_signif_stars(ft, j = "signif") - - # Add headers - ft <- add_header_nls(ft, data = data, header = header, title = title, - equation = equation, lang = lang, ...) + df_list <- .extract_infos_nls( + data, type = "coef", show.signif.stars = show.signif.stars, lang = lang, + auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, + title = title, colnames = colnames_nls, footer = footer) + # print(df_list) # use only for development - ft <- autofit(ft, part = c("header", "body")) - if (isTRUE(show.signif.stars)) - ft <- width(ft, j = "signif", width = 0.4) - - if (isTRUE(equation) | is.character(equation)) - ft <- italic(ft, j = "term",part = "body") - - ft + # formatted table ---- + formate_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from a nls object @@ -209,15 +153,19 @@ tabularise_coef.summary.nls <- function(data, header = TRUE, title = NULL, #' caption is detected (`tbl-cap` YAML entry). #' @param equation Add equation of the model to the table. If `TRUE`, #' [equation()] is used. The equation can also be passed in the form of a -#' character string (LaTeX equation). -#' @param footer If `TRUE` (by default), add a footer to the table. +#' character string (LaTeX). +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used (only the name of the variables). +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., #' `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments. Not used. +#' @param footer If `TRUE` (by default, it is TRUE), add a footer to the table. +#' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @return A **flextable** object that you can print in different forms or #' rearrange with the \{flextable\} functions. @@ -232,9 +180,9 @@ tabularise_coef.summary.nls <- function(data, header = TRUE, title = NULL, #' chick1_logis <- nls(data = chick1, weight ~ SSlogis(Time, Asym, xmid, scal)) #' #' tabularise::tabularise(chick1_logis) -tabularise_default.nls <- function(data, header = TRUE, title = NULL, - equation = header, footer = TRUE, lang = getOption("data.io_lang", "en"), - ..., kind = "ft", env = parent.frame()) { +tabularise_default.nls <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", "en"), footer = TRUE, ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -244,47 +192,14 @@ tabularise_default.nls <- function(data, header = TRUE, title = NULL, title <- FALSE } - ft <- tabularise_coef.nls(data, header = header, title = title, - equation = equation, lang = lang, kind = kind, env = env) - - # Choose the language - lang <- tolower(lang) - - if (lang != "fr") - lang <- "en" # Only en or fr for now - - if (lang == "fr") { - info_lang <- infos_fr.nls - } else { - info_lang <- infos_en.nls - } - - # Add footer - if (isTRUE(footer)) { - footer <- info_lang[["footer"]] - - # Use the same rule of print.summary.nls - digs <- max(3L, getOption("digits") - 3L) - - val <- paste(footer[["rss"]], ":", format(signif(data$m$deviance(), - digits = digs))) - - conv <- data$convInfo - if (isTRUE(conv$isConv)) { - convinfo <- c( - paste(footer[["nbc"]], ":", conv$finIter), - paste(footer[["ctol"]], ":", format(conv$finTol, - digits = digs))) - val <- c(val, convinfo) - } else { - val <- c(val, footer[["stop"]]) - } - - ft <- add_footer_lines(ft, top = FALSE, values = val) - ft <- align(ft, align = "left", part = "footer") - } + df_list <- .extract_infos_nls( + data, type = "coef", show.signif.stars = FALSE, lang = lang, + auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, + title = title, colnames = colnames_nls, footer = footer) + # print(df_list) # use only for development - autofit(ft, part = c("header", "body")) + # formatted table ---- + formate_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table using the coefficients of the nls object @@ -298,14 +213,21 @@ tabularise_default.nls <- function(data, header = TRUE, title = NULL, #' @param title If `TRUE`, add a title to the table header. Default to the same #' value than header, except outside of a chunk where it is `FALSE` if a table #' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add the equation of the model +#' @param equation Add equation of the model to the table. If `TRUE`, +#' [equation()] is used. The equation can also be passed in the form of a +#' character string (LaTeX). +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used (only the name of the variables). +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., #' `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments. +#' @param footer If `TRUE` (by default, it is TRUE), add a footer to the table. +#' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @return A **flextable** object that you can print in different forms or #' rearrange with the \{flextable\} functions. @@ -320,9 +242,9 @@ tabularise_default.nls <- function(data, header = TRUE, title = NULL, #' chick1_logis <- nls(data = chick1, weight ~ SSlogis(Time, Asym, xmid, scal)) #' #' tabularise::tabularise$coef(chick1_logis) -tabularise_coef.nls <- function(data, header = TRUE, title = NULL, - equation = header, lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { +tabularise_coef.nls <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", "en"), footer = TRUE, ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -332,28 +254,15 @@ tabularise_coef.nls <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Choose the language - lang <- tolower(lang) - - if (lang != "fr") - lang <- "en" # Only en or fr for now + df_list <- .extract_infos_nls( + data, type = "coef", show.signif.stars = FALSE, lang = lang, + auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, + title = title, colnames = colnames_nls, footer = footer) + # print(df_list) # use only for development - if (lang == "fr") { - info_lang <- infos_fr.nls - } else { - info_lang <- infos_en.nls - } + # formatted table ---- + formate_table(df_list, kind = kind, header = header) - co <- data.frame(rbind(coef(data))) - - ft <- flextable(co) |> - colformat_sci() - - # Add headers - ft <- add_header_nls(ft, data = data, header = header, title = title, - equation = equation, lang = lang) - - autofit(ft, part = c("header", "body")) } #' Tidy version of the nls object into a flextable object @@ -364,12 +273,28 @@ tabularise_coef.nls <- function(data, header = TRUE, title = NULL, #' formatted as an (almost) publication-ready form (good for informal reports, #' notebooks, etc). #' -#' @param data A **nls** object -#' @param ... arguments of [tabularise_coef.summary.nls()] +#' @param data An **nls** object. +#' @param header If `TRUE` (by default), add a title to the table. +#' @param title If `TRUE`, add a title to the table header. Default to the same +#' value than header, except outside of a chunk where it is `FALSE` if a table +#' caption is detected (`tbl-cap` YAML entry). +#' @param equation Add equation of the model to the table. If `TRUE`, +#' [equation()] is used. The equation can also be passed in the form of a +#' character string (LaTeX). +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used (only the name of the variables). +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. +#' @param lang The language to use. The default value can be set with, e.g., +#' `options(data.io_lang = "fr")` for French. +#' @param show.signif.stars If `TRUE`, add the significance stars to the table. +#' The default is `getOption("show.signif.stars")` +#' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). +#' #' @seealso [tabularise::tabularise()], [tabularise::tabularise_tidy()], #' [tabularise_coef.summary.nls()] #' @return A **flextable** object that you can print in different forms or @@ -387,9 +312,28 @@ tabularise_coef.nls <- function(data, header = TRUE, title = NULL, #' #' tabularise::tabularise$tidy(chick1_logis) #' tabularise::tabularise$tidy(chick1_logis, lang = "fr") -tabularise_tidy.nls <- function(data, ..., kind = "ft", env = parent.frame()) { - data <- summary(data) - tabularise_coef.summary.nls(data, ..., kind = kind, env = env) +tabularise_tidy.nls <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., + kind = "ft") { + + # If title is not provided, determine if we have to use TRUE or FALSE + if (missing(title)) { + title <- header # Default to same as header, but... + # if a caption is defined in the chunk, it defauts to FALSE + if (!is.null(knitr::opts_current$get('tbl-cap'))) + title <- FALSE + } + + df_list <- .extract_infos_nls( + data, type = "tidy", show.signif.stars = show.signif.stars, lang = lang, + auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, + title = title, colnames = colnames_nls, footer = FALSE) + # print(df_list) # use only for development + + # formatted table ---- + formate_table(df_list, kind = kind, header = header) } #' Glance version of the nls object into a flextable object @@ -407,13 +351,17 @@ tabularise_tidy.nls <- function(data, ..., kind = "ft", env = parent.frame()) { #' @param equation Add equation of the model to the table. If `TRUE`, #' [equation()] is used. The equation can also be passed in the form of a #' character string (LaTeX). +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used (only the name of the variables). +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., #' `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments passed to [equation()] +#' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). #' #' @seealso [tabularise::tabularise_glance()], [tabularise_coef.summary.nls()] #' @return A **flextable** object that you can print in different forms or @@ -431,9 +379,9 @@ tabularise_tidy.nls <- function(data, ..., kind = "ft", env = parent.frame()) { #' #' tabularise::tabularise$glance(chick1_logis) #' tabularise::tabularise$glance(chick1_logis, lang = "fr") -tabularise_glance.nls <- function(data, header = TRUE, title = NULL, - equation = header, lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { +tabularise_glance.nls <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, + labs = NULL, lang = getOption("data.io_lang", "en"), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -443,37 +391,14 @@ tabularise_glance.nls <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Choose the language - lang <- tolower(lang) - - if (lang != "fr") - lang <- "en" # Only en or fr for now - - if (lang == "fr") { - info_lang <- infos_fr.nls - } else { - info_lang <- infos_en.nls - } - - res <- summary(data) - - res1 <- data.frame( - sigma = res$sigma, finTol = res$convInfo$finTol, - logLik = as.numeric(stats::logLik(data)), AIC = stats::AIC(data), - BIC = stats::BIC(data), deviance = stats::deviance(data), - df.residual = stats::df.residual(data), nobs = stats::nobs(data)) - - ft <- flextable(res1) |> - colformat_sci() + df_list <- .extract_infos_nls( + data, type = "glance", show.signif.stars = FALSE, lang = lang, + auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, + title = title, colnames = colnames_nls, footer = FALSE) + # print(df_list) # use only for development - # Add labels - ft <- header_labels(ft, lang = lang) - - # Add headers - ft <- add_header_nls(ft, data = data, header = header, - title = title, equation = equation, lang = lang) - - autofit(ft) + # formatted table ---- + formate_table(df_list, kind = kind, header = header) } #' Get a LaTeX equation from an nls or the summary of a nls models @@ -492,6 +417,7 @@ tabularise_glance.nls <- function(data, header = TRUE, title = NULL, #' @param fix_signs Logical, defaults to `TRUE`. If disabled, coefficient #' estimates that are negative are preceded with a `+` (e.g. `5(x) + -3(z)`). #' If enabled, the `+ -` is replaced with a `-` (e.g. `5(x) - 3(z)`). +#' @param swap_var_names A named character vector as `c(old_var_name = "new name")` #' @param var_names A named character vector as `c(old_var_name = "new name")` #' @param op_latex The LaTeX product operator character to use in fancy #' scientific notation, either `\\cdot` (by default), or `\\times`. @@ -517,11 +443,11 @@ tabularise_glance.nls <- function(data, header = TRUE, title = NULL, #' equation(chick1_nls2) #' equation(summary(chick1_nls2)) #' -#' equation(summary(chick1_nls2), var_names = c( +#' equation(summary(chick1_nls2), swap_var_names = c( #' weight = "Body weight [gm]", #' Time = "Number of days")) equation.nls <- function(object, ital_vars = FALSE, use_coefs = FALSE, -coef_digits = 2L, fix_signs = TRUE, var_names = NULL, +coef_digits = 2L, fix_signs = TRUE, swap_var_names = NULL, var_names = swap_var_names, op_latex = c("\\cdot", "\\times"), ...) { x <- object if (!class(x) %in% c("nls", "summary.nls")) @@ -644,16 +570,18 @@ op_latex = c("\\cdot", "\\times"), ...) { for (i in 1:length(vals)) SSequation <- gsub(names(vals)[i], vals[i], SSequation) - if (!is.null(var_names)) { - if (!is.character(var_names)) + if (!is.null(swap_var_names)) { + if (!is.character(swap_var_names)) stop("var_names is not character vector") - if (is.null(names(var_names))) + if (is.null(names(swap_var_names))) stop("var_names must be named character vector") - if (any(names(var_names) %in% "")) + if (any(names(swap_var_names) %in% "")) stop("all elements must be named") + swap_var_names <- gsub(" " , " \\\\\\\\ ", swap_var_names) + for (i in 1:length(var_names)) - SSequation <- gsub(names(var_names)[i], var_names[i], SSequation) + SSequation <- gsub(names(swap_var_names)[i], swap_var_names[i], SSequation) } # Possibly fix signs @@ -670,219 +598,197 @@ op_latex = c("\\cdot", "\\times"), ...) { #' @export #' @method equation summary.nls equation.summary.nls <- function(object, ital_vars = FALSE, use_coefs = FALSE, -coef_digits = 2L, fix_signs = TRUE, var_names = NULL, +coef_digits = 2L, fix_signs = TRUE, swap_var_names = NULL, op_latex = c("\\cdot", "\\times"), ...) { # Same as equation.nls() equation.nls(object, ital_vars = ital_vars, use_coefs = use_coefs, - coef_digits = coef_digits, fix_signs = fix_signs, var_names = var_names, - op_latex = op_latex) + coef_digits = coef_digits, fix_signs = fix_signs, + swap_var_names = swap_var_names, op_latex = op_latex) } -infos_en.nls <- list( - labs = c( - term = "Term", - estimate = "Estimate", - std.error = "Standard Error", - statistic = "*t*~obs.~ value", - p.value = "*p* value", - sigma = "Relative standard error", - finTol = "Convergence tolerance", - logLik = "Log-Likelihood", - AIC = "AIC", - BIC = "BIC", - deviance = "Deviance", - df.residual = "df", - nobs = "N"), - SS = c( - SSasymp = "Nonlinear least squares asymptotic regression model (von Bertalanffy)", - SSAsympOff = "Nonlinear least squares asymptotic regression model (von Bertalanffy)", - SSasympOrig = "Nonlinear least squares asymptotic regression model through the origin (von Bertalanffy)", - SSbiexp = "Nonlinear least squares biexponential model", - SSfol = "Nonlinear least squares first-order compartment model", - SSfpl = "Nonlinear least squares four-parameter logistic model", - SSgompertz = "Nonlinear least squares Gompertz model", - SSlogis = "Nonlinear least squares logistic model", - SSmicmen = "Nonlinear least squares Michaelis-Menten model", - SSweibull = "Nonlinear least squares Weibull model" - ), - footer = c( - rss = "Residual sum-of-squares", - rse = "Residual standard error", - on = "on", - df = "degrees of freedom", - nbc = "Number of iterations to convergence", - ctol = "Achieved convergence tolerance", - stop = "The model does not converge") -) -infos_fr.nls <- list( - labs = c( - term = "Terme", - estimate = "Valeur estim\u00e9e", - std.error = "Ecart type", - statistic = "Valeur de *t*~obs.~", - p.value = "Valeur de *p*", - sigma = "Ecart type relatif", - AIC = "AIC", - df.residual = "Ddl", - nobs = "N", - statistic = "Valeur de *t*~obs.~", - sigma = "Ecart type des r\u00e9sidus", - finTol = "Tol\u00e9rance de convergence", - logLik = "Log-vraisemblance", - AIC = "AIC", - BIC = "BIC", - deviance = "D\u00e9viance", - df.residual = "Ddl", - nobs = "N" - ), - SS = c( - SSasymp = "Mod\u00e8le non lin\u00e9aire de r\u00e9gression asymptotique (von Bertalanffy)", - SSAsympOff = "Mod\u00e8le non lin\u00e9aire de r\u00e9gression asymptotique (von Bertalanffy)", - SSasympOrig = "Mod\u00e8le non lin\u00e9aire de r\u00e9gression asymptotique forc\u00e9e \u00e0 l'origine (von Bertalanffy)", - SSbiexp = "Mod\u00e8le non lin\u00e9aire biexponentiel", - SSfol = "Mod\u00e8le non lin\u00e9aire \u00e0 compartiments du premier ordre", - SSfpl = "Mod\u00e8le non lin\u00e9aire logistique \u00e0 quatre param\u00e8tres", - SSgompertz = "Mod\u00e8le non lin\u00e9aire de Gompertz", - SSlogis = "Mod\u00e8le non lin\u00e9aire logistique", - SSmicmen = "Mod\u00e8le non lin\u00e9aire de Michaelis-Menten", - SSweibull = "Mod\u00e8le non lin\u00e9aire de Weibull" - ), - footer = c( - rss = "Somme des carr\u00e9s des r\u00e9sidus", - rse = "Ecart type des r\u00e9sidus", - on = "pour", - df = "degr\u00e9s de libert\u00e9", - nbc = "Nombre d'it\u00e9rations pour converger", - ctol = "Tol\u00e9rance atteinte \u00e0 la convergence", - stop = "Le mod\u00e8le ne converge pas" - ) +.trad <- gettext( + term = "Term", + estimate = "Estimate", + std.error = "Standard Error", + statistic = "*t*~obs.~ value", + p.value = "*p* value", + sigma = "Relative standard error", + finTol = "Convergence tolerance", + logLik = "Log-Likelihood", + AIC = "AIC", + BIC = "BIC", + deviance = "Deviance", + df.residual = "df", + nobs = "N", + SSasymp = "Nonlinear least squares asymptotic regression model (von Bertalanffy)", + SSAsympOff = "Nonlinear least squares asymptotic regression model (von Bertalanffy)", + SSasympOrig = "Nonlinear least squares asymptotic regression model through the origin (von Bertalanffy)", + SSbiexp = "Nonlinear least squares biexponential model", + SSfol = "Nonlinear least squares first-order compartment model", + SSfpl = "Nonlinear least squares four-parameter logistic model", + SSgompertz = "Nonlinear least squares Gompertz model", + SSlogis = "Nonlinear least squares logistic model", + SSmicmen = "Nonlinear least squares Michaelis-Menten model", + SSweibull = "Nonlinear least squares Weibull model") + +colnames_nls <- c( + term = "Term", + estimate = "Estimate", + std.error = "Standard Error", + statistic = "*t*~obs.~ value", + p.value = "*p* value", + sigma = "Relative standard error", + finTol = "Convergence tolerance", + logLik = "Log-Likelihood", + AIC = "AIC", + BIC = "BIC", + deviance = "Deviance", + df.residual = "df", + nobs = "N") + +model_nls <- c( + SSasymp = "Nonlinear least squares asymptotic regression model (von Bertalanffy)", + SSAsympOff = "Nonlinear least squares asymptotic regression model (von Bertalanffy)", + SSasympOrig = "Nonlinear least squares asymptotic regression model through the origin (von Bertalanffy)", + SSbiexp = "Nonlinear least squares biexponential model", + SSfol = "Nonlinear least squares first-order compartment model", + SSfpl = "Nonlinear least squares four-parameter logistic model", + SSgompertz = "Nonlinear least squares Gompertz model", + SSlogis = "Nonlinear least squares logistic model", + SSmicmen = "Nonlinear least squares Michaelis-Menten model", + SSweibull = "Nonlinear least squares Weibull model" ) -# Internal function of flextable -pvalue_format <- function(x){ - #x <- get(as.character(substitute(x)), inherits = TRUE) - z <- cut(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), - labels = c("***", " **", " *", " .", " ")) - z <- as.character(z) - z[is.na(x)] <- "" - z +# Internal function for nls and summary.nls object + +.extract_footer_nls <- function(data, lang) { + digits <- max(3L, getOption("digits") - 3L) + domain <- "R-modelit" + + if (inherits(data, "nls")) { + val <- gettextf("Residual sum-of-squares: %.*g", + digits, data$m$deviance(), domain = domain, lang = lang) + } else { + val <- gettextf("Residuals standard error: %.*g on %.*g degrees of freedom", + digits, data$sigma, digits, max(data$df), + domain = domain, lang = lang) + } + + conv <- data$convInfo + if (isTRUE(conv$isConv)) { + convinfo <- paste( + gettextf("Number of iterations to convergence: %.*g", + digits, conv$finIter, domain = domain, lang = lang), + gettextf("Achieved convergence tolerance: %.*g", + digits, conv$finTol, domain = domain, lang = lang), + sep = "\n") + val <- c(val, convinfo) + } else { + val <- c(val, gettext("The model does not converge", lang = lang)) + } + return(val) } -add_header_nls <- function(x, data, - lang = lang, header = TRUE, title = NULL, equation = header, ...) { +.extract_infos_nls <- function(data, type = "coef", + show.signif.stars = getOption("show.signif.stars", TRUE), lang = "en", + colnames = colnames_nls, auto.labs = TRUE, origdata = NULL , labs = NULL, + equation = TRUE, title = TRUE, footer = TRUE) { + + if (!inherits(data, c("nls", "summary.nls"))) + stop(".extract_infos_nls() can apply only nls and summary.nls object.") + + type <- match.arg(type, choices = c("coef", "glance", "tidy")) + + # Extract df --------------------------------------------------------------- + if (inherits(data, "nls")) { + df <- switch(type, + coef = as.data.frame(t(coef(data))), + glance = { + res <- summary(data) + res1 <- data.frame( + sigma = res$sigma, finTol = res$convInfo$finTol, + logLik = as.numeric(stats::logLik(data)), AIC = stats::AIC(data), + BIC = stats::BIC(data), deviance = stats::deviance(data), + df.residual = stats::df.residual(data), nobs = stats::nobs(data)) + res1 + }, + tidy = { + res <- summary(data) + res1 <- coef(res) + df <- data.frame(term = rownames(res1), estimate = res1) + names(df) <- c("term", "estimate", "std.error", "statistic", "p.value") + + if (isTRUE(show.signif.stars)) { + df$signif <- .pvalue_format(df$p.value) + } + + df + } + ) + } else { + # only for summary.nls oject + if(type == "glance") { + stop(".extract_infos_nls() cannot apply type = 'glance' to a summary.nls + object.") + } + res1 <- coef(data) + df <- data.frame(term = rownames(res1), estimate = res1) + names(df) <- c("term", "estimate", "std.error", "statistic", "p.value") - if (!inherits(x, "flextable")) - stop(sprintf("Function `%s` supports only flextable objects.", - "add_header_nls()")) + if (isTRUE(show.signif.stars)) { + df$signif <- .pvalue_format(df$p.value) + } - # If title is not provided, determine if we have to use TRUE or FALSE - if (missing(title)) { - title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE - if (!is.null(knitr::opts_current$get('tbl-cap'))) - title <- FALSE + df } - # Choose the language - lang <- tolower(lang) - - if (lang != "fr") - lang <- "en" # Only en or fr for now - - if (lang == "fr") { - info_lang <- infos_fr.nls + if(isTRUE(show.signif.stars)) { + psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" } else { - info_lang <- infos_en.nls + psignif <- NULL } - ft <- x + cols <- .extract_colnames(df, labs = colnames, lang = lang) - if (isTRUE(header)) { + labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, + origdata = origdata, labs = labs) + equa <- .extract_equation(data, equation = equation, labs = labels) - if (isTRUE(equation)) { - ssequa <- equation(data, ...) - ft <- add_header_lines(ft, values = as_paragraph(as_equation(ssequa))) - ft <- align(ft, i = 1, align = "right", part = "header") - } else if (is.character(equation)) { - ft <- add_header_lines(ft, values = as_paragraph(as_equation(equation))) - ft <- align(ft, i = 1, align = "right", part = "header") - } + terms <- NULL - if (isTRUE(title)) { - ss <- info_lang[["SS"]] - rhs <- as.character(rlang::f_rhs(formula(data)))[1] - if (!is.na(ss[rhs])) { - ft <- add_header_lines(ft, values = ss[rhs]) - ft <- align(ft, i = 1, align = "right", part = "header") - } - } else if (is.character(title)) { - ft <- add_header_lines(ft, - values = as_paragraph(title)) - ft <- align(ft, i = 1, align = "right", part = "header") + # title + if (!isTRUE(title)) { + title <- NULL + } + if (isTRUE(title)) { + rhs <- as.character(rlang::f_rhs(formula(data)))[1] + if (!is.na(model_nls[rhs])) { + title <- gettext(model_nls[rhs], lang = lang) + } else { + title <- NULL } } - h_nrow <- nrow_part(ft, part = "header") - - if (h_nrow > 2) { - ft |> - border_inner_h(border = officer::fp_border(width = 0), part = "header") |> - hline(i = nrow_part(ft, "header") - 1, - border = officer::fp_border(width = 1.5, color = "#666666"), - part = "header") -> - ft + if (is.character(title)) { + title <- title } - ft -} - -# Internal function to change the labels (accept markdown) -header_labels <- function(x, lang, ...) { - - if (!inherits(x, "flextable")) - stop(sprintf("Function `%s` supports only flextable objects.", - "header_labels()")) - - # Choose thev language - lang <- tolower(lang) - - if (lang != "fr") - lang <- "en" # Only en or fr for now - - if (lang == "fr") { - info_lang <- infos_fr.nls + # footer + if(isTRUE(footer)) { + footer <- .extract_footer_nls(data, lang = lang) } else { - info_lang <- infos_en.nls + footer <- NULL } - ft <- x - - labels_auto <- info_lang[["labs"]] - labels_red <- labels_auto[names(labels_auto) %in% ft$header$col_keys] - - for (i in seq_along(labels_red)) - ft <- mk_par(ft, i = 1, j = names(labels_red)[i], - value = para_md(labels_red[i]), part = "header") - - ft + # List with all elements + list( + df = df, + title = title, + cols = cols, + equa = equa, + terms = terms, + psignif = psignif, + footer = footer) } -# Internal function to add pvalue signif -add_signif_stars <- function(x, i = NULL, j = NULL, part = "body", -align = "right", ...) { - - if (!inherits(x, "flextable")) - stop(sprintf("Function `%s` supports only flextable objects.", - "header_labels()")) - - ft <- x - - ft <- mk_par(ft, i = i, j = j, - value = as_paragraph(pvalue_format(.data$p.value))) - ft <- add_footer_lines(ft, - values = c("0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05")) - ft <- align(ft, i = 1, align = align, part = "footer") - - ft -} diff --git a/man/equation.nls.Rd b/man/equation.nls.Rd index 95b6b0a..14c21fd 100644 --- a/man/equation.nls.Rd +++ b/man/equation.nls.Rd @@ -11,7 +11,8 @@ use_coefs = FALSE, coef_digits = 2L, fix_signs = TRUE, - var_names = NULL, + swap_var_names = NULL, + var_names = swap_var_names, op_latex = c("\\\\cdot", "\\\\times"), ... ) @@ -22,7 +23,7 @@ use_coefs = FALSE, coef_digits = 2L, fix_signs = TRUE, - var_names = NULL, + swap_var_names = NULL, op_latex = c("\\\\cdot", "\\\\times"), ... ) @@ -44,6 +45,8 @@ round to when displaying model estimates with \code{use_coefs = TRUE}.} estimates that are negative are preceded with a \code{+} (e.g. \code{5(x) + -3(z)}). If enabled, the \verb{+ -} is replaced with a \code{-} (e.g. \code{5(x) - 3(z)}).} +\item{swap_var_names}{A named character vector as \code{c(old_var_name = "new name")}} + \item{var_names}{A named character vector as \code{c(old_var_name = "new name")}} \item{op_latex}{The LaTeX product operator character to use in fancy @@ -74,7 +77,7 @@ summary(chick1_nls2) equation(chick1_nls2) equation(summary(chick1_nls2)) -equation(summary(chick1_nls2), var_names = c( +equation(summary(chick1_nls2), swap_var_names = c( weight = "Body weight [gm]", Time = "Number of days")) } diff --git a/man/tabularise_coef.summary.lm.Rd b/man/tabularise_coef.summary.lm.Rd index 40402d1..2aed96b 100644 --- a/man/tabularise_coef.summary.lm.Rd +++ b/man/tabularise_coef.summary.lm.Rd @@ -59,7 +59,8 @@ The default is \code{getOption("show.signif.stars")}} \item{...}{Additional arguments} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for -flextable (default).} +flextable (default). +#' @param footer If \code{FALSE} (by default), add a footer to the table.} } \value{ A \strong{flextable} object you can print in different formats (HTML, diff --git a/man/tabularise_glance.lm.Rd b/man/tabularise_glance.lm.Rd index 83bd5a5..2d84558 100644 --- a/man/tabularise_glance.lm.Rd +++ b/man/tabularise_glance.lm.Rd @@ -7,8 +7,8 @@ \method{tabularise_glance}{lm}( data, header = TRUE, - title = NULL, - equation = TRUE, + title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, diff --git a/man/tabularise_glance.nls.Rd b/man/tabularise_glance.nls.Rd index 4751aad..290697c 100644 --- a/man/tabularise_glance.nls.Rd +++ b/man/tabularise_glance.nls.Rd @@ -7,12 +7,14 @@ \method{tabularise_glance}{nls}( data, header = TRUE, - title = NULL, + title = header, equation = header, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, lang = getOption("data.io_lang", "en"), ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ @@ -28,16 +30,22 @@ caption is detected (\code{tbl-cap} YAML entry).} \code{\link[=equation]{equation()}} is used. The equation can also be passed in the form of a character string (LaTeX).} +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used (only the name of the variables).} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} + \item{lang}{The language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{...}{Additional arguments passed to \code{\link[=equation]{equation()}}} +\item{...}{Not used} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different forms or diff --git a/man/tabularise_tidy.nls.Rd b/man/tabularise_tidy.nls.Rd index b19a9ae..f25893a 100644 --- a/man/tabularise_tidy.nls.Rd +++ b/man/tabularise_tidy.nls.Rd @@ -4,18 +4,52 @@ \alias{tabularise_tidy.nls} \title{Tidy version of the nls object into a flextable object} \usage{ -\method{tabularise_tidy}{nls}(data, ..., kind = "ft", env = parent.frame()) +\method{tabularise_tidy}{nls}( + data, + header = TRUE, + title = header, + equation = header, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, + lang = getOption("data.io_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), + ..., + kind = "ft" +) } \arguments{ -\item{data}{A \strong{nls} object} +\item{data}{An \strong{nls} object.} -\item{...}{arguments of \code{\link[=tabularise_coef.summary.nls]{tabularise_coef.summary.nls()}}} +\item{header}{If \code{TRUE} (by default), add a title to the table.} + +\item{title}{If \code{TRUE}, add a title to the table header. Default to the same +value than header, except outside of a chunk where it is \code{FALSE} if a table +caption is detected (\code{tbl-cap} YAML entry).} + +\item{equation}{Add equation of the model to the table. If \code{TRUE}, +\code{\link[=equation]{equation()}} is used. The equation can also be passed in the form of a +character string (LaTeX).} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used (only the name of the variables).} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} + +\item{lang}{The language to use. The default value can be set with, e.g., +\code{options(data.io_lang = "fr")} for French.} + +\item{show.signif.stars}{If \code{TRUE}, add the significance stars to the table. +The default is \code{getOption("show.signif.stars")}} + +\item{...}{Not used} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different forms or From 8ddb1486c08fb5f42d79cce7decfe2cdd8b893c6 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Fri, 18 Jul 2025 14:39:51 +0200 Subject: [PATCH 11/22] Add experimentalfunction lm_() --- NAMESPACE | 1 + R/lm_.R | 149 +++++++++++++++++++++++++++++++++++++-------- man/lm_.Rd | 26 ++++++-- man/summary.lm_.Rd | 35 +++++++++-- 4 files changed, 172 insertions(+), 39 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 47d3ff1..eec80a2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ S3method(AIC,model_fit) S3method(BIC,model_fit) +S3method(anova,lm_) S3method(anova,model_fit) S3method(as.function,lm) S3method(as.function,model_fit) diff --git a/R/lm_.R b/R/lm_.R index 27d4a70..50ac600 100644 --- a/R/lm_.R +++ b/R/lm_.R @@ -1,65 +1,160 @@ -#' Fitting Linear Models by SciViews +#' Fitting Linear Models with Enhanced Output (Experimental) #' #' @description -#'This function is used like the [stats::lm()] function. It allows adding -#'additional elements such as labels and units. +#' `lm_()` is an **experimental** wrapper around the base [stats::lm()] function. +#' It behaves similarly to `lm()` but enriches the returned object with additional +#' metadata. #' -#' @param data A data frame -#' @param formula An object of class formula -#' @param ... All the arguments of the lm() function +#' @param data A `data.frame` containing the variables in the model. +#' @param formula An object of class `formula`: a symbolic description of the model to be fitted. +#' @param ... Additional arguments passed to [stats::lm()]. +#' +#' @return An object of class `lm_`, which inherits from `lm`, and includes additional +#' components such as `labels`. If no additional attributes are added, a standard `lm` object is returned. #' -#' @return an lm_ object if attribute additions have been made. Otherwise, the -#' object will be of class lm #' @export #' #' @examples #' data(iris) +#' +#' # Add labels to variables +#' attr(iris$Sepal.Length, "label") <- "Sepal Length (cm)" +#' attr(iris$Petal.Length, "label") <- "Petal Length (cm)" +#' +#' # Fit the model using lm_() #' res <- lm_(iris, formula = Petal.Length ~ Sepal.Length + Species) +#' #' res #' class(res) +#' summary(res) +#' +#' # Access labels +#' res$labels #' lm_ <- function(data, formula, ...) { - res <- stats::lm(data = data, formula = formula,...) + res <- stats::lm(data = data, formula = formula, ...) - # Extract labels ---- - labs_auto <- tabularise:::.labels(data) - vars <- rownames(attr(res$terms, "factors")) - labs_auto <- labs_auto[names(labs_auto) %in% vars] - attr(res, "labs") <- labs_auto + # Extract labels + if (!is.null(res$model)) { + labs <- .labels3(res) + } else { + labs <- .labels3(res, origdata = data) + } + + res$labels <- labs - # Adding a new class if attribute additions have been made - if (!is.null(attr(res, "labs"))) { + # Add custom class if labels were successfully added + if (!is.null(res$labels)) { class(res) <- c("lm_", class(res)) } res } -#' Summarizing Linear Model Fits by SciViews + +#' Summarizing Linear Model Fits with Enhanced Output #' #' @description -#' summary method for class lm_ +#' `summary.lm_()` is a method for objects of class `lm_`, extending the standard +#' [summary.lm()] functionality. +#' It returns a summary object similar to `summary.lm`, but includes additional +#' metadata such as variable labels (if available), making the output more +#' informative for reporting and interpretation. +#' +#' This method is part of the experimental `lm_()` modeling framework. +#' +#' @param object An object of class `lm_`, typically returned by [lm_()]. +#' @param ... Additional arguments passed to [stats::summary.lm()]. #' -#' @param object an object of class lm_ -#' @param ... additional argument to stats:::summary.lm() +#' @return An object of class `summary.lm_`, which inherits from `summary.lm` and +#' includes an optional `labels` component if available in the original model. #' -#' @return an object of class summary.lm_ object, similar to summary.lm #' @export #' #' @examples -#' #TODO +#' data(iris) +#' +#' # Add labels to variables +#' attr(iris$Sepal.Length, "label") <- "Sepal Length (cm)" +#' attr(iris$Petal.Length, "label") <- "Petal Length (cm)" +#' attr(iris$Species, "label") <- "Iris Species" +#' +#' # Fit model using lm_() +#' model <- lm_(iris, formula = Petal.Length ~ Sepal.Length + Species) +#' +#' # Get summary with labels +#' summary_model <- summary(model) +#' summary_model +#' +#' # Access labels +#' summary_model$labels +#' summary.lm_ <- function(object, ...) { res <- stats::summary.lm(object = object, ...) - if(!is.null(attr(object, "labs"))) { - attr(res, "labs") <- attr(object, "labs") + # Add labels if available + if (!is.null(object$labels)) { + res$labels <- object$labels } - # Adding a new class if attribute additions have been made - if (is.null(attr(res, "labs"))) { - class(res) <- c("summary.lm_", class(res), "lm") + # Add custom class if labels were added + if (!is.null(res$labels)) { + class(res) <- c("summary.lm_", class(res)) } + res } +#' ANOVA Tables for Enhanced Linear Models (`lm_`) +#' +#' @description +#' `anova.lm_()` is a method for objects of class `lm_`, extending the standard +#' [stats::anova()] functionality. +#' It returns an ANOVA table similar to the base version but includes additional +#' metadata such as variable labels (if available), making the output more +#' informative for interpretation and reporting. +#' +#' This method is part of the experimental `lm_()` modeling framework. +#' +#' @param object An object of class `lm_`, typically returned by [lm_()]. +#' @param ... Additional arguments passed to [stats::anova()]. +#' +#' @return An object of class `anova_`, which inherits from `anova` and may include +#' a `labels` component if available in the original model. +#' +#' @export +#' +#' @examples +#' data(iris) +#' +#' # Add labels to variables +#' attr(iris$Sepal.Length, "label") <- "Sepal Length (cm)" +#' attr(iris$Petal.Length, "label") <- "Petal Length (cm)" +#' +#' # Fit model using lm_() +#' model <- lm_(iris, Petal.Length ~ Sepal.Length + Species) +#' +#' # Get ANOVA table with labels +#' anova_model <- anova(model) +#' anova_model +#' +#' # Access labels +#' anova_model$labels +#' +anova.lm_ <- function(object, ...) { + res <- .anova.lm(object = object, ...) + + # Add labels if available + if (!is.null(object$labels)) { + res$labels <- object$labels + } + + # Add custom class if labels were added + if (!is.null(res$labels)) { + class(res) <- c("anova_", class(res)) + } + + res +} +.anova.lm <- getS3method("anova", "lm") diff --git a/man/lm_.Rd b/man/lm_.Rd index f2fd8e7..c29b419 100644 --- a/man/lm_.Rd +++ b/man/lm_.Rd @@ -2,27 +2,41 @@ % Please edit documentation in R/lm_.R \name{lm_} \alias{lm_} -\title{Fitting Linear Models by SciViews} +\title{Fitting Linear Models with Enhanced Output (Experimental)} \usage{ lm_(data, formula, ...) } \arguments{ -\item{data}{A data frame} +\item{data}{A \code{data.frame} containing the variables in the model.} -\item{formula}{An object of class formula} +\item{formula}{An object of class \code{formula}: a symbolic description of the model to be fitted.} -\item{...}{All the arguments of the lm() function} +\item{...}{Additional arguments passed to \code{\link[stats:lm]{stats::lm()}}.} } \value{ -an lm_ object if attribute additions have been made. Otherwise, the object will be of class lm +An object of class \code{lm_}, which inherits from \code{lm}, and includes additional +components such as \code{labels}. If no additional attributes are added, a standard \code{lm} object is returned. } \description{ -The lm_() function is used like the lm() function from the {stats} package. It allows adding additional elements such as labels and units. +\code{lm_()} is an \strong{experimental} wrapper around the base \code{\link[stats:lm]{stats::lm()}} function. +It behaves similarly to \code{lm()} but enriches the returned object with additional +metadata. } \examples{ data(iris) + +# Add labels to variables +attr(iris$Sepal.Length, "label") <- "Sepal Length (cm)" +attr(iris$Petal.Length, "label") <- "Petal Length (cm)" + +# Fit the model using lm_() res <- lm_(iris, formula = Petal.Length ~ Sepal.Length + Species) + res class(res) +summary(res) + +# Access labels +res$labels } diff --git a/man/summary.lm_.Rd b/man/summary.lm_.Rd index 34f7a1e..89d7f79 100644 --- a/man/summary.lm_.Rd +++ b/man/summary.lm_.Rd @@ -2,21 +2,44 @@ % Please edit documentation in R/lm_.R \name{summary.lm_} \alias{summary.lm_} -\title{Summarizing Linear Model Fits by SciViews} +\title{Summarizing Linear Model Fits with Enhanced Output} \usage{ \method{summary}{lm_}(object, ...) } \arguments{ -\item{object}{an object of class lm_} +\item{object}{An object of class \code{lm_}, typically returned by \code{\link[=lm_]{lm_()}}.} -\item{...}{additional argument to stats:::summary.lm()} +\item{...}{Additional arguments passed to \code{\link[stats:summary.lm]{stats::summary.lm()}}.} } \value{ -an object of class summary.lm_ object, similar to summary.lm +An object of class \code{summary.lm_}, which inherits from \code{summary.lm} and +includes an optional \code{labels} component if available in the original model. } \description{ -summary method for class lm_ +\code{summary.lm_()} is a method for objects of class \code{lm_}, extending the standard +\code{\link[=summary.lm]{summary.lm()}} functionality. +It returns a summary object similar to \code{summary.lm}, but includes additional +metadata such as variable labels (if available), making the output more +informative for reporting and interpretation. + +This method is part of the experimental \code{lm_()} modeling framework. } \examples{ -#TODO +data(iris) + +# Add labels to variables +attr(iris$Sepal.Length, "label") <- "Sepal Length (cm)" +attr(iris$Petal.Length, "label") <- "Petal Length (cm)" +attr(iris$Species, "label") <- "Iris Species" + +# Fit model using lm_() +model <- lm_(iris, formula = Petal.Length ~ Sepal.Length + Species) + +# Get summary with labels +summary_model <- summary(model) +summary_model + +# Access labels +summary_model$labels + } From 6e4f3f4d66b1d1fc7e5f6478e7d198998e1e891e Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Fri, 18 Jul 2025 14:41:06 +0200 Subject: [PATCH 12/22] better documentation and exemple --- R/tabularise.lm.R | 257 +++++++++++++------------- R/tabularise.nls.R | 1 + man/anova.lm_.Rd | 44 +++++ man/tabularise_coef.lm.Rd | 19 ++ man/tabularise_coef.nls.Rd | 29 ++- man/tabularise_coef.summary.nls.Rd | 33 ++-- man/tabularise_default.nls.Rd | 28 ++- man/tabularise_default.summary.nls.Rd | 38 ++-- 8 files changed, 276 insertions(+), 173 deletions(-) create mode 100644 man/anova.lm_.Rd diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index 42f43bb..ba311ab 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -32,8 +32,27 @@ #' @importFrom knitr opts_current #' @method tabularise_coef lm #' @examples +#' data(iris) +#' # Fit a simple linear model: Petal.Length as a function of Sepal.Length #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$coef(iris_lm) +#' +#' # If the 'iris' dataset has labels and units, they can be used to enhance +#' # the output table +#' iris <- data.io::labelise(iris, self = FALSE, label = list( +#' Sepal.Length = "Length of the sepals", +#' Petal.Length = "Length of the petals", +#' Species = "Species"), units = c(rep("cm", 4), NA)) +#' +#' iris_lm1 <- lm(data = iris, Petal.Length ~ Sepal.Length + Species) +#' tabularise::tabularise$coef(iris_lm1) +#' +#' # The same table but without showing the model equation +#' tabularise::tabularise$coef(iris_lm, equation = FALSE) +#' +#' iris_lm2 <- lm(data = iris, Petal.Length ~ Sepal.Length * Species) +#' tabularise::tabularise$coef(iris_lm2) +#' tabularise_coef.lm <- function(data, header = TRUE, title = NULL, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), @@ -287,17 +306,6 @@ tabularise_default.summary.lm <- function(data, ..., footer = TRUE) { # A list of internals functions ------ - -.pvalue_format <- function(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), - labels = c("***", " **", " *", " .", " ")) { - #x <- get(as.character(substitute(x)), inherits = TRUE) - z <- cut(x, breaks = breaks, - labels = labels) - z <- as.character(z) - z[is.na(x)] <- "" - z -} - colnames_lm <- c( term = "Term", estimate = "Estimate", @@ -320,65 +328,6 @@ colnames_lm <- c( signif = "", "(Intercept)" = "Intercept") -library(svMisc) -# Migrer dans svMisc -.make_translation <- function() { - .trad <- list() - translation_fun <- structure(function(expr, lang = NULL, type = "lm", clear_cache = FALSE) { - if (isTRUE(clear_cache)) { - .trad <<- list() - if (missing(expr)) - return() - } - - if (is.null(lang)) { - lang <- substitute(expr)[["lang"]] - if (is.null(lang)) - stop("lang is not defined") - } - - slot <- paste(lang, type[[1]], sep = "-") - res <- .trad[[slot]] - if (is.null(res)) { - message("langue ", lang, " pas en cache") - res <- eval(expr) - .trad2 <- .trad - .trad2[[slot]] <- res - .trad <<- .trad2 # super assignation - } - res - }, class = c("function", "subsettable_type")) - translation_fun -} - -.translation <- .make_translation() - -.translation$lm(gettext(term = "Term", - estimate = "Estimate", - conf.low = "Lower bound (CI)", - conf.high = "Upper bound (CI)", - std.error = "Standard Error", - t.value = "t value", - sigma = "RSE", - r.squared = "R^2^", - adj.r.squared = "Adj.R^2^", - AIC = "AIC", - BIC = "BIC", - deviance = "Deviance", - logLik = "Log-likelihood", - statistic = "*t* value", - p.value = "*p* value", - df = "Model df", - df.residual = "Residuals df", - nobs = "N", - "(Intercept)" = "Intercept", lang = "fr")) - -.translation(clear_cache = TRUE) -environment(.translation)$.trad -environment(.translation)$.trad -> s - -s$`fr-lm` - .trads <- gettext(term = "Term", estimate = "Estimate", conf.low = "Lower bound (CI)", @@ -398,7 +347,17 @@ s$`fr-lm` df.residual = "Residuals df", nobs = "N", "(Intercept)" = "Intercept", lang = "fr") -.trads +#.trads + +.pvalue_format <- function(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), + labels = c("***", " **", " *", " .", " ")) { + #x <- get(as.character(substitute(x)), inherits = TRUE) + z <- cut(x, breaks = breaks, + labels = labels) + z <- as.character(z) + z[is.na(x)] <- "" + z +} .extract_colnames <- function(df, labs, lang) { vec <- labs[names(labs) %in% names(df)] @@ -491,12 +450,11 @@ s$`fr-lm` next } - # Construire le label de l'interaction interaction_label <- paste(labs[parts], collapse = " x ") labs[term] <- interaction_label } } - + labs <- gsub("\n", " ", labs) return(labs) } @@ -596,11 +554,11 @@ s$`fr-lm` .extract_infos_lm <- function(data, type = "coef", conf.int = TRUE, conf.level = 0.95, show.signif.stars = getOption("show.signif.stars", TRUE), - lang, auto.labs = TRUE, origdata = NULL , labs = NULL, equation = TRUE, + lang = "en", auto.labs = TRUE, origdata = NULL , labs = NULL, equation = TRUE, title = TRUE, colnames = colnames_lm , footer = FALSE, ...) { if (!inherits(data, c("lm", "summary.lm"))) - stop(".extract_infos_nls() can apply only lm and summary.lm object.") + stop(".extract_infos_lm() can apply only lm and summary.lm object.") type <- match.arg(type, choices = c("coef", "glance", "tidy")) @@ -638,10 +596,11 @@ s$`fr-lm` psignif <- NULL } + lang <- tolower(lang) cols <- .extract_colnames(df, labs = colnames_lm, lang = lang) labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) equa <- .extract_equation(data, equation = equation, labs = labels) @@ -657,8 +616,7 @@ s$`fr-lm` footer <- .extract_footer_lm(data, lang = lang) } else { footer <- NULL - } - + } list( df = df, @@ -831,65 +789,106 @@ formate_table <- function(df, kind, header) { ft } -# create_flextable <- function(x, header = TRUE) { -# df <- x$df + +# # TODO: Migrate this translation system into the 'svMisc' package # -# ft <- flextable(df) |> -# colformat_sci() +# # This function creates a translation handler that caches translations +# # for different languages and object types (e.g., "lm", "nls", etc.). +# # It avoids re-evaluating translation expressions by storing results +# # in a cache (.trad), indexed by a key combining language and type. +# .make_translation <- function() { +# .trad <- list() # Internal cache for translations # -# if ("p.value" %in% colnames(df)) { -# ft <- ft |> -# colformat_sci(j = "p.value", lod = 2e-16) -# } +# translation_fun <- structure(function(expr, lang = NULL, type = "lm", clear_cache = FALSE) { +# # Clear the cache if requested +# if (isTRUE(clear_cache)) { +# .trad <<- list() +# if (missing(expr)) +# return() +# } # -# if (!is.null(x$cols))) { -# ft <- .add_colnames(ft, attr(x, "col.names")) -# } +# # Try to extract language from the expression if not explicitly provided +# if (is.null(lang)) { +# lang <- substitute(expr)[["lang"]] +# if (is.null(lang)) +# stop("lang is not defined") +# } # -# if (!is.null(attr(x, "labs"))) { -# ft <- .add_labs(ft, attr(x, "labs")) -# } +# # Create a cache key based on language and type +# slot <- paste(lang, type[[1]], sep = "-") +# res <- .trad[[slot]] # -# if (!is.null(attr(x,"equation")) & !is.null(attr(x, "equation_params"))) { -# ft <- .add_params(ft, attr(x, "equation_params")) -# } +# # If translation is not cached, evaluate and store it +# if (is.null(res)) { +# message("Language ", lang, " not found in cache") +# res <- eval(expr) +# .trad2 <- .trad +# .trad2[[slot]] <- res +# .trad <<- .trad2 # Super assignment to update cache +# } # -# if (isTRUE(header)) { -# ft <- .add_header2(ft, title = attr(x, "title"), equation = attr(x, "equation")) -# } +# res # Return the cached or newly evaluated translation +# }, class = c("function", "subsettable_type")) # -# if (!is.null(attr(x,"signif.stars"))) { -# ft <- .add_signif(ft, attr(x, "signif.stars")) -# } +# translation_fun +# } # -# if (!is.null(attr(x, "footer"))) { -# vals <- attr(x, "footer") -# ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) -# ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", -# part = "footer") -# } +# # Create the translation handler +# .translation <- .make_translation() # -# ft <- autofit(ft, part = c("header", "body")) +# # Add translations for 'lm' objects in French and English +# .translation$lm(gettext( +# term = "Term", +# estimate = "Estimate", +# conf.low = "Lower bound (CI)", +# conf.high = "Upper bound (CI)", +# std.error = "Standard Error", +# t.value = "t value", +# sigma = "RSE", +# r.squared = "R^2^", +# adj.r.squared = "Adj.R^2^", +# AIC = "AIC", +# BIC = "BIC", +# deviance = "Deviance", +# logLik = "Log-likelihood", +# statistic = "*t* value", +# p.value = "*p* value", +# df = "Model df", +# df.residual = "Residuals df", +# nobs = "N", +# "(Intercept)" = "Intercept", +# lang = "fr" +# )) # -# sss <- attr(x,"show.signif.stars") -# if (!is.null(sss) && isTRUE(sss)) { -# ft <- width(ft, j = "signif", width = 0.4) -# } +# .translation$lm(gettext( +# term = "Term", +# estimate = "Estimate", +# conf.low = "Lower bound (CI)", +# conf.high = "Upper bound (CI)", +# std.error = "Standard Error", +# t.value = "t value", +# sigma = "RSE", +# r.squared = "R^2^", +# adj.r.squared = "Adj.R^2^", +# AIC = "AIC", +# BIC = "BIC", +# deviance = "Deviance", +# logLik = "Log-likelihood", +# statistic = "*t* value", +# p.value = "*p* value", +# df = "Model df", +# df.residual = "Residuals df", +# nobs = "N", +# "(Intercept)" = "Intercept", +# lang = "en" +# )) # -# return(ft) -# } - -# #formate_table <- function(df, kind, header) { -# switch(kind, -# df = {df}, -# tt = { -# stop("Not implemented yet") -# }, -# ft = { -# create_flextable(df, header = header) -# }, -# gt = { -# stop("Not implemented yet") -# } -# ) -# } +# # Optional: Clear the cache +# #.translation(clear_cache = TRUE) +# +# # Access the internal translation cache +# environment(.translation)$.trad -> s +# +# # View cached translations for French 'lm' objects +# s$`fr-lm` +# s diff --git a/R/tabularise.nls.R b/R/tabularise.nls.R index 7aadaab..614efcf 100644 --- a/R/tabularise.nls.R +++ b/R/tabularise.nls.R @@ -749,6 +749,7 @@ model_nls <- c( psignif <- NULL } + lang <- tolower(lang) cols <- .extract_colnames(df, labs = colnames, lang = lang) labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, diff --git a/man/anova.lm_.Rd b/man/anova.lm_.Rd new file mode 100644 index 0000000..10e90c4 --- /dev/null +++ b/man/anova.lm_.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lm_.R +\name{anova.lm_} +\alias{anova.lm_} +\title{ANOVA Tables for Enhanced Linear Models (\code{lm_})} +\usage{ +\method{anova}{lm_}(object, ...) +} +\arguments{ +\item{object}{An object of class \code{lm_}, typically returned by \code{\link[=lm_]{lm_()}}.} + +\item{...}{Additional arguments passed to \code{\link[stats:anova]{stats::anova()}}.} +} +\value{ +An object of class \code{anova_}, which inherits from \code{anova} and may include +a \code{labels} component if available in the original model. +} +\description{ +\code{anova.lm_()} is a method for objects of class \code{lm_}, extending the standard +\code{\link[stats:anova]{stats::anova()}} functionality. +It returns an ANOVA table similar to the base version but includes additional +metadata such as variable labels (if available), making the output more +informative for interpretation and reporting. + +This method is part of the experimental \code{lm_()} modeling framework. +} +\examples{ +data(iris) + +# Add labels to variables +attr(iris$Sepal.Length, "label") <- "Sepal Length (cm)" +attr(iris$Petal.Length, "label") <- "Petal Length (cm)" + +# Fit model using lm_() +model <- lm_(iris, Petal.Length ~ Sepal.Length + Species) + +# Get ANOVA table with labels +anova_model <- anova(model) +anova_model + +# Access labels +anova_model$labels + +} diff --git a/man/tabularise_coef.lm.Rd b/man/tabularise_coef.lm.Rd index 00a1206..c73c45f 100644 --- a/man/tabularise_coef.lm.Rd +++ b/man/tabularise_coef.lm.Rd @@ -57,6 +57,25 @@ object, similar to \code{\link[stats:coef]{stats::coef()}}, but in a rich-format \{flextable\}. } \examples{ +data(iris) +# Fit a simple linear model: Petal.Length as a function of Sepal.Length iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) tabularise::tabularise$coef(iris_lm) + +# If the 'iris' dataset has labels and units, they can be used to enhance +# the output table +iris <- data.io::labelise(iris, self = FALSE, label = list( + Sepal.Length = "Length of the sepals", + Petal.Length = "Length of the petals", + Species = "Species"), units = c(rep("cm", 4), NA)) + +iris_lm1 <- lm(data = iris, Petal.Length ~ Sepal.Length + Species) +tabularise::tabularise$coef(iris_lm1) + +# The same table but without showing the model equation +tabularise::tabularise$coef(iris_lm, equation = FALSE) + +iris_lm2 <- lm(data = iris, Petal.Length ~ Sepal.Length * Species) +tabularise::tabularise$coef(iris_lm2) + } diff --git a/man/tabularise_coef.nls.Rd b/man/tabularise_coef.nls.Rd index cde019f..8992bb2 100644 --- a/man/tabularise_coef.nls.Rd +++ b/man/tabularise_coef.nls.Rd @@ -7,12 +7,15 @@ \method{tabularise_coef}{nls}( data, header = TRUE, - title = NULL, + title = header, equation = header, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, lang = getOption("data.io_lang", "en"), + footer = TRUE, ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ @@ -24,18 +27,28 @@ value than header, except outside of a chunk where it is \code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add the equation of the model} +\item{equation}{Add equation of the model to the table. If \code{TRUE}, +\code{\link[=equation]{equation()}} is used. The equation can also be passed in the form of a +character string (LaTeX).} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used (only the name of the variables).} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} \item{lang}{The language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{...}{Additional arguments.} +\item{footer}{If \code{TRUE} (by default, it is TRUE), add a footer to the table.} + +\item{...}{Not used} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different forms or diff --git a/man/tabularise_coef.summary.nls.Rd b/man/tabularise_coef.summary.nls.Rd index 2efe170..a48706b 100644 --- a/man/tabularise_coef.summary.nls.Rd +++ b/man/tabularise_coef.summary.nls.Rd @@ -7,17 +7,20 @@ \method{tabularise_coef}{summary.nls}( data, header = TRUE, - title = NULL, + title = header, equation = header, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, lang = getOption("data.io_lang", "en"), + footer = FALSE, show.signif.stars = getOption("show.signif.stars", TRUE), ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ -\item{data}{A \strong{summary.nls} object.} +\item{data}{An \strong{nls} object.} \item{header}{If \code{TRUE} (by default), add a title to the table.} @@ -27,21 +30,29 @@ caption is detected (\code{tbl-cap} YAML entry).} \item{equation}{Add equation of the model to the table. If \code{TRUE}, \code{\link[=equation]{equation()}} is used. The equation can also be passed in the form of a -character string (LaTeX equation).} +character string (LaTeX).} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used (only the name of the variables).} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} \item{lang}{The language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{show.signif.stars}{If \code{TRUE} (by default), add the significance stars -to the table.} +\item{footer}{If \code{FALSE} (by default), add a footer to the table.} -\item{...}{Additional arguments passed to \code{\link[=equation]{equation()}}} +\item{show.signif.stars}{If \code{TRUE}, add the significance stars to the table. +The default is \code{getOption("show.signif.stars")}} + +\item{...}{Not used} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different forms or diff --git a/man/tabularise_default.nls.Rd b/man/tabularise_default.nls.Rd index fd093b3..6b60210 100644 --- a/man/tabularise_default.nls.Rd +++ b/man/tabularise_default.nls.Rd @@ -7,13 +7,15 @@ \method{tabularise_default}{nls}( data, header = TRUE, - title = NULL, + title = header, equation = header, - footer = TRUE, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, lang = getOption("data.io_lang", "en"), + footer = TRUE, ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ @@ -27,20 +29,26 @@ caption is detected (\code{tbl-cap} YAML entry).} \item{equation}{Add equation of the model to the table. If \code{TRUE}, \code{\link[=equation]{equation()}} is used. The equation can also be passed in the form of a -character string (LaTeX equation).} +character string (LaTeX).} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} -\item{footer}{If \code{TRUE} (by default), add a footer to the table.} +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used (only the name of the variables).} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} \item{lang}{The language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{...}{Additional arguments. Not used.} +\item{footer}{If \code{TRUE} (by default, it is TRUE), add a footer to the table.} + +\item{...}{Not used} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different forms or diff --git a/man/tabularise_default.summary.nls.Rd b/man/tabularise_default.summary.nls.Rd index 9bf2764..6f6396c 100644 --- a/man/tabularise_default.summary.nls.Rd +++ b/man/tabularise_default.summary.nls.Rd @@ -7,20 +7,22 @@ \method{tabularise_default}{summary.nls}( data, header = TRUE, - title = NULL, + title = header, equation = header, - footer = TRUE, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, lang = getOption("data.io_lang", "en"), + footer = TRUE, show.signif.stars = getOption("show.signif.stars", TRUE), ..., - kind = "ft", - env = parent.frame() + kind = "ft" ) } \arguments{ -\item{data}{A \strong{summary.nls} object.} +\item{data}{An \strong{nls} object.} -\item{header}{If \code{TRUE} (by default), add a header to the table} +\item{header}{If \code{TRUE} (by default), add a title to the table.} \item{title}{If \code{TRUE}, add a title to the table header. Default to the same value than header, except outside of a chunk where it is \code{FALSE} if a table @@ -28,23 +30,29 @@ caption is detected (\code{tbl-cap} YAML entry).} \item{equation}{Add equation of the model to the table. If \code{TRUE}, \code{\link[=equation]{equation()}} is used. The equation can also be passed in the form of a -character string (LaTeX equation).} +character string (LaTeX).} -\item{footer}{If \code{TRUE} (by default), add a footer to the table.} +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used (only the name of the variables).} -\item{lang}{The language to use. The default value can be set with, e.g. +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} + +\item{lang}{The language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{show.signif.stars}{If \code{TRUE} (by default), add the significance stars -to the table.} +\item{footer}{If \code{TRUE} (by default), add a footer to the table.} + +\item{show.signif.stars}{If \code{TRUE}, add the significance stars to the table. +The default is \code{getOption("show.signif.stars")}} -\item{...}{Additional arguments (Not used).} +\item{...}{Not used} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} } \value{ A \strong{flextable} object that you can print in different forms or From c801e96fa7d4096565843302eba97433fb340c0f Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Fri, 18 Jul 2025 14:42:12 +0200 Subject: [PATCH 13/22] first step to refactor tabularise_*** for anova object --- R/tabularise.anova.R | 104 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 104 insertions(+) diff --git a/R/tabularise.anova.R b/R/tabularise.anova.R index 82fe058..c06eacd 100644 --- a/R/tabularise.anova.R +++ b/R/tabularise.anova.R @@ -385,3 +385,107 @@ infos_fr.anova <- list( "NULL" = c("NULL" = "Aucun"), Model = c("Model" = "Mod\u00e8le") ) + +colnames_anova <- c( + term = "Term", + "model" = "Model", + "df" = "Df", + "df.residual" = "Residuals Df", + rss = "Residual sum of squares", + "sumsq" = "Sum of squares", + "meansq" = "Mean squares", + "p.value" = "*p* value", + num.df = "Num. Df", + NumDF = "Num. Df", + den.df = "Denom. Df", + DenDF = "Denom. Df", + deviance = "Deviance", + residual.deviance = "Residual deviance", + "F value" = "*F*~obs.~ value", + "F" = "*F*~obs.~ value", + Chisq = "$\\chi2_{obs.}$") + +.trad_anova <- gettext( + "Type III Analysis of Variance Table with Satterthwaite's method" = + "Type III analysis of variance with Satterthwaite's method", + "Analysis of Deviance Table" = "Analysis of deviance", + "Analysis of Variance Table" = "Analysis of variance", + "Response:" = "Response:", + "Model:" = "Model:", + "Model" = "Model", + "link:" = "link:", + "Terms added sequentially (first to last)" = "Terms added sequentially (first to last)", + term = "Term", + "model" = "Model", + "df" = "Df", + "df.residual" = "Residuals Df", + rss = "Residual sum of squares", + "sumsq" = "Sum of squares", + "meansq" = "Mean squares", + "p.value" = "*p* value", + num.df = "Num. Df", + NumDF = "Num. Df", + den.df = "Denom. Df", + DenDF = "Denom. Df", + deviance = "Deviance", + residual.deviance = "Residual deviance", + "F value" = "*F*~obs.~ value", + "F" = "*F*~obs.~ value", + Chisq = "$\\chi2_{obs.}$", + "NULL" = "None", + Residuals = "Residuals" +) + +.extract_infos_anova <- function(data, show.signif.stars = getOption("show.signif.stars", TRUE), + lang = "en", auto.labs = TRUE, origdata = NULL , labs = NULL, + title = TRUE, colnames = colnames_anova, ...) { + + if (!inherits(data, c("anova"))) + stop(".extract_infos_anova() can apply only anova object.") + + # df + df <- as.data.frame(broom::tidy(data)) + + # statistic variable has 3 possible significcation: "F value", "F", "Chisq" + statistic_cols <- c("F value", "F", "Chisq") + names(df)[names(df) == "statistic"] <- statistic_cols[statistic_cols %in% names(data)][1] + + # the term variable + if (grepl("^Model", attr(data, "heading")[2])) { + names(df)[names(df) == "term"] <- "model" + } + + if (isTRUE(show.signif.stars)) { + df$signif <- .pvalue_format(df$p.value) + } + + # psignif + if(isTRUE(show.signif.stars)) { + psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" + } else { + psignif <- NULL + } + + lang <- tolower(lang) + cols <- .extract_colnames(df, labs = colnames, lang = lang) + + labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, + origdata = origdata, labs = labs) + + + if(is.null(df[["term"]])){ + # TODO implement model variable + } else { + terms <- .extract_terms(df, labs = labels, lang = lang) + } + #message("labels are: ") + #message(labels) + + list( + df = df, + cols = cols, + equa = NULL, + terms = terms, + psignif = psignif, + footer = NULL) +} From 5d66aea5a88fa2332e76c685d6a60f73fb599c9f Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Fri, 18 Jul 2025 14:43:56 +0200 Subject: [PATCH 14/22] Complete NEWS and TODO files to clarify completed tasks and remaining work --- NEWS.md | 6 ++++-- TODO.md | 25 +++++++++++++++++-------- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/NEWS.md b/NEWS.md index 391cdff..3d1dead 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,10 @@ # modelit 1.4.7 -- Refactor all tabularise\_\*\*\* functions for lm object like tabularise_glance.lm(), tabularise_default.lm(), tabularise_tidy.lm(),... +- Refactored all tabularise\_\*\*\*() methods for lm, summary.lm, nls, summary.nls objects (e.g., tabularise_glance.lm(), tabularise_default.lm(), tabularise_tidy.lm(), etc.) to improve internal consistency and prepare for multi-format table rendering using {flextable}, {tinytable}, and {gt}. -- Adding the lm\_() function which is similar to lm() but adds useful attributes like labels and units of the variables used. +- Labels are now fully integrated into tabularise\_\*\*\*.nls and tabularise\_\*\*\*.summary.nls, allowing consistent and readable output for nonlinear model summaries. + +- Added the experimental lm\_() function, which extends [stats::lm()] by attaching additional metadata such as variable labels and units. Also introduced summary.lm\_() and anova.lm\_() methods to preserve the additional metadata. # modelit 1.4.6 diff --git a/TODO.md b/TODO.md index db4842f..4d75818 100644 --- a/TODO.md +++ b/TODO.md @@ -1,17 +1,26 @@ # modelit To Do list -- Using labels with `equation.nls()` +- 🔥 High Priority: Refactor all tabularise_***() methods for anova, aov, glm objects to improve internal consistency and prepare for multi-format table rendering using {flextable}, {tinytable}, and {gt}. -- Propose specific tables with `tabularise()` for **lm**, **nls**, **glm** objects, etc. with {tinytable} in addition to {flextable} +- 🔥 High Priority: Improve translation management across the package. Currently, multiple calls to gettext() and gettextf() from {svMisc} are used. -- `tabularise()` for **merMod** and **summary.merMod** objects (\< `lme4::glmer()`) +- Introduced the first version of tabularise_***() methods for objects such as lm, nls, and glm, initially designed to generate tables using the {flextable} package. +Future versions will support multiple output formats via {flextable}, {tinytable}, and {gt}. +To enable this flexibility, a unified internal object structure is being developed to store all relevant metadata (e.g., labels, units, formatting). +This structure will allow seamless conversion to different table formats using functions like as_flextable(), as_tinytable(), and as_gt(). -- `tabularise()` for **anova** and **aov** =\> rework and decide where to place these ({inferit}, {modelit}, elsewhere...?) + `car::Anova()`. Also, there is no proper `tabularise_default()` method for **aov** objects +- Implement tabularise_***() methods for enriched model objects: nls_, lm_, summary.lm_, anova_, etc. These methods should leverage the metadata (e.g., labels, units) embedded in the enriched objects to produce consistent and informative tables. -- `chart()` for **lm** with categorical variables +- Complete the examples sections of the tabularise_***() functions for the following object types: lm, summary.lm, nls, summary.nls,... -- multiple comparisons +- Implement tabularise_***() methods for merMod and summary.merMod objects (e.g., from lme4::glmer()). -- train/test +- Extend tabularise() support for anova and aov objects. + - Rework the current implementation and determine the appropriate package context ({inferit}, {modelit}, or another). + - Also consider integration with car::Anova(). + - Note: there is currently no proper tabularise_default() method for aov objects. + +- Develop chart() method for lm objects with categorical predictors (e.g., visualizing factor effects). + +- Add support for multiple comparisons. -- Add various SS models From 74b7abbce95c63f2bc3c248ac407a43aaf221419 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Sun, 17 Aug 2025 14:45:23 +0200 Subject: [PATCH 15/22] Refactor tabularise_* to support both anova and aov objects --- NAMESPACE | 8 +- R/lm_.R | 14 +- R/modelit-package.R | 2 +- R/tabularise.anova.R | 443 ++++++----------------- R/tabularise.lm.R | 21 +- R/tabularise.nls.R | 12 +- R/utils.R | 7 + inst/po/en@quot/LC_MESSAGES/R-modelit.mo | Bin 8218 -> 9596 bytes inst/po/fr/LC_MESSAGES/R-modelit.mo | Bin 5504 -> 7233 bytes man/tabularise_default.anova.Rd | 6 +- man/tabularise_default.aov.Rd | 24 ++ man/tabularise_tidy.anova.Rd | 43 +-- man/tabularise_tidy.aov.Rd | 15 +- po/R-fr.mo | Bin 5504 -> 7233 bytes po/R-fr.po | 105 ++++-- po/R-modelit.pot | 97 ++++- 16 files changed, 358 insertions(+), 439 deletions(-) create mode 100644 man/tabularise_default.aov.Rd diff --git a/NAMESPACE b/NAMESPACE index eec80a2..ee1761a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,6 +34,7 @@ S3method(tabularise_coef,summary.glm) S3method(tabularise_coef,summary.lm) S3method(tabularise_coef,summary.nls) S3method(tabularise_default,anova) +S3method(tabularise_default,aov) S3method(tabularise_default,glm) S3method(tabularise_default,lm) S3method(tabularise_default,nls) @@ -127,8 +128,11 @@ importFrom(stats,rstandard) importFrom(stats,variable.names) importFrom(stats,vcov) importFrom(svFlow,"%>.%") -importFrom(svMisc,gettext) -importFrom(svMisc,gettextf) +importFrom(svMisc,gettext_) +importFrom(svMisc,gettextf_) +importFrom(svMisc,ngettext_) +importFrom(svMisc,stop_) +importFrom(svMisc,warning_) importFrom(tabularise,colformat_sci) importFrom(tabularise,equation) importFrom(tabularise,para_md) diff --git a/R/lm_.R b/R/lm_.R index 50ac600..5f63289 100644 --- a/R/lm_.R +++ b/R/lm_.R @@ -31,7 +31,15 @@ #' # Access labels #' res$labels #' -lm_ <- function(data, formula, ...) { +lm_ <- function(data = (.), formula, ..., .data = data) { + + .__top_call__. <- TRUE + + # Implicit data-dot mechanism + if (missing(data) || !is.data.frame(data)) + return(eval_data_dot(sys.call(), arg = 'data', abort_msg = + gettext("`data` must be a `data.frame`."))) + res <- stats::lm(data = data, formula = formula, ...) # Extract labels @@ -51,7 +59,6 @@ lm_ <- function(data, formula, ...) { res } - #' Summarizing Linear Model Fits with Enhanced Output #' #' @description @@ -146,14 +153,13 @@ anova.lm_ <- function(object, ...) { # Add labels if available if (!is.null(object$labels)) { - res$labels <- object$labels + attr(res, "labels") <- object$labels } # Add custom class if labels were added if (!is.null(res$labels)) { class(res) <- c("anova_", class(res)) } - res } diff --git a/R/modelit-package.R b/R/modelit-package.R index c8a7140..19cc8b5 100644 --- a/R/modelit-package.R +++ b/R/modelit-package.R @@ -30,7 +30,7 @@ #' @importFrom stats AIC anova BIC coef confint cooks.distance deviance family fitted formula hatvalues nobs predict residuals rstandard variable.names vcov #' @importFrom stats coef pf #' @importFrom svFlow %>.% -#' @importFrom svMisc gettext gettextf +#' @importFrom svMisc gettext_ gettextf_ ngettext_ stop_ warning_ #' @importFrom tabularise colformat_sci equation para_md ## usethis namespace: end "_PACKAGE" diff --git a/R/tabularise.anova.R b/R/tabularise.anova.R index c06eacd..8944dd2 100644 --- a/R/tabularise.anova.R +++ b/R/tabularise.anova.R @@ -18,8 +18,6 @@ #' @param ... Additional arguments (not used for now) #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (not used -#' for now) #' #' @return A **flextable** object you can print in different form or rearrange #' with the \{flextable\} functions. @@ -32,8 +30,7 @@ tabularise_default.anova <- function(data, header = TRUE, title = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", "en"), -show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", -env = parent.frame()) { +show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -43,133 +40,19 @@ env = parent.frame()) { title <- FALSE } - # Select the language - info_lang <- .infos_lang.anova(lang = lang) + df_list <- .extract_infos_anova( + data, show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, title = title, + colnames = colnames_anova) - # Extract labels of data or origdata - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) - } - - # Turn an object into a tidy tibble - data_t <- as.data.frame(broom::tidy(data)) - - if (grepl("^Model", attr(data, "heading")[2])) { - data_t$term <- paste(info_lang[["Model"]], 1:nrow(data_t)) - info_lang$labs[["term"]] <- info_lang$Model[["Model"]] - } - - rownames(data_t) <- data_t$term - - if (isTRUE(show.signif.stars) && "p.value" %in% names(data_t)) { - ft <- flextable::flextable(data_t, col_keys = c(names(data_t), "signif")) - } else { - ft <- flextable::flextable(data_t) - } - - ft <- colformat_sci(ft) - if ("p.value" %in% names(data_t)) - ft <- colformat_sci(ft, j = "p.value", lod = 2e-16) - - # Rename headers labels - ft <- .header_labels(ft, info_lang = info_lang) - - statis <- info_lang[["statistic"]] - statis_red <- statis[names(statis) %in% names(data)] - - if (length(statis_red) == 1) { - ft <- mk_par(ft, i = 1, j = "statistic", - value = para_md(statis_red), part = "header") - } - - # Rename terms column - if (isTRUE(auto.labs)) { - if (any(data_t$term %in% "Residuals")) { - ft <- mk_par(ft, i = "Residuals", j = 1, part = "body", - value = as_paragraph(info_lang[["residuals"]])) - } - if (any(data_t$term %in% "NULL")) { - ft <- mk_par(ft, i = "NULL", j = 1, part = "body", - value = as_paragraph(info_lang[["NULL"]])) - } - } - - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% data_t$term] - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = 1, - value = para_md(labs_red[i]), part = "body") - } - - # Add header - if (isTRUE(header)) { - if (isTRUE(title)) { - heading <- paste0(attr(data, "heading"), collapse = "") - heading <- gsub("\n\n", "\n", heading) - heading <- sub("\n$", "", heading) - - if (!is.null(labs)) { - header <- c(info_lang[["method"]], info_lang[["header"]], - gsub("\n", " ", labs)) - } else { - header <- c(info_lang[["method"]], info_lang[["header"]]) - } - - for (i in seq_len(length(header))) - heading <- gsub(names(header)[i], header[i], heading, fixed = TRUE) - - - if (length(heading) == 1) { - ft <- add_header_lines(ft, values = heading) - ft <- align(ft, i = 1, align = "right", part = "header") - } - } - - if (is.character(title)) { - ft <- add_header_lines(ft, values = as_paragraph(title)) - ft <- align(ft, i = 1, align = "right", part = "header") - } - } - - # Add information on the p.value (with internal function) - if (ncol_keys(ft) > ncol(data_t)) { - ft <- .add_signif_stars(ft, j = "signif") - } - - # Adjust cell with autofit() - ft <- autofit(ft, part = c("header", "body")) - - if ("p.value" %in% names(data_t) && isTRUE(show.signif.stars)) - ft <- width(ft, j = "signif", width = 0.4) - - ft + # formatted table ---- + format_table(df_list, kind = kind, header = header) } - #' Tidy version of the anova object into a flextable object #' #' @param data An **anova** object -#' @param header If `TRUE` (by default), add a header to the table -#' @param title If `TRUE`, add a title to the table header. Default to the same -#' value than header, except outside of a chunk where it is `FALSE` if a table -#' caption is detected (`tbl-cap` YAML entry). -#' @param auto.labs If `TRUE` (by default), use labels (and units) from -#' `origdata=`. -#' @param origdata The original data set used for the ANOVA (used for changing -#' the labels). By default, it is `NULL`. -#' @param labs Labels to use to change the names of elements in the `term` -#' column. By default, it is `NULL`. -#' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. -#' @param show.signif.stars If `TRUE`, add the significance stars to the table. -#' The default is taken from `getOption("show.signif.stars")`. -#' @param ... Additional arguments (not used for now) -#' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for -#' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (not used -#' for now) +#' @param ... Additional arguments used tabularise_default.anova() #' #' @return A **flextable** object you can print in different form or rearrange #' with the \{flextable\} functions. @@ -179,212 +62,43 @@ env = parent.frame()) { #' @examples #' iris_anova <- anova(lm(data = iris, Petal.Length ~ Species)) #' tabularise::tabularise$tidy(iris_anova) -tabularise_tidy.anova <- function(data, header = TRUE, title = header, -auto.labs = TRUE, origdata = NULL, labs = NULL, -lang = getOption("data.io_lang", "en"), -show.signif.stars = getOption("show.signif.stars", TRUE), ..., -kind = "ft", env = parent.frame()) { - - # If title is not provided, determine if we have to use TRUE or FALSE - if (missing(title)) { - title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE - if (!is.null(knitr::opts_current$get('tbl-cap'))) - title <- FALSE - } - - # Select language - info_lang <- .infos_lang.anova(lang = lang) - - # Extract labels - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(NULL, labs = labs) - } - - # Turn an object into a tidy tibble - data_t <- as.data.frame(broom::tidy(data)) - rownames(data_t) <- data_t$term - - if (isTRUE(show.signif.stars) && "p.value" %in% names(data_t)) { - ft <- flextable(data_t, col_keys = c(names(data_t), "signif")) - } else { - ft <- flextable::flextable(data_t) - } - - ft <- colformat_sci(ft) - if ("p.value" %in% names(data_t)) - ft <- colformat_sci(ft, j = "p.value", lod = 2e-16) - - # Rename headers labels - ft <- .header_labels(ft, info_lang = info_lang) - - statis <- info_lang[["statistic"]] - statis_red <- statis[names(statis) %in% names(data)] - - if (length(statis_red) == 1) { - ft <- mk_par(ft, i = 1, j = "statistic", - value = para_md(statis_red), part = "header") - } - - # Rename terms column - if (isTRUE(auto.labs)) { - if (any(data_t$term %in% "Residuals")) { - ft <- mk_par(ft, i = "Residuals", j = 1, part = "body", - value = as_paragraph(info_lang[["residuals"]])) - } - if (any(data_t$term %in% "NULL")) { - ft <- mk_par(ft, i = "NULL", j = 1, part = "body", - value = as_paragraph(info_lang[["NULL"]])) - } - } - - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% data_t$term] - - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = 1, - value = para_md(labs_red[i]), part = "body") - } - - if (isTRUE(header)) { - if (isTRUE(title)) { - method <- info_lang[["method"]] - headings <- attr(data, "heading")[1] - - res <- sapply(names(method), function(name) - grepl(paste0("^",name), headings)) - method <- method[res] - - if (length(method) == 1) { - ft <- add_header_lines(ft, values = method) - ft <- align(ft, i = 1, align = "right", part = "header") - } - } - - if (is.character(title)) { - ft <- add_header_lines(ft, values = as_paragraph(title)) - ft <- align(ft, i = 1, align = "right", part = "header") - } - } - - # Add information on the p.value - if (ncol_keys(ft) > ncol(data_t)) - ft <- .add_signif_stars(ft, j = "signif") - - ft <- autofit(ft, part = c("header", "body")) - - if ("p.value" %in% names(data_t) && isTRUE(show.signif.stars)) - ft <- width(ft, j = "signif", width = 0.4) - ft +tabularise_tidy.anova <- function(data,...) { + tabularise_default.anova(data = data, ...) } -#' Tidy version of the aov object into a flextable object -#' -#' @param data An **anova** object -#' @param ... Additional arguments passed to [tabularise_tidy.anova()] -#' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for -#' flextable (default). -#' @param env The environment where to evaluate the object. +#' Create a rich-formatted table from an aov object #' +#' @param data An **aov** object +#' @param ... Additional arguments passed to [tabularise_default.anova()] #' @return **flextable** object you can print in different form or rearrange #' with the \{flextable\} functions. #' @export #' @importFrom tabularise tabularise_default colformat_sci -#' @method tabularise_tidy aov +#' @method tabularise_default aov #' @examples #' iris_aov <- aov(data = iris, Petal.Length ~ Species) #' tabularise::tabularise$tidy(iris_aov) -tabularise_tidy.aov <- function(data, ..., kind = "ft", env = parent.frame()) { - tabularise_tidy(anova(data), ..., kind = kind, env = env) +tabularise_default.aov <- function(data, ...) { + tabularise_default.anova(anova(data), ...) } -# Choose the lang and the infos_lang -.infos_lang.anova <- function(lang) { - lang <- tolower(lang) - if (lang == "fr") { - info_lang <- infos_fr.anova - } else {# Only english for now as second alternative - info_lang <- infos_en.anova - } - info_lang +#' Tidy version of the anova object into a flextable object +#' +#' @param data An **aov** object +#' @param ... Additional arguments passed to [tabularise_default.anova()] +#' @return **flextable** object you can print in different form or rearrange +#' with the \{flextable\} functions. +#' @export +#' @importFrom tabularise tabularise_default colformat_sci +#' @method tabularise_tidy aov +#' @examples +#' iris_aov <- aov(data = iris, Petal.Length ~ Species) +#' tabularise::tabularise$tidy(iris_aov) +tabularise_tidy.aov <- function(data, ...) { + tabularise_default.anova(anova(data), ...) } -infos_en.anova <- list( - method = c( - "Type III Analysis of Variance Table with Satterthwaite's method" = - "Type III analysis of variance with Satterthwaite's method", - "Analysis of Deviance Table" = - "Analysis of deviance", - "Analysis of Variance Table" = - "Analysis of variance" - ), - header = c( - "Response:" = "Response:" - ), - labs = c( - term = "Term", - "df" = "Df", - "df.residual" = "Residuals Df", - rss = "Residual sum of squares", - "sumsq" = "Sum of squares", - "meansq" = "Mean squares", - "p.value" = "*p* value", - num.df = "Num. Df", - NumDF = "Num. Df", - den.df = "Denom. Df", - DenDF = "Denom. Df", - deviance = "Deviance", - residual.deviance = "Residual deviance"), - statistic = c( - "F value" = "*F*~obs.~ value", - "F" = "*F*~obs.~ value", - Chisq = "$\\chi2_{obs.}$"), - residuals = c(Residuals = "Residuals"), - "NULL" = c("NULL" = "None"), - Model = c("Model" = "Model") -) - -infos_fr.anova <- list( - method = c( - "Type III Analysis of Variance Table with Satterthwaite's method" = - "Analyse de la variance de type III avec m\u00e9thode Sattertwaite", - "Analysis of Deviance Table" = - "Analyse de la d\u00e9viance", - "Analysis of Variance Table" = - "Analyse de la variance" - ), - header = c( - "Response:" = "R\u00e9ponse :", - "Model:" = "Mod\u00e8le :", - "Model" = "Mod\u00e8le", - "link:" = "Lien :", - "Terms added sequentially (first to last)" = - "Termes ajout\u00e9s s\u00e9quentiellement (du premier au dernier)" - ), - labs = c( - "term" = "Terme", - "df.residual" = "Ddl des r\u00e9sidus", - rss = "Somme des carr\u00e9s des r\u00e9sidus", - "df" = "Ddl", - "sumsq" = "Somme des carr\u00e9s", - "meansq" = "Carr\u00e9s moyens", - "p.value" = "Valeur de *p*", - num.df = "Ddl num.", - NumDF = "Ddl num.", - den.df = "Ddl d\u00e9nom.", - DenDF = "Ddl d\u00e9nom.", - deviance = "D\u00e9viance", - residual.deviance = "D\u00e9viance r\u00e9siduelle"), - statistic = c( - "F value" = "Valeur de *F*~obs.~", - "F" = "Valeur de *F*~obs.~", - Chisq = "$\\chi2_{obs.}$"), - residuals = c(Residuals = "R\u00e9sidus"), - "NULL" = c("NULL" = "Aucun"), - Model = c("Model" = "Mod\u00e8le") -) +# A list of internals functions and objects ------ colnames_anova <- c( term = "Term", @@ -403,13 +117,19 @@ colnames_anova <- c( residual.deviance = "Residual deviance", "F value" = "*F*~obs.~ value", "F" = "*F*~obs.~ value", - Chisq = "$\\chi2_{obs.}$") + Chisq = "$\\chi2_{obs.}$", + signif = "", + npar = "Number of parameters") .trad_anova <- gettext( "Type III Analysis of Variance Table with Satterthwaite's method" = "Type III analysis of variance with Satterthwaite's method", "Analysis of Deviance Table" = "Analysis of deviance", "Analysis of Variance Table" = "Analysis of variance", + "Anova Table (Type II tests)" = "Type II analysis of variance", + "Anova Table (Type III tests)" = "Type III analysis of variance", + "Analysis of Deviance Table (Type II tests)" = "Type II analysis of deviance table", + "Analysis of Deviance Table (Type III tests)" = "Type III analysis of deviance table", "Response:" = "Response:", "Model:" = "Model:", "Model" = "Model", @@ -433,7 +153,8 @@ colnames_anova <- c( "F" = "*F*~obs.~ value", Chisq = "$\\chi2_{obs.}$", "NULL" = "None", - Residuals = "Residuals" + Residuals = "Residuals", + npar = "Number of parameters" ) .extract_infos_anova <- function(data, show.signif.stars = getOption("show.signif.stars", TRUE), @@ -445,8 +166,9 @@ colnames_anova <- c( # df df <- as.data.frame(broom::tidy(data)) + rownames(df) <- df$term - # statistic variable has 3 possible significcation: "F value", "F", "Chisq" + # statistic variable has 3 possible signification: "F value", "F", "Chisq" statistic_cols <- c("F value", "F", "Chisq") names(df)[names(df) == "statistic"] <- statistic_cols[statistic_cols %in% names(data)][1] @@ -471,21 +193,92 @@ colnames_anova <- c( labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, origdata = origdata, labs = labs) + #message("labels are: ") + #message(labels) - - if(is.null(df[["term"]])){ - # TODO implement model variable + if (is.null(df[["term"]])) { + if (isTRUE(title)) { + df$model <- paste(gettext("Model", lang = lang)[[1]], 1:nrow(df)) + } else { + if (!is.null(labels)) { + labels_red <- gsub("\n", " ", labels) + for (i in seq_len(length(labels_red))) + df$model<- gsub(names(labels_red)[i], labels_red[i], df$model, fixed = TRUE) + } + } } else { terms <- .extract_terms(df, labs = labels, lang = lang) } - #message("labels are: ") - #message(labels) + + + # extract title + # Handle the 'heading' attribute if title is TRUE + if (isTRUE(title)) { + heading <- attr(data, "heading") + heading <- unlist(strsplit(heading, "\n\n")) + heading <- sub("\n$", "", heading) + + # Standardize heading if it starts with "Data" + if (grepl("^Data", heading)[[1]]) { + heading[[1]] <- "Analysis of Variance Table" + + # Format model headings if present + if (grepl("^Models:", heading)[[2]]) { + heading <- heading[-2] + heading[-1] <- paste0("Model ", seq_along(heading[-1]), ": ", heading[-1]) + } + } + + # Replace label names in heading if labels are provided + if (!is.null(labels)) { + labels_red <- gsub("\n", " ", labels) + for (i in seq_len(length(labels_red))) + heading <- gsub(names(labels_red)[i], labels_red[i], heading, fixed = TRUE) + } + + # Map verbose headers to simplified versions + header_anova <- c( + "Type III Analysis of Variance Table with Satterthwaite's method" = + "Type III analysis of variance with Satterthwaite's method", + "Analysis of Deviance Table" = "Analysis of deviance", + "Analysis of Variance Table" = "Analysis of variance", + "Anova Table (Type II tests)" = "Type II analysis of variance", + "Anova Table (Type III tests)" = "Type III analysis of variance", + "Analysis of Deviance Table (Type II tests)" = "Type II analysis of deviance table", + "Analysis of Deviance Table (Type III tests)" = "Type III analysis of deviance table", + "Response:" = "Response:", + "Model:" = "Model:", + "Model" = "Model", + "link:" = "link:", + "Terms added sequentially (first to last)" = "Terms added sequentially (first to last)" + ) + + # Translate headers based on language + header_anovat <- gettext(header_anova, lang = lang) + names(header_anovat) <- names(header_anova) + + # Apply header replacements + for (i in seq_len(length(header_anovat))) + heading <- gsub(names(header_anovat)[i], header_anovat[i], heading, fixed = TRUE) + + title <- paste0(heading, collapse = "\n") + + } else { + title <- NULL + } + + # Preserve title if it's a character string + if (is.character(title)) { + title <- title + } list( df = df, + title = title, cols = cols, equa = NULL, terms = terms, psignif = psignif, footer = NULL) } + diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index ba311ab..05c741d 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -73,7 +73,7 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL, colnames = colnames_lm, footer = FALSE) # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from an lm object @@ -162,7 +162,7 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Glance version of the lm object into a flextable object @@ -216,7 +216,7 @@ tabularise_glance.lm <- function(data, header = TRUE, title = header, colnames = colnames_lm, footer = FALSE) # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table using the table of coefficients of the summary.lm object @@ -280,7 +280,7 @@ tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, colnames = colnames_lm, footer = footer) # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from an summary.lm object @@ -363,6 +363,10 @@ colnames_lm <- c( vec <- labs[names(labs) %in% names(df)] vec1 <- gettext(vec, lang = lang) names(vec1) <- names(vec) + + #Remove elements with missing or empty names + vec1 <- vec1[!is.na(names(vec1)) & names(vec1) != ""] + vec1 } @@ -475,7 +479,10 @@ colnames_lm <- c( terms <- labs[names(labs) %in% vals] if(any(vals == "(Intercept)")) - terms <- c("(Intercept)"= gettext("Intercept", lang = lang), terms) + terms <- c("(Intercept)"= gettext("Intercept", lang = lang)[[1]], terms) + + if(any(vals == "Residuals")) + terms <- c(terms, "Residuals"= gettext("Residuals", lang = lang)[[1]]) terms } @@ -519,7 +526,7 @@ colnames_lm <- c( res <- NULL if (isTRUE(title)) { - res <- gettext("Linear model", lang = lang) + res <- gettext("Linear model", lang = lang)[[1]] } if (is.character(title)) { @@ -681,7 +688,7 @@ colnames_lm <- c( return(ft) } -formate_table <- function(df, kind, header) { +format_table <- function(df, kind, header) { switch(kind, df = {df}, tt = { diff --git a/R/tabularise.nls.R b/R/tabularise.nls.R index 614efcf..53322ab 100644 --- a/R/tabularise.nls.R +++ b/R/tabularise.nls.R @@ -69,7 +69,7 @@ tabularise_default.summary.nls <- function(data, header = TRUE, title = header, # print(df_list) # use only for development # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table using the table of coefficients of the summary.nls object @@ -137,7 +137,7 @@ tabularise_coef.summary.nls <- function(data, header = TRUE, title = header, # print(df_list) # use only for development # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from a nls object @@ -199,7 +199,7 @@ tabularise_default.nls <- function(data, header = TRUE, title = header, # print(df_list) # use only for development # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table using the coefficients of the nls object @@ -261,7 +261,7 @@ tabularise_coef.nls <- function(data, header = TRUE, title = header, # print(df_list) # use only for development # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } @@ -333,7 +333,7 @@ tabularise_tidy.nls <- function(data, header = TRUE, title = header, # print(df_list) # use only for development # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Glance version of the nls object into a flextable object @@ -398,7 +398,7 @@ tabularise_glance.nls <- function(data, header = TRUE, title = header, # print(df_list) # use only for development # formatted table ---- - formate_table(df_list, kind = kind, header = header) + format_table(df_list, kind = kind, header = header) } #' Get a LaTeX equation from an nls or the summary of a nls models diff --git a/R/utils.R b/R/utils.R index ea5f8a1..9c1b1c7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,3 +1,10 @@ +# gettext(), stop(), warning() +gettext <- svMisc::gettext_ +gettextf <- svMisc::gettextf_ +ngettext <- svMisc::ngettext_ +# stop <- svMisc::stop_ # +# warning <- svMisc::warning_ + # Internal functions of flextable .pvalue_format <- function(x) { #x <- get(as.character(substitute(x)), inherits = TRUE) diff --git a/inst/po/en@quot/LC_MESSAGES/R-modelit.mo b/inst/po/en@quot/LC_MESSAGES/R-modelit.mo index 153327a1d145e3b08afc77f636a1f07485f41684..11fdbda8d977e2db5fa20c0fa34ed3cdefa7fda2 100644 GIT binary patch literal 9596 zcmeI1dyE}b9mh|3vw%W*2?7q%<#yM-x9!qGyJdmxlZ7sn?E@&Z%j}(V@11t;%1Tg&&@?PdDZR@Eqtv2VMgofgglF zhy0o63%*#C{}nEv{LLc&Pk0vj)B5uME`aBf?}t~xRq$Hagc|<E8uEK;~@nmqLB7z?0!>sBy-iM0^u0!`qz2*Y_%{z(-*}{4rb)Uxs(UE1AT{;Db=|{w6#X{tOPlUqH$2 zb+{Csa!xL{YoO+_8eRx*fc%*|iu`VPDfx$?KIu8{5LGk@rxQg;upz2++FqhMn z1y?|gvkoqXcC;YVQ#rMFMOE8zE_=Jf*9xNpLpa4C!Y zEc^^)spc{^e-JK#>SqVM2;L7bhEG80!P5o551E4bA=G%kf*S8tsC_*XrI1_~!pq^s zQ0uuCUI{Hcj}3kdvW4bL2(<~n4P{T4v1qo;Y=@FltzfGtzZXhB9x3vVK~&9r0jj?P zkfoX*!K>hNQ1-NdMST%o2W3w$!X5Au7AgDK2W3z9LFwgFa14F}N-th3DB-LA`B3(B z5gdUQE{9J+L}7jhHUHP3`g;RPj{hq13lN_6vk$I@s~{pVZK!sSLFv)wpw{)3f=@&3 z+cU-Y=b_~O64W?|hZ;h|X+;(r*uH+)qP|`!%>1z6`$$C#j@;IRzz>JzZFE4Mf#U6QV-qQ}6`% z<$_;@vZt>@jrS9%@m_%1*SDbLdIFok)Jz}LdWN9vX&YPsRaPfy4m(Mcq;Zm-B_xfZ z_L`gI(?EG_9ak{;B-+(p_=8YSt`zTQBR zJxIs5k*Xx^mt?S&q`lQTc98VQmh{|7l78Jp+Dz&^cNZ^Ha4G3p5-Mb_Bk7TD>X8il zvbX$)ZOWboziW$k$+h#G$jeEjWhB|59+y-jO_R2e^msY4U+J%Wm7a|x>6M-pq%o5A zU5`&Xi&P>>*E)~v<7ATbPS345GQC`1yx(3>7$)6AlKu^mR+9AGoFn_4;8*s%t0=n> zqC%PO6-61&;CE9|aBjgh@U-IHEV{ee@Q0`Fi>8yx{fkV=X||Kpaa%3x#!fp-V>e7{ zQQWki$> zQBQC4>I|8R>v>bvCK4 zmUTv*QZ=%*l9NV`+tW>-)AJNvI@=Q4ZI$}oY>6#NQiPz^#a!vdv#IL`Y`A)^`BmSB zsgt_XfjwkNVSsE776OIy7Nz_VR@H5P=(6g88&>T>3#0zwR%XV=*P1aD+0JCs4rgp! zw=`#AfklO@(j7F+jCs2&le>m@nX%BZag6Fl)oMGAX|}InQSf-y59_`1kjfXT?$qL_ z>6G@DXzd2GiO;%fh-=2z2=fYO+&C{>!_3yAB$;|N-91)KYVEL^`e=LBp_`i&n=umw zGa5c@H*M@!(QtY}?wPSUVYII@*H z4SKWtZ0t-&Z7g!}+VKH1VHqvi+je7{m3Hb%{sjnjLJ=^nA3o6I&_X@uu=Vq0f+iL@zO zqqBI1*ERIwVnMaq?7)$StNC$~mZKOih_N?YZk#qH$Xr-Q9K9B`<1&@;rAXNcqI%}U zkJapL)|>FF4VN8C$`i~5n>_k#Znyq)I|z)jF9(RxW6an!CidXBz#uoKh1-QPkp z!qn%$>@1igvx#bHOHia)o0?nNxz)jGB#$fc*#QpGC`@EK)j4Y|9Nt{b?uI31vs>Nc z)~!?0SzPfW4uS+l+S~T!2&daAzDDOYhhM-!P%)ER)|2|&*-5wKpnQpNxZ!UvpujAS8l4~Ez9Q@9n zuk)u^SSGfST{S$J4USdbm=`ZD=>JMMTYY1wMwy>;D z=-`Nb&eb?Z$NRfW;QEl=eldpPhCg>1Hk;!}aYA|AD{r^4PVkZ3_4}!_tg^gvP2c8Q z%aiz1eJZcxVm0CnFCAV{Ub?cpY`L>+>Bx!|eVcGH<*ka+aLiFW;*7DGT*7?R4sXOQ zSm%TFs2JAUXheCdb(ZFmfx)CZofvx$Ei6 z=;F}1eAHPsu)6Qyc=VNrKA#Kom=WnK4?WrSa>rxR|8Gpnt|@k8OLPvtlem|f0XJYfh(eACRH*oD7faZ9NdOSw$#;(U>RQ-cwHwHU=png0? zea~W4+*uK&W{1M@IQ4xPr?N-7aBG7I3=WA^`P{FM$KzG~i?pKuPQd$K#;fc?X0&X? zkVA&RFOOO~1$pGEToJocX2%StN+pJiFf}44vWsn delta 2240 zcmb`|eN0t#9LMn=pgiiui(Cj0xdfsV7$|WQBDK86gDEL6W;u4_9)k@o-HWXQf-$6a_EY{*Q zD&tvPiGSf{tl}Y!IP7{9b^UA90@B!)6}Se2{J!bspch}q+wnSTt14JUH3qN_L#Uk@ z#|3x*3vmKVF@gMs`P7|X!gb7Nk$!_V*@)~m+cHphJ4|V<^7U3io;}p_P=CbP#$Ro|qn1|QA?7x~WlUW6>KxN*B>9`A( zQ5fkb6UA~I!&NweRXBzD)Zz*bGdKCkW{sdqd))OjY5^ahN_Re={nv?)IKi%)Z%|wH zJ8B^}@h~o?qttvSQO)`r?!@YXWJ#VwHS2ydK?El)OU z%=Iwp{5dSr`+t!Gk}y|M-Rdbz>P7WNKGIjF68Q}iKs9R@D)Yxt&H56mBo@`IN3a}E zpqlkOs#&k1N}=yo#`(~;s013_L>-~mOG8_)`rS>aPc+shF?YI(c0yTcG$onaMeUe& z?|x#3d;ShoA}U{e10Q}uL+|o~gtFa8sDU)J3(BaC=pyDvfCG}z+csBI^~VE*vfM_f zkJMxfiMxpTp zlA=u8UF5Z&Wsloeva9X3oEtW}=*#qdgP};jGrnvlVDVomlh=6@KmJQ zNZCr8?tRF<=v{6H{0}ePu_qJ>hhkxWFcuq$nJyJbbJN=+Xy!FKt<1_u?X@+g%H7scm;5;jv8boZHSacjoRq zx?7Cv#xHy!elR{DfkaG*TR#vC!4G^h*91w7CYoqK6tg5M!59-05=~6}{b$bH&TV_y zCNk-{zdL8nobx~b*ZJT6>B{~jC%s^ zg{R?X;LDId^*SH&-ftnItGDd^+px<0-ynbLnm(mI0k4O$pQ_~n_$ltE?ej;VZ2dTt zd0X&exCSfm43z!72rq;$!2$RRJOuv;Z-@OK&-oCP=ii1R&#Q1Zd>2l_%MnU+e+1qP zUxc5AZ$eb6{sD*J`%v_vFH>p+-UdZ44JdLPhu6RmUICx9_s_sDaQ_o1diXVDD)olt zU+nXL!Tt1KfpTQreNgmt#L|VbP7DX(DR?b>9#-M2@N@88cmuo$ClP-dgg3%TC~|mE z)_D?&-hT$KgTH~Fg@1=)$4hu9?1M7TWl-iBhGL&tDEe81*TaXQ$aNat1b+nIgTI1^ zq+UfScf;4A=(q1m=7hT}_dw~dL9y>FJOJn5SKzlSe-G!l*9;c@pMZN{3T3_@Lb1b3 z@M`!ADC6FSGS53u_PYmTid=`F==%tiamOGkP<2>?F%&(&2*s|iS-xTUp5=d`%y&7# zA$r*baWQoh#3j`jtil6O_UA*FsEl~7UgR(=TP+WJ4=}q6RTk;{(Bdc{g1;D=tHs3b5Q){1$Ya58SaJeK=I>i zarz6OT;gwE%)aFxqF33QT!@+3Rdgxu7gvoh*?w(@$UaGv93y#3bSiS*M-#shor@mi z61~fHFh}R}9=_eyx!d?6aV>ig`^Ys)lf6GEH}*OVAE1ftP*tWgkm*qLA=jNW@%{2O z%gqtmB2DzCY4_74#usQ}qq}J03ld*5w0@dg7t`ixV!r{JTwl$h_E`#W-Ru%Sl zY$JY3xMy($GXI)@x6&jh-Aa)!}6w205L;&A+$}UD3m>VZG}3 zsbN$s@12$@PUn59^HdEdcAR|c8nZ`L&8Z}E>d7%LXoT@GCkR)a!699D0`0U~{u)d3 zk#*~E>A0yU)y?nt&8;u^P2O>JoHm)XjiSLhW=UVX8h|x{7JXrzX@mb}*~P)%7q~HPN!+b>8+(BopPPP~-0L>inZ) zkE-#&@z-Jx$r{=RffAyz?IBo1OB}U!U}n6+MR47{272 zSo2f|;mN9+*iH_0&;((#st-2!W|!srB<|955~B{KK|S&Cn8$XO>}1GqSDxQ@f4)OHIwBe&V%QdU$>q{aMehXvaOC#tB+4_p4bo8wN%`{9G*G zIB`-eq4nXg*)mb`gcY~vI453fwvv!g(vew4x>!_`D}Hd5ulF#EgQqkaYeT)4Yj{zd zRKmz*+jW+9qNHhp;^#GacXdnadfddQX{Xc0!` z{z}-W*nTT+@igwt7)wg%bW7xI+>msZ$zTu3X|g9fLLMnS?H18SCb5y7J+6ceSqaG+ zd~w63yon8BQ&S7Y<|ebvEp+c-(L_xpAEa~FMPV_T%S}fz8q9)9jNud7LuwI!*d2?4 zvs}LFc)p~nYW6@fX6iegr+UHojS9<0i5DzuIU($jY_DtZ9xLSFBP}vsIqBkZ+T>oZ zo8(ZvWOP8PaaHLFuXjDdEgF$RvmH&7M5F>>?p2O=Tr_*w^_Jc`#tR;=sl?VA$bU>$ z?mg$mi1SQ*sv|EaN_Ox^<-^+^Txu=~r5LG9xs{_PlB8bC6PuUl(dypn9es26SLQh% zNBTIWNxsa1Z`E|d342S+cf8=vOlz@84jfrLRN1#NE~@}cRGAFw zp^Nv{^u8r8>3gtp*aVWJM2NZ2xNPOt>g|1MQ-O%nXT>3*q$&Eejn_Dh@_;po4P4i! zNTfhCJaHLIxyaa99o^_EYQ}P3Yq)%uY`V+qM=IeSm7@+wdFReNBh{lPBA!U)F3k)_ zi6#YRRd0S9LsJHx=UwpzHdhpt+O(7{k?cpi%0*S0hN%E*j>6AsLn+RjUJqu7@{DLqV_u3FuJ!LA;1nDfyJUl`PzE~!gb2k zPBkU*w6#_$RMNc)Hno+iCwh*xo9b3%njZG2kVSFZzh{e2S&Atr>63^kkQ%mqmaiRE zaj=#*weebydD->mg0=TZTdVdS@PDfZaeB@{B~dS2Z@@aVW#CauUF5VdDd2} z=gvH*W&NyZ#odXMl0>$0ZLgOq*U36XRhH-QRH|K~go-uZi1nh&Q1YsUu-TMk6!SlW zJfgZ@`ryaKe&#!CNP6j7l#Y%Blbo|Iepw#D6kSzq59#enI@4#Tu9XCUBlsS_5yTkC zkrlSOrZ(o;y2Y%fHTfr{?eQ?>c^c-oWV`Kb$=bR~(W)xlO-L@inJ(r!H2fm2q~mk=>MBJE@q$KK4;FHz4u!C z%>7k;<+101mU4G37ur!bTtE%@02kmm)?*=~@4>II97iw@U*cl?2bW_o zJ+a~@Oy;}=3-L>wgHhB1`gP9ucA3sS8hMG_b&cY_tN;`1|p2V5> z9a23T_8dW#^bXF)C&;4hUz~?Y%p$gkPAQ#**oc2%53a|r{bqb@(DMh>ibqi?{S_PV zk>_k?zn$|4s^%lO6z?Lp*jw-V1nPH_S>#_U*uYLAd)A8DRQoy9VJ|8JKVmLE^!(lP zou|^lqAY-wSd5xrBWk7Fa3dZ;ZRXpklK+)M{)2Q%dAe#?k2>#0{h%LJ^T((ZRs<5? zH{lY_qo`ef8MWfyP^Ei;s`+cw9{PwR)k;X8p0f9i>WND)cag>Q)u+ zaWm@wLGc-F6-}#BRM1qSPeEqm18cP!NZAO|wDCxSF@8J>II{4Vt?(|)L#0Hk*8hNJ ztx#4JKAKXjSCqeo_|8^}OKGYpTOpnS)m5RgDA;ROLsQzd*UD)swPKO&NbG!_6zkxH zHj&b;(8kneR9aOUZ8XJPno9F2^ls}lc2`sD+<0opRpzC*OTKK^>3ijlr!}SY9&GDs zkGSV)eW~5yNJlWd-^J2HZXlyz_?PtgNp3Q;%+>h!y1V{j_uk){*WAf`$gZ0s9 zchq)9qMhzaR>a-UKJRws+)7_rQB@nPs;R49?E<;i+|RjN-QqxPeAqt&A@?-!%)Q7v z;2Zni8~B^)*E7BdcLY1T!(-PvB5qB7wF?v!41b&NPjZ8WJbbJN=+Xy!FKt<1_u?X@+g%H7scm;5;jv8boZHSacjoRq zx?7Cv#xHy!elR{DfkaG*TR#vC!4G^h*91w7CYoqK6tg5M!59-05=~6}{b$bH&TV_y zCNk-{zdL8nobx~b*ZJT6>B{~jC%s^ zg{R?X;LDId^*SH&-ftnItGDd^+px<0-ynbLnm(mI0k4O$pQ_~n_$ltE?ej;VZ2dTt zd0X&exCSfm43z!72rq;$!2$RRJOuv;Z-@OK&-oCP=ii1R&#Q1Zd>2l_%MnU+e+1qP zUxc5AZ$eb6{sD*J`%v_vFH>p+-UdZ44JdLPhu6RmUICx9_s_sDaQ_o1diXVDD)olt zU+nXL!Tt1KfpTQreNgmt#L|VbP7DX(DR?b>9#-M2@N@88cmuo$ClP-dgg3%TC~|mE z)_D?&-hT$KgTH~Fg@1=)$4hu9?1M7TWl-iBhGL&tDEe81*TaXQ$aNat1b+nIgTI1^ zq+UfScf;4A=(q1m=7hT}_dw~dL9y>FJOJn5SKzlSe-G!l*9;c@pMZN{3T3_@Lb1b3 z@M`!ADC6FSGS53u_PYmTid=`F==%tiamOGkP<2>?F%&(&2*s|iS-xTUp5=d`%y&7# zA$r*baWQoh#3j`jtil6O_UA*FsEl~7UgR(=TP+WJ4=}q6RTk;{(Bdc{g1;D=tHs3b5Q){1$Ya58SaJeK=I>i zarz6OT;gwE%)aFxqF33QT!@+3Rdgxu7gvoh*?w(@$UaGv93y#3bSiS*M-#shor@mi z61~fHFh}R}9=_eyx!d?6aV>ig`^Ys)lf6GEH}*OVAE1ftP*tWgkm*qLA=jNW@%{2O z%gqtmB2DzCY4_74#usQ}qq}J03ld*5w0@dg7t`ixV!r{JTwl$h_E`#W-Ru%Sl zY$JY3xMy($GXI)@x6&jh-Aa)!}6w205L;&A+$}UD3m>VZG}3 zsbN$s@12$@PUn59^HdEdcAR|c8nZ`L&8Z}E>d7%LXoT@GCkR)a!699D0`0U~{u)d3 zk#*~E>A0yU)y?nt&8;u^P2O>JoHm)XjiSLhW=UVX8h|x{7JXrzX@mb}*~P)%7q~HPN!+b>8+(BopPPP~-0L>inZ) zkE-#&@z-Jx$r{=RffAyz?IBo1OB}U!U}n6+MR47{272 zSo2f|;mN9+*iH_0&;((#st-2!W|!srB<|955~B{KK|S&Cn8$XO>}1GqSDxQ@f4)OHIwBe&V%QdU$>q{aMehXvaOC#tB+4_p4bo8wN%`{9G*G zIB`-eq4nXg*)mb`gcY~vI453fwvv!g(vew4x>!_`D}Hd5ulF#EgQqkaYeT)4Yj{zd zRKmz*+jW+9qNHhp;^#GacXdnadfddQX{Xc0!` z{z}-W*nTT+@igwt7)wg%bW7xI+>msZ$zTu3X|g9fLLMnS?H18SCb5y7J+6ceSqaG+ zd~w63yon8BQ&S7Y<|ebvEp+c-(L_xpAEa~FMPV_T%S}fz8q9)9jNud7LuwI!*d2?4 zvs}LFc)p~nYW6@fX6iegr+UHojS9<0i5DzuIU($jY_DtZ9xLSFBP}vsIqBkZ+T>oZ zo8(ZvWOP8PaaHLFuXjDdEgF$RvmH&7M5F>>?p2O=Tr_*w^_Jc`#tR;=sl?VA$bU>$ z?mg$mi1SQ*sv|EaN_Ox^<-^+^Txu=~r5LG9xs{_PlB8bC6PuUl(dypn9es26SLQh% zNBTIWNxsa1Z`E|d342S+cf8=vOlz@84jfrLRN1#NE~@}cRGAFw zp^Nv{^u8r8>3gtp*aVWJM2NZ2xNPOt>g|1MQ-O%nXT>3*q$&Eejn_Dh@_;po4P4i! zNTfhCJaHLIxyaa99o^_EYQ}P3Yq)%uY`V+qM=IeSm7@+wdFReNBh{lPBA!U)F3k)_ zi6#YRRd0S9LsJHx=UwpzHdhpt+O(7{k?cpi%0*S0hN%E*j>6AsLn+RjUJqu7@{DLqV_u3FuJ!LA;1nDfyJUl`PzE~!gb2k zPBkU*w6#_$RMNc)Hno+iCwh*xo9b3%njZG2kVSFZzh{e2S&Atr>63^kkQ%mqmaiRE zaj=#*weebydD->mg0=TZTdVdS@PDfZaeB@{B~dS2Z@@aVW#CauUF5VdDd2} z=gvH*W&NyZ#odXMl0>$0ZLgOq*U36XRhH-QRH|K~go-uZi1nh&Q1YsUu-TMk6!SlW zJfgZ@`ryaKe&#!CNP6j7l#Y%Blbo|Iepw#D6kSzq59#enI@4#Tu9XCUBlsS_5yTkC zkrlSOrZ(o;y2Y%fHTfr{?eQ?>c^c-oWV`Kb$=bR~(W)xlO-L@inJ(r!H2fm2q~mk=>MBJE@q$KK4;FHz4u!C z%>7k;<+101mU4G37ur!bTtE%@02kmm)?*=~@4>II97iw@U*cl?2bW_o zJ+a~@Oy;}=3-L>wgHhB1`gP9ucA3sS8hMG_b&cY_tN;`1|p2V5> z9a23T_8dW#^bXF)C&;4hUz~?Y%p$gkPAQ#**oc2%53a|r{bqb@(DMh>ibqi?{S_PV zk>_k?zn$|4s^%lO6z?Lp*jw-V1nPH_S>#_U*uYLAd)A8DRQoy9VJ|8JKVmLE^!(lP zou|^lqAY-wSd5xrBWk7Fa3dZ;ZRXpklK+)M{)2Q%dAe#?k2>#0{h%LJ^T((ZRs<5? zH{lY_qo`ef8MWfyP^Ei;s`+cw9{PwR)k;X8p0f9i>WND)cag>Q)u+ zaWm@wLGc-F6-}#BRM1qSPeEqm18cP!NZAO|wDCxSF@8J>II{4Vt?(|)L#0Hk*8hNJ ztx#4JKAKXjSCqeo_|8^}OKGYpTOpnS)m5RgDA;ROLsQzd*UD)swPKO&NbG!_6zkxH zHj&b;(8kneR9aOUZ8XJPno9F2^ls}lc2`sD+<0opRpzC*OTKK^>3ijlr!}SY9&GDs zkGSV)eW~5yNJlWd-^J2HZXlyz_?PtgNp3Q;%+>h!y1V{j_uk){*WAf`$gZ0s9 zchq)9qMhzaR>a-UKJRws+)7_rQB@nPs;R49?E<;i+|RjN-QqxPeAqt&A@?-!%)Q7v z;2Zni8~B^)*E7BdcLY1T!(-PvB5qB7wF?v!41b&NPjZ8W\n" "Language-Team: LANGUAGE \n" @@ -43,18 +43,93 @@ msgstr "" msgid "You must give either 'h=' or 'v='." msgstr "" -msgid "lang is not defined" +msgid "Type III analysis of variance with Satterthwaite's method" msgstr "" -msgid "langue" +msgid "Analysis of deviance" msgstr "" -msgid "pas en cache" +msgid "Analysis of variance" +msgstr "" + +msgid "Type II analysis of variance" +msgstr "" + +msgid "Type III analysis of variance" +msgstr "" + +msgid "Type II analysis of deviance table" +msgstr "" + +msgid "Type III analysis of deviance table" +msgstr "" + +msgid "Response:" +msgstr "" + +msgid "Model:" +msgstr "" + +msgid "Model" +msgstr "" + +msgid "link:" +msgstr "" + +msgid "Terms added sequentially (first to last)" msgstr "" msgid "Term" msgstr "" +msgid "Df" +msgstr "" + +msgid "Residuals Df" +msgstr "" + +msgid "Residual sum of squares" +msgstr "" + +msgid "Sum of squares" +msgstr "" + +msgid "Mean squares" +msgstr "" + +msgid "*p* value" +msgstr "" + +msgid "Num. Df" +msgstr "" + +msgid "Denom. Df" +msgstr "" + +msgid "Deviance" +msgstr "" + +msgid "Residual deviance" +msgstr "" + +msgid "*F*~obs.~ value" +msgstr "" + +msgid "$\\chi2_{obs.}$" +msgstr "" + +msgid "None" +msgstr "" + +msgid "Residuals" +msgstr "" + +msgid "Number of parameters" +msgstr "" + +msgid ".extract_infos_anova() can apply only anova object." +msgstr "" + msgid "Estimate" msgstr "" @@ -85,18 +160,12 @@ msgstr "" msgid "BIC" msgstr "" -msgid "Deviance" -msgstr "" - msgid "Log-likelihood" msgstr "" msgid "*t* value" msgstr "" -msgid "*p* value" -msgstr "" - msgid "Model df" msgstr "" @@ -145,7 +214,7 @@ msgstr "" msgid "*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s" msgstr "" -msgid ".extract_infos_nls() can apply only lm and summary.lm object." +msgid ".extract_infos_lm() can apply only lm and summary.lm object." msgstr "" msgid ".extract_infos_lm() cannot apply type = 'coef' to a summary.lm\n object. Use type = 'tidy' instead to extract a detailed coefficient table." @@ -250,12 +319,6 @@ msgstr "" msgid ".extract_infos_nls() cannot apply type = 'glance' to a summary.nls\n object." msgstr "" -msgid "add_header_nls()" -msgstr "" - -msgid "header_labels()" -msgstr "" - msgid "header_labels_lm()" msgstr "" From 365cc1f8f55fe197dbdf51ac0c929be439237911 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 20 Aug 2025 09:23:50 +0200 Subject: [PATCH 16/22] Improved examples and functions documentation. --- R/tabularise.anova.R | 59 ++++++-- R/tabularise.lm.R | 172 +++++++++++++++++------- R/tabularise.nls.R | 39 +++++- man/tabularise_coef.lm.Rd | 30 +++-- man/tabularise_coef.summary.lm.Rd | 26 +++- man/tabularise_default.anova.Rd | 22 ++- man/tabularise_default.lm.Rd | 4 +- man/tabularise_default.summary.nls.Rd | 9 ++ man/tabularise_glance.lm.Rd | 26 +++- man/tabularise_tidy.anova.Rd | 18 ++- man/tabularise_tidy.aov.Rd | 4 +- man/tabularise_tidy.lm.Rd | 28 +++- tests/testthat/test-.extract_infos_lm.R | 5 +- 13 files changed, 338 insertions(+), 104 deletions(-) diff --git a/R/tabularise.anova.R b/R/tabularise.anova.R index 8944dd2..f329eb2 100644 --- a/R/tabularise.anova.R +++ b/R/tabularise.anova.R @@ -25,8 +25,26 @@ #' @importFrom tabularise tabularise_default colformat_sci #' @method tabularise_default anova #' @examples -#' iris_anova <- anova(lm(data = iris, Petal.Length ~ Species)) -#' tabularise::tabularise(iris_anova) +#' is <- data.io::read("iris", package = "datasets") +#' +#' is_lm1 <- lm(data = is, petal_length ~ species) +#' +#' library(tabularise) +#' +#' anova(is_lm1) |> tabularise_default() +#' # identical +#' anova(is_lm1) |> tabularise() +#' # Use labels +#' anova(is_lm1) |> tabularise(origdata = is) +#' +#' # alternative with anova_() in {modelit} package +#' anova_(is_lm1) |> tabularise() +#' +#' is_lm2 <- lm(data = is, petal_length ~ sepal_length + species) +#' +#' anova(is_lm1, is_lm2) |> tabularise(origdata = is) +#' anova_(is_lm1, is_lm2) |> tabularise() +#' tabularise_default.anova <- function(data, header = TRUE, title = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", "en"), @@ -52,7 +70,7 @@ show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { #' Tidy version of the anova object into a flextable object #' #' @param data An **anova** object -#' @param ... Additional arguments used tabularise_default.anova() +#' @param ... Additional arguments used [tabularise_default.anova()] #' #' @return A **flextable** object you can print in different form or rearrange #' with the \{flextable\} functions. @@ -60,8 +78,20 @@ show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { #' @importFrom tabularise tabularise_default colformat_sci #' @method tabularise_tidy anova #' @examples -#' iris_anova <- anova(lm(data = iris, Petal.Length ~ Species)) -#' tabularise::tabularise$tidy(iris_anova) +#' is <- data.io::read("iris", package = "datasets") +#' +#' is_lm1 <- lm(data = is, petal_length ~ species) +#' +#' library(tabularise) +#' +#' anova(is_lm1) |> tabularise_tidy() +#' # identical +#' anova(is_lm1) |> tabularise$tidy() +#' # Use labels +#' anova(is_lm1) |> tabularise$tidy(origdata = is) +#' +#' # alternative with anova_() in {modelit} package +#' anova_(is_lm1) |> tabularise$tidy() tabularise_tidy.anova <- function(data,...) { tabularise_default.anova(data = data, ...) } @@ -79,10 +109,10 @@ tabularise_tidy.anova <- function(data,...) { #' iris_aov <- aov(data = iris, Petal.Length ~ Species) #' tabularise::tabularise$tidy(iris_aov) tabularise_default.aov <- function(data, ...) { - tabularise_default.anova(anova(data), ...) + tabularise_default.anova(anova_(data), ...) } -#' Tidy version of the anova object into a flextable object +#' Tidy version of the aov object into a flextable object #' #' @param data An **aov** object #' @param ... Additional arguments passed to [tabularise_default.anova()] @@ -95,7 +125,7 @@ tabularise_default.aov <- function(data, ...) { #' iris_aov <- aov(data = iris, Petal.Length ~ Species) #' tabularise::tabularise$tidy(iris_aov) tabularise_tidy.aov <- function(data, ...) { - tabularise_default.anova(anova(data), ...) + tabularise_default.anova(anova_(data), ...) } # A list of internals functions and objects ------ @@ -191,10 +221,15 @@ colnames_anova <- c( lang <- tolower(lang) cols <- .extract_colnames(df, labs = colnames, lang = lang) - labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, - origdata = origdata, labs = labs) - #message("labels are: ") - #message(labels) + data_obj <- attr(data, "object") + + if (is.null(data_obj)) { + labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, + origdata = origdata, labs = labs) + } else { + labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, + origdata = origdata, labs = labs) + } if (is.null(df[["term"]])) { if (isTRUE(title)) { diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index 05c741d..a70467e 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -6,12 +6,24 @@ #' \{flextable\}. #' #' @param data An **lm** object -#' @param header If `TRUE` (by default), add a header to the table -#' @param title If `TRUE`, add a title to the table header. Default to the same -#' value than header, except outside of a chunk where it is `FALSE` if a table -#' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add a equation to the table header. -#' The equation can also be passed in the form of a character string. +#' @param header Logical. If `TRUE` (`FALSE`by default), a header is added to +#' the table. The header includes both the title and the equation (if +#' applicable). If set to `FALSE`, neither the title nor the equation will be +#' displayed in the table header, even if the `title` or `equation` parameters +#' are provided. +#' @param title If `TRUE` (`FALSE`by default) , add a title to the table header. +#' Default to the same value than header, except outside of a chunk where it is +#' `FALSE` if a table caption is detected (`tbl-cap` YAML entry). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE`: The equation is generated and added to the table header. Its +#' parameters are also used in the "Term" column. +#' - `FALSE` (by default): No equation is generated or displayed, and its +#' parameters are not used in the "Term" column. +#' - `NA`: The equation is generated but not displayed in the table header. +#' Its parameters are used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. #' @param auto.labs If `TRUE` (by default), use labels (and units) automatically #' from data or `origdata=`. #' @param origdata The original data set this model was fitted to. By default it @@ -53,7 +65,7 @@ #' iris_lm2 <- lm(data = iris, Petal.Length ~ Sepal.Length * Species) #' tabularise::tabularise$coef(iris_lm2) #' -tabularise_coef.lm <- function(data, header = TRUE, title = NULL, +tabularise_coef.lm <- function(data, header = FALSE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), ..., kind = "ft") { @@ -86,7 +98,6 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL, #' @param ... Additional arguments passed to [modelit::tabularise_coef.lm()] #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate the model. #' @return A **flextable** object that you can print in different formats (HTML, #' LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} functions. #' @export @@ -95,10 +106,10 @@ tabularise_coef.lm <- function(data, header = TRUE, title = NULL, #' @examples #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise(iris_lm) -tabularise_default.lm <- function(data, ..., kind = "ft", env = parent.frame()) { +tabularise_default.lm <- function(data, ..., kind = "ft") { # Note: there isn't much in print(lm_obj) than the table of coefficients # so, we produce the same table as tabularise$coef() here - tabularise_coef.lm(data = data, ..., kind = kind, env = env) + tabularise_coef.lm(data = data, ..., kind = kind) } #' Tidy version of the lm object into a flextable object @@ -108,12 +119,24 @@ tabularise_default.lm <- function(data, ..., kind = "ft", env = parent.frame()) #' object. #' #' @param data An **lm** object -#' @param header If `TRUE` (by default), add an header to the table -#' @param title If `TRUE`, add a title to the table header. Default to the same -#' value than header, except outside of a chunk where it is `FALSE` if a table -#' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add an equation to the table header. -#' The equation can also be passed in the form of a character string (LaTeX). +#' @param header Logical. If `TRUE` (`TRUE`by default), a header is added to +#' the table. The header includes both the title and the equation (if +#' applicable). If set to `FALSE`, neither the title nor the equation will be +#' displayed in the table header, even if the `title` or `equation` parameters +#' are provided. +#' @param title If `TRUE` (by default) , add a title to the table header. +#' Default to the same value than header, except outside of a chunk where it is +#' `FALSE` if a table caption is detected (`tbl-cap` YAML entry). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE`(by default): The equation is generated and added to the table +#' header. Its parameters are also used in the "Term" column. +#' - `FALSE`: No equation is generated or displayed, and its +#' parameters are not used in the "Term" column. +#' - `NA`: The equation is generated but not displayed in the table header. +#' Its parameters are used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. #' @param auto.labs If `TRUE` (by default), use labels (and units) automatically #' from data or `origdata=`. #' @param origdata The original data set this model was fitted to. By default it @@ -141,7 +164,7 @@ tabularise_default.lm <- function(data, ..., kind = "ft", env = parent.frame()) #' @examples #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$tidy(iris_lm) -tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, +tabularise_tidy.lm <- function(data, header = TRUE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, conf.int = FALSE, conf.level = 0.95, lang = getOption("data.io_lang", "en"), show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { @@ -158,7 +181,7 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, data, type = "tidy", conf.int = conf.int, conf.level = 0.95, show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, title = title, - colnames = colnames_lm, footer = FALSE) + colnames = colnames_lm, footer = FALSE, ...) # formatted table ---- @@ -172,12 +195,24 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = NULL, #' object. #' #' @param data An **lm** object -#' @param header If `TRUE` (by default), add a header to the table -#' @param title If `TRUE`, add a title to the table header. Default to the same -#' value than header, except outside of a chunk where it is `FALSE` if a table -#' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add a equation to the table header. -#' The equation can also be passed in the form of a character string (LaTeX). +#' @param header Logical. If `TRUE` (`TRUE`by default), a header is added to +#' the table. The header includes both the title and the equation (if +#' applicable). If set to `FALSE`, neither the title nor the equation will be +#' displayed in the table header, even if the `title` or `equation` parameters +#' are provided. +#' @param title If `TRUE` (by default) , add a title to the table header. +#' Default to the same value than header, except outside of a chunk where it is +#' `FALSE` if a table caption is detected (`tbl-cap` YAML entry). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE`(by default): The equation is generated and added to the table +#' header. Its parameters are also used in the "Term" column. +#' - `FALSE`: No equation is generated or displayed, and its +#' parameters are not used in the "Term" column. +#' - `NA`: The equation is generated but not displayed in the table header. +#' Its parameters are used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. #' @param auto.labs If `TRUE` (by default), use labels (and units) automatically #' from data or `origdata=`. #' @param origdata The original data set this model was fitted to. By default it @@ -213,7 +248,7 @@ tabularise_glance.lm <- function(data, header = TRUE, title = header, data, type = "glance", conf.int = FALSE, conf.level = 0.95, show.signif.stars = FALSE, lang = lang, auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, title = title, - colnames = colnames_lm, footer = FALSE) + colnames = colnames_lm, footer = FALSE, ...) # formatted table ---- format_table(df_list, kind = kind, header = header) @@ -222,12 +257,24 @@ tabularise_glance.lm <- function(data, header = TRUE, title = header, #' Create a rich-formatted table using the table of coefficients of the summary.lm object #' #' @param data An **summary.lm** object -#' @param header If `TRUE` (by default), add a header to the table -#' @param title If `TRUE`, add a title to the table header. Default to the same -#' value than header, except outside of a chunk where it is `FALSE` if a table -#' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add a equation to the table header. -#' The equation can also be passed in the form of a character string. +#' @param header Logical. If `TRUE` (`TRUE`by default), a header is added to +#' the table. The header includes both the title and the equation (if +#' applicable). If set to `FALSE`, neither the title nor the equation will be +#' displayed in the table header, even if the `title` or `equation` parameters +#' are provided. +#' @param title If `TRUE` (by default) , add a title to the table header. +#' Default to the same value than header, except outside of a chunk where it is +#' `FALSE` if a table caption is detected (`tbl-cap` YAML entry). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE`(by default): The equation is generated and added to the table +#' header. Its parameters are also used in the "Term" column. +#' - `FALSE`: No equation is generated or displayed, and its +#' parameters are not used in the "Term" column. +#' - `NA`: The equation is generated but not displayed in the table header. +#' Its parameters are used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. #' @param footer If `TRUE` (by default, it is FALSE), add a footer to the table. #' @param auto.labs If `TRUE` (by default), use labels (and units) automatically #' from data or `origdata=`. @@ -277,7 +324,7 @@ tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, data, type = "tidy", conf.int = conf.int, conf.level = conf.level, show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, origdata = origdata, labs = labs, equation = equation, title = title, - colnames = colnames_lm, footer = footer) + colnames = colnames_lm, footer = footer, ...) # formatted table ---- format_table(df_list, kind = kind, header = header) @@ -346,6 +393,7 @@ colnames_lm <- c( df = "Model df", df.residual = "Residuals df", nobs = "N", + "header" = "Linear model", "(Intercept)" = "Intercept", lang = "fr") #.trads @@ -488,21 +536,35 @@ colnames_lm <- c( } .extract_equation <- function(data, equation, labs, ...) { - if (isTRUE(equation)) { - if (!is.null(labs)) { - equa <- tabularise::equation(data, swap_var_names = labs, ...) - } else { - equa <- tabularise::equation(data, auto.labs = FALSE, ...) - } - return(equa) - #attr(x, "equation_params") <- .params_equa(equa) + + if (!(is.logical(equation) || is.character(equation))) { + stop("The 'equation' argument must be TRUE, FALSE, NA, or a character string.") + } + + equa <- NULL + + if (isTRUE(equation) || is.na(equation)) { + equa <- try({ + if (!is.null(labs)) { + tabularise::equation(data, swap_var_names = labs, ...) + } else { + tabularise::equation(data, auto.labs = FALSE, ...) + } + }, silent = TRUE) + if (inherits(equa, "try-error")) + equa <- NULL } if (is.character(equation)) { - return(equation) + equa <- equation } + + equa } + + + .params_equa <- function(x, intercept = "alpha", greek = "beta") { vals <- NULL @@ -522,11 +584,11 @@ colnames_lm <- c( vals } -.extract_title_lm <- function(title, lang = "en") { +.extract_title <- function(title, lang = "en", default = "Linear model") { res <- NULL if (isTRUE(title)) { - res <- gettext("Linear model", lang = lang)[[1]] + res <- gettext(default, lang = lang)[[1]] } if (is.character(title)) { @@ -606,18 +668,34 @@ colnames_lm <- c( lang <- tolower(lang) cols <- .extract_colnames(df, labs = colnames_lm, lang = lang) - labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, + data_obj <- attr(data, "object") + + if (is.null(data_obj)) { + + labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, origdata = origdata, labs = labs) - equa <- .extract_equation(data, equation = equation, labs = labels) + equa <- .extract_equation(data, equation = equation, labs = labels) - if(isTRUE(equation)){ + } else { + + labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, + origdata = origdata, labs = labs) + + equa <- .extract_equation(data_obj, equation = equation, labs = labels) + } + + if ((isTRUE(equation) || is.na(equation)) && !is.null(equa)) { terms <- .params_equa(equa) } else { terms <- .extract_terms(df, labs = labels, lang = lang) } - title <- .extract_title_lm(title, lang = lang) + if (is.na(equation)) { + equa <- NULL + } + + title <- .extract_title(title, lang = lang, default = "Linear model") if(isTRUE(footer)) { footer <- .extract_footer_lm(data, lang = lang) diff --git a/R/tabularise.nls.R b/R/tabularise.nls.R index 53322ab..6db710a 100644 --- a/R/tabularise.nls.R +++ b/R/tabularise.nls.R @@ -48,6 +48,15 @@ #' #' tabularise::tabularise(chick1_logis_sum) #' tabularise::tabularise(chick1_logis_sum, footer = FALSE) +#' +#' growth <- data.io::read("urchin_growth", package = "data.io") +#' growth_logis <- nls(data = growth, diameter ~ SSlogis(age, Asym, xmid, scal)) +#' chart::chart(growth_logis) +#' tabularise::tabularise(summary(growth_logis)) # No labels +#' tabularise::tabularise(summary(growth_logis), origdata = growth) # with labels +#' tabularise::tabularise(summary(growth_logis), origdata = growth, +#' equation = FALSE, show.signif.stars = FALSE) +#' tabularise_default.summary.nls <- function(data, header = TRUE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", "en"), footer = TRUE, @@ -450,8 +459,9 @@ equation.nls <- function(object, ital_vars = FALSE, use_coefs = FALSE, coef_digits = 2L, fix_signs = TRUE, swap_var_names = NULL, var_names = swap_var_names, op_latex = c("\\cdot", "\\times"), ...) { x <- object - if (!class(x) %in% c("nls", "summary.nls")) - stop("x must be an nls or summary.nls object") + if (!inherits(x, "nls") && !inherits(x, "summary.nls")) { + stop("`x` must be an object of class 'nls' or 'summary.nls'.") + } res <- try(stats::formula(x), silent = TRUE) @@ -693,7 +703,7 @@ model_nls <- c( .extract_infos_nls <- function(data, type = "coef", show.signif.stars = getOption("show.signif.stars", TRUE), lang = "en", colnames = colnames_nls, auto.labs = TRUE, origdata = NULL , labs = NULL, - equation = TRUE, title = TRUE, footer = TRUE) { + equation = TRUE, title = TRUE, footer = TRUE, ...) { if (!inherits(data, c("nls", "summary.nls"))) stop(".extract_infos_nls() can apply only nls and summary.nls object.") @@ -752,9 +762,26 @@ model_nls <- c( lang <- tolower(lang) cols <- .extract_colnames(df, labs = colnames, lang = lang) - labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, - origdata = origdata, labs = labs) - equa <- .extract_equation(data, equation = equation, labs = labels) + data_obj <- attr(data, "object") + + if (is.null(data_obj)) { + + labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, + origdata = origdata, labs = labs) + + equa <- .extract_equation(data, equation = equation, labs = labels,...) + + } else { + + labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, + origdata = origdata, labs = labs) + + equa <- .extract_equation(data_obj, equation = equation, labs = labels,...) + } + + if (is.na(equation)) { + equa <- NULL + } terms <- NULL diff --git a/man/tabularise_coef.lm.Rd b/man/tabularise_coef.lm.Rd index c73c45f..a36b558 100644 --- a/man/tabularise_coef.lm.Rd +++ b/man/tabularise_coef.lm.Rd @@ -6,8 +6,8 @@ \usage{ \method{tabularise_coef}{lm}( data, - header = TRUE, - title = NULL, + header = FALSE, + title = header, equation = header, auto.labs = TRUE, origdata = NULL, @@ -20,14 +20,28 @@ \arguments{ \item{data}{An \strong{lm} object} -\item{header}{If \code{TRUE} (by default), add a header to the table} +\item{header}{Logical. If \code{TRUE} (\code{FALSE}by default), a header is added to +the table. The header includes both the title and the equation (if +applicable). If set to \code{FALSE}, neither the title nor the equation will be +displayed in the table header, even if the \code{title} or \code{equation} parameters +are provided.} -\item{title}{If \code{TRUE}, add a title to the table header. Default to the same -value than header, except outside of a chunk where it is \code{FALSE} if a table -caption is detected (\code{tbl-cap} YAML entry).} +\item{title}{If \code{TRUE} (\code{FALSE}by default) , add a title to the table header. +Default to the same value than header, except outside of a chunk where it is +\code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add a equation to the table header. -The equation can also be passed in the form of a character string.} +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE}: The equation is generated and added to the table header. Its +parameters are also used in the "Term" column. +\item \code{FALSE} (by default): No equation is generated or displayed, and its +parameters are not used in the "Term" column. +\item \code{NA}: The equation is generated but not displayed in the table header. +Its parameters are used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} \item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically from data or \verb{origdata=}.} diff --git a/man/tabularise_coef.summary.lm.Rd b/man/tabularise_coef.summary.lm.Rd index 2aed96b..626a124 100644 --- a/man/tabularise_coef.summary.lm.Rd +++ b/man/tabularise_coef.summary.lm.Rd @@ -24,14 +24,28 @@ \arguments{ \item{data}{An \strong{summary.lm} object} -\item{header}{If \code{TRUE} (by default), add a header to the table} +\item{header}{Logical. If \code{TRUE} (\code{TRUE}by default), a header is added to +the table. The header includes both the title and the equation (if +applicable). If set to \code{FALSE}, neither the title nor the equation will be +displayed in the table header, even if the \code{title} or \code{equation} parameters +are provided.} -\item{title}{If \code{TRUE}, add a title to the table header. Default to the same -value than header, except outside of a chunk where it is \code{FALSE} if a table -caption is detected (\code{tbl-cap} YAML entry).} +\item{title}{If \code{TRUE} (by default) , add a title to the table header. +Default to the same value than header, except outside of a chunk where it is +\code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add a equation to the table header. -The equation can also be passed in the form of a character string.} +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE}(by default): The equation is generated and added to the table +header. Its parameters are also used in the "Term" column. +\item \code{FALSE}: No equation is generated or displayed, and its +parameters are not used in the "Term" column. +\item \code{NA}: The equation is generated but not displayed in the table header. +Its parameters are used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} \item{footer}{If \code{TRUE} (by default, it is FALSE), add a footer to the table.} diff --git a/man/tabularise_default.anova.Rd b/man/tabularise_default.anova.Rd index 8d8e5e3..22f761d 100644 --- a/man/tabularise_default.anova.Rd +++ b/man/tabularise_default.anova.Rd @@ -54,6 +54,24 @@ with the \{flextable\} functions. Create a rich-formatted table from an anova object } \examples{ -iris_anova <- anova(lm(data = iris, Petal.Length ~ Species)) -tabularise::tabularise(iris_anova) +is <- data.io::read("iris", package = "datasets") + +is_lm1 <- lm(data = is, petal_length ~ species) + +library(tabularise) + +anova(is_lm1) |> tabularise_default() +# identical +anova(is_lm1) |> tabularise() +# Use labels +anova(is_lm1) |> tabularise(origdata = is) + +# alternative with anova_() in {modelit} package +anova_(is_lm1) |> tabularise() + +is_lm2 <- lm(data = is, petal_length ~ sepal_length + species) + +anova(is_lm1, is_lm2) |> tabularise(origdata = is) +anova_(is_lm1, is_lm2) |> tabularise() + } diff --git a/man/tabularise_default.lm.Rd b/man/tabularise_default.lm.Rd index a291c73..1672e17 100644 --- a/man/tabularise_default.lm.Rd +++ b/man/tabularise_default.lm.Rd @@ -4,7 +4,7 @@ \alias{tabularise_default.lm} \title{Create a rich-formatted table from an lm object} \usage{ -\method{tabularise_default}{lm}(data, ..., kind = "ft", env = parent.frame()) +\method{tabularise_default}{lm}(data, ..., kind = "ft") } \arguments{ \item{data}{An \strong{lm} object} @@ -13,8 +13,6 @@ \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} - -\item{env}{The environment where to evaluate the model.} } \value{ A \strong{flextable} object that you can print in different formats (HTML, diff --git a/man/tabularise_default.summary.nls.Rd b/man/tabularise_default.summary.nls.Rd index 6f6396c..929b149 100644 --- a/man/tabularise_default.summary.nls.Rd +++ b/man/tabularise_default.summary.nls.Rd @@ -73,6 +73,15 @@ chick1_logis_sum <- summary(chick1_logis) tabularise::tabularise(chick1_logis_sum) tabularise::tabularise(chick1_logis_sum, footer = FALSE) + +growth <- data.io::read("urchin_growth", package = "data.io") +growth_logis <- nls(data = growth, diameter ~ SSlogis(age, Asym, xmid, scal)) +chart::chart(growth_logis) +tabularise::tabularise(summary(growth_logis)) # No labels +tabularise::tabularise(summary(growth_logis), origdata = growth) # with labels +tabularise::tabularise(summary(growth_logis), origdata = growth, + equation = FALSE, show.signif.stars = FALSE) + } \seealso{ \code{\link[tabularise:tabularise]{tabularise::tabularise()}}, \code{\link[tabularise:tabularise_tidy]{tabularise::tabularise_tidy()}}, diff --git a/man/tabularise_glance.lm.Rd b/man/tabularise_glance.lm.Rd index 2d84558..227ea89 100644 --- a/man/tabularise_glance.lm.Rd +++ b/man/tabularise_glance.lm.Rd @@ -20,14 +20,28 @@ \arguments{ \item{data}{An \strong{lm} object} -\item{header}{If \code{TRUE} (by default), add a header to the table} +\item{header}{Logical. If \code{TRUE} (\code{TRUE}by default), a header is added to +the table. The header includes both the title and the equation (if +applicable). If set to \code{FALSE}, neither the title nor the equation will be +displayed in the table header, even if the \code{title} or \code{equation} parameters +are provided.} -\item{title}{If \code{TRUE}, add a title to the table header. Default to the same -value than header, except outside of a chunk where it is \code{FALSE} if a table -caption is detected (\code{tbl-cap} YAML entry).} +\item{title}{If \code{TRUE} (by default) , add a title to the table header. +Default to the same value than header, except outside of a chunk where it is +\code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add a equation to the table header. -The equation can also be passed in the form of a character string (LaTeX).} +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE}(by default): The equation is generated and added to the table +header. Its parameters are also used in the "Term" column. +\item \code{FALSE}: No equation is generated or displayed, and its +parameters are not used in the "Term" column. +\item \code{NA}: The equation is generated but not displayed in the table header. +Its parameters are used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} \item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically from data or \verb{origdata=}.} diff --git a/man/tabularise_tidy.anova.Rd b/man/tabularise_tidy.anova.Rd index 2b60007..3e6f199 100644 --- a/man/tabularise_tidy.anova.Rd +++ b/man/tabularise_tidy.anova.Rd @@ -9,7 +9,7 @@ \arguments{ \item{data}{An \strong{anova} object} -\item{...}{Additional arguments used tabularise_default.anova()} +\item{...}{Additional arguments used \code{\link[=tabularise_default.anova]{tabularise_default.anova()}}} } \value{ A \strong{flextable} object you can print in different form or rearrange @@ -19,6 +19,18 @@ with the \{flextable\} functions. Tidy version of the anova object into a flextable object } \examples{ -iris_anova <- anova(lm(data = iris, Petal.Length ~ Species)) -tabularise::tabularise$tidy(iris_anova) +is <- data.io::read("iris", package = "datasets") + +is_lm1 <- lm(data = is, petal_length ~ species) + +library(tabularise) + +anova(is_lm1) |> tabularise_tidy() +# identical +anova(is_lm1) |> tabularise$tidy() +# Use labels +anova(is_lm1) |> tabularise$tidy(origdata = is) + +# alternative with anova_() in {modelit} package +anova_(is_lm1) |> tabularise$tidy() } diff --git a/man/tabularise_tidy.aov.Rd b/man/tabularise_tidy.aov.Rd index 72ed14d..5ac49a9 100644 --- a/man/tabularise_tidy.aov.Rd +++ b/man/tabularise_tidy.aov.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tabularise.anova.R \name{tabularise_tidy.aov} \alias{tabularise_tidy.aov} -\title{Tidy version of the anova object into a flextable object} +\title{Tidy version of the aov object into a flextable object} \usage{ \method{tabularise_tidy}{aov}(data, ...) } @@ -16,7 +16,7 @@ with the \{flextable\} functions. } \description{ -Tidy version of the anova object into a flextable object +Tidy version of the aov object into a flextable object } \examples{ iris_aov <- aov(data = iris, Petal.Length ~ Species) diff --git a/man/tabularise_tidy.lm.Rd b/man/tabularise_tidy.lm.Rd index ce7f3f9..2ec0c9e 100644 --- a/man/tabularise_tidy.lm.Rd +++ b/man/tabularise_tidy.lm.Rd @@ -7,7 +7,7 @@ \method{tabularise_tidy}{lm}( data, header = TRUE, - title = NULL, + title = header, equation = header, auto.labs = TRUE, origdata = NULL, @@ -23,14 +23,28 @@ \arguments{ \item{data}{An \strong{lm} object} -\item{header}{If \code{TRUE} (by default), add an header to the table} +\item{header}{Logical. If \code{TRUE} (\code{TRUE}by default), a header is added to +the table. The header includes both the title and the equation (if +applicable). If set to \code{FALSE}, neither the title nor the equation will be +displayed in the table header, even if the \code{title} or \code{equation} parameters +are provided.} -\item{title}{If \code{TRUE}, add a title to the table header. Default to the same -value than header, except outside of a chunk where it is \code{FALSE} if a table -caption is detected (\code{tbl-cap} YAML entry).} +\item{title}{If \code{TRUE} (by default) , add a title to the table header. +Default to the same value than header, except outside of a chunk where it is +\code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add an equation to the table header. -The equation can also be passed in the form of a character string (LaTeX).} +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE}(by default): The equation is generated and added to the table +header. Its parameters are also used in the "Term" column. +\item \code{FALSE}: No equation is generated or displayed, and its +parameters are not used in the "Term" column. +\item \code{NA}: The equation is generated but not displayed in the table header. +Its parameters are used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} \item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically from data or \verb{origdata=}.} diff --git a/tests/testthat/test-.extract_infos_lm.R b/tests/testthat/test-.extract_infos_lm.R index 7d9c1cd..ed28ee9 100644 --- a/tests/testthat/test-.extract_infos_lm.R +++ b/tests/testthat/test-.extract_infos_lm.R @@ -69,14 +69,15 @@ test_that("x$title is NULL when title = FALSE/TRUE/chr", { res <- .extract_infos_lm(mod, type = "tidy", title = TRUE) expect_equal(res$title, "Linear model") - res <- .extract_infos_lm(mod, type = "tidy", title = TRUE, lang = "fr") - expect_equal(res$title, "Modèle linéaire") + #res <- .extract_infos_lm(mod, type = "tidy", title = TRUE, lang = "fr") + #expect_equal(res$title, "Modèle linéaire") res <- .extract_infos_lm(mod, type = "tidy", title = "blablabla") expect_type(res$title, "character") expect_equal(res$title, "blablabla") }) + # cols -------------------------------------------------------------------- test_that("x$cols is a named character vector", { From f7bc021f758758f8fb37f4dadcc55a4bcf3d14e5 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 20 Aug 2025 09:24:46 +0200 Subject: [PATCH 17/22] add tabularise_*** for glm object --- R/tabularise.glm.R | 816 ++++++++++++++------------ R/utils.R | 3 + man/tabularise_coef.glm.Rd | 51 +- man/tabularise_coef.summary.glm.Rd | 46 +- man/tabularise_default.glm.Rd | 51 +- man/tabularise_default.summary.glm.Rd | 37 +- man/tabularise_glance.glm.Rd | 34 +- man/tabularise_tidy.glm.Rd | 44 +- po/R-fr.mo | Bin 7233 -> 11833 bytes po/R-fr.po | 145 ++++- po/R-modelit.pot | 81 ++- 11 files changed, 829 insertions(+), 479 deletions(-) diff --git a/R/tabularise.glm.R b/R/tabularise.glm.R index bfcc4a5..87ee82d 100644 --- a/R/tabularise.glm.R +++ b/R/tabularise.glm.R @@ -10,25 +10,37 @@ #' to [stats::coef()], but in a rich-formatted **flextable** object. #' #' @param data A **glm** object -#' @param header If `TRUE` (by default), add a header to the table +#' @param header Logical. If `TRUE` (default), a header is added to the table. +#' The header includes both the title and the equation (if applicable). +#' If set to `FALSE`, neither the title nor the equation will be displayed in +#' the table header, even if the `title` or `equation` parameters are provided. #' @param title If `TRUE`, add a title to the table header. Default to the same #' value than header, except outside of a chunk where it is `FALSE` if a table #' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add an equation to the table header. -#' The equation can also be passed in the form of a character string (LaTeX). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE`: The equation is generated and added to the table header. Its +#' parameters are also used in the "Term" column. +#' - `FALSE` (by default): No equation is generated or displayed, and its +#' parameters are not used in the "Term" column. +#' - `NA`: The equation is generated but not displayed in the table header. +#' Its parameters are used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. #' @param auto.labs If `TRUE` (by default), use labels (and units) automatically -#' from `origdata=`. +#' from data or `origdata=`. #' @param origdata The original data set this model was fitted to. By default it -#' is `NULL` and labels of the original data set are not used. +#' is `NULL` and no label is used. #' @param labs Labels to change the names of elements in the `term` column of -#' the table. By default, it is `NULL` and no change is performed. +#' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, #' e.g., `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments (not used yet). +#' @param footer If `TRUE` (`FALSE` by default), add a footer to the table. +#' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). +#' @param env The environment where to evaluate formulas (you probably do not +#' need to change the default). #' #' @return A **flextable** object is returned. You can print it in different #' formats (HTML, LaTeX, Word, PowerPoint) or rearrange it with the @@ -39,9 +51,21 @@ #' @examples #' iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$coef(iris_glm) -tabularise_coef.glm <- function(data, header = TRUE, title = NULL, -equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, -lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame()) { +#' +#' # If the 'iris' dataset has labels and units, they can be used to enhance +#' # the output table +#' iris <- data.io::labelise(iris, self = FALSE, label = list( +#' Sepal.Length = "Length of the sepals", +#' Petal.Length = "Length of the petals", +#' Species = "Species"), units = c(rep("cm", 4), NA)) +#' +#' iris_glm1 <- glm(data = iris, Petal.Length ~ Sepal.Length + Species) +#' tabularise::tabularise$coef(iris_glm1) +#' +tabularise_coef.glm <- function(data, header = FALSE, title = header, +equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, footer = FALSE, +lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), +..., kind = "ft", env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -51,74 +75,50 @@ lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame()) title <- FALSE } - # Choose the language - info_lang <- .infos_lang.glm(lang = lang) - - # Extract coef - co <- coef(data) - co <- data.frame(term = names(co), estimate = co) - # co <- as.data.frame(rbind(coef(data))) - - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) - } - - # Create the flextable object - ft <- flextable(co) |> - colformat_sci() - - ft <- .header_labels(ft, info_lang = info_lang) - - # Header and equation - if (isTRUE(equation)) { - if (!is.null(labs)) { - equa <- equation(data, swap_var_names = labs, ...) - } else { - equa <- equation(data, auto.labs = FALSE,...) - } - - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equa) - } else { - equa <- NULL - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equation) - } - - if (isTRUE(auto.labs) && any(co$term %in% "(Intercept)")) { - ft <- mk_par(ft, i = "(Intercept)", j = 1, part = "body", - value = as_paragraph(info_lang[["(Intercept)"]])) - } - - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% co$term] - - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = "term", - value = para_md(labs_red[i]), part = "body") - } - - if (isTRUE(equation) & !is.null(equa)) { - params <- .params_equa(equa,...) - if (length(params) == length(co$term)) - ft <- mk_par(ft, j = "term", value = para_md(params), part = "body") - } + df_list <- .extract_infos_glm( + data, type = "coef", conf.int = FALSE, conf.level = 0.95, + show.signif.stars = FALSE, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_glm, footer = footer, ...) - autofit(ft, part = c("header", "body")) + # formatted table ---- + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from a glm object #' #' @param data A **glm** object -#' @param footer If `TRUE` (by default), add a footer to the table +#' @param header Logical. If `TRUE` (`FALSE` by default), a header is added to the table. +#' The header includes both the title and the equation (if applicable). +#' If set to `FALSE`, neither the title nor the equation will be displayed in +#' the table header, even if the `title` or `equation` parameters are provided. +#' @param title If `TRUE` (`FALSE` by default), add a title to the table header. Default to the same +#' value than header, except outside of a chunk where it is `FALSE` if a table +#' caption is detected (`tbl-cap` YAML entry). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE`: The equation is generated and added to the table header. Its +#' parameters are also used in the "Term" column. +#' - `FALSE` (by default): No equation is generated or displayed, and its +#' parameters are not used in the "Term" column. +#' - `NA`: The equation is generated but not displayed in the table header. +#' Its parameters are used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used. +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. +#' @param footer If `TRUE` (`FALSE` by default), add a footer to the table #' @param lang The natural language to use. The default value can be set with, #' e.g., `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments passed to [modelit::tabularise_coef.glm()] +#' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate the model. +#' @param env The environment where to evaluate formulas (you probably do not +#' need to change the default). #' #' @return A **flextable** object is returned. You can print it in different #' formats (HTML, LaTeX, Word, PowerPoint) or rearrange it with the @@ -129,28 +129,30 @@ lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame()) #' @examples #' iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise(iris_glm) -tabularise_default.glm <- function(data, footer = TRUE, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { - ft <- tabularise_coef.glm(data = data, ...) +#' tabularise::tabularise(iris_glm, header = TRUE, footer = TRUE) +#' tabularise::tabularise(iris_glm, header = TRUE, footer = FALSE) +#' tabularise::tabularise(iris_glm, header = TRUE, equation = NA,footer = TRUE) +tabularise_default.glm <- function(data, header = FALSE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + footer = FALSE, lang = getOption("data.io_lang", + default = Sys.getenv("LANGUAGE",unset = "en")), ..., kind = "ft", env = parent.frame()) { - if (isTRUE(footer)) { - info_lang <- .infos_lang.glm(lang = lang) - - digits <- max(3L, getOption("digits") - 3L) - footer <- info_lang[["footer"]] - vals <- c( - paste(footer[["df"]], data$df.null, footer[["total"]], data$df.residual, - footer[["residual"]]), - paste(footer[["null.deviance"]], - format(signif(data$null.deviance, digits))), - paste(footer[["resid.deviance"]], format(signif(data$deviance, - digits)), footer[["AIC"]], format(signif(data$aic, digits))) - ) - ft <- add_footer_lines(ft, values = vals) + # If title is not provided, determine if we have to use TRUE or FALSE + if (missing(title)) { + title <- header # Default to same as header, but... + # if a caption is defined in the chunk, it defauts to FALSE + if (!is.null(knitr::opts_current$get('tbl-cap'))) + title <- FALSE } - autofit(ft, part = c("header", "body")) + df_list <- .extract_infos_glm( + data, type = "coef", conf.int = FALSE, conf.level = 0.95, + show.signif.stars = FALSE, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_glm, footer = footer, ..., env = env) + + # formatted table ---- + format_table(df_list, kind = kind, header = header) } #' Create a tidy version of the glm object as a rich-formatted table @@ -161,16 +163,27 @@ tabularise_default.glm <- function(data, footer = TRUE, #' Word, PowerPoint), or rearranged later on. #' #' @param data A **glm** object -#' @param header If `TRUE` (by default), add a header to the table -#' @param title If `TRUE`, add a title to the table header. Default to the same +#' @param header Logical. If `TRUE` (`TRUE` by default), a header is added to the table. +#' The header includes both the title and the equation (if applicable). +#' If set to `FALSE`, neither the title nor the equation will be displayed in +#' the table header, even if the `title` or `equation` parameters are provided. +#' @param title If `TRUE` (`TRUE` by default), add a title to the table header. Default to the same #' value than header, except outside of a chunk where it is `FALSE` if a table #' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add an equation to the table header. -#' The equation can also be passed in the form of a character string (LaTeX). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE` (default) : The equation is generated and added to the table +#' header. Its parameters are also used in the "Term" column. +#' - `FALSE`: No equation is generated or displayed, and its parameters are +#' not used in the "Term" column. +#' - `NA`: The equation is generated but not displayed in the table header. +#' Its parameters are used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. #' @param auto.labs If `TRUE` (by default), use labels (and units) automatically -#' from `origdata=`. ` +#' from data or `origdata=`. #' @param origdata The original data set this model was fitted to. By default it -#' is `NULL` and variables labels from this data set are not used. +#' is `NULL` and no label is used. #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param conf.int If `TRUE`, add the confidence interval. The default is @@ -180,12 +193,12 @@ tabularise_default.glm <- function(data, footer = TRUE, #' @param lang The natural language to use. The default value can be set with, #' e.g., `options(data.io_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. -#' Its value is obtained from `getOption("show.signif.stars")`. -#' @param ... Additional arguments passed to [tabularise::equation()] +#' The default is `getOption("show.signif.stars")` +#' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). +#' @param env The environment where to evaluate formulas (you probably do not +#' need to change the default). #' #' @return A **flextable** object is returned. You can print it in different #' formats (HTML, LaTeX, Word, PowerPoint), or rearrange it with the @@ -195,14 +208,23 @@ tabularise_default.glm <- function(data, footer = TRUE, #' @importFrom rlang .data #' @method tabularise_tidy glm #' @examples +#' #' # If the 'iris' dataset has labels and units, they can be used to enhance +#' # the output table +#' iris <- data.io::labelise(iris, self = FALSE, label = list( +#' Sepal.Length = "Length of the sepals", +#' Petal.Length = "Length of the petals", +#' Species = "Species"), units = c(rep("cm", 4), NA)) #' iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) +#' #' tabularise::tabularise$tidy(iris_glm) +#' tabularise::tabularise$tidy(iris_glm, conf.int = TRUE) +#' tabularise::tabularise$tidy(iris_glm, conf.int = TRUE, equation = NA) tabularise_tidy.glm <- function(data, header = TRUE, title = NULL, -equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, -conf.int = FALSE, conf.level = 0.95, lang = getOption("data.io_lang", "en"), -show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", -env = parent.frame()) { - + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + conf.int = FALSE, conf.level = 0.95, + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", + env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... @@ -211,86 +233,14 @@ env = parent.frame()) { title <- FALSE } - # Choose the language - info_lang <- .infos_lang.glm(lang = lang) - - # Extract labels of data or origdata - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) - } - - # Turn an object into a tidy tibble - data_t <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, - conf.level = conf.level)) - rownames(data_t) <- data_t$term - - if (isTRUE(conf.int)) { - data_t <- data_t[, c("term", "estimate", "conf.low", "conf.high", - "std.error", "statistic", "p.value")] - } - - s <- colnames(coef(summary(data))) - if (any(s %in% "z value")) - colnames(data_t)[colnames(data_t) == "statistic"] <- "statistic2" - - if (isTRUE(show.signif.stars)) { - ft <- flextable(data_t, col_keys = c(names(data_t), "signif")) - } else { - ft <- flextable(data_t) - } - ft <- colformat_sci(ft) - ft <- colformat_sci(ft, j = "p.value", lod = 2e-16) - - # Rename headers labels - ft <- .header_labels(ft, info_lang = info_lang) - - # headers - if (isTRUE(equation)) { - if (!is.null(labs)) { - equa <- equation(data, swap_var_names = labs, ...) - } else { - equa <- equation(data, auto.labs = FALSE, ...) - } - - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equa) - } else { - equa <- NULL - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - title = title, equation = equation) - } - - if (isTRUE(auto.labs) && any(data_t$term %in% "(Intercept)")) { - ft <- mk_par(ft, i = "(Intercept)", j = 1, part = "body", - value = as_paragraph(info_lang[["(Intercept)"]])) - } - - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% data_t$term] + df_list <- .extract_infos_glm( + data, type = "tidy", conf.int = conf.int, conf.level = 0.95, + show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_glm, footer = FALSE, ..., env = env) - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = 1, - value = para_md(labs_red[i]), part = "body") - } - - if (isTRUE(equation) && !is.null(equa)) { - params <- .params_equa(equa) - if (length(params) == length(data_t$term)) - ft <- mk_par(ft, j = "term", value = para_md(params), part = "body") - } - - # Add information on the p.value - if (ncol_keys(ft) > ncol(data_t)) - ft <- .add_signif_stars(ft, j = "signif") - - ft <- autofit(ft, part = c("header", "body")) - - if (isTRUE(show.signif.stars)) - ft <- width(ft, j = "signif", width = 0.4) - - ft + # formatted table ---- + format_table(df_list, kind = kind, header = header) } #' Create a glance version of the glm object as a rich-formatted table @@ -301,16 +251,25 @@ env = parent.frame()) { #' Word, PowerPoint), or rearranged later on. #' #' @param data A **glm** object -#' @param header If `TRUE` (by default), add an header to the table -#' @param title If `TRUE`, add a title to the table header. Default to the same +#' @param header Logical. If `TRUE` (`TRUE` by default), a header is added to the table. +#' The header includes both the title and the equation (if applicable). +#' If set to `FALSE`, neither the title nor the equation will be displayed in +#' the table header, even if the `title` or `equation` parameters are provided. +#' @param title If `TRUE` (`TRUE` by default), add a title to the table header. Default to the same #' value than header, except outside of a chunk where it is `FALSE` if a table #' caption is detected (`tbl-cap` YAML entry). -#' @param equation If `TRUE` (by default), add an equation to the table header. -#' The equation can also be passed in the form of a character string (LaTeX). +#' @param equation Logical or character. Controls whether an equation is added +#' to the table header and how parameters are used. Accepted values are: +#' - `TRUE` (default) : The equation is generated and added to the table +#' header. Its parameters are also used in the "Term" column. +#' - `FALSE`: No equation is generated or displayed, and its parameters are +#' not used in the "Term" column. +#' - Character string: A custom equation is provided directly and added to +#' the table header. #' @param auto.labs If `TRUE` (by default), use labels (and units) automatically -#' from `origdata=`. +#' from data or `origdata=`. #' @param origdata The original data set this model was fitted to. By default it -#' is `NULL` and original labels are not used. +#' is `NULL` and no label is used. #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, @@ -318,8 +277,8 @@ env = parent.frame()) { #' @param ... Additional arguments passed to [tabularise::equation()] #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate lazyeval expressions (unused for -#' now). +#' @param env The environment where to evaluate formulas (you probably do not +#' need to change the default). #' #' @return A **flextable** object is produced that you can print in different #' formats (HTML, LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} @@ -330,11 +289,13 @@ env = parent.frame()) { #' @examples #' iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$glance(iris_glm) -tabularise_glance.glm <- function(data, header = TRUE, title = NULL, - equation = TRUE, auto.labs = TRUE, origdata = NULL, labs = NULL, +#' tabularise::tabularise$glance(iris_glm, equation = FALSE) +#' tabularise::tabularise$glance(iris_glm, equation = "my personal equation") +#' +tabularise_glance.glm <- function(data, header = TRUE, title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame()) { - # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... @@ -343,58 +304,14 @@ tabularise_glance.glm <- function(data, header = TRUE, title = NULL, title <- FALSE } - # Choose the language - info_lang <- .infos_lang.glm(lang = lang) - - # Extract labels off data or origdata - if (isTRUE(auto.labs)) { - labs <- tabularise:::.labels2(x = data, origdata = origdata, labs = labs) - } else { - labs <- tabularise:::.labels2(x = NULL, labs = labs) - } - - # Turn an object into a tidy tibble - data_t <- as.data.frame(broom::glance(x = data)) - rownames(data_t) <- data_t$term - - # Use flextable - ft <- flextable(data_t) - ft <- colformat_sci(ft) - #ft <- colformat_sci(ft, j = "p.value", lod = 2e-16) - - # Rename headers labels - ft <- .header_labels(ft, info_lang = info_lang) - - # Headers - if (isTRUE(equation)) { - if (!is.null(labs)) { - equa <- equation(data, swap_var_names = labs, ...) - } else { - equa <- equation(data, auto.labs = FALSE, ...) - } - - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - equation = equa) - } else { - equa <- NULL - ft <- .add_header(ft, data = data, info_lang = info_lang, header = header, - equation = equation) - } - - if (isTRUE(auto.labs) && any(data_t$term %in% "(Intercept)")) { - ft <- mk_par(ft, i = "(Intercept)", j = 1, part = "body", - value = as_paragraph(info_lang[["(Intercept)"]])) - } + df_list <- .extract_infos_glm( + data, type = "glance", conf.int = FALSE, conf.level = 0.95, + show.signif.stars = FALSE, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_glm, footer = FALSE, ..., env = env) - if (!is.null(labs)) { - labs_red <- labs[names(labs) %in% data_t$term] - - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = 1, - value = para_md(labs_red[i]), part = "body") - } - - autofit(ft, part = c("header", "body")) + # formatted table ---- + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table using the table of coefficients of the summary.glm object @@ -404,10 +321,27 @@ tabularise_glance.glm <- function(data, header = TRUE, title = NULL, #' from the [summary()] of a **glm** object. #' #' @param data A **summary.glm** object -#' @param ... Additional arguments passed to [modelit::tabularise_tidy.glm()] +#' @param header If `TRUE` (by default), add a header to the table +#' @param title If `TRUE`, add a title to the table header. Default to the same +#' value than header, except outside of a chunk where it is `FALSE` if a table +#' caption is detected (`tbl-cap` YAML entry). +#' @param equation If `TRUE` (by default), try to add a equation to the table +#' header. The equation can also be passed in the form of a character string. +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used. +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. +#' @param lang The natural language to use. The default value can be set with, +#' e.g., `options(data.io_lang = "fr")` for French. +#' @param show.signif.stars If `TRUE`, add the significance stars to the table. +#' The default is `getOption("show.signif.stars")` +#' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate the model. +#' @param env The environment where to evaluate formulas (you probably do not +#' need to change the default). #' #' @return A **flextable** object that you can print in different formats #' (HTML, LaTeX, Word, PowerPoint) or rearrange with the \{flextable\} @@ -419,14 +353,28 @@ tabularise_glance.glm <- function(data, header = TRUE, title = NULL, #' @examples #' iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) #' iris_glm_sum <- summary(iris_glm) -#' tabularise::tabularise$coef(iris_glm_sum) -tabularise_coef.summary.glm <- function(data, ..., kind = "ft", - env = parent.frame()) { +#' tabularise::tabularise_coef(iris_glm_sum) +tabularise_coef.summary.glm <- function(data, header = TRUE, title = NULL, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", + env = parent.frame()) { + # If title is not provided, determine if we have to use TRUE or FALSE + if (missing(title)) { + title <- header # Default to same as header, but... + # if a caption is defined in the chunk, it defauts to FALSE + if (!is.null(knitr::opts_current$get('tbl-cap'))) + title <- FALSE + } - lm_original <- data$call - data <- eval(lm_original, envir = env) + df_list <- .extract_infos_glm( + data, type = "coef", conf.int = FALSE, conf.level = 0.95, + show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_glm, footer = FALSE, ..., env = env) - tabularise_tidy.glm(data = data, ..., kind = kind, env = env) + # formatted table ---- + format_table(df_list, kind = kind, header = header) } #' Create a rich-formatted table from a summary.glm object @@ -435,13 +383,28 @@ tabularise_coef.summary.glm <- function(data, ..., kind = "ft", #' Create a rich-formatted table version of the [summary()] of a **glm** object. #' #' @param data A **summary.glm** object -#' @param footer If `TRUE` (by default), add a footer to the table +#' @param header If `TRUE` (by default), add a header to the table +#' @param title If `TRUE`, add a title to the table header. Default to the same +#' value than header, except outside of a chunk where it is `FALSE` if a table +#' caption is detected (`tbl-cap` YAML entry). +#' @param equation If `TRUE` (by default), try to add a equation to the table +#' header. The equation can also be passed in the form of a character string. +#' @param auto.labs If `TRUE` (by default), use labels (and units) automatically +#' from data or `origdata=`. +#' @param origdata The original data set this model was fitted to. By default it +#' is `NULL` and no label is used. +#' @param labs Labels to change the names of elements in the `term` column of +#' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, #' e.g., `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments passed to [modelit::tabularise_coef.summary.glm()] +#' @param show.signif.stars If `TRUE`, add the significance stars to the table. +#' The default is `getOption("show.signif.stars")` +#' @param footer If `TRUE` (by default), add a footer to the table +#' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). -#' @param env The environment where to evaluate the model. +#' @param env The environment where to evaluate formulas (you probably do not +#' need to change the default). #' #' @return A **flextable** object that you can print in different form or #' rearrange with the \{flextable\} functions. @@ -454,148 +417,223 @@ tabularise_coef.summary.glm <- function(data, ..., kind = "ft", #' iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) #' iris_glm_sum <- summary(iris_glm) #' tabularise::tabularise(iris_glm_sum) -tabularise_default.summary.glm <- function(data, footer = TRUE, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", - env = parent.frame()) { +tabularise_default.summary.glm <- function(data, header = TRUE, title = NULL, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), footer = TRUE, + ..., kind = "ft", env = parent.frame()) { + # If title is not provided, determine if we have to use TRUE or FALSE + if (missing(title)) { + title <- header # Default to same as header, but... + # if a caption is defined in the chunk, it defauts to FALSE + if (!is.null(knitr::opts_current$get('tbl-cap'))) + title <- FALSE + } - ft <- tabularise_coef.summary.glm(data = data, lang = lang,..., kind = kind, - env = env) + df_list <- .extract_infos_glm( + data, type = "coef", conf.int = FALSE, conf.level = 0.95, + show.signif.stars = show.signif.stars, lang = lang, auto.labs = auto.labs, + origdata = origdata, labs = labs, equation = equation, title = title, + colnames = colnames_glm, footer = footer, ..., env = env) - if (isTRUE(footer)) { - info_lang <- .infos_lang.glm(lang = lang) - - digits <- max(3L, getOption("digits") - 3L) - footer <- info_lang[["footer"]] - vals <- c( - paste0("(", footer[["dispersion"]], " ", footer[[data$family$family]], - ": ", format(signif(data$dispersion, digits)), ")"), - paste(footer[["null.deviance"]], - format(signif(data$null.deviance, digits)), footer[["on"]], - data$df.null, footer[["df2"]]), - paste(footer[["resid.deviance"]], - format(signif(data$deviance, digits)), footer[["on"]], - max(data$df), footer[["df2"]]), - paste(footer[["AIC"]], format(signif(data$aic, digits)), " - ", - footer[["iter"]], data$iter) - ) - ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) - ft <- align(ft, i = seq_len(length(vals)) + 1 , align = "left", - part = "footer") - } + # formatted table ---- + format_table(df_list, kind = kind, header = header) +} - autofit(ft, part = c("header", "body")) +# A list of internals functions ------ + +colnames_glm <- c( + term = "Term", + estimate = "Estimate", + conf.low = "Lower bound (CI)", + conf.high = "Upper bound (CI)", + std.error = "Standard Error", + t.value = "*t* value", + sigma = "Sigma",# The misnomer “Residual standard error” + r.squared = "R^2^", + adj.r.squared = "Adj.R^2^", + AIC = "AIC", + BIC = "BIC", + statistic = "*t* value", + statistic2 = "*z* value", + p.value = "*p* value", + deviance = "Deviance", + logLik = "Log-Likelihood", + null.deviance = "Total deviance", + df.null = "Total df", + df = "Num. df", + df.residual = "Residuals df", + nobs = "N", + signif = "", + "(Intercept)" = "Intercept") + +.trads <- gettext(term = "Term", + estimate = "Estimate", + conf.low = "Lower bound (CI)", + conf.high = "Upper bound (CI)", + std.error = "Standard Error", + t.value = "*t* value", + sigma = "Sigma",# The misnomer “Residual standard error” + r.squared = "R^2^", + adj.r.squared = "Adj.R^2^", + AIC = "AIC", + BIC = "BIC", + statistic = "*t* value", + statistic2 = "*z* value", + p.value = "*p* value", + deviance = "Deviance", + logLik = "Log-Likelihood", + null.deviance = "Total deviance", + df.null = "Total df", + df = "Num. df", + df.residual = "Residuals df", + nobs = "N", + "(Intercept)" = "Intercept", + "header" = "Generalized Linear Model", + lang = "fr") + +.extract_footer_glm <- function(data, lang = "en") { + digits <- max(3L, getOption("digits") - 3L) + domain <- "R-modelit" + + if (inherits(data, "summary.glm")) { + footer_glm <- c(gaussian = "Gaussian family", binomial = "Binomial family", + Gamma = "Gamma family", inverse.gaussian = "Inverse Gaussian family", + poisson = "Poisson family", + quasi = "Quasi-Gaussian family", + quasibinomial = "Quasi-Binomial family", + quasipoisson = "Quasi-Poisson family") + family_glm <- gettext(footer_glm[data$family$family], lang = lang) + + res <- paste( + gettextf("(Dispersion parameter for %s: %.*g)", family_glm, digits, + data$dispersion, domain = domain, lang = lang), + gettextf("Total deviance: %.*g on %.*g degrees of freedom",digits, data$null.deviance, digits, data$df.null, domain = domain, lang = lang), + gettextf("Residual deviance: %.*g on %.*g degrees of freedom",digits, data$deviance, digits, max(data$df), domain = domain, lang = lang), + gettextf("AIC: %.*g - Number of Fisher Scoring iterations: %.*g",digits, data$aic, digits, max(data$iter), domain = domain, lang = lang), + sep = "\n") + res + } + else { + res <- paste( + gettextf("Degrees of Freedom: %.*g Total (i.e. no model); %.*g Residual", digits, data$df.null, digits, + data$df.residual, domain = domain, lang = lang), + gettextf("Total deviance: %.*g",digits, data$null.deviance, domain = domain, lang = lang), + gettextf("Residual deviance: %.*g AIC: %.*g",digits, data$deviance, digits, data$ai, domain = domain, lang = lang), + sep = "\n") + res + } } -# Choose the lang and the infos_lang -.infos_lang.glm <- function(lang) { +.extract_infos_glm <- function(data, type = "coef", conf.int = FALSE, + conf.level = 0.95, show.signif.stars = TRUE, lang = "en", + colnames = colnames_glm, auto.labs = TRUE, origdata = NULL, labs = NULL, + equation = TRUE, title = TRUE, footer = TRUE, env = parent.frame()) { + + if (!inherits(data, c("glm", "summary.glm"))) + stop(".extract_infos_glm() can apply only glm and summary.glm object.") + + type <- match.arg(type, choices = c("coef", "glance", "tidy")) + + if (inherits(data, "summary.glm") && type != "coef") { + #TODO: Implement support for type = "glance" and type = "coef" + message(".extract_infos_glm() can only apply type = 'coef' to a summary.glm + object.") + #type <- "tidy" + } + + if(inherits(data, "summary.glm")) { + s <- data$coefficients + df <- data.frame(term = rownames(s), s) + colnames(df) <- c("term", "estimate", "std.error", "statistic", + "p.value") + + if (any(colnames(s) %in% "z value")) + colnames(df)[colnames(df) == "statistic"] <- "statistic2" + + rownames(df) <- df$term + } else { + df <- switch(type, + coef = {df <- coef(data) + df <- data.frame(term = names(df), estimate = df)}, + glance = {df <- as.data.frame(broom::glance(x = data)) + rownames(df) <- df$term + df}, + tidy = {df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, + conf.level = conf.level)) + rownames(df) <- df$term + + s <- colnames(coef(summary(data))) + if (any(s %in% "z value")) { + colnames(df)[colnames(df) == "statistic"] <- "statistic2" + } + + if (isTRUE(conf.int)) { + df <- df[, c("term", "estimate", "conf.low", "conf.high", + "std.error", "statistic", "p.value")] + } + + if (isTRUE(show.signif.stars)) { + df$signif <- .pvalue_format(df$p.value) + } + df + } + ) + } + + if(isTRUE(show.signif.stars)) { + psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" + } else { + psignif <- NULL + } + lang <- tolower(lang) + cols <- .extract_colnames(df, labs = colnames_glm, lang = lang) + + data_obj <- attr(data, "object") + + if (is.null(data_obj)) { + + labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, + origdata = origdata, labs = labs) - if (lang != "fr") lang <- "en" # Only en or fr for now + equa <- .extract_equation(data, equation = equation, labs = labels) + + } else { + + labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, + origdata = origdata, labs = labs) + + equa <- .extract_equation(data_obj, equation = equation, labs = labels) + } - if (lang == "fr") { - info_lang <- infos_fr.glm + if ((isTRUE(equation) || is.na(equation)) && !is.null(equa)) { + terms <- .params_equa(equa) } else { - info_lang <- infos_en.glm + terms <- .extract_terms(df, labs = labels, lang = lang) } - info_lang -} + if (is.na(equation)) { + equa <- NULL + } + + title <- .extract_title(title, lang, default = "Generalized Linear Model") + + # footer + if (isTRUE(footer)) { + footer <- .extract_footer_glm(data, lang) + } else { + footer <- NULL + } -infos_en.glm <- list( - labs = c( - term = "Term", - estimate = "Estimate", - conf.low = "Lower bound (CI)", - conf.high = "Upper bound (CI)", - std.error = "Standard Error", - t.value = "*t* value", - sigma = "Sigma",# The misnomer “Residual standard error” - r.squared = "R^2^", - adj.r.squared = "Adj.R^2^", - AIC = "AIC", - BIC = "BIC", - statistic = "*t* value", - statistic2 = "*z* value", - p.value = "*p* value", - deviance = "Deviance", - logLik = "Log-Likelihood", - null.deviance = "Total deviance", - df.null = "Total df", - df = "Num. df", - df.residual = "Residuals df", - nobs = "N", - "(Intercept)" = "Intercept"), - footer = c( - "df" = "Degrees of freedom:", - "total" = "Total (i.e. no model)", - "residual" = "Residual", - "dispersion" = "Dispersion parameter for", - # Various choices for family - gaussian = "Gaussian family", - binomial = "Binomial family", - Gamma = "Gamma family", - inverse.gaussian = "Inverse Gaussian family", - poisson = "Poisson family", - quasi = "Quasi-Gaussian family", - quasibinomial = "Quasi-Binomial family", - quasipoisson = "Quasi-Poisson family", - "null.deviance" = "Total deviance:", - "on" = "on", - "df2" = "degrees of freedom", - "resid.deviance" = "Residual deviance:", - AIC = "AIC:", - "iter" = "Number of Fisher Scoring iterations:"), - "(Intercept)" = "Intercept", - "summary" = "Model summary", - "header" = "Generalized Linear Model" -) - -infos_fr.glm <- list( - labs = c( - term = "Terme", - estimate = "Valeur estim\u00e9e", - conf.low = "Limite basse (IC)", - conf.high = "Limite haute (IC)", - std.error = "Ecart type", - t.value = "Valeur de *t*", - p.value = "Valeur de *p*", - sigma = "Sigma", # The misnomer “Residual standard error” - r.squared = "R^2^", - adj.r.squared = "R^2^ ajust\u00e9", - deviance = "D\u00e9viance", - logLik = "Log-vraisemblance", - null.deviance = "D\u00e9viance totale", - df.null = "Ddl totaux", - AIC = "AIC", - BIC = "BIC", - statistic = "Valeur de *t*", - statistic2 = "Valeur de *z*", - df = "Ddl mod\u00e8le", - df.residual = "Ddl r\u00e9sidus", - nobs = "N", - "(Intercept)" = "Ordonn\u00e9e \u00e0 l'origine" - ), - footer = c( - "df" = "Degr\u00e9s de libert\u00e9 :", - "total" = "Totaux (i.e., hors mod\u00e8le)", - "residual" = "R\u00e9sidus", - "dispersion" = "Param\u00e8tre de dispersion pour une", - # Various choices for family - gaussian = "famille Gaussienne", - binomial = "famille Binomiale", - Gamma = "famille Gamma", - inverse.gaussian = "famille Gaussienne inverse", - poisson = "famille Poisson", - quasi = "famille Quasi-Gaussienne", - quasibinomial = "famille Quasi-Binomiale", - quasipoisson = "famille Quasi-Poisson", - "null.deviance" = "D\u00e9viance totale :", - "on" = "pour", - "df2" = "degr\u00e9s de libert\u00e9", - "resid.deviance" = "D\u00e9viance r\u00e9siduelle :", - AIC = "AIC :", - "iter" = "Nombre d'it\u00e9rations de la fonction de score de Fisher:"), - "(Intercept)" = "Ordonn\u00e9e \u00e0 l'origine", - "summary" = "R\u00e9sum\u00e9 du mod\u00e8le", - "header" = "Mod\u00e8le lin\u00e9aire g\u00e9n\u00e9ralis\u00e9" -) + list( + df = df, + title = title, + cols = cols, + equa = equa, + terms = terms, + psignif = psignif, + footer = footer + ) + +} diff --git a/R/utils.R b/R/utils.R index 9c1b1c7..85c7490 100644 --- a/R/utils.R +++ b/R/utils.R @@ -5,6 +5,9 @@ ngettext <- svMisc::ngettext_ # stop <- svMisc::stop_ # # warning <- svMisc::warning_ +# Need this for R CMD check to pass +. <- NULL + # Internal functions of flextable .pvalue_format <- function(x) { #x <- get(as.character(substitute(x)), inherits = TRUE) diff --git a/man/tabularise_coef.glm.Rd b/man/tabularise_coef.glm.Rd index 65d08c9..15d2e38 100644 --- a/man/tabularise_coef.glm.Rd +++ b/man/tabularise_coef.glm.Rd @@ -6,13 +6,14 @@ \usage{ \method{tabularise_coef}{glm}( data, - header = TRUE, - title = NULL, + header = FALSE, + title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), + footer = FALSE, + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE", unset = "en")), ..., kind = "ft", env = parent.frame() @@ -21,34 +22,49 @@ \arguments{ \item{data}{A \strong{glm} object} -\item{header}{If \code{TRUE} (by default), add a header to the table} +\item{header}{Logical. If \code{TRUE} (default), a header is added to the table. +The header includes both the title and the equation (if applicable). +If set to \code{FALSE}, neither the title nor the equation will be displayed in +the table header, even if the \code{title} or \code{equation} parameters are provided.} \item{title}{If \code{TRUE}, add a title to the table header. Default to the same value than header, except outside of a chunk where it is \code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add an equation to the table header. -The equation can also be passed in the form of a character string (LaTeX).} +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE}: The equation is generated and added to the table header. Its +parameters are also used in the "Term" column. +\item \code{FALSE} (by default): No equation is generated or displayed, and its +parameters are not used in the "Term" column. +\item \code{NA}: The equation is generated but not displayed in the table header. +Its parameters are used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} \item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically -from \verb{origdata=}.} +from data or \verb{origdata=}.} \item{origdata}{The original data set this model was fitted to. By default it -is \code{NULL} and labels of the original data set are not used.} +is \code{NULL} and no label is used.} \item{labs}{Labels to change the names of elements in the \code{term} column of -the table. By default, it is \code{NULL} and no change is performed.} +the table. By default it is \code{NULL} and nothing is changed.} + +\item{footer}{If \code{TRUE} (\code{FALSE} by default), add a footer to the table.} \item{lang}{The natural language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{...}{Additional arguments (not used yet).} +\item{...}{Additional arguments} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} +\item{env}{The environment where to evaluate formulas (you probably do not +need to change the default).} } \value{ A \strong{flextable} object is returned. You can print it in different @@ -62,4 +78,15 @@ to \code{\link[stats:coef]{stats::coef()}}, but in a rich-formatted \strong{flex \examples{ iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) tabularise::tabularise$coef(iris_glm) + +# If the 'iris' dataset has labels and units, they can be used to enhance +# the output table +iris <- data.io::labelise(iris, self = FALSE, label = list( + Sepal.Length = "Length of the sepals", + Petal.Length = "Length of the petals", + Species = "Species"), units = c(rep("cm", 4), NA)) + +iris_glm1 <- glm(data = iris, Petal.Length ~ Sepal.Length + Species) +tabularise::tabularise$coef(iris_glm1) + } diff --git a/man/tabularise_coef.summary.glm.Rd b/man/tabularise_coef.summary.glm.Rd index 5ee8ae3..2dffef5 100644 --- a/man/tabularise_coef.summary.glm.Rd +++ b/man/tabularise_coef.summary.glm.Rd @@ -4,17 +4,55 @@ \alias{tabularise_coef.summary.glm} \title{Create a rich-formatted table using the table of coefficients of the summary.glm object} \usage{ -\method{tabularise_coef}{summary.glm}(data, ..., kind = "ft", env = parent.frame()) +\method{tabularise_coef}{summary.glm}( + data, + header = TRUE, + title = NULL, + equation = header, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE", unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), + ..., + kind = "ft", + env = parent.frame() +) } \arguments{ \item{data}{A \strong{summary.glm} object} -\item{...}{Additional arguments passed to \code{\link[=tabularise_tidy.glm]{tabularise_tidy.glm()}}} +\item{header}{If \code{TRUE} (by default), add a header to the table} + +\item{title}{If \code{TRUE}, add a title to the table header. Default to the same +value than header, except outside of a chunk where it is \code{FALSE} if a table +caption is detected (\code{tbl-cap} YAML entry).} + +\item{equation}{If \code{TRUE} (by default), try to add a equation to the table +header. The equation can also be passed in the form of a character string.} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used.} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} + +\item{lang}{The natural language to use. The default value can be set with, +e.g., \code{options(data.io_lang = "fr")} for French.} + +\item{show.signif.stars}{If \code{TRUE}, add the significance stars to the table. +The default is \code{getOption("show.signif.stars")}} + +\item{...}{Additional arguments} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} -\item{env}{The environment where to evaluate the model.} +\item{env}{The environment where to evaluate formulas (you probably do not +need to change the default).} } \value{ A \strong{flextable} object that you can print in different formats @@ -28,5 +66,5 @@ from the \code{\link[=summary]{summary()}} of a \strong{glm} object. \examples{ iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) iris_glm_sum <- summary(iris_glm) -tabularise::tabularise$coef(iris_glm_sum) +tabularise::tabularise_coef(iris_glm_sum) } diff --git a/man/tabularise_default.glm.Rd b/man/tabularise_default.glm.Rd index 2e9aede..317804d 100644 --- a/man/tabularise_default.glm.Rd +++ b/man/tabularise_default.glm.Rd @@ -6,8 +6,14 @@ \usage{ \method{tabularise_default}{glm}( data, - footer = TRUE, - lang = getOption("data.io_lang", "en"), + header = FALSE, + title = header, + equation = header, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, + footer = FALSE, + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE", unset = "en")), ..., kind = "ft", env = parent.frame() @@ -16,17 +22,49 @@ \arguments{ \item{data}{A \strong{glm} object} -\item{footer}{If \code{TRUE} (by default), add a footer to the table} +\item{header}{Logical. If \code{TRUE} (\code{FALSE} by default), a header is added to the table. +The header includes both the title and the equation (if applicable). +If set to \code{FALSE}, neither the title nor the equation will be displayed in +the table header, even if the \code{title} or \code{equation} parameters are provided.} + +\item{title}{If \code{TRUE} (\code{FALSE} by default), add a title to the table header. Default to the same +value than header, except outside of a chunk where it is \code{FALSE} if a table +caption is detected (\code{tbl-cap} YAML entry).} + +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE}: The equation is generated and added to the table header. Its +parameters are also used in the "Term" column. +\item \code{FALSE} (by default): No equation is generated or displayed, and its +parameters are not used in the "Term" column. +\item \code{NA}: The equation is generated but not displayed in the table header. +Its parameters are used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used.} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} + +\item{footer}{If \code{TRUE} (\code{FALSE} by default), add a footer to the table} \item{lang}{The natural language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{...}{Additional arguments passed to \code{\link[=tabularise_coef.glm]{tabularise_coef.glm()}}} +\item{...}{Additional arguments} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} -\item{env}{The environment where to evaluate the model.} +\item{env}{The environment where to evaluate formulas (you probably do not +need to change the default).} } \value{ A \strong{flextable} object is returned. You can print it in different @@ -39,4 +77,7 @@ Create a rich-formatted table from a glm object \examples{ iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) tabularise::tabularise(iris_glm) +tabularise::tabularise(iris_glm, header = TRUE, footer = TRUE) +tabularise::tabularise(iris_glm, header = TRUE, footer = FALSE) +tabularise::tabularise(iris_glm, header = TRUE, equation = NA,footer = TRUE) } diff --git a/man/tabularise_default.summary.glm.Rd b/man/tabularise_default.summary.glm.Rd index 3a04d5e..4dea8ad 100644 --- a/man/tabularise_default.summary.glm.Rd +++ b/man/tabularise_default.summary.glm.Rd @@ -6,8 +6,15 @@ \usage{ \method{tabularise_default}{summary.glm}( data, + header = TRUE, + title = NULL, + equation = header, + auto.labs = TRUE, + origdata = NULL, + labs = NULL, + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE", unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), footer = TRUE, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", env = parent.frame() @@ -16,17 +23,39 @@ \arguments{ \item{data}{A \strong{summary.glm} object} -\item{footer}{If \code{TRUE} (by default), add a footer to the table} +\item{header}{If \code{TRUE} (by default), add a header to the table} + +\item{title}{If \code{TRUE}, add a title to the table header. Default to the same +value than header, except outside of a chunk where it is \code{FALSE} if a table +caption is detected (\code{tbl-cap} YAML entry).} + +\item{equation}{If \code{TRUE} (by default), try to add a equation to the table +header. The equation can also be passed in the form of a character string.} + +\item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically +from data or \verb{origdata=}.} + +\item{origdata}{The original data set this model was fitted to. By default it +is \code{NULL} and no label is used.} + +\item{labs}{Labels to change the names of elements in the \code{term} column of +the table. By default it is \code{NULL} and nothing is changed.} \item{lang}{The natural language to use. The default value can be set with, e.g., \code{options(data.io_lang = "fr")} for French.} -\item{...}{Additional arguments passed to \code{\link[=tabularise_coef.summary.glm]{tabularise_coef.summary.glm()}}} +\item{show.signif.stars}{If \code{TRUE}, add the significance stars to the table. +The default is \code{getOption("show.signif.stars")}} + +\item{footer}{If \code{TRUE} (by default), add a footer to the table} + +\item{...}{Additional arguments} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} -\item{env}{The environment where to evaluate the model.} +\item{env}{The environment where to evaluate formulas (you probably do not +need to change the default).} } \value{ A \strong{flextable} object that you can print in different form or diff --git a/man/tabularise_glance.glm.Rd b/man/tabularise_glance.glm.Rd index 2f3b6c4..af994ed 100644 --- a/man/tabularise_glance.glm.Rd +++ b/man/tabularise_glance.glm.Rd @@ -7,8 +7,8 @@ \method{tabularise_glance}{glm}( data, header = TRUE, - title = NULL, - equation = TRUE, + title = header, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, @@ -21,20 +21,31 @@ \arguments{ \item{data}{A \strong{glm} object} -\item{header}{If \code{TRUE} (by default), add an header to the table} +\item{header}{Logical. If \code{TRUE} (\code{TRUE} by default), a header is added to the table. +The header includes both the title and the equation (if applicable). +If set to \code{FALSE}, neither the title nor the equation will be displayed in +the table header, even if the \code{title} or \code{equation} parameters are provided.} -\item{title}{If \code{TRUE}, add a title to the table header. Default to the same +\item{title}{If \code{TRUE} (\code{TRUE} by default), add a title to the table header. Default to the same value than header, except outside of a chunk where it is \code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add an equation to the table header. -The equation can also be passed in the form of a character string (LaTeX).} +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE} (default) : The equation is generated and added to the table +header. Its parameters are also used in the "Term" column. +\item \code{FALSE}: No equation is generated or displayed, and its parameters are +not used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} \item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically -from \verb{origdata=}.} +from data or \verb{origdata=}.} \item{origdata}{The original data set this model was fitted to. By default it -is \code{NULL} and original labels are not used.} +is \code{NULL} and no label is used.} \item{labs}{Labels to change the names of elements in the \code{term} column of the table. By default it is \code{NULL} and nothing is changed.} @@ -47,8 +58,8 @@ e.g., \code{options(data.io_lang = "fr")} for French.} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} +\item{env}{The environment where to evaluate formulas (you probably do not +need to change the default).} } \value{ A \strong{flextable} object is produced that you can print in different @@ -63,4 +74,7 @@ Word, PowerPoint), or rearranged later on. \examples{ iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) tabularise::tabularise$glance(iris_glm) +tabularise::tabularise$glance(iris_glm, equation = FALSE) +tabularise::tabularise$glance(iris_glm, equation = "my personal equation") + } diff --git a/man/tabularise_tidy.glm.Rd b/man/tabularise_tidy.glm.Rd index c5145b5..32a9a21 100644 --- a/man/tabularise_tidy.glm.Rd +++ b/man/tabularise_tidy.glm.Rd @@ -14,7 +14,7 @@ labs = NULL, conf.int = FALSE, conf.level = 0.95, - lang = getOption("data.io_lang", "en"), + lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE", unset = "en")), show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", @@ -24,20 +24,33 @@ \arguments{ \item{data}{A \strong{glm} object} -\item{header}{If \code{TRUE} (by default), add a header to the table} +\item{header}{Logical. If \code{TRUE} (\code{TRUE} by default), a header is added to the table. +The header includes both the title and the equation (if applicable). +If set to \code{FALSE}, neither the title nor the equation will be displayed in +the table header, even if the \code{title} or \code{equation} parameters are provided.} -\item{title}{If \code{TRUE}, add a title to the table header. Default to the same +\item{title}{If \code{TRUE} (\code{TRUE} by default), add a title to the table header. Default to the same value than header, except outside of a chunk where it is \code{FALSE} if a table caption is detected (\code{tbl-cap} YAML entry).} -\item{equation}{If \code{TRUE} (by default), add an equation to the table header. -The equation can also be passed in the form of a character string (LaTeX).} +\item{equation}{Logical or character. Controls whether an equation is added +to the table header and how parameters are used. Accepted values are: +\itemize{ +\item \code{TRUE} (default) : The equation is generated and added to the table +header. Its parameters are also used in the "Term" column. +\item \code{FALSE}: No equation is generated or displayed, and its parameters are +not used in the "Term" column. +\item \code{NA}: The equation is generated but not displayed in the table header. +Its parameters are used in the "Term" column. +\item Character string: A custom equation is provided directly and added to +the table header. +}} \item{auto.labs}{If \code{TRUE} (by default), use labels (and units) automatically -from \verb{origdata=}. `} +from data or \verb{origdata=}.} \item{origdata}{The original data set this model was fitted to. By default it -is \code{NULL} and variables labels from this data set are not used.} +is \code{NULL} and no label is used.} \item{labs}{Labels to change the names of elements in the \code{term} column of the table. By default it is \code{NULL} and nothing is changed.} @@ -52,15 +65,15 @@ the table. By default it is \code{NULL} and nothing is changed.} e.g., \code{options(data.io_lang = "fr")} for French.} \item{show.signif.stars}{If \code{TRUE}, add the significance stars to the table. -Its value is obtained from \code{getOption("show.signif.stars")}.} +The default is \code{getOption("show.signif.stars")}} -\item{...}{Additional arguments passed to \code{\link[tabularise:equation]{tabularise::equation()}}} +\item{...}{Additional arguments} \item{kind}{The kind of table to produce: "tt" for tinytable, or "ft" for flextable (default).} -\item{env}{The environment where to evaluate lazyeval expressions (unused for -now).} +\item{env}{The environment where to evaluate formulas (you probably do not +need to change the default).} } \value{ A \strong{flextable} object is returned. You can print it in different @@ -73,6 +86,15 @@ Turn the tidy of \strong{glm} object into a rich-formatted table with Word, PowerPoint), or rearranged later on. } \examples{ +#' # If the 'iris' dataset has labels and units, they can be used to enhance +# the output table +iris <- data.io::labelise(iris, self = FALSE, label = list( + Sepal.Length = "Length of the sepals", + Petal.Length = "Length of the petals", + Species = "Species"), units = c(rep("cm", 4), NA)) iris_glm <- glm(data = iris, Petal.Length ~ Sepal.Length) + tabularise::tabularise$tidy(iris_glm) +tabularise::tabularise$tidy(iris_glm, conf.int = TRUE) +tabularise::tabularise$tidy(iris_glm, conf.int = TRUE, equation = NA) } diff --git a/po/R-fr.mo b/po/R-fr.mo index 783ea6a1f4d214eae73a2b66b47cfb43503c3108..c0677b11970137d0b8516db6cb66d6662e39d54a 100644 GIT binary patch literal 11833 zcmd6tdyHJyUB^#iw@I9)(6sasQaI3<+1>0+)=uKY>u!_HdYvp?Kk%-dq)oiOJ9B2| z+IQ|9-^bYNlqd}nq=4E#3aCwKR9aNxkb(q%gu)*IEmTE94MGtGf&xUP3aSt&DvziX z@%f#5?wvdPu-#B3Mn3bMd+vGs&hLGG>zA+J{>zHbM`$hbfz;}Sp zID8(Ic`t$=1pf-01aIO{w}DIG4}re~%KT?QIp?dOtos^xCHNip{NG@M=c|5Dsds~W zzNQ~z8T#9Hl^y|wV?2I zFSs4t2iCy5!2@6i+ynl$!*9Cx@4Y^!a~9mm`xKl7p9CKO{~o*<+>1~|E`~2riB*Rm z1xI=Q7%2SwU2p>YDk%JX9Ta-L3%(1yl0j^(ZUBD_90zxUhd_D%QSiOsr$OP*bD*66 zj~sr@y?+VZOaJSjjJp-#2!EzP;p2?MqoC~Xfg@lW6nT6Cycc{L6#o1xDDt`k;ruYz z29JY}gRo&^>$boj0e=qUpZX$SH-LW#ioU(%@MREDseb^4j&FlP$J-bz ze7PMIx$Ogm?=ztA!+_rcKMu+{&vW>n2R{amgYRImyTNG?5vs>QvDaU5`0K9!cii(= zK+(e&K}V4ly$bjocDw80)_vJ;9>AHpy=PXz$d_69A4z~``{7qN|+~l zwE&8p-VX|$UjT)!KL_W*mqA#qZq~WI&44oRLtqy?0X_i!8F(MK6Q;m26@o&~6X3Pr z3!v!NOQ6jEM^Mi7Pv9i@I>=V)HiUH$Tm(@K^?4AHsxO10?|0e%L26Zl2<{46MZea`j&DY%#C z7eKM!Yfx^{mz|)Aw%022X>chhG9kUVj6A61?W-96t*Ry}KB67dQio-uw(G>wW=b3-u=s{{<8~ zc~3pJ^ExQ@JpqcGXF!qTBjB6C=fUg1uYk9JFM_v$+acx(u=w2TejEqoyw#74zmImd z(kU_!x;w7VcZm3`pT8As(jeE$IRxc{7%YE;mnkiyounP0$>&3~6`JUXoI}noAF)Bv zJK@QLv>xp!EuqQzx6$OYBL~$7TQu0MJlapuX)@KX97is5c!n^7RGf)9dWFa3- zi)msTxGMV*dlp@}n}%DmpR4%py5F$c%KRbl3{CVOaa%cv&VPhUCy+F6T)Jse%^QBK7ry6Qxzn}C>ocK|wdtU5y zO=@CURPRhC_0GoF%BUJUFjh}eFZGkuZ|0qv;qp>@VJrX9YU{cl>y7EY7i5M}iOhRc z4)kc=r^>f#EOq1L*YKG0#hY=}@LH{Mc) z(Z>=~&Px5(Y7M?l;bojN<#D2mR?PDnzMHD(i zQPbG4>D$AGeG{)3HiaDl!}ygisHR(|8b?p;KB1;VZQ>Y1i<-?Wj+u70W3cUbRTi&s zQLNorxo*c%SJ%$fnC%6ti4Qm0FuCu`4nv)NFU~vf;XE^Fyw$(1ciPC5b`~~;^n5`t z_a=z29|e8cKFqo%_L~?ks~|1wXLJ~yZ4B1x1)@K1Xlm)t%K2ygw4--#x?i*jGu3{x z5*x@8vGAi6b)CQ#qZDU1;x|kKdUNVV_vJq7s7d@*<^{|Sqi#d*Z}ZFXj^DHRx2~5O zb)ewR$(_kbOtaUE;*`C_TeJhTTUg@sFlnfJO^ApC|2#6B_d{{n2gN(9xo$5?5?=-* zPs=a7@9zD>r|w2E?>mU7a(*=zwoK3Pg~1e3&^5Zzx~A!+%I#$1fSQk1>hu0-6ZoAd zYT3u2`gj(-U5+xG^~lWJs5)raEjg2Uu}M@;tNqrkcK$f24rW2>_n>_2=oso+nuFIm zMQGxr)qVopp(r%+732&Ej7I=-TWEc6)FsNK=W}^%JoZ32bRs7@0F`ODfw@7S{(+Fo;%c$h*|E%N%#m zZ+1K+l++JG3#NW?YVJ4waux)a81?;O*u_>!J8_h)bSlZj_aKR7-<<2A8DZ*UmBoQc zLb|Ayhy+DiHL1eMT646B5)Pd1z{`paH3!bX`P0G3QgDen;x$iuD@NBO%W3!#(J4Wp z&Sbv$+2t(7HAp5zq7V?B8tUl6tg>GDs0r}teWQ65w!FBNJ84z8j)Ak?(Bn*`j2#>2 zxDlwa&7E2UAJ)!&*kB6zfcUn;M$66UuSe~=>vudT-X`VzM0{J>EoMD@LtSIbq-HZ>3BhJv<8cCN4T1BIU8r#&YXgy1gtldiv1e!F3;2n_PIxN*M?(ZY?=|b4@m++h(I-{e50%Db?dTmGm1_pmIT%hNLXWBrBEaa*IC)I)#<@Hq35&h`7hLWMyPFKXu8uC7ts&%GnqQ|xV zRIQ;-irYR}GSJhuqtTY@>B)w|XKRy(k8+GCf2;Zi2|H(yzrqE!W0l_?m#}FQBujD; zQexkQ)ebyFpUWWb%f1|1sNzM6F@AV@Qc0G^#aE$qOZLLL<(h*Lmst2n9Lb%uKG&)r z&#&l{c?k7Wy{mCs^L}gaCWfeuExZUnMg7g)V>Q)qntU-2P6iT=d3{^;uNLgglSoJAg_mo#ssw2*i zQIq_?s-tL*p1ktdr=^zS%Zblq@|4-Qgvg}avc)z3;xnb50;h6MYs)JQHC&d-FZ-<0 zGbD2b0kO8Ocj}eLKGp1)HpJ+)&mkd4P_Z79w;<~hCmJRz=x$iWR#rArCGkK{xpEH_ z6@=K@O8!#U@+yiUfiWb<(dya--4g|~2Pbb8owXNF7~Dc%D;1SDcpUgpWwT|=_sC{j zSh*;lH9hIVl!ixB8b!Y8DE)k#V8{#WmsbrnmxxBzLt~(+($EHzTlzEs+ zohMQI@v=xpYCURyDIt0b7l{h^aL}lEk*||OwdiB;9>QLGyAa+>K1i-zR)HE)FOf*2 zDSWJ5@WfD8*iv+qtNz-Bb#jPJ578$`2nJCDpcqu)5Ii8viky3ajakT>!?DCjnvuNP(Mb)O?TOv?`A!Imn>N?dkM+h$lS~*Rliv1 zhS#emv^66+wB@j4f4SA9%1c8eV6KGZqF~+Cj0%e^tn`qY&YD?RE+FxJz)e)6s2*)S z0@})IQCZB8khHOARLE<17j)AVihPkZs+Zv$OxH(D)RE!=Cx_>`+K+6-5^^I&0VGw) zGlr5=Hfb3gYA|icr+1gl_ez0?g6Ry& zUCsJskI+Qw2s5Qrw01#+f-zyc4XMau&)9aMd52s~sZ}G24W5NliA!B`Lx+VlFOPZ2 z=#|HQ)fJ6idF-=VXt8x8G+%9>YPIg7GqENe+(p9m^&9#btuT`B@LS8&!lMAgM#7yBPA44} zB8C6frH@q1+~!r>4op0%P>7vXX-n20g;L3HsCnFLS#hdVq3k_n?HO?Z8|zP*y(n91gHWsGjw9b?yK`CqolVG)4c~nVMr?@YXE*00PGPP#930zSs6XNlA zU63Fq+vZ2^aDQ8WdQ#VchNn`csv1V#QK;hjftRN^;wWUD?40}im?fr~vxz)x7Ctw( zZb*^7Z9Re@oF{&jA(yer<`SjjqVs4u?3aQAHl(xECly3ARVyT~q!we-M5+|z9vF#~$L0dvX0_79 z^2!*j=*zXXtc_Jc%~wz<1nOZ=Bge8CzvR?P?WBQlgd=Os!F%zWN|heh(C#vQBM}hJ^IZ5 ZE>YO9E65EKVm7CwGJc51n~yGb{vThJzs~>w delta 2303 zcmY+^e@IqW9LMqVlxC^d!P0h3)mbGeGL5-&Qj1+&R&l44`XADL# zYJcqPSJ3{bA*&J6a254mv}nO_tiiTgo1W zLQKbHxEAa22yVseI8m?4<|%nx$VIN1)i?t;`i7Ak%|Wch!#ER1kUw*SgZ}RuWbEdS ze?EpG&VNJxOh%$H$(VzhP{@<1*3y~Ag%dg)w!0@o)GOmvTOx{OHDYs8qH3cA#D~h()*` zXW>Z<;bnXd?_(~;Qz)vbBAkaSQ3L5jz2``f^;hbza3K?KVix|6TFV4}l!>SZO+`JZ z1hqsPP#M~SIk*!wu)|n@ALBzDMaE<=1U~AF>{xWW^9?BiYpJf zWQtKYHefbxLv5RVI2lhM%W8&DMSKDE;;X0+&abE$=aFYQAC8NUt z;sQL4D#9O7Rr~~%nM^L~1vRMayRZRYM?Ls+RA#>Q)k9fkQ-UhuI#dQ4upGNFLHqwh zIx3nWoR1?|iT6;|Jd4r~pqh$quGbqsD7BiM8sqfVR@v15|JSPNcr*4dXz(iueQRp< z#Zp=|(shK2M`>3k)RcO)rg5GgSJ10+Ur$MkX-8|=S`@VkLi63O6Thv-ZG;w#^mus! zFK;SSwHiVt|7_d9Nh`61P|hsz0-??QBEh=EOdTCnfHu~8B9Bm;L~JIsXoZB@rg6*? zUqQusP1UEimC$-<gviu69< z;I(>=tnt&fnBG#iH!;JdCv^u(-DpyiTb>>7hLe}LLsO5r`jq+ZY)X~e6Krx1f-NJb zrrn+3j;5V)Z_fD4HO<`PYSP!l9q12RcPJy@y`15K{r%wq+uj%L?XX3S&BbmgbJ@i1 zwsyBJE6YvKdbMD`?THRXYcNfZny!~2Pq\n" "Language-Team: LANGUAGE \n" @@ -40,6 +40,15 @@ msgstr "" msgid "The type= argument must provide a model_spec object or its name in a character string." msgstr "" +msgid "`data` must be a `data.frame`." +msgstr "" + +msgid "Unable to summarize the object." +msgstr "" + +msgid "Unable to compute ANOVA for the object." +msgstr "" + msgid "You must give either 'h=' or 'v='." msgstr "" @@ -142,10 +151,10 @@ msgstr "" msgid "Standard Error" msgstr "" -msgid "t value" +msgid "*t* value" msgstr "" -msgid "RSE" +msgid "Sigma" msgstr "" msgid "R^2^" @@ -160,13 +169,19 @@ msgstr "" msgid "BIC" msgstr "" -msgid "Log-likelihood" +msgid "*z* value" msgstr "" -msgid "*t* value" +msgid "Log-Likelihood" msgstr "" -msgid "Model df" +msgid "Total deviance" +msgstr "" + +msgid "Total df" +msgstr "" + +msgid "Num. df" msgstr "" msgid "Residuals df" @@ -178,9 +193,54 @@ msgstr "" msgid "Intercept" msgstr "" +msgid "Generalized Linear Model" +msgstr "" + msgid "fr" msgstr "" +msgid "(Dispersion parameter for %s: %.*g)" +msgstr "" + +msgid "Total deviance: %.*g on %.*g degrees of freedom" +msgstr "" + +msgid "Residual deviance: %.*g on %.*g degrees of freedom" +msgstr "" + +msgid "AIC: %.*g - Number of Fisher Scoring iterations: %.*g" +msgstr "" + +msgid "Degrees of Freedom: %.*g Total (i.e. no model); %.*g Residual" +msgstr "" + +msgid "Total deviance: %.*g" +msgstr "" + +msgid "Residual deviance: %.*g AIC: %.*g" +msgstr "" + +msgid ".extract_infos_glm() can apply only glm and summary.glm object." +msgstr "" + +msgid ".extract_infos_glm() can only apply type = 'coef' to a summary.glm\n object." +msgstr "" + +msgid "t value" +msgstr "" + +msgid "RSE" +msgstr "" + +msgid "Log-likelihood" +msgstr "" + +msgid "Model df" +msgstr "" + +msgid "Linear model" +msgstr "" + msgid "Package 'data.io' is required but not installed." msgstr "" @@ -199,7 +259,7 @@ msgstr "" msgid "," msgstr "" -msgid "Linear model" +msgid "The 'equation' argument must be TRUE, FALSE, NA, or a character string." msgstr "" msgid "Residuals range: [%.*g, %.*g]" @@ -235,7 +295,7 @@ msgstr "" msgid ".add_colnames()" msgstr "" -msgid "x must be an nls or summary.nls object" +msgid "`x` must be an object of class 'nls' or 'summary.nls'." msgstr "" msgid "An error occurred when trying to extract the formula from 'x'" @@ -265,9 +325,6 @@ msgstr "" msgid "Convergence tolerance" msgstr "" -msgid "Log-Likelihood" -msgstr "" - msgid "df" msgstr "" From ee50647ff142817957ef2b8f592db9fb0e802d40 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 20 Aug 2025 09:25:10 +0200 Subject: [PATCH 18/22] add lm_, glm_, nls_ functions --- DESCRIPTION | 2 +- NAMESPACE | 5 + NEWS.md | 20 +++ R/lm_.R | 208 ++++++++++++++++++++++- R/modelit-package.R | 2 +- TODO.md | 36 ++-- inst/po/en@quot/LC_MESSAGES/R-modelit.mo | Bin 9596 -> 11430 bytes inst/po/fr/LC_MESSAGES/R-modelit.mo | Bin 7233 -> 11833 bytes man/anova_.Rd | 29 ++++ man/glm_.Rd | 48 ++++++ man/lm_.Rd | 9 +- man/nls_.Rd | 50 ++++++ man/summary_.Rd | 31 ++++ 13 files changed, 417 insertions(+), 23 deletions(-) create mode 100644 man/anova_.Rd create mode 100644 man/glm_.Rd create mode 100644 man/nls_.Rd create mode 100644 man/summary_.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 1b82666..c807946 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: modelit Type: Package -Version: 1.4.7 +Version: 1.4.8 Title: Statistical Models for 'SciViews::R' Description: Create and use statistical models (linear, general, nonlinear...) with extensions to support rich-formatted tables, equations and plots for the diff --git a/NAMESPACE b/NAMESPACE index ee1761a..e475cca 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -53,15 +53,19 @@ S3method(variable.names,model_fit) S3method(vcov,model_fit) export(add_predictions) export(add_residuals) +export(anova_) export(autoplot.lm) export(autoplot.nls) export(fit_model) export(geom_ref_line) +export(glm_) export(lm_) export(mae) +export(nls_) export(qae) export(rmse) export(rsquare) +export(summary_) importFrom(broom,augment) importFrom(broom,glance) importFrom(broom,tidy) @@ -128,6 +132,7 @@ importFrom(stats,rstandard) importFrom(stats,variable.names) importFrom(stats,vcov) importFrom(svFlow,"%>.%") +importFrom(svMisc,eval_data_dot) importFrom(svMisc,gettext_) importFrom(svMisc,gettextf_) importFrom(svMisc,ngettext_) diff --git a/NEWS.md b/NEWS.md index 3d1dead..68c3117 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,23 @@ +# modelit 1.4.8 + +- Refactored all tabularise\_\*\*\*() methods for glm, summary.glm, anova, aov objects (e.g., tabularise_glance.glm(), tabularise_default.glm(), tabularise_tidy.glm(), etc.) to improve internal consistency and prepare for multi-format table rendering using {flextable}, {tinytable}, and {gt}. + +- added summary\_() and anova\_() functions. These two functions provide the same information as the summary() and anova() functions. They add an attribute that preserves a link to the object used in these two functions. Adding this argument makes it possible to retrieve information from the original object that would otherwise be lost when using summary() or anova(). + +- Added the experimental glm\_() and nls\_() functions, which extend [stats::glm()] and [stats::nls()] by attaching additional metadata such as variable labels and units. The order of arguments has been modified to start with data =. All three functions — lm\_(), glm\_(), and nls\_() — use a data-dot mechanism inspired by svMisc::eval_data_dot(). Note: nls\_() uses model = TRUE by default, whereas the base nls() function uses model = FALSE. + +- The `equation=` argument now accepts `NA` in addition to `TRUE`, `FALSE`, and character strings, offering more flexibility in how model equations are displayed and used: + + - `TRUE` *(default)*: The equation is automatically generated and added to the table header. Its parameters are also used in the "Term" column. + + - `FALSE`: No equation is generated or displayed, and its parameters are not used in the "Term" column. + + - `NA`: The equation is generated but not displayed in the table header. Its parameters are still used in the "Term" column. + + - *Character string*: A custom equation is provided directly and added to the table header. + + This enhancement allows for finer control over equation display and ensures that model parameters remain accessible even when the equation is hidden. + # modelit 1.4.7 - Refactored all tabularise\_\*\*\*() methods for lm, summary.lm, nls, summary.nls objects (e.g., tabularise_glance.lm(), tabularise_default.lm(), tabularise_tidy.lm(), etc.) to improve internal consistency and prepare for multi-format table rendering using {flextable}, {tinytable}, and {gt}. diff --git a/R/lm_.R b/R/lm_.R index 5f63289..628d7d3 100644 --- a/R/lm_.R +++ b/R/lm_.R @@ -2,12 +2,14 @@ #' #' @description #' `lm_()` is an **experimental** wrapper around the base [stats::lm()] function. -#' It behaves similarly to `lm()` but enriches the returned object with additional -#' metadata. +#' It behaves similarly to `lm()`, but enriches the returned object with additional metadata. +#' The order of the arguments differs from `lm()`, and the function uses evaluation +#' through [svMisc::eval_data_dot()] to support flexible data referencing. #' #' @param data A `data.frame` containing the variables in the model. #' @param formula An object of class `formula`: a symbolic description of the model to be fitted. #' @param ... Additional arguments passed to [stats::lm()]. +#' @param .data an alias for the `data` argument #' #' @return An object of class `lm_`, which inherits from `lm`, and includes additional #' components such as `labels`. If no additional attributes are added, a standard `lm` object is returned. @@ -37,7 +39,7 @@ lm_ <- function(data = (.), formula, ..., .data = data) { # Implicit data-dot mechanism if (missing(data) || !is.data.frame(data)) - return(eval_data_dot(sys.call(), arg = 'data', abort_msg = + return(svMisc::eval_data_dot(sys.call(), arg = 'data', abort_msg = gettext("`data` must be a `data.frame`."))) res <- stats::lm(data = data, formula = formula, ...) @@ -164,3 +166,203 @@ anova.lm_ <- function(object, ...) { } .anova.lm <- getS3method("anova", "lm") + +#' Fitting Generalized Linear Models with Enhanced Output (Experimental) +#' +#' @description +#' `glm_()` is an **experimental** wrapper around the base [stats::glm()] +#' function. It behaves similarly to `glm()`, but enriches the returned object +#' with additional metadata. The order of the arguments differs from `glm()`, +#' and the function uses evaluation through [svMisc::eval_data_dot()] to support +#' flexible data referencing. +#' +#' @param data A `data.frame` containing the variables in the model. +#' @param formula An object of class `formula`: a symbolic description of the +#' model to be fitted. +#' @param ... Additional arguments passed to [stats::glm()]. +#' @param .data an alias for the `data` argument +#' +#' @return An object of class `glm_`, which inherits from `glm`, and includes +#' additional components such as `labels`. If no additional attributes are +#' added, a standard `glm` object is returned. +#' +#' @export +#' +#' @examples +#' data(iris) +#' +#' # Add labels to variables +#' attr(iris$Sepal.Length, "label") <- "Sepal Length (cm)" +#' attr(iris$Petal.Length, "label") <- "Petal Length (cm)" +#' +#' # Fit the model using lm_() +#' res <- glm_(iris, formula = Petal.Length ~ Sepal.Length + Species) +#' +#' res +#' class(res) +#' summary(res) +#' +#' # Access labels +#' res$labels +#' +glm_ <- function(data = (.), formula, ..., .data = data) { + + .__top_call__. <- TRUE + + # Implicit data-dot mechanism + if (missing(data) || !is.data.frame(data)) + return(svMisc::eval_data_dot(sys.call(), arg = 'data', abort_msg = + gettext("`data` must be a `data.frame`."))) + + res <- stats::glm(data = data, formula = formula, ...) + + # Extract labels + if (!is.null(res$model)) { + labs <- .labels3(res) + } else { + labs <- .labels3(res, origdata = data) + } + + res$labels <- labs + + # Add custom class if labels were successfully added + if (!is.null(res$labels)) { + class(res) <- c("glm_", class(res)) + } + + res +} + + +#' Fitting Non Linear Models with Enhanced Output (Experimental) +#' +#' @description +#' `nls_()` is an **experimental** wrapper around the base [stats::nls()] +#' function. It behaves similarly to `glm()`, but enriches the returned object +#' with additional metadata. The order of the arguments differs from `glm()`, +#' and the function uses evaluation through [svMisc::eval_data_dot()] to support +#' flexible data referencing. +#' +#' @param data A `data.frame` containing the variables in the model. +#' @param formula An object of class `formula`: a symbolic description of the +#' model to be fitted. +#' @param model logical. If true, the model frame is returned as part of the +#' object. Default is FALSE. +#' @param ... Additional arguments passed to [stats::nls()]. +#' @param .data an alias for the `data` argument +#' +#' @return An object of class `nls_`, which inherits from `nls`, and includes +#' additional components such as `labels`. If no additional attributes are +#' added, a standard `nls` object is returned. +#' +#' @export +#' +#' @examples +#' chick1 <- ChickWeight[ChickWeight$Chick == 1, ] +#' # Add labels to variables +#' attr(chick1$weight, "label") <- "Body weight [gm]" +#' attr(chick1$Time, "label") <- "Number of days" +#' +#' chick1_nls <- nls_(data = chick1, weight ~ SSlogis(Time, Asym, xmid, scal)) +#' +#' +#' chick1_nls +#' class(chick1_nls) +#' summary(chick1_nls) +#' +#' # Access labels +#' chick1_nls +#' +nls_ <- function(data = (.), formula, model = TRUE, ..., .data = data) { + + .__top_call__. <- TRUE + + # Implicit data-dot mechanism + if (missing(data) || !is.data.frame(data)) + return(svMisc::eval_data_dot(sys.call(), arg = 'data', abort_msg = + gettext("`data` must be a `data.frame`."))) + + res <- stats::nls(data = data, formula = formula, model = model, ...) + + # Extract labels + if (!is.null(res$model)) { + labs <- .labels3(res) + } else { + labs <- .labels3(res, origdata = data) + } + + res$labels <- labs + + # Add custom class if labels were successfully added + if (!is.null(res$labels)) { + class(res) <- c("nls_", class(res)) + } + + res +} + +#' Object summaries with the original object as an attribute +#' +#' @description +#' This function attempts to summarize an object using the standard [base::summary()] +#' function. The original object is attached as an attribute to the result for +#' reference. +#' +#' @param object An object to be summarized. +#' @param ... Additional arguments passed to the `summary()` function. +#' +#' @return A summary object with an additional `"object"` attribute containing +#' the original input. +#' @export +#' +#' @examples +#' +#' is_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) +#' summary(is_lm) +#' +#' summary_(is_lm) +#' attr(summary_(is_lm), "object") +#' +summary_ <- function(object, ...) { + res <- try(summary(object, ...), silent = TRUE) + if (inherits(res, "try-error")) { + warning("Unable to summarize the object.") + return(NULL) + } + attr(res, "object") <- object + res +} + +#' ANOVA tables with the original object as an attribute +#' +#' @description +#' This function attempts to compute anova or deviance tables using the +#' standard [stats::anova()] function. The original object is attached as an +#' attribute to the result for reference. +#' +#' @param object An object for which anova or deviance tables should be computed. +#' @param ... Additional arguments passed to the `anova()` function. +#' +#' @return An anova object with an additional `"object"` attribute containing +#' the original input. +#' @export +#' +#' @examples +#' is_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) +#' anova(is_lm) +#' +#' anova_(is_lm) +#' attr(anova_(is_lm), "object") + +anova_ <- function(object, ...) { + res <- try(anova(object, ...), silent = TRUE) + if (inherits(res, "try-error")) { + warning("Unable to compute ANOVA for the object.") + return(NULL) + } + attr(res, "object") <- object + res +} + + + diff --git a/R/modelit-package.R b/R/modelit-package.R index 19cc8b5..be861ba 100644 --- a/R/modelit-package.R +++ b/R/modelit-package.R @@ -30,7 +30,7 @@ #' @importFrom stats AIC anova BIC coef confint cooks.distance deviance family fitted formula hatvalues nobs predict residuals rstandard variable.names vcov #' @importFrom stats coef pf #' @importFrom svFlow %>.% -#' @importFrom svMisc gettext_ gettextf_ ngettext_ stop_ warning_ +#' @importFrom svMisc gettext_ gettextf_ ngettext_ stop_ warning_ eval_data_dot #' @importFrom tabularise colformat_sci equation para_md ## usethis namespace: end "_PACKAGE" diff --git a/TODO.md b/TODO.md index 4d75818..6429df9 100644 --- a/TODO.md +++ b/TODO.md @@ -1,26 +1,32 @@ -# modelit To Do list +--- +editor_options: + markdown: + wrap: sentence +--- -- 🔥 High Priority: Refactor all tabularise_***() methods for anova, aov, glm objects to improve internal consistency and prepare for multi-format table rendering using {flextable}, {tinytable}, and {gt}. +# modelit To Do list -- 🔥 High Priority: Improve translation management across the package. Currently, multiple calls to gettext() and gettextf() from {svMisc} are used. +- 🔥 High Priority: Improve translation management across the package. + Currently, multiple calls to gettext() and gettextf() from {svMisc} are used. -- Introduced the first version of tabularise_***() methods for objects such as lm, nls, and glm, initially designed to generate tables using the {flextable} package. -Future versions will support multiple output formats via {flextable}, {tinytable}, and {gt}. -To enable this flexibility, a unified internal object structure is being developed to store all relevant metadata (e.g., labels, units, formatting). -This structure will allow seamless conversion to different table formats using functions like as_flextable(), as_tinytable(), and as_gt(). +- Introduced the first version of tabularise\_\*\*\*() methods for objects such as lm, nls, and glm, initially designed to generate tables using the {flextable} package. + Future versions will support multiple output formats via {flextable}, {tinytable}, and {gt}. + To enable this flexibility, a unified internal object structure is being developed to store all relevant metadata (e.g., labels, units, formatting). + This structure will allow seamless conversion to different table formats using functions like as_flextable(), as_tinytable(), and as_gt(). -- Implement tabularise_***() methods for enriched model objects: nls_, lm_, summary.lm_, anova_, etc. These methods should leverage the metadata (e.g., labels, units) embedded in the enriched objects to produce consistent and informative tables. +- Implement tabularise\_\*\*\*() methods for enriched model objects: nls\_, lm\_, summary.lm\_, anova\_, etc. + These methods should leverage the metadata (e.g., labels, units) embedded in the enriched objects to produce consistent and informative tables. -- Complete the examples sections of the tabularise_***() functions for the following object types: lm, summary.lm, nls, summary.nls,... +- Complete the examples sections of the tabularise\_\*\*\*() functions for the following object types: lm, summary.lm, nls, summary.nls,... -- Implement tabularise_***() methods for merMod and summary.merMod objects (e.g., from lme4::glmer()). +- Implement tabularise\_\*\*\*() methods for merMod and summary.merMod objects (e.g., from lme4::glmer()). - Extend tabularise() support for anova and aov objects. - - Rework the current implementation and determine the appropriate package context ({inferit}, {modelit}, or another). - - Also consider integration with car::Anova(). - - Note: there is currently no proper tabularise_default() method for aov objects. -- Develop chart() method for lm objects with categorical predictors (e.g., visualizing factor effects). + - Rework the current implementation and determine the appropriate package context ({inferit}, {modelit}, or another). + - Also consider integration with car::Anova(). + - Note: there is currently no proper tabularise_default() method for aov objects. -- Add support for multiple comparisons. +- Develop chart() method for lm objects with categorical predictors (e.g., visualizing factor effects). +- Add support for multiple comparisons. diff --git a/inst/po/en@quot/LC_MESSAGES/R-modelit.mo b/inst/po/en@quot/LC_MESSAGES/R-modelit.mo index 11fdbda8d977e2db5fa20c0fa34ed3cdefa7fda2..4de7b36fce29453b5420b561ddc502d7e83a6330 100644 GIT binary patch literal 11430 zcmeI1dyE}b9mfv^1eS+ND?adX5SF{U?7g(x7R#1Zmv*-oOYTq55V7^!5^-7^ciy=ya#&lL-1m_ z=4@kL122Wohx_4KFvz)(m%lB)e=j_R`j6!0AA{#||2e4szXI37@57Do=kRrK?K#Hm zgER0d_#o7PpMa`ALMN*KDm)dgqqEKMCGZls3!VvMI0o;4>)@Aj{t&9&FX6TDNjM5O zF{w>3gfD`hfNK9`sChmO)$f`YAnxEoHw1$YJgdd@%R^~LkE zaqflv)ZYas;Dhi+_`G0VH@s)?}h5`SCChlr{U%BTqYwskHJ^NNvOE-pyJ|g zsChgHHO}uq*<%eae-#{px4>)QyWppw?7iis)WIpJeiQgg_(6CD`~u{k`5k{=2G8J+ z{O;8``ynPX15o4H3N@Y^q4aYHl>OcYrT=$A>E$zU9S-ypsQLaHB{bkOQ0;4U_8NFE z#O2K+P6b-C_&Gk3JFcK7OMY?ATDCo!;Nq|R2(nBH^MK%tKeED z|53Obs{Sdc`VvZ%f87H&!~3A({1GU-JPF6)AE4~E(Pn%DRJ&WC;@p9w@Uw6ed=lak z<`pPs3~q#)=OL(mZ->(NUHSdnq5S6E5EGiOL&f=H5LYqlFrwOD2Ia?_q2_;e&g-G< zeju+u1ZAf?q26~FRGi-j73c4Rr@)7y{Q8?ve)U}_KmG%hpKQTsVhC0LNvLuD0QSSb z!U=dWO1lwyP;ve+lwF>J@{=_@EcU@ccs`UquY%Io_3%`9H#`l#6XNRTT~KlU07Mn$ zOHgtC)4cw?OSAa66iPqaq4cvW=goP29bQTK-B8bc1D+1Q2c^d!<@`C+`=5gH=RZN& zdRmb!wMpuI>_~iF6mB}Z2LN77Fk4;(|Rx5-uQ@Yr^_NSq8O2$bzOkW zBdU;Me`P35{bGIx78AD50? zVhXm=iWBQJo30btR**za5Ld&f;a02{*re{-Mp$wELTpvq@||HDMs_i5Weww2v*|CU z&xMg!^8&}W6(@0GH&J_)>2|DS2DW=~(~V*;3~bYhoQ9jYkvg^g@u=-D4b=wC(Bx1t zPMpMx6R(^VS{_%Wb%ILvqf)g+JJcMqZO3o9JQb_motn^{S()k9nxQ0rPQR8vb6clo z*p!?~Wv(3h0i%is2DAIR>r~um`Q1q8Huh?PSDj<9QQE*=Ky&3}&I_txJm&;q+Zh|L2%7MrdevxRc# zRtq)>tz&z->a#u9D&4L$s-p(A`j|S6gD`b5Im+q-@*69S$L@{YZmYzrEEe#qIKeiW zPOd_xRdEx?^YL0uwd$2UH%M&a%=_*!nhtzScC>9MT&8K=ucDG}`(vk7^PQmV9;IoX zUukA$d}^B{_w%CN)oRQW5@FR&dU2g!GiBl@s9BFlAt=Hi4-_*_47=@gvO(L8YA!ED z9X^loE9=mVS8grs**~)1j0e_@A_6Tems?Rpv%__l*p3#}d5;zq?Rk{jY7{nXVWB{4 z$6t&+v{6OLZBK7lR@io;tng~)vki|={jcF1bk(HV3d$OK)}fPS6HM3+{kC2ov>I;Y zl?hyW!CGmau|asawA5GAm;d}zO}qK5+y1bZ)a}TM?+aH@rrGY+B9~#wEc~d1joe_f zVM4MS@Jeop@n)kN+?wU6J#Oq(T8>ZaAZ(QE_A0+}-SK;Z{MK+1*GzV_bD%#yKxj6b zVU+MLWs9nhcS|L?AI2rK!woR8@7;zCcY1+R_O!CInQAn{IQH}~_DuCf_8r;2eAbOH zqP~uadggDYf{NR8`9r{TtY8Zi<8@`XnV9@d={jI`hPC2O@1W~@^)RfYw|?*KVf=PJ zY>})7woMJ1X_vRfhgweL#wHtU`qx&f+3l#AZuyDVWaLA8hH%$zI5?GCS(=z>Z#fIx zt}t-*$IletyABIj{t9b%gbh}ifKbmC{BuD#7aTtX|S**4Jk5H)~chdhOMZ$v?{4i<`w z(~N~sKmKTLaJ~7K@1NkQ=SE@2>m{j2VXIc}*-ZQcmYDb4g(jX6Bpy-OnJ}A>2CgNO z;7E&ZVo0)SIHtr2my+&MmQ@Uumy$uAPnVwT8ZI`wo$^7a=GuaGIVCS-b&7GQLoH8v zcD|L68nhE)qu{eTmCT-*36o~!J+4nqZ@ZSNpyEW8EJ>SA>R3v)$CTtD(p@`_ZIeHN z8>f4x%2E!iW;txB3Ht%%woZ(8Uq*Q`tQPa~TnC-nxZ6HfZtE5+te0+BjcTk$H){;T z=}2zrsa-zrXEkCB9J`}t#;Y|PGt<%Agcdh5vwR-2ZqzXP!?IqfV2c=|WZpq;9Z2I= zcJ|30gJzbMuRoUU(lx!!RwCOvsG>m2bonhH)y z&>?LI3d8v(v=Ema-}S?C?$a1m&(~Rj3XJlf?cE;LFE1{K;lVf^0{#1JSR+!UMx=_~ z`_Ajr@X=tLRuZ!LWjuVCF56Jt#Frd3u2Ag`PS#wy6n}Ez6{h*cRB?XPsrH zS}ducWJvYa%~qXm*NT}+Zw-!-=a8(5%vp_0_R%>mwnlfW-G6k*bSvk zr7eBCuPg3h->bbx>o@i7Bmoy^b?m@;7)GOZ9NV)w z_V7|NHQzS44W7({L9K-Y6=z+CJ$QiWyJe%+4f>|1rYDvLvZ1uTZ(FGC58V?cqc&kb zeR?vsZsI+6MBI%L7pI(xv3 z+E@IC9JH)9s1qNy&{D@On$CajfeVAoj$Dq>`hV}C3v*gvI?K*jIvc2Eg`I7OIeGBn zpFDUudGK=b;N>_cRsX98FJ#O7=p|jLP9DBw2hZr?f8+24`*x0BWZ-}20SvFw=agQ< z$7K4^-FpZ_b-yZ49>knHh|&Mw9_Oe8S4odz@RniA4JR7eaZINmJCe~|ekj93%Z_EJ z(kVsOR!1`wJV$R-r$@gl9c6Z0(-~sVkxi$l_t>UWmLJ`ux7`8f$2Sx{_XjwPzCK3J cxq90A{jVP6&?nyuOP%%{=cK*=zZ~fN9UZOUApigX delta 2625 zcma*neN5F=9LMo<0THi?%A+7$FY%-o!3&5A_=KS-5D29yiHLYri0c#34?aocLYq0om}H!Vz39g!ID#|qbL7vQw_dc*e?9?2<4RmL)tF8AC^9$m9TwpCn1p7UG0R~J zreTA1E9&zHunC8-22bH4you?IZ_1e#lQRvdFKoj&?6CKpSjPP>ti_|4f#*>FH-UVY z`5l$1zpcsK%;Y{7^}Y-zVJ&K$I!t7I(@3Wj+fXTsU;++fF&@UX_%<%a>(&M2U+;Uc z3`emLKf*P588>4Qvnas`l5+DVPR7qLGM~;FI!fI&3}WJ}Sn8IbCQ^%;xC;3*o9%rc z=5l`sm5DLbO2@75+xMrjn&&^EK9`dc%T!Sc`DZbviU%5~9_QhDoQ(%jD<4Iz@I1~z z56e(Z6T5&K_y%@jkX1g7Pa$hHzI5^*ptCSN_C+0-#r-3gjmJ>6 zaKic?G6(YkYQQg115Tj!b{d7D)TUq_W}_Cg42v*?Y3%V4)WTnmkk>GscTmU5$FkWr zvk8@|UDo~f`9r808L{_Aka{yOqP}n(S*-aGEAcGqRC!p{OSl4csxD#&MsirDj>-L~ zWA!kqI>)dM-$2#I6|3^E&!?k~RTkD@2p8cPk__`LY5`YJ-*+9A$-nHqhxDqEZ{jJ}@`qMXhK7>R4?= z59--&LX+qu+KKgq+CoBO=>Ii2Wy;U^Zn4mJn+C5Zv`RJo_~;nvXs#r*kBsH+uZm0Q z3=wUF8YN-wA^M2rgqpT?6`@n1Lf=UA5Zbah?f+eb_E#(EAk=iE)V2^RvPNP9@o(E| zJ6#wgmJxG_6@;1!R83j*y1m$iopReAuD25!-%YJlizgC@aze*Zt((|I>>%zW)ON;j zul#noKU%tJAXHpxRYV=3y;ticrW3`4>W$`(?;ev$+^P7~T4T7s`D<+dZmXyuwi7DC z1;kQ9ttp0ky@RWc^)~x#9a2Va0oq5vG^RqceUfTjjY-b1ci0)t>32N2hn+58k`wT? zL}yI*dZMk#VUIJA*BtGdSrzZ37uGwMQ$x=4X(yd?MSGmbi|0D|8E2e7=A}9>WM(+~ zGoOhz&u;QKpO#D%J>U-y4Gj8sg#6um{d@Zd{QD022ZqAo?t>4Oxwkv|LOp}dH`#dw zOS~IeOWQ;D^$zsz+gn=SJs7I-R|G4nN`p&F%NO~}gEduE(X2Two?9mw4fu9?oYv&s l(GtJ+Ka+gxmI+?Hb#hMg>?~({pd^|VXmBT4{Qo9t{sD0P9NPc@ diff --git a/inst/po/fr/LC_MESSAGES/R-modelit.mo b/inst/po/fr/LC_MESSAGES/R-modelit.mo index 783ea6a1f4d214eae73a2b66b47cfb43503c3108..c0677b11970137d0b8516db6cb66d6662e39d54a 100644 GIT binary patch literal 11833 zcmd6tdyHJyUB^#iw@I9)(6sasQaI3<+1>0+)=uKY>u!_HdYvp?Kk%-dq)oiOJ9B2| z+IQ|9-^bYNlqd}nq=4E#3aCwKR9aNxkb(q%gu)*IEmTE94MGtGf&xUP3aSt&DvziX z@%f#5?wvdPu-#B3Mn3bMd+vGs&hLGG>zA+J{>zHbM`$hbfz;}Sp zID8(Ic`t$=1pf-01aIO{w}DIG4}re~%KT?QIp?dOtos^xCHNip{NG@M=c|5Dsds~W zzNQ~z8T#9Hl^y|wV?2I zFSs4t2iCy5!2@6i+ynl$!*9Cx@4Y^!a~9mm`xKl7p9CKO{~o*<+>1~|E`~2riB*Rm z1xI=Q7%2SwU2p>YDk%JX9Ta-L3%(1yl0j^(ZUBD_90zxUhd_D%QSiOsr$OP*bD*66 zj~sr@y?+VZOaJSjjJp-#2!EzP;p2?MqoC~Xfg@lW6nT6Cycc{L6#o1xDDt`k;ruYz z29JY}gRo&^>$boj0e=qUpZX$SH-LW#ioU(%@MREDseb^4j&FlP$J-bz ze7PMIx$Ogm?=ztA!+_rcKMu+{&vW>n2R{amgYRImyTNG?5vs>QvDaU5`0K9!cii(= zK+(e&K}V4ly$bjocDw80)_vJ;9>AHpy=PXz$d_69A4z~``{7qN|+~l zwE&8p-VX|$UjT)!KL_W*mqA#qZq~WI&44oRLtqy?0X_i!8F(MK6Q;m26@o&~6X3Pr z3!v!NOQ6jEM^Mi7Pv9i@I>=V)HiUH$Tm(@K^?4AHsxO10?|0e%L26Zl2<{46MZea`j&DY%#C z7eKM!Yfx^{mz|)Aw%022X>chhG9kUVj6A61?W-96t*Ry}KB67dQio-uw(G>wW=b3-u=s{{<8~ zc~3pJ^ExQ@JpqcGXF!qTBjB6C=fUg1uYk9JFM_v$+acx(u=w2TejEqoyw#74zmImd z(kU_!x;w7VcZm3`pT8As(jeE$IRxc{7%YE;mnkiyounP0$>&3~6`JUXoI}noAF)Bv zJK@QLv>xp!EuqQzx6$OYBL~$7TQu0MJlapuX)@KX97is5c!n^7RGf)9dWFa3- zi)msTxGMV*dlp@}n}%DmpR4%py5F$c%KRbl3{CVOaa%cv&VPhUCy+F6T)Jse%^QBK7ry6Qxzn}C>ocK|wdtU5y zO=@CURPRhC_0GoF%BUJUFjh}eFZGkuZ|0qv;qp>@VJrX9YU{cl>y7EY7i5M}iOhRc z4)kc=r^>f#EOq1L*YKG0#hY=}@LH{Mc) z(Z>=~&Px5(Y7M?l;bojN<#D2mR?PDnzMHD(i zQPbG4>D$AGeG{)3HiaDl!}ygisHR(|8b?p;KB1;VZQ>Y1i<-?Wj+u70W3cUbRTi&s zQLNorxo*c%SJ%$fnC%6ti4Qm0FuCu`4nv)NFU~vf;XE^Fyw$(1ciPC5b`~~;^n5`t z_a=z29|e8cKFqo%_L~?ks~|1wXLJ~yZ4B1x1)@K1Xlm)t%K2ygw4--#x?i*jGu3{x z5*x@8vGAi6b)CQ#qZDU1;x|kKdUNVV_vJq7s7d@*<^{|Sqi#d*Z}ZFXj^DHRx2~5O zb)ewR$(_kbOtaUE;*`C_TeJhTTUg@sFlnfJO^ApC|2#6B_d{{n2gN(9xo$5?5?=-* zPs=a7@9zD>r|w2E?>mU7a(*=zwoK3Pg~1e3&^5Zzx~A!+%I#$1fSQk1>hu0-6ZoAd zYT3u2`gj(-U5+xG^~lWJs5)raEjg2Uu}M@;tNqrkcK$f24rW2>_n>_2=oso+nuFIm zMQGxr)qVopp(r%+732&Ej7I=-TWEc6)FsNK=W}^%JoZ32bRs7@0F`ODfw@7S{(+Fo;%c$h*|E%N%#m zZ+1K+l++JG3#NW?YVJ4waux)a81?;O*u_>!J8_h)bSlZj_aKR7-<<2A8DZ*UmBoQc zLb|Ayhy+DiHL1eMT646B5)Pd1z{`paH3!bX`P0G3QgDen;x$iuD@NBO%W3!#(J4Wp z&Sbv$+2t(7HAp5zq7V?B8tUl6tg>GDs0r}teWQ65w!FBNJ84z8j)Ak?(Bn*`j2#>2 zxDlwa&7E2UAJ)!&*kB6zfcUn;M$66UuSe~=>vudT-X`VzM0{J>EoMD@LtSIbq-HZ>3BhJv<8cCN4T1BIU8r#&YXgy1gtldiv1e!F3;2n_PIxN*M?(ZY?=|b4@m++h(I-{e50%Db?dTmGm1_pmIT%hNLXWBrBEaa*IC)I)#<@Hq35&h`7hLWMyPFKXu8uC7ts&%GnqQ|xV zRIQ;-irYR}GSJhuqtTY@>B)w|XKRy(k8+GCf2;Zi2|H(yzrqE!W0l_?m#}FQBujD; zQexkQ)ebyFpUWWb%f1|1sNzM6F@AV@Qc0G^#aE$qOZLLL<(h*Lmst2n9Lb%uKG&)r z&#&l{c?k7Wy{mCs^L}gaCWfeuExZUnMg7g)V>Q)qntU-2P6iT=d3{^;uNLgglSoJAg_mo#ssw2*i zQIq_?s-tL*p1ktdr=^zS%Zblq@|4-Qgvg}avc)z3;xnb50;h6MYs)JQHC&d-FZ-<0 zGbD2b0kO8Ocj}eLKGp1)HpJ+)&mkd4P_Z79w;<~hCmJRz=x$iWR#rArCGkK{xpEH_ z6@=K@O8!#U@+yiUfiWb<(dya--4g|~2Pbb8owXNF7~Dc%D;1SDcpUgpWwT|=_sC{j zSh*;lH9hIVl!ixB8b!Y8DE)k#V8{#WmsbrnmxxBzLt~(+($EHzTlzEs+ zohMQI@v=xpYCURyDIt0b7l{h^aL}lEk*||OwdiB;9>QLGyAa+>K1i-zR)HE)FOf*2 zDSWJ5@WfD8*iv+qtNz-Bb#jPJ578$`2nJCDpcqu)5Ii8viky3ajakT>!?DCjnvuNP(Mb)O?TOv?`A!Imn>N?dkM+h$lS~*Rliv1 zhS#emv^66+wB@j4f4SA9%1c8eV6KGZqF~+Cj0%e^tn`qY&YD?RE+FxJz)e)6s2*)S z0@})IQCZB8khHOARLE<17j)AVihPkZs+Zv$OxH(D)RE!=Cx_>`+K+6-5^^I&0VGw) zGlr5=Hfb3gYA|icr+1gl_ez0?g6Ry& zUCsJskI+Qw2s5Qrw01#+f-zyc4XMau&)9aMd52s~sZ}G24W5NliA!B`Lx+VlFOPZ2 z=#|HQ)fJ6idF-=VXt8x8G+%9>YPIg7GqENe+(p9m^&9#btuT`B@LS8&!lMAgM#7yBPA44} zB8C6frH@q1+~!r>4op0%P>7vXX-n20g;L3HsCnFLS#hdVq3k_n?HO?Z8|zP*y(n91gHWsGjw9b?yK`CqolVG)4c~nVMr?@YXE*00PGPP#930zSs6XNlA zU63Fq+vZ2^aDQ8WdQ#VchNn`csv1V#QK;hjftRN^;wWUD?40}im?fr~vxz)x7Ctw( zZb*^7Z9Re@oF{&jA(yer<`SjjqVs4u?3aQAHl(xECly3ARVyT~q!we-M5+|z9vF#~$L0dvX0_79 z^2!*j=*zXXtc_Jc%~wz<1nOZ=Bge8CzvR?P?WBQlgd=Os!F%zWN|heh(C#vQBM}hJ^IZ5 ZE>YO9E65EKVm7CwGJc51n~yGb{vThJzs~>w delta 2303 zcmY+^e@IqW9LMqVlxC^d!P0h3)mbGeGL5-&Qj1+&R&l44`XADL# zYJcqPSJ3{bA*&J6a254mv}nO_tiiTgo1W zLQKbHxEAa22yVseI8m?4<|%nx$VIN1)i?t;`i7Ak%|Wch!#ER1kUw*SgZ}RuWbEdS ze?EpG&VNJxOh%$H$(VzhP{@<1*3y~Ag%dg)w!0@o)GOmvTOx{OHDYs8qH3cA#D~h()*` zXW>Z<;bnXd?_(~;Qz)vbBAkaSQ3L5jz2``f^;hbza3K?KVix|6TFV4}l!>SZO+`JZ z1hqsPP#M~SIk*!wu)|n@ALBzDMaE<=1U~AF>{xWW^9?BiYpJf zWQtKYHefbxLv5RVI2lhM%W8&DMSKDE;;X0+&abE$=aFYQAC8NUt z;sQL4D#9O7Rr~~%nM^L~1vRMayRZRYM?Ls+RA#>Q)k9fkQ-UhuI#dQ4upGNFLHqwh zIx3nWoR1?|iT6;|Jd4r~pqh$quGbqsD7BiM8sqfVR@v15|JSPNcr*4dXz(iueQRp< z#Zp=|(shK2M`>3k)RcO)rg5GgSJ10+Ur$MkX-8|=S`@VkLi63O6Thv-ZG;w#^mus! zFK;SSwHiVt|7_d9Nh`61P|hsz0-??QBEh=EOdTCnfHu~8B9Bm;L~JIsXoZB@rg6*? zUqQusP1UEimC$-<gviu69< z;I(>=tnt&fnBG#iH!;JdCv^u(-DpyiTb>>7hLe}LLsO5r`jq+ZY)X~e6Krx1f-NJb zrrn+3j;5V)Z_fD4HO<`PYSP!l9q12RcPJy@y`15K{r%wq+uj%L?XX3S&BbmgbJ@i1 zwsyBJE6YvKdbMD`?THRXYcNfZny!~2Pq Date: Wed, 20 Aug 2025 09:25:56 +0200 Subject: [PATCH 19/22] modification in .extract_footer_glm --- R/tabularise.glm.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tabularise.glm.R b/R/tabularise.glm.R index 87ee82d..96fc345 100644 --- a/R/tabularise.glm.R +++ b/R/tabularise.glm.R @@ -518,7 +518,7 @@ colnames_glm <- c( res <- paste( gettextf("Degrees of Freedom: %.*g Total (i.e. no model); %.*g Residual", digits, data$df.null, digits, data$df.residual, domain = domain, lang = lang), - gettextf("Total deviance: %.*g",digits, data$null.deviance, domain = domain, lang = lang), + gettextf("Total deviance: %.*g", digits, data$null.deviance, domain = domain, lang = lang), gettextf("Residual deviance: %.*g AIC: %.*g",digits, data$deviance, digits, data$ai, domain = domain, lang = lang), sep = "\n") res From 7064a9d9928f1508757a45ccfea112c0ea0f8b5a Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 20 Aug 2025 09:36:57 +0200 Subject: [PATCH 20/22] common internal functions for lm, summary.lm, glm, etc. are now centralized in utils.R --- R/tabularise.anova.R | 2 + R/tabularise.glm.R | 2 + R/tabularise.lm.R | 360 +-------------- R/utils.R | 562 +++++++++++++++++++---- inst/po/en@quot/LC_MESSAGES/R-modelit.mo | Bin 11430 -> 11332 bytes inst/po/fr/LC_MESSAGES/R-modelit.mo | Bin 11833 -> 11719 bytes po/R-fr.po | 86 ++-- po/R-modelit.pot | 72 ++- 8 files changed, 542 insertions(+), 542 deletions(-) diff --git a/R/tabularise.anova.R b/R/tabularise.anova.R index f329eb2..9f87295 100644 --- a/R/tabularise.anova.R +++ b/R/tabularise.anova.R @@ -187,6 +187,8 @@ colnames_anova <- c( npar = "Number of parameters" ) +# See utils.R for internal functions used by various .extract_infos_*** +# .extract_infos_anova <- function(data, show.signif.stars = getOption("show.signif.stars", TRUE), lang = "en", auto.labs = TRUE, origdata = NULL , labs = NULL, title = TRUE, colnames = colnames_anova, ...) { diff --git a/R/tabularise.glm.R b/R/tabularise.glm.R index 96fc345..f537e42 100644 --- a/R/tabularise.glm.R +++ b/R/tabularise.glm.R @@ -492,6 +492,8 @@ colnames_glm <- c( "header" = "Generalized Linear Model", lang = "fr") +# See utils.R for internal functions used by various .extract_infos_*** + .extract_footer_glm <- function(data, lang = "en") { digits <- max(3L, getOption("digits") - 3L) domain <- "R-modelit" diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index a70467e..b9e2bf5 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -397,205 +397,7 @@ colnames_lm <- c( "(Intercept)" = "Intercept", lang = "fr") #.trads -.pvalue_format <- function(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), - labels = c("***", " **", " *", " .", " ")) { - #x <- get(as.character(substitute(x)), inherits = TRUE) - z <- cut(x, breaks = breaks, - labels = labels) - z <- as.character(z) - z[is.na(x)] <- "" - z -} - -.extract_colnames <- function(df, labs, lang) { - vec <- labs[names(labs) %in% names(df)] - vec1 <- gettext(vec, lang = lang) - names(vec1) <- names(vec) - - #Remove elements with missing or empty names - vec1 <- vec1[!is.na(names(vec1)) & names(vec1) != ""] - - vec1 -} - -.labels_factor <- function(df) { - if (!is.data.frame(df)) { - # warning("No dataframe found.") - return(NULL) - # stop("Input must be a data frame.") - } - - factor_cols <- which(sapply(df, is.factor)) - if (length(factor_cols) == 0) { - # warning("No factor columns found in the data frame.") - return(NULL) - } - - if (!requireNamespace("data.io", quietly = TRUE)) { - stop("Package 'data.io' is required but not installed.") - } - #class(df) - df <- as.data.frame(df) - #class(df) - labels <- vapply(df[,factor_cols, drop = FALSE], data.io::label, character(1), units = FALSE) - valid_vars <- names(labels)[labels != ""] - if (length(valid_vars) == 0) { - #warning("No labeled factor variables found.") - return(NULL) - } - - # Fusion of result and names generation - result <- vector("character") - result_names <- vector("character") - - for (var in valid_vars) { - levs <- levels(df[[var]]) - result <- c(result, paste0(labels[[var]], " [", levs, "]")) - result_names <- c(result_names, paste0(var, levs)) - } - - names(result) <- result_names - return(result) -} - -.labels3 <- function (x, origdata = NULL, labs = NULL) { - if (is.null(origdata)) { - labs_auto <- c(tabularise:::.labels(x$model), .labels_factor(x$model)) - } - else { - labs_auto <- c(tabularise:::.labels(origdata), .labels_factor(origdata)) - } - if (!is.null(labs)) { - if (!is.character(labs)) - stop("labs is not character vector") - if (is.null(names(labs))) - stop("labs must be named character vector") - if (any(names(labs) %in% "")) - stop("all element must be named") - labs_res <- c(labs, labs_auto[!names(labs_auto) %in% - names(labs)]) - } - else { - labs_res <- labs_auto - } - labs_res -} - -.extend_labs_with_interactions <- function(labs, terms) { - if (!is.character(labs) || is.null(names(labs))) { - return(NULL) - } - if (!is.character(terms)) { - return(labs) - } - - for (term in terms) { - if (grepl(":", term)) { - parts <- unlist(strsplit(term, ":")) - missing_parts <- parts[!parts %in% names(labs)] - - if (length(missing_parts) > 0) { - warning(sprintf( - "The following terms are missing in 'labs' for the interaction '%s': %s", - term, paste(missing_parts, collapse = ", ") - )) - next - } - - interaction_label <- paste(labs[parts], collapse = " x ") - labs[term] <- interaction_label - } - } - labs <- gsub("\n", " ", labs) - return(labs) -} - -.extract_labels <- function(df, data, auto.labs, origdata, labs) { - if (isTRUE(auto.labs)) { - labs <- .labels3(x = data, origdata = origdata, labs = labs) - # Compare the names of labs with the rownames - labs <- .extend_labs_with_interactions(labs = labs, terms = df[["term"]]) - } else { - labs <- .labels3(x = NULL, labs = labs) - } - - labs -} - -.extract_terms <- function(df, labs, lang) { - vals <- df[["term"]] - terms <- labs[names(labs) %in% vals] - - if(any(vals == "(Intercept)")) - terms <- c("(Intercept)"= gettext("Intercept", lang = lang)[[1]], terms) - - if(any(vals == "Residuals")) - terms <- c(terms, "Residuals"= gettext("Residuals", lang = lang)[[1]]) - - terms -} - -.extract_equation <- function(data, equation, labs, ...) { - - if (!(is.logical(equation) || is.character(equation))) { - stop("The 'equation' argument must be TRUE, FALSE, NA, or a character string.") - } - - equa <- NULL - - if (isTRUE(equation) || is.na(equation)) { - equa <- try({ - if (!is.null(labs)) { - tabularise::equation(data, swap_var_names = labs, ...) - } else { - tabularise::equation(data, auto.labs = FALSE, ...) - } - }, silent = TRUE) - if (inherits(equa, "try-error")) - equa <- NULL - } - - if (is.character(equation)) { - equa <- equation - } - - equa -} - - - - -.params_equa <- function(x, intercept = "alpha", greek = "beta") { - vals <- NULL - - if (intercept != greek && grepl(intercept, x)) { - it <- paste0("\\\\", intercept) - res <- regmatches(x, gregexpr(it, x))[[1]] - vals <- paste0("$",res, "$") - } - - if (grepl(greek, x)) { - g <- paste0("\\\\", greek,"_\\{\\d*\\}") - res <- regmatches(x, gregexpr(g, x))[[1]] - res1 <- paste0("$",res, "$") - vals <- c(vals, res1) - } - - vals -} - -.extract_title <- function(title, lang = "en", default = "Linear model") { - res <- NULL - - if (isTRUE(title)) { - res <- gettext(default, lang = lang)[[1]] - } - - if (is.character(title)) { - res <- title - } - return(res) -} +# See utils.R for internal functions used by various .extract_infos_*** .extract_footer_lm <- function(data, lang) { digits <- max(3L, getOption("digits") - 3L) @@ -714,166 +516,6 @@ colnames_lm <- c( ) } -.create_flextable <- function(x, header = TRUE) { - df <- x$df - - ft <- flextable(df) |> - colformat_sci() - - if ("p.value" %in% colnames(df)) { - ft <- ft |> - colformat_sci(j = "p.value", lod = 2e-16) - } - - if (!is.null(x$cols)) { - ft <- .add_colnames(ft, x$cols) - } - - if (!is.null(x$terms)) { - vec <- x$terms - if(is.character(vec) && !is.null(names(vec)) && all(nzchar(names(vec)))) { - ft <- .add_labs(ft, vec) - } else { - ft <- .add_params(ft, vec) - } - } - - if (isTRUE(header)) { - ft <- .add_header2(ft, title = x$title, equation = x$equa) - } - - # footer and psignif - n <- 0 # use to define align right and left - - if (!is.null(x$psignif)) { - ft <- .add_signif(ft, x$psignif) - n <- 1 - } - - if (!is.null(x$footer)) { - vals <- x$footer - ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) - ft <- align(ft, i = seq_len(length(vals)) + n , align = "left", - part = "footer") - } - - ft <- autofit(ft, part = c("header", "body")) - - if (!is.null(df$signif)) { - ft <- width(ft, j = "signif", width = 0.4) - } - - return(ft) -} - -format_table <- function(df, kind, header) { - switch(kind, - df = {df}, - tt = { - stop("Not implemented yet") - }, - ft = { - .create_flextable(df, header = header) - }, - gt = { - stop("Not implemented yet") - } - ) -} - -.add_signif <- function(x, signif) { - - if (!inherits(x, "flextable")) { - stop(sprintf("Function `%s` supports only flextable objects.", - ".add_signif_stars()"))} - - ft <- x - s <- signif - - ft <- add_footer_lines(ft, - values = s) - align(ft, i = 1, align = "right", part = "footer") -} - -.add_header2 <- function(x, title, equation) { - - if (!inherits(x, "flextable")) { - stop(sprintf("Function `%s` supports only flextable objects.", - ".add_header2()")) } - - ft <- x - - if (is.character(equation)) { - ft <- add_header_lines(ft, - values = as_paragraph(as_equation(equation))) - ft <- align(ft, i = 1, align = "center", part = "header") - } - - if (is.character(title)) { - ft <- add_header_lines(ft, - values = as_paragraph(title)) - ft <- align(ft, i = 1, align = "center", part = "header") - } - - h_nrow <- nrow_part(ft, part = "header") - - if (h_nrow > 2) { - ft |> - border_inner_h(border = officer::fp_border(width = 0), part = "header") |> - hline(i = nrow_part(ft, "header") - 1, - border = officer::fp_border(width = 1.5, color = "#666666"), - part = "header") -> - ft - } - - ft -} - -.add_colnames <- function(x, labs) { - - if (!inherits(x, "flextable")) { - stop(sprintf("Function `%s` supports only flextable objects.", - ".add_colnames()")) } - - ft <- x - - for (i in seq_along(labs)) - ft <- mk_par(ft, i = 1, j = names(labs)[i], - value = para_md(labs[i]), part = "header") - - ft -} - -.add_labs <- function(x, labs) { - if (!inherits(x, "flextable")) { - stop(sprintf("Function `%s` supports only flextable objects.", - ".add_colnames()")) } - - ft <- x - - labs_red <- labs[names(labs) %in%ft$body$dataset$term] - - for (i in seq_along(labs_red)) - ft <- mk_par(ft, i = names(labs_red)[i], j = "term", - value = para_md(labs_red[i]), part = "body") - - ft -} - -.add_params <- function(x, params) { - - if (!inherits(x, "flextable")) { - stop(sprintf("Function `%s` supports only flextable objects.", - ".add_colnames()")) } - - ft <- x - - if (length(params) == length(ft$body$dataset$term)) - ft <- mk_par(ft, j = "term", value = para_md(params), part = "body") - - ft -} - # # TODO: Migrate this translation system into the 'svMisc' package # diff --git a/R/utils.R b/R/utils.R index 85c7490..4642184 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,78 +8,172 @@ ngettext <- svMisc::ngettext_ # Need this for R CMD check to pass . <- NULL -# Internal functions of flextable -.pvalue_format <- function(x) { +# Internal functions for .extract_infos_***() +.pvalue_format <- function(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), + labels = c("***", " **", " *", " .", " ")) { #x <- get(as.character(substitute(x)), inherits = TRUE) - z <- cut(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), - labels = c("***", " **", " *", " .", " ")) + z <- cut(x, breaks = breaks, + labels = labels) z <- as.character(z) z[is.na(x)] <- "" z } +.extract_colnames <- function(df, labs, lang) { + vec <- labs[names(labs) %in% names(df)] + vec1 <- gettext(vec, lang = lang) + names(vec1) <- names(vec) -# Add pvalue signif -.add_signif_stars <- function(x, i = NULL, j = NULL, part = "body", -align = "right", ...) { + #Remove elements with missing or empty names + vec1 <- vec1[!is.na(names(vec1)) & names(vec1) != ""] - if (!inherits(x, "flextable")) { - stop(sprintf("Function `%s` supports only flextable objects.", - ".add_signif_stars()"))} + vec1 +} - ft <- mk_par(x, i = i, j = j, - value = as_paragraph(.pvalue_format(.data$p.value))) - ft <- add_footer_lines(ft, - values = c("0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05")) - align(ft, i = 1, align = align, part = "footer") -} - -# TODO: this is duplicated in tabularise -> export from there and reuse here! -# Extract labels and units -# .labels <- function(x, units = TRUE, ...) { -# labels <- sapply(x, data.io::label, units = units) -# -# if (any(labels != "")) { -# # Use a \n before labels and the units -# if (isTRUE(units)) -# labels <- sub(" +\\[([^]]+)\\]$", "\n [\\1]", labels) -# # set names if empty -# labels[labels == ""] <- names(x)[labels == ""] -# # Specific case for I() using in a formula -# labels[grepl("^I\\(.*\\)$", names(labels))] <- names(labels)[grepl("^I\\(.*\\)$", names(labels))] -# } -# -# if (all(labels == "")) -# labels <- NULL -# -# labels -# } +.labels_factor <- function(df) { + if (!is.data.frame(df)) { + # warning("No dataframe found.") + return(NULL) + # stop("Input must be a data frame.") + } -# .labels2 <- function(x, origdata = NULL, labs = NULL) { -# -# #labs_auto <- NULL -# if (is.null(origdata)) { -# labs_auto <- .labels(x$model) -# } else { -# labs_auto <- .labels(origdata) -# } -# -# if (!is.null(labs)) { -# if (!is.character(labs)) -# stop("labs is not character vector") -# if (is.null(names(labs))) -# stop("labs must be named character vector") -# if (any(names(labs) %in% "")) -# stop("all element must be named") -# labs_res <- c(labs, labs_auto[!names(labs_auto) %in% names(labs)]) -# } else { -# labs_res <- labs_auto -# } -# -# labs_res -# } + factor_cols <- which(sapply(df, is.factor)) + if (length(factor_cols) == 0) { + # warning("No factor columns found in the data frame.") + return(NULL) + } + + if (!requireNamespace("data.io", quietly = TRUE)) { + stop("Package 'data.io' is required but not installed.") + } + #class(df) + df <- as.data.frame(df) + #class(df) + labels <- vapply(df[,factor_cols, drop = FALSE], data.io::label, character(1), units = FALSE) + valid_vars <- names(labels)[labels != ""] + if (length(valid_vars) == 0) { + #warning("No labeled factor variables found.") + return(NULL) + } + + # Fusion of result and names generation + result <- vector("character") + result_names <- vector("character") + + for (var in valid_vars) { + levs <- levels(df[[var]]) + result <- c(result, paste0(labels[[var]], " [", levs, "]")) + result_names <- c(result_names, paste0(var, levs)) + } + + names(result) <- result_names + return(result) +} + +.labels3 <- function (x, origdata = NULL, labs = NULL) { + if (is.null(origdata)) { + labs_auto <- c(tabularise:::.labels(x$model), .labels_factor(x$model)) + } + else { + labs_auto <- c(tabularise:::.labels(origdata), .labels_factor(origdata)) + } + if (!is.null(labs)) { + if (!is.character(labs)) + stop("labs is not character vector") + if (is.null(names(labs))) + stop("labs must be named character vector") + if (any(names(labs) %in% "")) + stop("all element must be named") + labs_res <- c(labs, labs_auto[!names(labs_auto) %in% + names(labs)]) + } + else { + labs_res <- labs_auto + } + labs_res +} + +.extend_labs_with_interactions <- function(labs, terms) { + if (!is.character(labs) || is.null(names(labs))) { + return(NULL) + } + if (!is.character(terms)) { + return(labs) + } + + for (term in terms) { + if (grepl(":", term)) { + parts <- unlist(strsplit(term, ":")) + missing_parts <- parts[!parts %in% names(labs)] + + if (length(missing_parts) > 0) { + warning(sprintf( + "The following terms are missing in 'labs' for the interaction '%s': %s", + term, paste(missing_parts, collapse = ", ") + )) + next + } + + interaction_label <- paste(labs[parts], collapse = " x ") + labs[term] <- interaction_label + } + } + labs <- gsub("\n", " ", labs) + return(labs) +} + +.extract_labels <- function(df, data, auto.labs, origdata, labs) { + if (isTRUE(auto.labs)) { + labs <- .labels3(x = data, origdata = origdata, labs = labs) + # Compare the names of labs with the rownames + labs <- .extend_labs_with_interactions(labs = labs, terms = df[["term"]]) + } else { + labs <- .labels3(x = NULL, labs = labs) + } + + labs +} + +.extract_terms <- function(df, labs, lang) { + vals <- df[["term"]] + terms <- labs[names(labs) %in% vals] + + if(any(vals == "(Intercept)")) + terms <- c("(Intercept)"= gettext("Intercept", lang = lang)[[1]], terms) + + if(any(vals == "Residuals")) + terms <- c(terms, "Residuals"= gettext("Residuals", lang = lang)[[1]]) + + terms +} + +.extract_equation <- function(data, equation, labs, ...) { + + if (!(is.logical(equation) || is.character(equation))) { + stop("The 'equation' argument must be TRUE, FALSE, NA, or a character string.") + } + + equa <- NULL + + if (isTRUE(equation) || is.na(equation)) { + equa <- try({ + if (!is.null(labs)) { + tabularise::equation(data, swap_var_names = labs, ...) + } else { + tabularise::equation(data, auto.labs = FALSE, ...) + } + }, silent = TRUE) + if (inherits(equa, "try-error")) + equa <- NULL + } + + if (is.character(equation)) { + equa <- equation + } + + equa +} -# Retrieve model parameters .params_equa <- function(x, intercept = "alpha", greek = "beta") { vals <- NULL @@ -99,60 +193,120 @@ align = "right", ...) { vals } -# Change labels of header -.header_labels <- function(x, info_lang, ...) { +.extract_title <- function(title, lang = "en", default = "Linear model") { + res <- NULL - if (!inherits(x, "flextable")) { - stop(sprintf("Function `%s` supports only flextable objects.", - "header_labels_lm()")) } + if (isTRUE(title)) { + res <- gettext(default, lang = lang)[[1]] + } - ft <- x + if (is.character(title)) { + res <- title + } + return(res) +} - hlabs <- info_lang[["labs"]] - hlabs_red <- hlabs[names(hlabs) %in% ft$header$col_keys] +# Internal functions for format_table() - for (i in seq_along(hlabs_red)) - ft <- mk_par(ft, i = 1, j = names(hlabs_red)[i], - value = para_md(hlabs_red[i]), part = "header") +.create_flextable <- function(x, header = TRUE) { + df <- x$df - ft -} + ft <- flextable(df) |> + colformat_sci() -# Add header -.add_header <- function(x, info_lang, header = TRUE, title = NULL, equation, -...) { + if ("p.value" %in% colnames(df)) { + ft <- ft |> + colformat_sci(j = "p.value", lod = 2e-16) + } - # If title is not provided, determine if we have to use TRUE or FALSE - if (missing(title)) { - title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE - if (!is.null(knitr::opts_current$get('tbl-cap'))) - title <- FALSE + if (!is.null(x$cols)) { + ft <- .add_colnames(ft, x$cols) + } + + if (!is.null(x$terms)) { + vec <- x$terms + if(is.character(vec) && !is.null(names(vec)) && all(nzchar(names(vec)))) { + ft <- .add_labs(ft, vec) + } else { + ft <- .add_params(ft, vec) + } + } + + if (isTRUE(header)) { + ft <- .add_header2(ft, title = x$title, equation = x$equa) } + # footer and psignif + n <- 0 # use to define align right and left + + if (!is.null(x$psignif)) { + ft <- .add_signif(ft, x$psignif) + n <- 1 + } + + if (!is.null(x$footer)) { + vals <- x$footer + ft <- add_footer_lines(ft, top = FALSE, values = para_md(vals)) + ft <- align(ft, i = seq_len(length(vals)) + n , align = "left", + part = "footer") + } + + ft <- autofit(ft, part = c("header", "body")) + + if (!is.null(df$signif)) { + ft <- width(ft, j = "signif", width = 0.4) + } + + return(ft) +} + +format_table <- function(df, kind, header) { + switch(kind, + df = {df}, + tt = { + stop("Not implemented yet") + }, + ft = { + .create_flextable(df, header = header) + }, + gt = { + stop("Not implemented yet") + } + ) +} + +.add_signif <- function(x, signif) { + if (!inherits(x, "flextable")) { stop(sprintf("Function `%s` supports only flextable objects.", - ".add_header()")) } + ".add_signif_stars()"))} ft <- x + s <- signif - if (isTRUE(header)) { - if (is.character(equation)) { - ft <- add_header_lines(ft, - values = as_paragraph(as_equation(equation))) - ft <- align(ft, i = 1, align = "right", part = "header") - } + ft <- add_footer_lines(ft, + values = s) + align(ft, i = 1, align = "right", part = "footer") +} - if (isTRUE(title)) { - ft <- add_header_lines(ft, values = info_lang[["header"]]) - ft <- align(ft, i = 1, align = "right", part = "header") - } +.add_header2 <- function(x, title, equation) { - if (is.character(title)) { - ft <- add_header_lines(ft, - values = as_paragraph(title)) - ft <- align(ft, i = 1, align = "right", part = "header") - } + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_header2()")) } + + ft <- x + + if (is.character(equation)) { + ft <- add_header_lines(ft, + values = as_paragraph(as_equation(equation))) + ft <- align(ft, i = 1, align = "center", part = "header") + } + + if (is.character(title)) { + ft <- add_header_lines(ft, + values = as_paragraph(title)) + ft <- align(ft, i = 1, align = "center", part = "header") } h_nrow <- nrow_part(ft, part = "header") @@ -161,10 +315,216 @@ align = "right", ...) { ft |> border_inner_h(border = officer::fp_border(width = 0), part = "header") |> hline(i = nrow_part(ft, "header") - 1, - border = officer::fp_border(width = 1.5, color = "#666666"), - part = "header") -> + border = officer::fp_border(width = 1.5, color = "#666666"), + part = "header") -> ft } ft } + +.add_colnames <- function(x, labs) { + + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_colnames()")) } + + ft <- x + + for (i in seq_along(labs)) + ft <- mk_par(ft, i = 1, j = names(labs)[i], + value = para_md(labs[i]), part = "header") + + ft +} + +.add_labs <- function(x, labs) { + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_colnames()")) } + + ft <- x + + labs_red <- labs[names(labs) %in%ft$body$dataset$term] + + for (i in seq_along(labs_red)) + ft <- mk_par(ft, i = names(labs_red)[i], j = "term", + value = para_md(labs_red[i]), part = "body") + + ft +} + +.add_params <- function(x, params) { + + if (!inherits(x, "flextable")) { + stop(sprintf("Function `%s` supports only flextable objects.", + ".add_colnames()")) } + + ft <- x + + if (length(params) == length(ft$body$dataset$term)) + ft <- mk_par(ft, j = "term", value = para_md(params), part = "body") + + ft +} + +# Internal functions of flextable +# .pvalue_format <- function(x) { +# #x <- get(as.character(substitute(x)), inherits = TRUE) +# z <- cut(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), +# labels = c("***", " **", " *", " .", " ")) +# z <- as.character(z) +# z[is.na(x)] <- "" +# z +# } +# +# +# # Add pvalue signif +# .add_signif_stars <- function(x, i = NULL, j = NULL, part = "body", +# align = "right", ...) { +# +# if (!inherits(x, "flextable")) { +# stop(sprintf("Function `%s` supports only flextable objects.", +# ".add_signif_stars()"))} +# +# ft <- mk_par(x, i = i, j = j, +# value = as_paragraph(.pvalue_format(.data$p.value))) +# ft <- add_footer_lines(ft, +# values = c("0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05")) +# align(ft, i = 1, align = align, part = "footer") +# } +# +# # TODO: this is duplicated in tabularise -> export from there and reuse here! +# # Extract labels and units +# # .labels <- function(x, units = TRUE, ...) { +# # labels <- sapply(x, data.io::label, units = units) +# # +# # if (any(labels != "")) { +# # # Use a \n before labels and the units +# # if (isTRUE(units)) +# # labels <- sub(" +\\[([^]]+)\\]$", "\n [\\1]", labels) +# # # set names if empty +# # labels[labels == ""] <- names(x)[labels == ""] +# # # Specific case for I() using in a formula +# # labels[grepl("^I\\(.*\\)$", names(labels))] <- names(labels)[grepl("^I\\(.*\\)$", names(labels))] +# # } +# # +# # if (all(labels == "")) +# # labels <- NULL +# # +# # labels +# # } +# +# # .labels2 <- function(x, origdata = NULL, labs = NULL) { +# # +# # #labs_auto <- NULL +# # if (is.null(origdata)) { +# # labs_auto <- .labels(x$model) +# # } else { +# # labs_auto <- .labels(origdata) +# # } +# # +# # if (!is.null(labs)) { +# # if (!is.character(labs)) +# # stop("labs is not character vector") +# # if (is.null(names(labs))) +# # stop("labs must be named character vector") +# # if (any(names(labs) %in% "")) +# # stop("all element must be named") +# # labs_res <- c(labs, labs_auto[!names(labs_auto) %in% names(labs)]) +# # } else { +# # labs_res <- labs_auto +# # } +# # +# # labs_res +# # } +# +# # Retrieve model parameters +# .params_equa <- function(x, intercept = "alpha", greek = "beta") { +# vals <- NULL +# +# if (intercept != greek && grepl(intercept, x)) { +# it <- paste0("\\\\", intercept) +# res <- regmatches(x, gregexpr(it, x))[[1]] +# vals <- paste0("$",res, "$") +# } +# +# if (grepl(greek, x)) { +# g <- paste0("\\\\", greek,"_\\{\\d*\\}") +# res <- regmatches(x, gregexpr(g, x))[[1]] +# res1 <- paste0("$",res, "$") +# vals <- c(vals, res1) +# } +# +# vals +# } +# +# # Change labels of header +# .header_labels <- function(x, info_lang, ...) { +# +# if (!inherits(x, "flextable")) { +# stop(sprintf("Function `%s` supports only flextable objects.", +# "header_labels_lm()")) } +# +# ft <- x +# +# hlabs <- info_lang[["labs"]] +# hlabs_red <- hlabs[names(hlabs) %in% ft$header$col_keys] +# +# for (i in seq_along(hlabs_red)) +# ft <- mk_par(ft, i = 1, j = names(hlabs_red)[i], +# value = para_md(hlabs_red[i]), part = "header") +# +# ft +# } +# +# # Add header +# .add_header <- function(x, info_lang, header = TRUE, title = NULL, equation, +# ...) { +# +# # If title is not provided, determine if we have to use TRUE or FALSE +# if (missing(title)) { +# title <- header # Default to same as header, but... +# # if a caption is defined in the chunk, it defauts to FALSE +# if (!is.null(knitr::opts_current$get('tbl-cap'))) +# title <- FALSE +# } +# +# if (!inherits(x, "flextable")) { +# stop(sprintf("Function `%s` supports only flextable objects.", +# ".add_header()")) } +# +# ft <- x +# +# if (isTRUE(header)) { +# if (is.character(equation)) { +# ft <- add_header_lines(ft, +# values = as_paragraph(as_equation(equation))) +# ft <- align(ft, i = 1, align = "right", part = "header") +# } +# +# if (isTRUE(title)) { +# ft <- add_header_lines(ft, values = info_lang[["header"]]) +# ft <- align(ft, i = 1, align = "right", part = "header") +# } +# +# if (is.character(title)) { +# ft <- add_header_lines(ft, +# values = as_paragraph(title)) +# ft <- align(ft, i = 1, align = "right", part = "header") +# } +# } +# +# h_nrow <- nrow_part(ft, part = "header") +# +# if (h_nrow > 2) { +# ft |> +# border_inner_h(border = officer::fp_border(width = 0), part = "header") |> +# hline(i = nrow_part(ft, "header") - 1, +# border = officer::fp_border(width = 1.5, color = "#666666"), +# part = "header") -> +# ft +# } +# +# ft +# } diff --git a/inst/po/en@quot/LC_MESSAGES/R-modelit.mo b/inst/po/en@quot/LC_MESSAGES/R-modelit.mo index 4de7b36fce29453b5420b561ddc502d7e83a6330..576fc8861322c4eb9798af4df761db15c3728e74 100644 GIT binary patch delta 2721 zcmYk-drZ}39LMo5hl_w*0wF;p2t%YOj$Gs_NXA7h?25-sE1?p}6!8{NN1A_RV_Kd3 z1Iw}0>Ee%OJDX*!>C9GR+8>VQni<)M&6-;+tyymN{u~~*p7H&?p5NvCe$Vgwe4igj zSDp3we@u?pZ?s-wE^$5F>=>S#!G^Xz)+_-#umgAEJp38UFlwe*BGzCGwm5z6_&T@0 z1;aSs=Z?RQ+}Ce=>CEE9K`h2kuoi#8R?LkvtHwUmNKc~9uZW*IzYiI+O=2njiuYhP zcaO$;T#PN4f&7MpH%FJ_=_+<h@2dit)5Neg<{l3&^zF6)eUZSd00j>1nP14m#BwIEx1{ zjMvr$L&ya-jw-53@>hyAsP(-SH5G$chlfy8HQ~I8`dvcy)bdWoO7_=c2@Yba*8jJ3 z7IR<%^@cg*NjEM)rMT4Xm!oQ>4pmH>QR{mTQWo|V>i0jOigyx~fj^xd=2cUjggT#t zkv!iD>F9x_sP$cgTHo~;hTW)Y-i9is9#r)nLe<7qXEyVu^D9vU^-C#9a!p5j7P%kgVD+q+snZl07?(dXov%Ks}_1ds#JRVLNu= zZVcjIs5u{IZEJatI44odJIT*P)X?!FOV>6bE7JC$2ah<9p$0OH8pzkE%>0Hk@DEh# zZz5x}jDo4!p&M!q&ZkhtI^9%%p>^4a+ozABDqACe$sJqoWa>hh()_L?cwQ(I`gW+1 z`OrXAFI$Oi#Ir;_p|*;6k)WjPL9Ks{R!#FalgK7irJIPyh;Bl~rNUE-og%btV@rnZ zIpR@5O<7Y@VJovw5IYF1l>awnu~X|`^Pr~r+d`})R4i)zpRnhNT0-epQ@URc_4r1h zmg;I^Gof12JgewbC%weOguXA&5Y5DNtESU3J?b^?sA@o8y(VHQp(<59yh^-4EFsjM zB(wt5HW14Recc`pT#1<#_&p}Vzk)q45ksh{EZd2l+Hvg_Tt*}k`q*o2EF_|cWI}B% z5lyJta)=%xo_L5TC-Mk=m(?C2I*2+ATweyYIBkOcvE^Zbg3M0?iSa3ce=}bTCdQ}7 h2jU721iqV79bM$j_EuCDmj=@_B0a%^%<~C4^&hKQ_?-X% delta 2810 zcmaLYYfRO39LMn=2M{=1G&q6*7D^y!8VCouh8Hd(K@dq8aZM5mB|wQ1I@2)-MB+vFbr*Yw9eU*u~m{=Gxd?`lJoIvCPfjL96%Y@N45yzwte<-~V#{m+$xcJ6x_i zy~}ewGT>#y7$o9}fB<98;BP^EFkW;T6M-Yxfv;gAIzo-vgvq!R8!-g;S^Mq&!*=^5 z`f>bCyZ>zrH^yT=Vxk*dz$p9{Gw=o$VpNzhwOE7sIEH%SY1HvSuA<|gqCdL0m>XB% zJy?ms*oy@?fG#}m(__p86MgX~EXNtl#Y|o+6T5IZzKgoRdDNTEp)TxLMqnsvI|4Ug z46eWu%)=&(#y3#k{}{u#zq!DKdzvfODdf*g^TA7+ISjb8 zdx zowp5@p$b$cYpkuP2k6EW>_e609W2GO%gMh|q{1i@r5J~OSc@l77yKEyr ztqX89mY`No2WoW;qh4eT^`Kv)O5)(|cjH=Yz#SeY$CW|9y73rly^o_xGlN_3CaQE92@7sVeXjw_xxZ;)lFN<{ zF%xHy{xB=aPXT72-n1Ka;e)7@583S(P`&dKQbltSwce+Yb}=sMsPC^sHM1L)fvuAJ zn`$PieX~8G8&#|4Q8yeyt@mT7^?nNd@Di%KFQc043aXiJqIxBpy2&oo@zbaW{SK4x zZ}b#1NhEJ|*nwK_myp_+SyZz)I9oa~6(dn8%|~Ud8vSt?1Mmpa@a8yby`MpnVa}nJ z`!#z!BANVCW|N$}kfI_~iYl%3sN?OJgTts)evX0o4JwtB)*Gk?m_;@9EmTS3d42t~ zyRi}vp)xVKhWu;2|HF=2jN@CnU=QjI524okD;SJlBH1+)NQ0X{kt~{}q(u*!fqKwt z%*xwBDWMUAj^0y&3OE4{E)ChOA68g$}%By^UJ$^QZ?3 zyLaJ%Qc)SIz#yzam7pGZW;2NDA@!eclvhcK=P8d}?X2ztb9BgmLt?Ge#qKqga^wX*a zK1e)4Y#}su5?TowPZ19gc|;Adc#KYl1SmXJ>`f;^?9m=J+V0jW8nI+v3dj8=Z*%!dn$K79QQ+ z*0Q^;r>V20wXL(asdH~is$o7_9UD6u6MHT=JtraEotu{For(=~cqihoMg0Fa2LA=U C^#_yy diff --git a/inst/po/fr/LC_MESSAGES/R-modelit.mo b/inst/po/fr/LC_MESSAGES/R-modelit.mo index c0677b11970137d0b8516db6cb66d6662e39d54a..fcb7eb857744aff386915fe751a1ed1cb3204cd3 100644 GIT binary patch delta 2690 zcmYk-eN2^Q7{~F8H<4F?KoTfH-ZelH5d%ayyhwoMON4+Xq^5)@6_r>!6|*(g%3@a7 z+*f?YE2rA9DRT1+%)fTozMN;&pFR?Ki7TT51+Pu z-Riv-7kt`ieMAcJTaei>ejdsPZELt$G}hr^Y{qo_0yp3cF2lPc%)&6=S%Mm`bjLd| zfa5kdz8AT!*ShK4!HMT_9ln7TcoCa0B+{%5+fXwdLY*&&@}ED7%-JS!Jzl~L)YX?l zCYED9#$%WBMGWHp_7sd zOEEUaY&kZfe!m}i2J6OX?r$g5!2#sYhWOAIMlb|FM%{1%m*6Dk;diK%&SNm%!fXtT zHLJnZSd2Z+4^ZcSLQOO@j{IlRDW+46ZP<+O;~JbtEloBbDu+_12Xi^DN2RnE*Wv(b zDaKI~I**C?6>?9zifQ;e-itBuO#aFx5T6_ujns0{QwPr37FaUrJ}1sUFcop+BSj(cpkMBf8Z*d zL+zSmoySS?#77do zgetnT&i7Cg7)DLt0xBcZs3p6BO8H-?OvH1MU$GqZfZkjldw@;}-h*G_X8aRbCM)FX z>?o^t?nI5ZyW?I|5%wbmZzoX~K8^a`IV{6ZP${3q2e6DZQFC5+Orh4MmB)S% zhf&3J6SY0(P!p^okD5>qHlP>DrhSX7hE1b>H;+ef0h{qiDlapfM3Q04NK1|Oe=eN} z29BYM>N(T}UPe990P4MP2Dz5~fQ>kdx}k^lV%4k#Rpn1QPdeXreu&DbMb=+GaQ2i5odShSaHzplW6kwKR#8x?V5` zP`l4s|w{Z5l@Aa)T?5nipY+Fn8_Ri*DEA_=Xno>uK~KlU)*Pb?+0 zkGZdJdmcfxr->Ru>#tTvu(N#+p<_MVaiWok(EiufNhL~&{e%ie)!IsIC)AXQL}DAE zEm=#15Q|Nz;d@bH7C}!XG zYQi`T(87o=qMA5LB#-un7X=J1q!f(KM9fD8b+va4)+Z&6#wJ}499>8$j2ZOg{rw+? CBKHCS delta 2777 zcmZY9e@vBC9LMo5_oDm~Q~U{GQHnu`iu@7~fo`a!VyOZCf>1AEfE6Nvx^CK5SWW++ zTH#`)&6?rb;t#X_z_v2mnz+WYvXM1&G}mg*GBaE6&vQ?W)!F^t*Lj}%+~=I<`#tCR zWZm)gp`nDx7mc=yNGAUDo4twOMDayyk2M>M9k>NMaXMbce4HF-b`w@$4AwXs-1!!F zyayxr{dsqOAI6)7tcQ*U=*0>60cPU>mY{!(StSN=0d}Kid=~Y4Gk4MNN0GT(Bsa^& zXq!+hX4&qY$5({w#kClV9I0;`s-QWo7NrzE4zKlM+?vDS$ z*&IiWGnZ)PUD z{u=7KZ0e&76{9j4aIQp6pbpcp9#xY4xESA>ME;ecUpS#mOOwbvq1ZQ3LTYT zHLkz|s6}`QJ28vLSFPU1`_M=Jw76EGwrdq?qK8luJA=z`2+6i(q=dI!0QJAM*o-w; z&G_~ioh6(|B`;*nwxTA~iE%i9T4d)?H~0bdWItjdUPH#R9O|_kS0l^A4x$#@an!2+ z+v5~@b&sDZOk0~h0LT#OOehN@{hGPXT|0elVf@dD;yGOxcBT!rb_ z>W+I**Y{(nnvOp;yja#_3dc{P27Vnik+)Hc@))vF?0YQ6-_ehGGsD}g5S8*0)OA(J zCDx3}R2OP7pLXYeno0h(jV7=+wEB}#`#lqR2rEPuiPc~%9>7s}*d6zxQhUsu{}c;2 z9zbp57?!x!Oe(50ZK(InN631&t7+taBb@~DqX}$BJ;BqMi#@1;2a$5wx2Tl+NQWjk z19g50mSH1mF&;&g>}%}8n2fNmq9&ZhMI{&r(b3|03U%W{$Qbsq^Jmm{Nz4rI_e|72 zpNpz>09DJKI2!vg9#7&N9K;-qWHu4_Ph0Fdp-MV>;*m{%SVBBL;-t!;nK!s|Tbz{A zd*^54CW85Twcd(qRKm-Uve`;(Cmtjg5wwu4<@+H*3q?<&r&rTf)Z$ZC))0>pD~WA{ zGTsu*bO|%orp2q*Tu^X(3P&w36h!#RSgqN1rw6C>Z zN(tUiUW?+p+4ae`SNHY!7@=K2$-Po&>WfsQAVgeKty^y79lPpiilP2+<(!o$Ra{9BYp|e?-+6X2>p8r?Tqox~lYMbgd2Aj6kHZ`ZE8~v_75|jE)B%b$mHO3Y94J7-\n" "Language-Team: LANGUAGE \n" @@ -241,27 +241,6 @@ msgstr "" msgid "Linear model" msgstr "" -msgid "Package 'data.io' is required but not installed." -msgstr "" - -msgid "labs is not character vector" -msgstr "" - -msgid "labs must be named character vector" -msgstr "" - -msgid "all element must be named" -msgstr "" - -msgid "The following terms are missing in 'labs' for the interaction '%s': %s" -msgstr "" - -msgid "," -msgstr "" - -msgid "The 'equation' argument must be TRUE, FALSE, NA, or a character string." -msgstr "" - msgid "Residuals range: [%.*g, %.*g]" msgstr "" @@ -280,21 +259,6 @@ msgstr "" msgid ".extract_infos_lm() cannot apply type = 'coef' to a summary.lm\n object. Use type = 'tidy' instead to extract a detailed coefficient table." msgstr "" -msgid "Not implemented yet" -msgstr "" - -msgid "Function `%s` supports only flextable objects." -msgstr "" - -msgid ".add_signif_stars()" -msgstr "" - -msgid ".add_header2()" -msgstr "" - -msgid ".add_colnames()" -msgstr "" - msgid "`x` must be an object of class 'nls' or 'summary.nls'." msgstr "" @@ -376,8 +340,38 @@ msgstr "" msgid ".extract_infos_nls() cannot apply type = 'glance' to a summary.nls\n object." msgstr "" -msgid "header_labels_lm()" +msgid "Package 'data.io' is required but not installed." +msgstr "" + +msgid "labs is not character vector" +msgstr "" + +msgid "labs must be named character vector" +msgstr "" + +msgid "all element must be named" +msgstr "" + +msgid "The following terms are missing in 'labs' for the interaction '%s': %s" +msgstr "" + +msgid "," msgstr "" -msgid ".add_header()" +msgid "The 'equation' argument must be TRUE, FALSE, NA, or a character string." +msgstr "" + +msgid "Not implemented yet" +msgstr "" + +msgid "Function `%s` supports only flextable objects." +msgstr "" + +msgid ".add_signif_stars()" +msgstr "" + +msgid ".add_header2()" +msgstr "" + +msgid ".add_colnames()" msgstr "" From b334a33b1705efe219629590266396faeff0bcb3 Mon Sep 17 00:00:00 2001 From: Guyliann Engels Date: Wed, 20 Aug 2025 14:43:56 +0200 Subject: [PATCH 21/22] Replace eval_data_dot() bu prepare_data_dot() and recall_with_data_dot() --- NAMESPACE | 3 ++- R/lm_.R | 35 ++++++++++++++--------------------- R/modelit-package.R | 2 +- man/glm_.Rd | 4 ++-- man/lm_.Rd | 2 +- man/nls_.Rd | 2 +- 6 files changed, 21 insertions(+), 27 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index e475cca..de244fe 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -132,10 +132,11 @@ importFrom(stats,rstandard) importFrom(stats,variable.names) importFrom(stats,vcov) importFrom(svFlow,"%>.%") -importFrom(svMisc,eval_data_dot) importFrom(svMisc,gettext_) importFrom(svMisc,gettextf_) importFrom(svMisc,ngettext_) +importFrom(svMisc,prepare_data_dot) +importFrom(svMisc,recall_with_data_dot) importFrom(svMisc,stop_) importFrom(svMisc,warning_) importFrom(tabularise,colformat_sci) diff --git a/R/lm_.R b/R/lm_.R index 628d7d3..4418f19 100644 --- a/R/lm_.R +++ b/R/lm_.R @@ -4,7 +4,7 @@ #' `lm_()` is an **experimental** wrapper around the base [stats::lm()] function. #' It behaves similarly to `lm()`, but enriches the returned object with additional metadata. #' The order of the arguments differs from `lm()`, and the function uses evaluation -#' through [svMisc::eval_data_dot()] to support flexible data referencing. +#' through [svMisc::prepare_data_dot] and [svMisc::recall_with_data_dot] to support flexible data referencing. #' #' @param data A `data.frame` containing the variables in the model. #' @param formula An object of class `formula`: a symbolic description of the model to be fitted. @@ -26,6 +26,10 @@ #' # Fit the model using lm_() #' res <- lm_(iris, formula = Petal.Length ~ Sepal.Length + Species) #' +#' . <- iris +#' res1 <- lm_(Petal.Length ~ Sepal.Length + Species) +#' +#' #' res #' class(res) #' summary(res) @@ -35,12 +39,8 @@ #' lm_ <- function(data = (.), formula, ..., .data = data) { - .__top_call__. <- TRUE - - # Implicit data-dot mechanism - if (missing(data) || !is.data.frame(data)) - return(svMisc::eval_data_dot(sys.call(), arg = 'data', abort_msg = - gettext("`data` must be a `data.frame`."))) + if (!prepare_data_dot(data)) + return(recall_with_data_dot(arg = "data")) res <- stats::lm(data = data, formula = formula, ...) @@ -173,8 +173,8 @@ anova.lm_ <- function(object, ...) { #' `glm_()` is an **experimental** wrapper around the base [stats::glm()] #' function. It behaves similarly to `glm()`, but enriches the returned object #' with additional metadata. The order of the arguments differs from `glm()`, -#' and the function uses evaluation through [svMisc::eval_data_dot()] to support -#' flexible data referencing. +#' and the function uses evaluation through [svMisc::prepare_data_dot] and +#' [svMisc::recall_with_data_dot] to support flexible data referencing. #' #' @param data A `data.frame` containing the variables in the model. #' @param formula An object of class `formula`: a symbolic description of the @@ -207,12 +207,9 @@ anova.lm_ <- function(object, ...) { #' glm_ <- function(data = (.), formula, ..., .data = data) { - .__top_call__. <- TRUE - # Implicit data-dot mechanism - if (missing(data) || !is.data.frame(data)) - return(svMisc::eval_data_dot(sys.call(), arg = 'data', abort_msg = - gettext("`data` must be a `data.frame`."))) + if (!prepare_data_dot(data)) + return(recall_with_data_dot(arg = "data")) res <- stats::glm(data = data, formula = formula, ...) @@ -240,7 +237,7 @@ glm_ <- function(data = (.), formula, ..., .data = data) { #' `nls_()` is an **experimental** wrapper around the base [stats::nls()] #' function. It behaves similarly to `glm()`, but enriches the returned object #' with additional metadata. The order of the arguments differs from `glm()`, -#' and the function uses evaluation through [svMisc::eval_data_dot()] to support +#' and the function uses evaluation through [svMisc::recall_with_data_dot()] to support #' flexible data referencing. #' #' @param data A `data.frame` containing the variables in the model. @@ -275,12 +272,8 @@ glm_ <- function(data = (.), formula, ..., .data = data) { #' nls_ <- function(data = (.), formula, model = TRUE, ..., .data = data) { - .__top_call__. <- TRUE - - # Implicit data-dot mechanism - if (missing(data) || !is.data.frame(data)) - return(svMisc::eval_data_dot(sys.call(), arg = 'data', abort_msg = - gettext("`data` must be a `data.frame`."))) + if (!prepare_data_dot(data)) + return(recall_with_data_dot(arg = "data")) res <- stats::nls(data = data, formula = formula, model = model, ...) diff --git a/R/modelit-package.R b/R/modelit-package.R index be861ba..2167134 100644 --- a/R/modelit-package.R +++ b/R/modelit-package.R @@ -30,7 +30,7 @@ #' @importFrom stats AIC anova BIC coef confint cooks.distance deviance family fitted formula hatvalues nobs predict residuals rstandard variable.names vcov #' @importFrom stats coef pf #' @importFrom svFlow %>.% -#' @importFrom svMisc gettext_ gettextf_ ngettext_ stop_ warning_ eval_data_dot +#' @importFrom svMisc gettext_ gettextf_ ngettext_ stop_ warning_ prepare_data_dot recall_with_data_dot #' @importFrom tabularise colformat_sci equation para_md ## usethis namespace: end "_PACKAGE" diff --git a/man/glm_.Rd b/man/glm_.Rd index 7072a25..d2ac606 100644 --- a/man/glm_.Rd +++ b/man/glm_.Rd @@ -25,8 +25,8 @@ added, a standard \code{glm} object is returned. \code{glm_()} is an \strong{experimental} wrapper around the base \code{\link[stats:glm]{stats::glm()}} function. It behaves similarly to \code{glm()}, but enriches the returned object with additional metadata. The order of the arguments differs from \code{glm()}, -and the function uses evaluation through \code{\link[svMisc:eval_data_dot]{svMisc::eval_data_dot()}} to support -flexible data referencing. +and the function uses evaluation through \link[svMisc:prepare_data_dot]{svMisc::prepare_data_dot} and +\link[svMisc:prepare_data_dot]{svMisc::recall_with_data_dot} to support flexible data referencing. } \examples{ data(iris) diff --git a/man/lm_.Rd b/man/lm_.Rd index 990bbfd..9062150 100644 --- a/man/lm_.Rd +++ b/man/lm_.Rd @@ -23,7 +23,7 @@ components such as \code{labels}. If no additional attributes are added, a stand \code{lm_()} is an \strong{experimental} wrapper around the base \code{\link[stats:lm]{stats::lm()}} function. It behaves similarly to \code{lm()}, but enriches the returned object with additional metadata. The order of the arguments differs from \code{lm()}, and the function uses evaluation -through \code{\link[svMisc:eval_data_dot]{svMisc::eval_data_dot()}} to support flexible data referencing. +through \link[svMisc:prepare_data_dot]{svMisc::prepare_data_dot} and \link[svMisc:prepare_data_dot]{svMisc::recall_with_data_dot} to support flexible data referencing. } \examples{ data(iris) diff --git a/man/nls_.Rd b/man/nls_.Rd index 4605d5c..3963a56 100644 --- a/man/nls_.Rd +++ b/man/nls_.Rd @@ -28,7 +28,7 @@ added, a standard \code{nls} object is returned. \code{nls_()} is an \strong{experimental} wrapper around the base \code{\link[stats:nls]{stats::nls()}} function. It behaves similarly to \code{glm()}, but enriches the returned object with additional metadata. The order of the arguments differs from \code{glm()}, -and the function uses evaluation through \code{\link[svMisc:eval_data_dot]{svMisc::eval_data_dot()}} to support +and the function uses evaluation through \code{\link[svMisc:prepare_data_dot]{svMisc::recall_with_data_dot()}} to support flexible data referencing. } \examples{ From a1a4e613011c25eeaf64ce0334e7a24badab415a Mon Sep 17 00:00:00 2001 From: Philippe Grosjean Date: Thu, 28 Aug 2025 02:52:57 +0200 Subject: [PATCH 22/22] Adaptation to changes in data.io/svBase/svMisc/equatiomatic/tabularise --- DESCRIPTION | 11 +- NAMESPACE | 19 +- NEWS.md | 2 + R/chart.lm.R | 4 +- R/chart.nls.R | 4 +- R/lm_.R | 10 +- R/{utils.R => modelit-internal.R} | 132 ++++++------ R/modelit-package.R | 8 +- R/tabularise.anova.R | 48 ++--- R/tabularise.glm.R | 257 ++++++++++++----------- R/tabularise.lm.R | 171 ++++++++------- R/tabularise.nls.R | 146 ++++++------- README.Rmd | 26 ++- README.md | 16 +- inst/CITATION | 35 ++- inst/WORDLIST | 4 + man/chart.lm.Rd | 4 +- man/chart.nls.Rd | 4 +- man/equation.nls.Rd | 2 +- man/figures/README-unnamed-chunk-7-1.png | Bin 36834 -> 36869 bytes man/glm_.Rd | 4 +- man/lm_.Rd | 6 +- man/modelit-package.Rd | 2 +- man/nls_.Rd | 4 +- man/tabularise_coef.glm.Rd | 6 +- man/tabularise_coef.lm.Rd | 6 +- man/tabularise_coef.nls.Rd | 4 +- man/tabularise_coef.summary.glm.Rd | 4 +- man/tabularise_coef.summary.lm.Rd | 4 +- man/tabularise_coef.summary.nls.Rd | 4 +- man/tabularise_default.anova.Rd | 4 +- man/tabularise_default.glm.Rd | 4 +- man/tabularise_default.nls.Rd | 4 +- man/tabularise_default.summary.glm.Rd | 4 +- man/tabularise_default.summary.nls.Rd | 6 +- man/tabularise_glance.glm.Rd | 6 +- man/tabularise_glance.lm.Rd | 6 +- man/tabularise_glance.nls.Rd | 4 +- man/tabularise_tidy.glm.Rd | 6 +- man/tabularise_tidy.lm.Rd | 6 +- man/tabularise_tidy.nls.Rd | 4 +- vignettes/modelit.R | 4 +- vignettes/modelit.Rmd | 8 +- 43 files changed, 504 insertions(+), 509 deletions(-) rename R/{utils.R => modelit-internal.R} (79%) diff --git a/DESCRIPTION b/DESCRIPTION index c807946..0feb734 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: modelit Type: Package Version: 1.4.8 -Title: Statistical Models for 'SciViews::R' +Title: 'SciViews::R' - Statistical Models Description: Create and use statistical models (linear, general, nonlinear...) with extensions to support rich-formatted tables, equations and plots for the 'SciViews::R' dialect. @@ -18,7 +18,7 @@ Depends: broom (>= 1.0.4) Imports: chart (>= 1.5.0), - data.io (>= 1.5.0), + equatiomatic (>= 0.4.4), flextable (>= 0.9.1), generics (>= 0.1.3), ggplot2 (>= 3.4.2), @@ -27,22 +27,23 @@ Imports: officer (>= 0.6.2), rlang (>= 1.1.1), stats (>= 4.2.0), + svBase (>= 1.7.0), svFlow (>= 1.2.0), - svMisc, tabularise (>= 0.6.0) Suggests: + data.io (>= 1.7.0), broom.mixed (>= 0.2.9.4), datasets (>= 4.2.0), dplyr (>= 1.1.4), equatags (>= 0.2.0), - equatiomatic (>= 0.3.0), parsnip (>= 1.1.0), rmarkdown (>= 2.21), spelling (>= 2.2.1), testthat (>= 3.0.0) Remotes: - SciViews/data.io, SciViews/chart, + SciViews/data.io, + SciViews/svBase, SciViews/svFlow, SciViews/tabularise License: MIT + file LICENSE diff --git a/NAMESPACE b/NAMESPACE index de244fe..ffe6758 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -71,7 +71,7 @@ importFrom(broom,glance) importFrom(broom,tidy) importFrom(chart,chart) importFrom(chart,combine_charts) -importFrom(data.io,label) +importFrom(equatiomatic,equation) importFrom(flextable,add_footer_lines) importFrom(flextable,add_header_lines) importFrom(flextable,align) @@ -131,17 +131,18 @@ importFrom(stats,residuals) importFrom(stats,rstandard) importFrom(stats,variable.names) importFrom(stats,vcov) +importFrom(svBase,gettext_) +importFrom(svBase,gettextf_) +importFrom(svBase,label) +importFrom(svBase,ngettext_) +importFrom(svBase,prepare_data_dot) +importFrom(svBase,recall_with_data_dot) +importFrom(svBase,stop_) +importFrom(svBase,warning_) importFrom(svFlow,"%>.%") -importFrom(svMisc,gettext_) -importFrom(svMisc,gettextf_) -importFrom(svMisc,ngettext_) -importFrom(svMisc,prepare_data_dot) -importFrom(svMisc,recall_with_data_dot) -importFrom(svMisc,stop_) -importFrom(svMisc,warning_) importFrom(tabularise,colformat_sci) -importFrom(tabularise,equation) importFrom(tabularise,para_md) +importFrom(tabularise,tabularise) importFrom(tabularise,tabularise_coef) importFrom(tabularise,tabularise_default) importFrom(tabularise,tabularise_glance) diff --git a/NEWS.md b/NEWS.md index 68c3117..d4daf2f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # modelit 1.4.8 +- Dependency to svBase and equatiomatic updated, and dependencies to data.io and svMisc eliminated. + - Refactored all tabularise\_\*\*\*() methods for glm, summary.glm, anova, aov objects (e.g., tabularise_glance.glm(), tabularise_default.glm(), tabularise_tidy.glm(), etc.) to improve internal consistency and prepare for multi-format table rendering using {flextable}, {tinytable}, and {gt}. - added summary\_() and anova\_() functions. These two functions provide the same information as the summary() and anova() functions. They add an attribute that preserves a link to the object used in these two functions. Adding this argument makes it possible to retrieve information from the original object that would otherwise be lost when using summary() or anova(). diff --git a/R/chart.lm.R b/R/chart.lm.R index 49a1f59..18ff023 100644 --- a/R/chart.lm.R +++ b/R/chart.lm.R @@ -65,7 +65,7 @@ #' chart(trees_lm5, origdata = trees) # origdata required here! chart.lm <- function(data, type = "model", ..., origdata = NULL, title, labels = "AUTO", name = deparse(substitute(data)), -lang = getOption("data.io_lang", "en"), env = parent.frame()) { +lang = getOption("SciViews_lang", "en"), env = parent.frame()) { if (type == "residuals") { a <- autoplot.lm(data, ..., name = name, type = "resfitted", title = "", lang = lang, env = env) @@ -95,7 +95,7 @@ autoplot.lm <- function(object, origdata = NULL, type = c("model", "resfitted", "qqplot", "scalelocation", "cooksd", "resleverage", "cookleverage", "reshist", "resautocor"), title, xlab, ylab, ..., name = deparse(substitute(object)), -lang = getOption("data.io_lang", "en"), env = parent.frame()) { +lang = getOption("SciViews_lang", "en"), env = parent.frame()) { # TODO: chart style if invoked via chart(), otherwise default ggplot theme # TODO: lindia::resx() but several plots for more complex formulas and one # could question the validity of this plot as the distrubition of residuals diff --git a/R/chart.nls.R b/R/chart.nls.R index f22b838..9b466db 100644 --- a/R/chart.nls.R +++ b/R/chart.nls.R @@ -50,7 +50,7 @@ #' # The four most important residual analysis plots in one figure #' chart$residuals(chick1_logis) chart.nls <- function(data, type = "model", ..., title, labels = "AUTO", -name = deparse(substitute(data)), lang = getOption("data.io_lang", "en"), +name = deparse(substitute(data)), lang = getOption("SciViews_lang", "en"), env = parent.frame()) { if (type == "residuals") { a <- autoplot.nls(data, ..., name = name, type = "resfitted", @@ -79,7 +79,7 @@ class(chart.nls) <- c("function", "subsettable_type") autoplot.nls <- function(object, type = c("model", "resfitted", "qqplot", "scalelocation", "reshist", "resautocor"), title, xlab, ylab, ..., name = deparse(substitute(object)), - lang = getOption("data.io_lang", "en"), env = parent.frame()) { + lang = getOption("SciViews_lang", "en"), env = parent.frame()) { # TODO: chart style if invoked via chart(), otherwise default ggplot theme # Needed to avoid spurious R CMD check errors diff --git a/R/lm_.R b/R/lm_.R index 4418f19..2d41236 100644 --- a/R/lm_.R +++ b/R/lm_.R @@ -4,7 +4,7 @@ #' `lm_()` is an **experimental** wrapper around the base [stats::lm()] function. #' It behaves similarly to `lm()`, but enriches the returned object with additional metadata. #' The order of the arguments differs from `lm()`, and the function uses evaluation -#' through [svMisc::prepare_data_dot] and [svMisc::recall_with_data_dot] to support flexible data referencing. +#' through [svBase::prepare_data_dot] and [svBase::recall_with_data_dot] to support the data-dot mechanism. #' #' @param data A `data.frame` containing the variables in the model. #' @param formula An object of class `formula`: a symbolic description of the model to be fitted. @@ -173,8 +173,8 @@ anova.lm_ <- function(object, ...) { #' `glm_()` is an **experimental** wrapper around the base [stats::glm()] #' function. It behaves similarly to `glm()`, but enriches the returned object #' with additional metadata. The order of the arguments differs from `glm()`, -#' and the function uses evaluation through [svMisc::prepare_data_dot] and -#' [svMisc::recall_with_data_dot] to support flexible data referencing. +#' and the function uses evaluation through [svBase::prepare_data_dot] and +#' [svBase::recall_with_data_dot] to support the data-dot mechanism. #' #' @param data A `data.frame` containing the variables in the model. #' @param formula An object of class `formula`: a symbolic description of the @@ -237,8 +237,8 @@ glm_ <- function(data = (.), formula, ..., .data = data) { #' `nls_()` is an **experimental** wrapper around the base [stats::nls()] #' function. It behaves similarly to `glm()`, but enriches the returned object #' with additional metadata. The order of the arguments differs from `glm()`, -#' and the function uses evaluation through [svMisc::recall_with_data_dot()] to support -#' flexible data referencing. +#' and the function uses evaluation through [svBase::recall_with_data_dot()] to support +#' the data-dot mechanism. #' #' @param data A `data.frame` containing the variables in the model. #' @param formula An object of class `formula`: a symbolic description of the diff --git a/R/utils.R b/R/modelit-internal.R similarity index 79% rename from R/utils.R rename to R/modelit-internal.R index 4642184..71df990 100644 --- a/R/utils.R +++ b/R/modelit-internal.R @@ -1,19 +1,18 @@ # gettext(), stop(), warning() -gettext <- svMisc::gettext_ -gettextf <- svMisc::gettextf_ -ngettext <- svMisc::ngettext_ -# stop <- svMisc::stop_ # -# warning <- svMisc::warning_ +gettext <- svBase::gettext_ +gettextf <- svBase::gettextf_ +ngettext <- svBase::ngettext_ +# stop <- svBase::stop_ # +# warning <- svBase::warning_ # Need this for R CMD check to pass . <- NULL # Internal functions for .extract_infos_***() .pvalue_format <- function(x, breaks = c(-Inf, 0.001, 0.01, 0.05, 0.1, Inf), - labels = c("***", " **", " *", " .", " ")) { + labels = c("***", " **", " *", " .", " ")) { #x <- get(as.character(substitute(x)), inherits = TRUE) - z <- cut(x, breaks = breaks, - labels = labels) + z <- cut(x, breaks = breaks, labels = labels) z <- as.character(z) z[is.na(x)] <- "" z @@ -43,13 +42,15 @@ ngettext <- svMisc::ngettext_ return(NULL) } - if (!requireNamespace("data.io", quietly = TRUE)) { - stop("Package 'data.io' is required but not installed.") - } + # Not needed anymore + #if (!requireNamespace("data.io", quietly = TRUE)) + # stop("Package 'data.io' is required but not installed.") + #class(df) df <- as.data.frame(df) #class(df) - labels <- vapply(df[,factor_cols, drop = FALSE], data.io::label, character(1), units = FALSE) + labels <- vapply(df[,factor_cols, drop = FALSE], svBase::label, character(1), + units = FALSE) valid_vars <- names(labels)[labels != ""] if (length(valid_vars) == 0) { #warning("No labeled factor variables found.") @@ -70,12 +71,12 @@ ngettext <- svMisc::ngettext_ return(result) } -.labels3 <- function (x, origdata = NULL, labs = NULL) { +.labels3 <- function(x, origdata = NULL, labs = NULL) { if (is.null(origdata)) { - labs_auto <- c(tabularise:::.labels(x$model), .labels_factor(x$model)) + labs_auto <- c(.labels(x$model), .labels_factor(x$model)) } else { - labs_auto <- c(tabularise:::.labels(origdata), .labels_factor(origdata)) + labs_auto <- c(.labels(origdata), .labels_factor(origdata)) } if (!is.null(labs)) { if (!is.character(labs)) @@ -84,8 +85,7 @@ ngettext <- svMisc::ngettext_ stop("labs must be named character vector") if (any(names(labs) %in% "")) stop("all element must be named") - labs_res <- c(labs, labs_auto[!names(labs_auto) %in% - names(labs)]) + labs_res <- c(labs, labs_auto[!names(labs_auto) %in% names(labs)]) } else { labs_res <- labs_auto @@ -93,6 +93,26 @@ ngettext <- svMisc::ngettext_ labs_res } +# Extract labels and units +.labels <- function(x, units = TRUE, ...) { + labels <- sapply(x, svBase::label, units = units) + if (any(labels != "")) { + # Use a \n before labels and the units + if (isTRUE(units)) + labels <- sub(" +\\[([^]]+)\\]$", "\n [\\1]", labels) + + # set names if empty + labels[labels == ""] <- names(x)[labels == ""] + # Specific case for I() using in a formula + labels[grepl("^I\\(.*\\)$", names(labels))] <- + names(labels)[grepl("^I\\(.*\\)$", names(labels))] + } + if (all(labels == "")) + labels <- NULL + + labels +} + .extend_labs_with_interactions <- function(labs, terms) { if (!is.character(labs) || is.null(names(labs))) { return(NULL) @@ -138,11 +158,11 @@ ngettext <- svMisc::ngettext_ vals <- df[["term"]] terms <- labs[names(labs) %in% vals] - if(any(vals == "(Intercept)")) - terms <- c("(Intercept)"= gettext("Intercept", lang = lang)[[1]], terms) + if (any(vals == "(Intercept)")) + terms <- c("(Intercept)" = gettext("Intercept", lang = lang)[[1]], terms) - if(any(vals == "Residuals")) - terms <- c(terms, "Residuals"= gettext("Residuals", lang = lang)[[1]]) + if (any(vals == "Residuals")) + terms <- c(terms, "Residuals" = gettext("Residuals", lang = lang)[[1]]) terms } @@ -158,9 +178,9 @@ ngettext <- svMisc::ngettext_ if (isTRUE(equation) || is.na(equation)) { equa <- try({ if (!is.null(labs)) { - tabularise::equation(data, swap_var_names = labs, ...) + equation(data, swap_var_names = labs, ...) } else { - tabularise::equation(data, auto.labs = FALSE, ...) + equation(data, auto.labs = FALSE, ...) } }, silent = TRUE) if (inherits(equa, "try-error")) @@ -225,7 +245,7 @@ ngettext <- svMisc::ngettext_ if (!is.null(x$terms)) { vec <- x$terms - if(is.character(vec) && !is.null(names(vec)) && all(nzchar(names(vec)))) { + if (is.character(vec) && !is.null(names(vec)) && all(nzchar(names(vec)))) { ft <- .add_labs(ft, vec) } else { ft <- .add_params(ft, vec) @@ -262,16 +282,10 @@ ngettext <- svMisc::ngettext_ format_table <- function(df, kind, header) { switch(kind, - df = {df}, - tt = { - stop("Not implemented yet") - }, - ft = { - .create_flextable(df, header = header) - }, - gt = { - stop("Not implemented yet") - } + df = df, + tt = stop("Not implemented yet"), + ft = .create_flextable(df, header = header), + gt = stop("Not implemented yet") ) } @@ -279,13 +293,12 @@ format_table <- function(df, kind, header) { if (!inherits(x, "flextable")) { stop(sprintf("Function `%s` supports only flextable objects.", - ".add_signif_stars()"))} + ".add_signif_stars()"))} ft <- x s <- signif - ft <- add_footer_lines(ft, - values = s) + ft <- add_footer_lines(ft, values = s) align(ft, i = 1, align = "right", part = "footer") } @@ -293,19 +306,17 @@ format_table <- function(df, kind, header) { if (!inherits(x, "flextable")) { stop(sprintf("Function `%s` supports only flextable objects.", - ".add_header2()")) } + ".add_header2()")) } ft <- x if (is.character(equation)) { - ft <- add_header_lines(ft, - values = as_paragraph(as_equation(equation))) + ft <- add_header_lines(ft, values = as_paragraph(as_equation(equation))) ft <- align(ft, i = 1, align = "center", part = "header") } if (is.character(title)) { - ft <- add_header_lines(ft, - values = as_paragraph(title)) + ft <- add_header_lines(ft, values = as_paragraph(title)) ft <- align(ft, i = 1, align = "center", part = "header") } @@ -315,8 +326,8 @@ format_table <- function(df, kind, header) { ft |> border_inner_h(border = officer::fp_border(width = 0), part = "header") |> hline(i = nrow_part(ft, "header") - 1, - border = officer::fp_border(width = 1.5, color = "#666666"), - part = "header") -> + border = officer::fp_border(width = 1.5, color = "#666666"), + part = "header") -> ft } @@ -327,13 +338,13 @@ format_table <- function(df, kind, header) { if (!inherits(x, "flextable")) { stop(sprintf("Function `%s` supports only flextable objects.", - ".add_colnames()")) } + ".add_colnames()")) } ft <- x for (i in seq_along(labs)) ft <- mk_par(ft, i = 1, j = names(labs)[i], - value = para_md(labs[i]), part = "header") + value = para_md(labs[i]), part = "header") ft } @@ -341,15 +352,15 @@ format_table <- function(df, kind, header) { .add_labs <- function(x, labs) { if (!inherits(x, "flextable")) { stop(sprintf("Function `%s` supports only flextable objects.", - ".add_colnames()")) } + ".add_colnames()")) } ft <- x - labs_red <- labs[names(labs) %in%ft$body$dataset$term] + labs_red <- labs[names(labs) %in% ft$body$dataset$term] for (i in seq_along(labs_red)) ft <- mk_par(ft, i = names(labs_red)[i], j = "term", - value = para_md(labs_red[i]), part = "body") + value = para_md(labs_red[i]), part = "body") ft } @@ -358,7 +369,7 @@ format_table <- function(df, kind, header) { if (!inherits(x, "flextable")) { stop(sprintf("Function `%s` supports only flextable objects.", - ".add_colnames()")) } + ".add_colnames()")) } ft <- x @@ -395,26 +406,7 @@ format_table <- function(df, kind, header) { # } # # # TODO: this is duplicated in tabularise -> export from there and reuse here! -# # Extract labels and units -# # .labels <- function(x, units = TRUE, ...) { -# # labels <- sapply(x, data.io::label, units = units) -# # -# # if (any(labels != "")) { -# # # Use a \n before labels and the units -# # if (isTRUE(units)) -# # labels <- sub(" +\\[([^]]+)\\]$", "\n [\\1]", labels) -# # # set names if empty -# # labels[labels == ""] <- names(x)[labels == ""] -# # # Specific case for I() using in a formula -# # labels[grepl("^I\\(.*\\)$", names(labels))] <- names(labels)[grepl("^I\\(.*\\)$", names(labels))] -# # } -# # -# # if (all(labels == "")) -# # labels <- NULL -# # -# # labels -# # } -# + # # .labels2 <- function(x, origdata = NULL, labs = NULL) { # # # # #labs_auto <- NULL diff --git a/R/modelit-package.R b/R/modelit-package.R index 2167134..399ad07 100644 --- a/R/modelit-package.R +++ b/R/modelit-package.R @@ -1,4 +1,4 @@ -#' Statistical Models for 'SciViews::R' +#' 'SciViews::R' - Statistical Models #' #' The \{modelit\} package provides an extension to base R functions for model #' fitting like [lm()], [glm()] or [nls()] with enhanced plots and utilitarian @@ -19,7 +19,6 @@ ## usethis namespace: start #' @importFrom broom augment glance tidy #' @importFrom chart chart combine_charts -#' @importFrom data.io label #' @importFrom flextable add_footer_lines add_header_lines align as_equation #' @importFrom flextable as_paragraph autofit border_inner_h flextable #' @importFrom flextable hline italic mk_par ncol_keys nrow_part width @@ -30,7 +29,8 @@ #' @importFrom stats AIC anova BIC coef confint cooks.distance deviance family fitted formula hatvalues nobs predict residuals rstandard variable.names vcov #' @importFrom stats coef pf #' @importFrom svFlow %>.% -#' @importFrom svMisc gettext_ gettextf_ ngettext_ stop_ warning_ prepare_data_dot recall_with_data_dot -#' @importFrom tabularise colformat_sci equation para_md +#' @importFrom svBase label gettext_ gettextf_ ngettext_ stop_ warning_ prepare_data_dot recall_with_data_dot +#' @importFrom tabularise colformat_sci para_md tabularise +#' @importFrom equatiomatic equation ## usethis namespace: end "_PACKAGE" diff --git a/R/tabularise.anova.R b/R/tabularise.anova.R index 9f87295..e5fd7b4 100644 --- a/R/tabularise.anova.R +++ b/R/tabularise.anova.R @@ -12,7 +12,7 @@ #' @param labs Labels to change the default names in the `term` column of the #' table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value is set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is taken from `getOption("show.signif.stars")`. #' @param ... Additional arguments (not used for now) @@ -46,9 +46,9 @@ #' anova_(is_lm1, is_lm2) |> tabularise() #' tabularise_default.anova <- function(data, header = TRUE, title = header, -auto.labs = TRUE, origdata = NULL, labs = NULL, -lang = getOption("data.io_lang", "en"), -show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { + auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("SciViews_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -63,7 +63,7 @@ show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { origdata = origdata, labs = labs, title = title, colnames = colnames_anova) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -128,7 +128,7 @@ tabularise_tidy.aov <- function(data, ...) { tabularise_default.anova(anova_(data), ...) } -# A list of internals functions and objects ------ +# A list of internals functions and objects colnames_anova <- c( term = "Term", @@ -189,9 +189,10 @@ colnames_anova <- c( # See utils.R for internal functions used by various .extract_infos_*** # -.extract_infos_anova <- function(data, show.signif.stars = getOption("show.signif.stars", TRUE), - lang = "en", auto.labs = TRUE, origdata = NULL , labs = NULL, - title = TRUE, colnames = colnames_anova, ...) { +.extract_infos_anova <- function(data, + show.signif.stars = getOption("show.signif.stars", TRUE), + lang = "en", auto.labs = TRUE, origdata = NULL , labs = NULL, + title = TRUE, colnames = colnames_anova, ...) { if (!inherits(data, c("anova"))) stop(".extract_infos_anova() can apply only anova object.") @@ -202,19 +203,18 @@ colnames_anova <- c( # statistic variable has 3 possible signification: "F value", "F", "Chisq" statistic_cols <- c("F value", "F", "Chisq") - names(df)[names(df) == "statistic"] <- statistic_cols[statistic_cols %in% names(data)][1] + names(df)[names(df) == "statistic"] <- + statistic_cols[statistic_cols %in% names(data)][1] # the term variable - if (grepl("^Model", attr(data, "heading")[2])) { + if (grepl("^Model", attr(data, "heading")[2])) names(df)[names(df) == "term"] <- "model" - } - if (isTRUE(show.signif.stars)) { + if (isTRUE(show.signif.stars)) df$signif <- .pvalue_format(df$p.value) - } # psignif - if(isTRUE(show.signif.stars)) { + if (isTRUE(show.signif.stars)) { psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" } else { psignif <- NULL @@ -227,11 +227,11 @@ colnames_anova <- c( if (is.null(data_obj)) { labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) } else { labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, - origdata = origdata, labs = labs) - } + origdata = origdata, labs = labs) + } if (is.null(df[["term"]])) { if (isTRUE(title)) { @@ -310,12 +310,12 @@ colnames_anova <- c( } list( - df = df, - title = title, - cols = cols, - equa = NULL, - terms = terms, + df = df, + title = title, + cols = cols, + equa = NULL, + terms = terms, psignif = psignif, - footer = NULL) + footer = NULL) } diff --git a/R/tabularise.glm.R b/R/tabularise.glm.R index f537e42..8addd37 100644 --- a/R/tabularise.glm.R +++ b/R/tabularise.glm.R @@ -1,4 +1,4 @@ -# when we calculate a glm with the glm function, we obtain an object of +# When we calculate a glm with the glm function, we obtain an object of # type `glm` and `lm`. So `tabularise()` using the `lm` method # The equatiomatic package is not capable of extracting an equation from an # object of type summary.glm @@ -34,7 +34,7 @@ #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param footer If `TRUE` (`FALSE` by default), add a footer to the table. #' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for @@ -54,7 +54,7 @@ #' #' # If the 'iris' dataset has labels and units, they can be used to enhance #' # the output table -#' iris <- data.io::labelise(iris, self = FALSE, label = list( +#' iris <- svBase::labelise(iris, self = FALSE, label = list( #' Sepal.Length = "Length of the sepals", #' Petal.Length = "Length of the petals", #' Species = "Species"), units = c(rep("cm", 4), NA)) @@ -63,9 +63,10 @@ #' tabularise::tabularise$coef(iris_glm1) #' tabularise_coef.glm <- function(data, header = FALSE, title = header, -equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, footer = FALSE, -lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), -..., kind = "ft", env = parent.frame()) { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + footer = FALSE, lang = getOption("SciViews_lang", + default = Sys.getenv("LANGUAGE",unset = "en")), ..., kind = "ft", + env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -81,7 +82,7 @@ lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_glm, footer = footer, ...) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -113,7 +114,7 @@ lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), #' the table. By default it is `NULL` and nothing is changed. #' @param footer If `TRUE` (`FALSE` by default), add a footer to the table #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). @@ -133,14 +134,15 @@ lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), #' tabularise::tabularise(iris_glm, header = TRUE, footer = FALSE) #' tabularise::tabularise(iris_glm, header = TRUE, equation = NA,footer = TRUE) tabularise_default.glm <- function(data, header = FALSE, title = header, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - footer = FALSE, lang = getOption("data.io_lang", - default = Sys.getenv("LANGUAGE",unset = "en")), ..., kind = "ft", env = parent.frame()) { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + footer = FALSE, lang = getOption("SciViews_lang", + default = Sys.getenv("LANGUAGE",unset = "en")), ..., kind = "ft", + env = parent.frame()) { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE + # if a caption is defined in the chunk, it defaults to FALSE if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } @@ -151,7 +153,7 @@ tabularise_default.glm <- function(data, header = FALSE, title = header, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_glm, footer = footer, ..., env = env) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -191,7 +193,7 @@ tabularise_default.glm <- function(data, header = FALSE, title = header, #' @param conf.level The confidence level to use for the confidence interval if #' `conf.int = TRUE`. The default is 0.95. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` #' @param ... Additional arguments @@ -210,7 +212,7 @@ tabularise_default.glm <- function(data, header = FALSE, title = header, #' @examples #' #' # If the 'iris' dataset has labels and units, they can be used to enhance #' # the output table -#' iris <- data.io::labelise(iris, self = FALSE, label = list( +#' iris <- svBase::labelise(iris, self = FALSE, label = list( #' Sepal.Length = "Length of the sepals", #' Petal.Length = "Length of the petals", #' Species = "Species"), units = c(rep("cm", 4), NA)) @@ -221,14 +223,15 @@ tabularise_default.glm <- function(data, header = FALSE, title = header, #' tabularise::tabularise$tidy(iris_glm, conf.int = TRUE, equation = NA) tabularise_tidy.glm <- function(data, header = TRUE, title = NULL, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - conf.int = FALSE, conf.level = 0.95, - lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", - env = parent.frame()) { + conf.int = FALSE, conf.level = 0.95, lang = getOption("SciViews_lang", + default = Sys.getenv("LANGUAGE",unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", + env = parent.frame()) { + # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE + # if a caption is defined in the chunk, it defaults to FALSE if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } @@ -239,7 +242,7 @@ tabularise_tidy.glm <- function(data, header = TRUE, title = NULL, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_glm, footer = FALSE, ..., env = env) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -273,8 +276,8 @@ tabularise_tidy.glm <- function(data, header = TRUE, title = NULL, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments passed to [tabularise::equation()] +#' e.g., `options(SciViews_lang = "fr")` for French. +#' @param ... Additional arguments passed to [equatiomatic::equation()] #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). #' @param env The environment where to evaluate formulas (you probably do not @@ -294,12 +297,13 @@ tabularise_tidy.glm <- function(data, header = TRUE, title = NULL, #' tabularise_glance.glm <- function(data, header = TRUE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), ..., kind = "ft", + lang = getOption("SciViews_lang", "en"), ..., kind = "ft", env = parent.frame()) { + # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE + # if a caption is defined in the chunk, it defaults to FALSE if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } @@ -310,7 +314,7 @@ tabularise_glance.glm <- function(data, header = TRUE, title = header, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_glm, footer = FALSE, ..., env = env) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -334,7 +338,7 @@ tabularise_glance.glm <- function(data, header = TRUE, title = header, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` #' @param ... Additional arguments @@ -355,14 +359,15 @@ tabularise_glance.glm <- function(data, header = TRUE, title = header, #' iris_glm_sum <- summary(iris_glm) #' tabularise::tabularise_coef(iris_glm_sum) tabularise_coef.summary.glm <- function(data, header = TRUE, title = NULL, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", - env = parent.frame()) { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("SciViews_lang", default = Sys.getenv("LANGUAGE",unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft", + env = parent.frame()) { + # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE + # if a caption is defined in the chunk, it defaults to FALSE if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } @@ -373,7 +378,7 @@ tabularise_coef.summary.glm <- function(data, header = TRUE, title = NULL, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_glm, footer = FALSE, ..., env = env) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -396,7 +401,7 @@ tabularise_coef.summary.glm <- function(data, header = TRUE, title = NULL, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` #' @param footer If `TRUE` (by default), add a footer to the table @@ -418,14 +423,15 @@ tabularise_coef.summary.glm <- function(data, header = TRUE, title = NULL, #' iris_glm_sum <- summary(iris_glm) #' tabularise::tabularise(iris_glm_sum) tabularise_default.summary.glm <- function(data, header = TRUE, title = NULL, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), - show.signif.stars = getOption("show.signif.stars", TRUE), footer = TRUE, - ..., kind = "ft", env = parent.frame()) { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("SciViews_lang", default = Sys.getenv("LANGUAGE",unset = "en")), + show.signif.stars = getOption("show.signif.stars", TRUE), footer = TRUE, + ..., kind = "ft", env = parent.frame()) { + # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE + # if a caption is defined in the chunk, it defaults to FALSE if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } @@ -436,11 +442,11 @@ tabularise_default.summary.glm <- function(data, header = TRUE, title = NULL, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_glm, footer = footer, ..., env = env) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } -# A list of internals functions ------ +# A list of internals functions colnames_glm <- c( term = "Term", @@ -467,30 +473,31 @@ colnames_glm <- c( signif = "", "(Intercept)" = "Intercept") -.trads <- gettext(term = "Term", - estimate = "Estimate", - conf.low = "Lower bound (CI)", - conf.high = "Upper bound (CI)", - std.error = "Standard Error", - t.value = "*t* value", - sigma = "Sigma",# The misnomer “Residual standard error” - r.squared = "R^2^", - adj.r.squared = "Adj.R^2^", - AIC = "AIC", - BIC = "BIC", - statistic = "*t* value", - statistic2 = "*z* value", - p.value = "*p* value", - deviance = "Deviance", - logLik = "Log-Likelihood", - null.deviance = "Total deviance", - df.null = "Total df", - df = "Num. df", - df.residual = "Residuals df", - nobs = "N", - "(Intercept)" = "Intercept", - "header" = "Generalized Linear Model", - lang = "fr") +.trads <- gettext( + term = "Term", + estimate = "Estimate", + conf.low = "Lower bound (CI)", + conf.high = "Upper bound (CI)", + std.error = "Standard Error", + t.value = "*t* value", + sigma = "Sigma",# The misnomer “Residual standard error” + r.squared = "R^2^", + adj.r.squared = "Adj.R^2^", + AIC = "AIC", + BIC = "BIC", + statistic = "*t* value", + statistic2 = "*z* value", + p.value = "*p* value", + deviance = "Deviance", + logLik = "Log-Likelihood", + null.deviance = "Total deviance", + df.null = "Total df", + df = "Num. df", + df.residual = "Residuals df", + nobs = "N", + "(Intercept)" = "Intercept", + header = "Generalized Linear Model", + lang = "fr") # See utils.R for internal functions used by various .extract_infos_*** @@ -500,28 +507,33 @@ colnames_glm <- c( if (inherits(data, "summary.glm")) { footer_glm <- c(gaussian = "Gaussian family", binomial = "Binomial family", - Gamma = "Gamma family", inverse.gaussian = "Inverse Gaussian family", - poisson = "Poisson family", - quasi = "Quasi-Gaussian family", - quasibinomial = "Quasi-Binomial family", - quasipoisson = "Quasi-Poisson family") + Gamma = "Gamma family", inverse.gaussian = "Inverse Gaussian family", + poisson = "Poisson family", + quasi = "Quasi-Gaussian family", + quasibinomial = "Quasi-Binomial family", + quasipoisson = "Quasi-Poisson family") family_glm <- gettext(footer_glm[data$family$family], lang = lang) res <- paste( gettextf("(Dispersion parameter for %s: %.*g)", family_glm, digits, - data$dispersion, domain = domain, lang = lang), - gettextf("Total deviance: %.*g on %.*g degrees of freedom",digits, data$null.deviance, digits, data$df.null, domain = domain, lang = lang), - gettextf("Residual deviance: %.*g on %.*g degrees of freedom",digits, data$deviance, digits, max(data$df), domain = domain, lang = lang), - gettextf("AIC: %.*g - Number of Fisher Scoring iterations: %.*g",digits, data$aic, digits, max(data$iter), domain = domain, lang = lang), + data$dispersion, domain = domain, lang = lang), + gettextf("Total deviance: %.*g on %.*g degrees of freedom", digits, + data$null.deviance, digits, data$df.null, domain = domain, lang = lang), + gettextf("Residual deviance: %.*g on %.*g degrees of freedom", digits, + data$deviance, digits, max(data$df), domain = domain, lang = lang), + gettextf("AIC: %.*g - Number of Fisher Scoring iterations: %.*g", digits, + data$aic, digits, max(data$iter), domain = domain, lang = lang), sep = "\n") res - } - else { + } else { res <- paste( - gettextf("Degrees of Freedom: %.*g Total (i.e. no model); %.*g Residual", digits, data$df.null, digits, - data$df.residual, domain = domain, lang = lang), - gettextf("Total deviance: %.*g", digits, data$null.deviance, domain = domain, lang = lang), - gettextf("Residual deviance: %.*g AIC: %.*g",digits, data$deviance, digits, data$ai, domain = domain, lang = lang), + gettextf("Degrees of Freedom: %.*g Total (i.e. no model); %.*g Residual", + digits, data$df.null, digits, data$df.residual, domain = domain, + lang = lang), + gettextf("Total deviance: %.*g", digits, data$null.deviance, + domain = domain, lang = lang), + gettextf("Residual deviance: %.*g AIC: %.*g",digits, data$deviance, + digits, data$ai, domain = domain, lang = lang), sep = "\n") res } @@ -539,51 +551,50 @@ colnames_glm <- c( if (inherits(data, "summary.glm") && type != "coef") { #TODO: Implement support for type = "glance" and type = "coef" - message(".extract_infos_glm() can only apply type = 'coef' to a summary.glm - object.") + message(".extract_infos_glm() can only apply type = 'coef' to a summary.glm object.") #type <- "tidy" } - if(inherits(data, "summary.glm")) { + if (inherits(data, "summary.glm")) { s <- data$coefficients df <- data.frame(term = rownames(s), s) - colnames(df) <- c("term", "estimate", "std.error", "statistic", - "p.value") + colnames(df) <- c("term", "estimate", "std.error", "statistic", "p.value") if (any(colnames(s) %in% "z value")) colnames(df)[colnames(df) == "statistic"] <- "statistic2" rownames(df) <- df$term + } else { df <- switch(type, - coef = {df <- coef(data) - df <- data.frame(term = names(df), estimate = df)}, - glance = {df <- as.data.frame(broom::glance(x = data)) - rownames(df) <- df$term - df}, - tidy = {df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, - conf.level = conf.level)) - rownames(df) <- df$term - - s <- colnames(coef(summary(data))) - if (any(s %in% "z value")) { - colnames(df)[colnames(df) == "statistic"] <- "statistic2" - } - - if (isTRUE(conf.int)) { - df <- df[, c("term", "estimate", "conf.low", "conf.high", - "std.error", "statistic", "p.value")] - } - - if (isTRUE(show.signif.stars)) { - df$signif <- .pvalue_format(df$p.value) - } - df - } - ) + coef = { + df <- coef(data) + df <- data.frame(term = names(df), estimate = df)}, + glance = { + df <- as.data.frame(broom::glance(x = data)) + rownames(df) <- df$term + df}, + tidy = { + df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, + conf.level = conf.level)) + rownames(df) <- df$term + + s <- colnames(coef(summary(data))) + if (any(s %in% "z value")) + colnames(df)[colnames(df) == "statistic"] <- "statistic2" + + if (isTRUE(conf.int)) { + df <- df[, c("term", "estimate", "conf.low", "conf.high", + "std.error", "statistic", "p.value")] + } + + if (isTRUE(show.signif.stars)) + df$signif <- .pvalue_format(df$p.value) + df} + ) } - if(isTRUE(show.signif.stars)) { + if (isTRUE(show.signif.stars)) { psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" } else { psignif <- NULL @@ -595,16 +606,14 @@ colnames_glm <- c( data_obj <- attr(data, "object") if (is.null(data_obj)) { - labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) equa <- .extract_equation(data, equation = equation, labs = labels) - } else { - + } else { labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) equa <- .extract_equation(data_obj, equation = equation, labs = labels) } @@ -615,13 +624,11 @@ colnames_glm <- c( terms <- .extract_terms(df, labs = labels, lang = lang) } - if (is.na(equation)) { + if (is.na(equation)) equa <- NULL - } title <- .extract_title(title, lang, default = "Generalized Linear Model") - # footer if (isTRUE(footer)) { footer <- .extract_footer_glm(data, lang) } else { @@ -629,13 +636,13 @@ colnames_glm <- c( } list( - df = df, - title = title, - cols = cols, - equa = equa, - terms = terms, + df = df, + title = title, + cols = cols, + equa = equa, + terms = terms, psignif = psignif, - footer = footer + footer = footer ) } diff --git a/R/tabularise.lm.R b/R/tabularise.lm.R index b9e2bf5..a171a7d 100644 --- a/R/tabularise.lm.R +++ b/R/tabularise.lm.R @@ -31,7 +31,7 @@ #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param ... Additional arguments #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). @@ -51,7 +51,7 @@ #' #' # If the 'iris' dataset has labels and units, they can be used to enhance #' # the output table -#' iris <- data.io::labelise(iris, self = FALSE, label = list( +#' iris <- svBase::labelise(iris, self = FALSE, label = list( #' Sepal.Length = "Length of the sepals", #' Petal.Length = "Length of the petals", #' Species = "Species"), units = c(rep("cm", 4), NA)) @@ -66,9 +66,9 @@ #' tabularise::tabularise$coef(iris_lm2) #' tabularise_coef.lm <- function(data, header = FALSE, title = header, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", default = Sys.getenv("LANGUAGE",unset = "en")), - ..., kind = "ft") { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("SciViews_lang", default = Sys.getenv("LANGUAGE",unset = "en")), + ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -84,7 +84,7 @@ tabularise_coef.lm <- function(data, header = FALSE, title = header, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_lm, footer = FALSE) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -148,10 +148,10 @@ tabularise_default.lm <- function(data, ..., kind = "ft") { #' @param conf.level The confidence level to use for the confidence interval if #' `conf.int = TRUE`. The default is 0.95. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` -#' @param ... Additional arguments passed to [tabularise::equation()] +#' @param ... Additional arguments passed to [equatiomatic::equation()] #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). #' @@ -165,9 +165,9 @@ tabularise_default.lm <- function(data, ..., kind = "ft") { #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$tidy(iris_lm) tabularise_tidy.lm <- function(data, header = TRUE, title = header, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - conf.int = FALSE, conf.level = 0.95, lang = getOption("data.io_lang", "en"), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + conf.int = FALSE, conf.level = 0.95, lang = getOption("SciViews_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -184,7 +184,7 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = header, colnames = colnames_lm, footer = FALSE, ...) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -220,8 +220,8 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = header, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. -#' @param ... Additional arguments passed to [tabularise::equation()] +#' e.g., `options(SciViews_lang = "fr")` for French. +#' @param ... Additional arguments passed to [equatiomatic::equation()] #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). #' @@ -234,8 +234,9 @@ tabularise_tidy.lm <- function(data, header = TRUE, title = header, #' iris_lm <- lm(data = iris, Petal.Length ~ Sepal.Length) #' tabularise::tabularise$glance(iris_lm) tabularise_glance.lm <- function(data, header = TRUE, title = header, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), ..., kind = "ft") { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("SciViews_lang", "en"), ..., kind = "ft") { + # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... @@ -250,7 +251,7 @@ tabularise_glance.lm <- function(data, header = TRUE, title = header, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_lm, footer = FALSE, ...) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -287,7 +288,7 @@ tabularise_glance.lm <- function(data, header = TRUE, title = header, #' @param conf.level The confidence level to use for the confidence interval if #' `conf.int = TRUE`. The default is 0.95. #' @param lang The natural language to use. The default value can be set with, -#' e.g., `options(data.io_lang = "fr")` for French. +#' e.g., `options(SciViews_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` #' @param ... Additional arguments @@ -309,7 +310,7 @@ tabularise_glance.lm <- function(data, header = TRUE, title = header, tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, equation = header, footer = FALSE, auto.labs = TRUE, origdata = NULL, labs = NULL, conf.int = FALSE, conf.level = 0.95, - lang = getOption("data.io_lang", "en"), + lang = getOption("SciViews_lang", "en"), show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE @@ -326,7 +327,7 @@ tabularise_coef.summary.lm <- function(data, header = TRUE, title = header, origdata = origdata, labs = labs, equation = equation, title = title, colnames = colnames_lm, footer = footer, ...) - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -352,7 +353,7 @@ tabularise_default.summary.lm <- function(data, ..., footer = TRUE) { } -# A list of internals functions ------ +# A list of internals functions colnames_lm <- c( term = "Term", estimate = "Estimate", @@ -376,26 +377,25 @@ colnames_lm <- c( "(Intercept)" = "Intercept") .trads <- gettext(term = "Term", - estimate = "Estimate", - conf.low = "Lower bound (CI)", - conf.high = "Upper bound (CI)", - std.error = "Standard Error", - t.value = "t value", - sigma = "RSE", - r.squared = "R^2^", - adj.r.squared = "Adj.R^2^", - AIC = "AIC", - BIC = "BIC", - deviance = "Deviance", - logLik = "Log-likelihood", - statistic = "*t* value", - p.value = "*p* value", - df = "Model df", - df.residual = "Residuals df", - nobs = "N", - "header" = "Linear model", - "(Intercept)" = "Intercept", lang = "fr") -#.trads + estimate = "Estimate", + conf.low = "Lower bound (CI)", + conf.high = "Upper bound (CI)", + std.error = "Standard Error", + t.value = "t value", + sigma = "RSE", + r.squared = "R^2^", + adj.r.squared = "Adj.R^2^", + AIC = "AIC", + BIC = "BIC", + deviance = "Deviance", + logLik = "Log-likelihood", + statistic = "*t* value", + p.value = "*p* value", + df = "Model df", + df.residual = "Residuals df", + nobs = "N", + header = "Linear model", + "(Intercept)" = "Intercept", lang = "fr") # See utils.R for internal functions used by various .extract_infos_*** @@ -403,23 +403,23 @@ colnames_lm <- c( digits <- max(3L, getOption("digits") - 3L) domain <- "R-modelit" res <- paste(gettextf("Residuals range: [%.*g, %.*g]", - digits, min(data$residuals, na.rm = TRUE), - digits, max(data$residuals, na.rm = TRUE), - domain = domain, lang = lang), - gettextf("Residuals standard error: %.*g on %.*g degrees of freedom", - digits, data$sigma, digits, max(data$df), - domain = domain, lang = lang), - gettextf("Multiple *R*^2^: %.*g - adjusted *R*^2^: %.*g", - digits, data$r.squared, digits, data$adj.r.squared, - domain = domain, lang = lang), - gettextf("*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s", - digits, data$fstatistic[1L], - digits, data$fstatistic[2L], - digits, data$fstatistic[3L], - format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], - data$fstatistic[3L], lower.tail = FALSE)), - domain = domain, lang = lang), - sep = "\n") + digits, min(data$residuals, na.rm = TRUE), + digits, max(data$residuals, na.rm = TRUE), + domain = domain, lang = lang), + gettextf("Residuals standard error: %.*g on %.*g degrees of freedom", + digits, data$sigma, digits, max(data$df), + domain = domain, lang = lang), + gettextf("Multiple *R*^2^: %.*g - adjusted *R*^2^: %.*g", + digits, data$r.squared, digits, data$adj.r.squared, + domain = domain, lang = lang), + gettextf("*F*-statistic: %.*g on %.*g and %.*g df - *p* value: %s", + digits, data$fstatistic[1L], + digits, data$fstatistic[2L], + digits, data$fstatistic[3L], + format.pval(pf(data$fstatistic[1L], data$fstatistic[2L], + data$fstatistic[3L], lower.tail = FALSE)), + domain = domain, lang = lang), + sep = "\n") res } @@ -434,34 +434,35 @@ colnames_lm <- c( type <- match.arg(type, choices = c("coef", "glance", "tidy")) if (inherits(data, "summary.lm") && type == "coef") { - message(".extract_infos_lm() cannot apply type = 'coef' to a summary.lm - object. Use type = 'tidy' instead to extract a detailed coefficient table.") + message(".extract_infos_lm() cannot apply type = 'coef' to a summary.lm object. Use type = 'tidy' instead to extract a detailed coefficient table.") type <- "tidy" - } + } df <- switch(type, - coef = {df <- coef(data) - data.frame(term = names(df), estimate = df)}, - glance = {df <- as.data.frame(broom::glance(x = data)) - rownames(df) <- df$term - df - }, - tidy = {df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, - conf.level = conf.level)) - rownames(df) <- df$term - - if (isTRUE(conf.int)) { - df <- df[, c("term", "estimate", "conf.low", "conf.high", - "std.error", "statistic", "p.value")] - } - if (isTRUE(show.signif.stars)) { - df$signif <- .pvalue_format(df$p.value) - } - df} + coef = { + df <- coef(data) + data.frame(term = names(df), estimate = df)}, + glance = { + df <- as.data.frame(broom::glance(x = data)) + rownames(df) <- df$term + df}, + tidy = { + df <- as.data.frame(broom::tidy(x = data, conf.int = conf.int, + conf.level = conf.level)) + rownames(df) <- df$term + + if (isTRUE(conf.int)) { + df <- df[, c("term", "estimate", "conf.low", "conf.high", + "std.error", "statistic", "p.value")] + } + if (isTRUE(show.signif.stars)) { + df$signif <- .pvalue_format(df$p.value) + } + df} ) - if(isTRUE(show.signif.stars)) { + if (isTRUE(show.signif.stars)) { psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" } else { psignif <- NULL @@ -473,16 +474,14 @@ colnames_lm <- c( data_obj <- attr(data, "object") if (is.null(data_obj)) { - labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) equa <- .extract_equation(data, equation = equation, labs = labels) } else { - labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) equa <- .extract_equation(data_obj, equation = equation, labs = labels) } @@ -499,7 +498,7 @@ colnames_lm <- c( title <- .extract_title(title, lang = lang, default = "Linear model") - if(isTRUE(footer)) { + if (isTRUE(footer)) { footer <- .extract_footer_lm(data, lang = lang) } else { footer <- NULL @@ -517,7 +516,7 @@ colnames_lm <- c( } -# # TODO: Migrate this translation system into the 'svMisc' package +# # TODO: Migrate this translation system into the 'svBase' package # # # This function creates a translation handler that caches translations # # for different languages and object types (e.g., "lm", "nls", etc.). diff --git a/R/tabularise.nls.R b/R/tabularise.nls.R index 6db710a..8b7e3df 100644 --- a/R/tabularise.nls.R +++ b/R/tabularise.nls.R @@ -20,7 +20,7 @@ #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., -#' `options(data.io_lang = "fr")` for French. +#' `options(SciViews_lang = "fr")` for French. #' @param footer If `TRUE` (by default), add a footer to the table. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` @@ -55,11 +55,11 @@ #' tabularise::tabularise(summary(growth_logis)) # No labels #' tabularise::tabularise(summary(growth_logis), origdata = growth) # with labels #' tabularise::tabularise(summary(growth_logis), origdata = growth, -#' equation = FALSE, show.signif.stars = FALSE) +#' equation = FALSE, show.signif.stars = FALSE) #' tabularise_default.summary.nls <- function(data, header = TRUE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), footer = TRUE, + lang = getOption("SciViews_lang", "en"), footer = TRUE, show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { @@ -77,7 +77,7 @@ tabularise_default.summary.nls <- function(data, header = TRUE, title = header, title = title, colnames = colnames_nls, footer = footer) # print(df_list) # use only for development - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -102,7 +102,7 @@ tabularise_default.summary.nls <- function(data, header = TRUE, title = header, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., -#' `options(data.io_lang = "fr")` for French. +#' `options(SciViews_lang = "fr")` for French. #' @param footer If `FALSE` (by default), add a footer to the table. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` @@ -126,15 +126,15 @@ tabularise_default.summary.nls <- function(data, header = TRUE, title = header, #' tabularise::tabularise$coef(chick1_logis_sum) #' tabularise::tabularise$coef(chick1_logis_sum, header = FALSE, equation = TRUE) tabularise_coef.summary.nls <- function(data, header = TRUE, title = header, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), footer = FALSE, + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("SciViews_lang", "en"), footer = FALSE, show.signif.stars = getOption("show.signif.stars", TRUE), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { title <- header # Default to same as header, but... - # if a caption is defined in the chunk, it defauts to FALSE + # if a caption is defined in the chunk, it defaults to FALSE if (!is.null(knitr::opts_current$get('tbl-cap'))) title <- FALSE } @@ -145,7 +145,7 @@ tabularise_coef.summary.nls <- function(data, header = TRUE, title = header, title = title, colnames = colnames_nls, footer = footer) # print(df_list) # use only for development - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -170,7 +170,7 @@ tabularise_coef.summary.nls <- function(data, header = TRUE, title = header, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., -#' `options(data.io_lang = "fr")` for French. +#' `options(SciViews_lang = "fr")` for French. #' @param footer If `TRUE` (by default, it is TRUE), add a footer to the table. #' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for @@ -191,7 +191,7 @@ tabularise_coef.summary.nls <- function(data, header = TRUE, title = header, #' tabularise::tabularise(chick1_logis) tabularise_default.nls <- function(data, header = TRUE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), footer = TRUE, ..., kind = "ft") { + lang = getOption("SciViews_lang", "en"), footer = TRUE, ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -207,7 +207,7 @@ tabularise_default.nls <- function(data, header = TRUE, title = header, title = title, colnames = colnames_nls, footer = footer) # print(df_list) # use only for development - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -232,7 +232,7 @@ tabularise_default.nls <- function(data, header = TRUE, title = header, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., -#' `options(data.io_lang = "fr")` for French. +#' `options(SciViews_lang = "fr")` for French. #' @param footer If `TRUE` (by default, it is TRUE), add a footer to the table. #' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for @@ -253,7 +253,7 @@ tabularise_default.nls <- function(data, header = TRUE, title = header, #' tabularise::tabularise$coef(chick1_logis) tabularise_coef.nls <- function(data, header = TRUE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), footer = TRUE, ..., kind = "ft") { + lang = getOption("SciViews_lang", "en"), footer = TRUE, ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -269,9 +269,8 @@ tabularise_coef.nls <- function(data, header = TRUE, title = header, title = title, colnames = colnames_nls, footer = footer) # print(df_list) # use only for development - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) - } #' Tidy version of the nls object into a flextable object @@ -297,7 +296,7 @@ tabularise_coef.nls <- function(data, header = TRUE, title = header, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., -#' `options(data.io_lang = "fr")` for French. +#' `options(SciViews_lang = "fr")` for French. #' @param show.signif.stars If `TRUE`, add the significance stars to the table. #' The default is `getOption("show.signif.stars")` #' @param ... Not used @@ -322,10 +321,10 @@ tabularise_coef.nls <- function(data, header = TRUE, title = header, #' tabularise::tabularise$tidy(chick1_logis) #' tabularise::tabularise$tidy(chick1_logis, lang = "fr") tabularise_tidy.nls <- function(data, header = TRUE, title = header, - equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, - lang = getOption("data.io_lang", "en"), - show.signif.stars = getOption("show.signif.stars", TRUE), ..., - kind = "ft") { + equation = header, auto.labs = TRUE, origdata = NULL, labs = NULL, + lang = getOption("SciViews_lang", "en"), + show.signif.stars = getOption("show.signif.stars", TRUE), ..., + kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -341,7 +340,7 @@ tabularise_tidy.nls <- function(data, header = TRUE, title = header, title = title, colnames = colnames_nls, footer = FALSE) # print(df_list) # use only for development - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -367,7 +366,7 @@ tabularise_tidy.nls <- function(data, header = TRUE, title = header, #' @param labs Labels to change the names of elements in the `term` column of #' the table. By default it is `NULL` and nothing is changed. #' @param lang The language to use. The default value can be set with, e.g., -#' `options(data.io_lang = "fr")` for French. +#' `options(SciViews_lang = "fr")` for French. #' @param ... Not used #' @param kind The kind of table to produce: "tt" for tinytable, or "ft" for #' flextable (default). @@ -390,7 +389,7 @@ tabularise_tidy.nls <- function(data, header = TRUE, title = header, #' tabularise::tabularise$glance(chick1_logis, lang = "fr") tabularise_glance.nls <- function(data, header = TRUE, title = header, equation = header, auto.labs = TRUE, origdata = NULL, - labs = NULL, lang = getOption("data.io_lang", "en"), ..., kind = "ft") { + labs = NULL, lang = getOption("SciViews_lang", "en"), ..., kind = "ft") { # If title is not provided, determine if we have to use TRUE or FALSE if (missing(title)) { @@ -406,7 +405,7 @@ tabularise_glance.nls <- function(data, header = TRUE, title = header, title = title, colnames = colnames_nls, footer = FALSE) # print(df_list) # use only for development - # formatted table ---- + # formatted table format_table(df_list, kind = kind, header = header) } @@ -437,7 +436,7 @@ tabularise_glance.nls <- function(data, header = TRUE, title = header, #' @method equation nls #' #' @examples -#' equation <- tabularise::equation +#' equation <- equatiomatic::equation #' chick1 <- ChickWeight[ChickWeight$Chick == 1, ] #' chick1_nls <- nls(data = chick1, weight ~ SSlogis(Time, Asym, xmid, scal)) #' summary(chick1_nls) @@ -608,8 +607,8 @@ op_latex = c("\\cdot", "\\times"), ...) { #' @export #' @method equation summary.nls equation.summary.nls <- function(object, ital_vars = FALSE, use_coefs = FALSE, -coef_digits = 2L, fix_signs = TRUE, swap_var_names = NULL, -op_latex = c("\\cdot", "\\times"), ...) { + coef_digits = 2L, fix_signs = TRUE, swap_var_names = NULL, + op_latex = c("\\cdot", "\\times"), ...) { # Same as equation.nls() equation.nls(object, ital_vars = ital_vars, use_coefs = use_coefs, coef_digits = coef_digits, fix_signs = fix_signs, @@ -673,31 +672,30 @@ model_nls <- c( # Internal function for nls and summary.nls object .extract_footer_nls <- function(data, lang) { - digits <- max(3L, getOption("digits") - 3L) - domain <- "R-modelit" - - if (inherits(data, "nls")) { - val <- gettextf("Residual sum-of-squares: %.*g", - digits, data$m$deviance(), domain = domain, lang = lang) - } else { - val <- gettextf("Residuals standard error: %.*g on %.*g degrees of freedom", - digits, data$sigma, digits, max(data$df), - domain = domain, lang = lang) - } - - conv <- data$convInfo - if (isTRUE(conv$isConv)) { - convinfo <- paste( - gettextf("Number of iterations to convergence: %.*g", - digits, conv$finIter, domain = domain, lang = lang), - gettextf("Achieved convergence tolerance: %.*g", - digits, conv$finTol, domain = domain, lang = lang), - sep = "\n") - val <- c(val, convinfo) - } else { - val <- c(val, gettext("The model does not converge", lang = lang)) - } - return(val) + digits <- max(3L, getOption("digits") - 3L) + domain <- "R-modelit" + + if (inherits(data, "nls")) { + val <- gettextf("Residual sum-of-squares: %.*g", + digits, data$m$deviance(), domain = domain, lang = lang) + } else { + val <- gettextf("Residuals standard error: %.*g on %.*g degrees of freedom", + digits, data$sigma, digits, max(data$df), domain = domain, lang = lang) + } + + conv <- data$convInfo + if (isTRUE(conv$isConv)) { + convinfo <- paste( + gettextf("Number of iterations to convergence: %.*g", + digits, conv$finIter, domain = domain, lang = lang), + gettextf("Achieved convergence tolerance: %.*g", + digits, conv$finTol, domain = domain, lang = lang), + sep = "\n") + val <- c(val, convinfo) + } else { + val <- c(val, gettext("The model does not converge", lang = lang)) + } + return(val) } .extract_infos_nls <- function(data, type = "coef", @@ -706,11 +704,11 @@ model_nls <- c( equation = TRUE, title = TRUE, footer = TRUE, ...) { if (!inherits(data, c("nls", "summary.nls"))) - stop(".extract_infos_nls() can apply only nls and summary.nls object.") + stop(".extract_infos_nls() can apply only nls and summary.nls object.") type <- match.arg(type, choices = c("coef", "glance", "tidy")) - # Extract df --------------------------------------------------------------- + # Extract df if (inherits(data, "nls")) { df <- switch(type, coef = as.data.frame(t(coef(data))), @@ -737,23 +735,21 @@ model_nls <- c( } ) } else { - # only for summary.nls oject - if(type == "glance") { - stop(".extract_infos_nls() cannot apply type = 'glance' to a summary.nls - object.") + # Only for summary.nls oject + if (type == "glance") { + stop(".extract_infos_nls() cannot apply type = 'glance' to a summary.nls object.") } res1 <- coef(data) df <- data.frame(term = rownames(res1), estimate = res1) names(df) <- c("term", "estimate", "std.error", "statistic", "p.value") - if (isTRUE(show.signif.stars)) { + if (isTRUE(show.signif.stars)) df$signif <- .pvalue_format(df$p.value) - } df } - if(isTRUE(show.signif.stars)) { + if (isTRUE(show.signif.stars)) { psignif <- "0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05" } else { psignif <- NULL @@ -765,31 +761,27 @@ model_nls <- c( data_obj <- attr(data, "object") if (is.null(data_obj)) { - labels <- .extract_labels(df = df, data = data, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) equa <- .extract_equation(data, equation = equation, labs = labels,...) } else { - labels <- .extract_labels(df = df, data = data_obj, auto.labs = auto.labs, - origdata = origdata, labs = labs) + origdata = origdata, labs = labs) equa <- .extract_equation(data_obj, equation = equation, labs = labels,...) } - if (is.na(equation)) { + if (is.na(equation)) equa <- NULL - } terms <- NULL # title if (!isTRUE(title)) { title <- NULL - } - if (isTRUE(title)) { + } else { rhs <- as.character(rlang::f_rhs(formula(data)))[1] if (!is.na(model_nls[rhs])) { title <- gettext(model_nls[rhs], lang = lang) @@ -798,9 +790,8 @@ model_nls <- c( } } - if (is.character(title)) { + if (is.character(title)) title <- title - } # footer if(isTRUE(footer)) { @@ -812,11 +803,10 @@ model_nls <- c( # List with all elements list( df = df, - title = title, - cols = cols, - equa = equa, - terms = terms, + title = title, + cols = cols, + equa = equa, + terms = terms, psignif = psignif, - footer = footer) + footer = footer) } - diff --git a/README.Rmd b/README.Rmd index f2e59cd..db3c815 100644 --- a/README.Rmd +++ b/README.Rmd @@ -1,17 +1,10 @@ --- -title: "Statistical Models for 'SciViews::R' " output: github_document --- - + - - -[![R-CMD-check](https://github.com/SciViews/modelit/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/SciViews/modelit/actions/workflows/R-CMD-check.yaml) [![Codecov test coverage](https://codecov.io/gh/SciViews/modelit/branch/main/graph/badge.svg)](https://codecov.io/gh/SciViews/modelit?branch=main) [![CRAN status](https://www.r-pkg.org/badges/version/modelit)](https://cran.r-project.org/package=modelit) [![r-universe status](https://sciviews.r-universe.dev/badges/modelit)](https://sciviews.r-universe.dev/modelit) [![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) - - - -```{r setup, include = FALSE} +```{r setup, include=FALSE} knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.path = "man/figures/README-", out.width = "80%") library(modelit) @@ -19,16 +12,27 @@ library(tabularise) library(chart) ``` +# 'SciViews::R' - Statistical Models + + +[![R-CMD-check](https://github.com/SciViews/modelit/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/SciViews/modelit/actions/workflows/R-CMD-check.yaml) +[![codeecov](https://codecov.io/gh/SciViews/modelit/branch/main/graph/badge.svg)](https://codecov.io/gh/SciViews/modelit?branch=main) +[![CRAN status](https://www.r-pkg.org/badges/version/modelit)](https://cran.r-project.org/package=modelit) +[![r-universe status](https://sciviews.r-universe.dev/badges/modelit)](https://sciviews.r-universe.dev/modelit) +[![License: MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) +[![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) + + The {modelit} package adds the statistical models to the SciViews::R dialect. It uses both the `fun$type(data = ...., formula)` approach and the enhanced formula allowing to specify arguments with `%arg=%` directly inside the formula. It also takes the variable labels into account in the outputs. The {modelit} package provides methods (**lm**, **glm**; **nls** objects) for the `chart()` function in the {chart} package and the `tabularise()` function in the {tabularise} package. ## Installation -{modelit} is not available from CRAN yet. You should install it from the [SciViews R-Universe](https://sciviews.r-universe.dev). {chart} is an alternate formula interface to {ggplot2}. {tabularise} produces publication-ready (rich-formatted) tabular output. The {equatags} and {equatiomatic} packages are optional, but they are useful to display equations, both inline in R Markdown/Quarto documents and in {tabularise} tables. {data.io} is useful too because it manages labels and units that {chart} uses. To install these six packages and their dependencies, run the following command in R: +{modelit} is not available from CRAN yet. You should install it from the [SciViews R-Universe](https://sciviews.r-universe.dev). {chart} is an alternate formula interface to {ggplot2}. {tabularise} produces publication-ready (rich-formatted) tabular output. The {equatags} and {equatiomatic} packages are optional, but they are useful to display equations, both inline in R Markdown/Quarto documents and in {tabularise} tables. {svBase} is useful too because it manages labels and units that {chart} uses. To install these six packages and their dependencies, run the following command in R: ```{r, eval=FALSE} -install.packages(c('modelit', 'chart', 'tabularise', 'equatags', 'equatiomatic', 'data.io'), +install.packages(c('modelit', 'chart', 'tabularise', 'equatags', 'equatiomatic', 'svBase'), repos = c('https://sciviews.r-universe.dev', 'https://cloud.r-project.org')) ``` diff --git a/README.md b/README.md index 7992a0e..3fc39e8 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,12 @@ -Statistical Models for ‘SciViews::R’ - -================ - + + +# ‘SciViews::R’ - Statistical Models + [![R-CMD-check](https://github.com/SciViews/modelit/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/SciViews/modelit/actions/workflows/R-CMD-check.yaml) -[![Codecov test -coverage](https://codecov.io/gh/SciViews/modelit/branch/main/graph/badge.svg)](https://codecov.io/gh/SciViews/modelit?branch=main) +[![codeecov](https://codecov.io/gh/SciViews/modelit/branch/main/graph/badge.svg)](https://codecov.io/gh/SciViews/modelit?branch=main) [![CRAN status](https://www.r-pkg.org/badges/version/modelit)](https://cran.r-project.org/package=modelit) [![r-universe @@ -16,7 +15,6 @@ status](https://sciviews.r-universe.dev/badges/modelit)](https://sciviews.r-univ MIT](https://img.shields.io/badge/License-MIT-yellow.svg)](https://opensource.org/licenses/MIT) [![Lifecycle: experimental](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://lifecycle.r-lib.org/articles/stages.html#experimental) - The {modelit} package adds the statistical models to the SciViews::R @@ -37,12 +35,12 @@ alternate formula interface to {ggplot2}. {tabularise} produces publication-ready (rich-formatted) tabular output. The {equatags} and {equatiomatic} packages are optional, but they are useful to display equations, both inline in R Markdown/Quarto documents and in -{tabularise} tables. {data.io} is useful too because it manages labels +{tabularise} tables. {svBase} is useful too because it manages labels and units that {chart} uses. To install these six packages and their dependencies, run the following command in R: ``` r -install.packages(c('modelit', 'chart', 'tabularise', 'equatags', 'equatiomatic', 'data.io'), +install.packages(c('modelit', 'chart', 'tabularise', 'equatags', 'equatiomatic', 'svBase'), repos = c('https://sciviews.r-universe.dev', 'https://cloud.r-project.org')) ``` diff --git a/inst/CITATION b/inst/CITATION index 5be4aa1..2be61fc 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -1,24 +1,13 @@ -citHeader("To cite SciViews-R in publications use:") - -citEntry( - entry = "Manual", - title = "SciViews::R", - author = personList(as.person("Philippe Grosjean"), - as.person("Guyliann Engels")), - organization = "UMONS", - address = "MONS, Belgium", - year = version$year, - url = "https://sciviews.r-universe.dev/", - - textVersion = - paste("Grosjean, Ph. & Engels, G. (", version$year, "). ", - "SciViews::R. ", - "UMONS, Mons, Belgium. ", - "URL https://sciviews.r-universe.dev/.", - sep = "") +bibentry( + bibtype = "Misc", + header = "To cite SciViews::R in publications, please use", + author = c(person("Philippe", "Grosjean", role = c("aut", "cre"), + email = "phgrosjean@sciviews.org", + comment = c(ORCID = "0000-0002-2694-9471")), + person("Guyliann", "Engels", role = "aut", + email = "guyliann.engels@umons.ac.be", + comment = c(ORCID = "0000-0001-9514-1014"))), + title = "'data.trame': A better 'data.frame' for 'SciViews::R'", + year = "2025", + url = "https://sciviews.r-universe.dev/", ) - -citFooter("We have invested a lot of time and effort in creating SciViews-R,", - "please cite it when using it together with R.", - "See also", sQuote("citation()"), - "for citing R.") diff --git a/inst/WORDLIST b/inst/WORDLIST index b56ad8f..644bd8d 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -6,12 +6,14 @@ Codecov datalorax dir equatiomatic +eval flextable ggplot GitHub glm Gompertz hexSticker +io lazyeval Lifecycle lightblue @@ -22,6 +24,7 @@ modelr mtcars nls ORCID +param Pinus png qqplot @@ -33,6 +36,7 @@ resleverage scalelocation SciViews showWarnings +svBase svMisc tabularise tadea diff --git a/man/chart.lm.Rd b/man/chart.lm.Rd index 7e6d1ef..8b155f6 100644 --- a/man/chart.lm.Rd +++ b/man/chart.lm.Rd @@ -13,7 +13,7 @@ title, labels = "AUTO", name = deparse(substitute(data)), - lang = getOption("data.io_lang", "en"), + lang = getOption("SciViews_lang", "en"), env = parent.frame() ) @@ -27,7 +27,7 @@ autoplot.lm( ylab, ..., name = deparse(substitute(object)), - lang = getOption("data.io_lang", "en"), + lang = getOption("SciViews_lang", "en"), env = parent.frame() ) } diff --git a/man/chart.nls.Rd b/man/chart.nls.Rd index bc418ab..57fad85 100644 --- a/man/chart.nls.Rd +++ b/man/chart.nls.Rd @@ -12,7 +12,7 @@ title, labels = "AUTO", name = deparse(substitute(data)), - lang = getOption("data.io_lang", "en"), + lang = getOption("SciViews_lang", "en"), env = parent.frame() ) @@ -24,7 +24,7 @@ autoplot.nls( ylab, ..., name = deparse(substitute(object)), - lang = getOption("data.io_lang", "en"), + lang = getOption("SciViews_lang", "en"), env = parent.frame() ) } diff --git a/man/equation.nls.Rd b/man/equation.nls.Rd index 14c21fd..d50e6f8 100644 --- a/man/equation.nls.Rd +++ b/man/equation.nls.Rd @@ -62,7 +62,7 @@ Create the model equation of several self-starting nonlinear models available in the stats package. } \examples{ -equation <- tabularise::equation +equation <- equatiomatic::equation chick1 <- ChickWeight[ChickWeight$Chick == 1, ] chick1_nls <- nls(data = chick1, weight ~ SSlogis(Time, Asym, xmid, scal)) summary(chick1_nls) diff --git a/man/figures/README-unnamed-chunk-7-1.png b/man/figures/README-unnamed-chunk-7-1.png index 7c4cfd51d76cefed6169f9f21cc9270488869e50..689c6c39a8cb6a7ee7e0c43499920fb25c4b5a06 100644 GIT binary patch literal 36869 zcmZ5o1yoe;(_U7P5NSmT=}tvZ8tLwkMgi&WUJwbTyBDQfx}~LA8tIUwOKL^xyZjXN z`=7I%vu8Q??tAB*cjlRAp4nhUd5OCiL>M3t=&qEcs4@ryP6vUI7SL`3pSXw2KLvr1 zvCKq76fHy~L~JZ=>{V=E85&C%TN~S(87fN%gFw$iL)COmNz@1gl55MEs0ZGTW@krX zU2w)!SSkOzykPqS z%cly(PsnfSe-8eV_&7|6zFEsrULRd!(bzk4vXZjvy*lTxGj}JVhFLpqjt0z3RLlY& zSt{>bX>aFoZ1Ebr>ov&26c)=EON&JOy|rm-dzbv{+{AG;;?iWZSWyBgX!hN=!sk7d zOU9s!dmUxE5abu9UFZ|9f1!)Bic`K)2u3$d`Ei5sze0E1rJ^CzX#u(Has$t62xgYeiX661Hu-6WY zi5bttAa~ZA_b-@tK78NDRnHM<*T_qY7e3c#sV4YJ!yllRg6Y`B?sRta%UL5e5p5}o zoA3@%2o0NhmIuSzGwtFwwb54K}HS+(VFSUwJg(*KgSlf=35y~EL&JwPmlt0zOpFp1DqtPb&}TT`VBcUCJ+TwkdOTj%8XxM#)uHv{4(pE8 zCPd~ej$KousrInTR{hn9&-$y+v@kDFy>Iz!PODdQZa(c($MCAN(QcPG;FmWN$YN2m zd{v(DNt09k7nrOU0JVqO%|p6$7g+7} z?e*=*9H0{Bqi(xTEp|#WN-! zlu)<+cIRgsqXMr&2w|SXmUUtI_@bbyc-(C|&+PBJ9Jl1Hzxz{32|lEJXI1a+zkQVL z>@CATRpR^A;fEz3%4<)3&!++ef~~f1AI^XHqO|p6)PB9J7i%fREVZICY2$rc_wx7G z7$r{_?_40`Jj4NP%V`WZ)eV@J9svUBwdc^(Wx; z^jp{OkruB0iKjn30|E(wq(on+x*~0*qNb?A$1Y)IjfkH6JdC+$?*kxy(zr-UE$_b) zg%Uj#k4|V9T0STCsmBHxj~wad zRgISpa$>Tc3;BDgBm^8Ye~VfOeDkuV5klHfpJ{mb&%Hn>^i8P$?;E8d;L)NQH;$Wo zeYne|>>Mq13dr8>hwJ*pJ8_J!1W7-)?SU zkyTl#1_pzvSy=}nWxR@6G*4!jR&PcB_Y{~M;I^-~>RxwXNXg5OH>G**OBHAwZCB54 ztPWbY`lG9_>XsVTU8cIst=qc9>(~bq&2LSXlYSYWL)rauT3o1IJ)p-?!Y!Ck*l-(+ zD*fmA^kfabp$(?(E}SFgt9cGvP|03ypSEK0<;%n|N21)hFX`-D#m4sp8hLG@<~wMZ zyht0nyCt7(<{C7yNO>}wz|rKKsS^sA-$TEC6?Z%6e-`)ye}Cx4JPnb}pEYlp`}r(K zO7ytQd(o+>sg*gb%5xuoGt6pi)UC3f%}*k6=zF{mkJnF1()Jo38|#)J^U9o3S5@s= z?v941I1EIFgkTmpf19kbN=_OVuh+lWkGEgXia$0t_4H+k=%7(*XnT?sd&t}Mh^;8qwyVsp) zl9tzy^&Ck&p(=3Iaj8An{?~dAQ=EICpv?m-RK3lKlK8VT&!ZW`&aivT$q)G59bv4g zQ$A}S1CcF6RtHiG#*d3N%f*j(W|>B^<)WEN8kAdGTaCVd4c#Btw#jpSt-VbM}G?TWU? zax?4Oajd%eQwudrThR&v>rM(Yh(I#$wPDc&@14T(f#GUSyL{_&n9oJI%mKk>ryc3> zkD0hP6|;bW2@Af+rtD$u@9#6$KdqQ0EKtf2&+|y}I-b}>YT}wdC;LtKze@nS$&Tz~E4YeKQBn@J_blM1aF~ScAGe6O{pcX< zWvQO|^l51EUgK6-?{c!u7o~}_!x4pj!OH`|PmQ;``}$%~$vhRU>$kbi8`L_d26|$d zVkPcJZeRZF6pYcpn`n{o7?FE+WVuszet76OBpN?ApO=%yn1mDK?~i=`fJ@Kk+-V3o zwJ(KR#f^HA^Wr<%C4FjYDwu7tm#wKV%#chLrw@f=3M*|*tw24`;sW7wsi7O5PA|80 z=LzB23Cu@*Rp$s+Q1XTGU=^m3CSU0D?$!BjBVvxJM$m6$czAf!Zlq=u>yqL+s@Ret zO>9hl-0UB|Wxl^>rZS^DRpBsEs97F^kiqBGrL{@PLRC#J9&0p&@gq_$aP|fg`BIY- zlse@mENpT&+pq;kr_Ea>cH5SbW}AGPyk+t8+^2KW+@(n+=25Xo6gyA%H`WQC*D7gh z=FMN~U;c`p`w)zsw%B@yZ8Y3aB>BF^gnvMQvzdkDkpnGu2JOJu2jS{!rN>cKztO%4 zXoNTqoGpYXW;t6J(70NsdR^w+B%HUt`L^|Nyyr~gzl$Wp?kY&gqLm5#I;G$$*YtDg z4*W+Ox*U7{L1biPkAa z>DDDODylY|SM1ABK)~%=8ppFnKbAVw>0}MVLPPJ#Np7xw4!{d=ie=B({u)lkrjjii zsax;NV8h6l|MJv*zniYtZ8eoHiJd?WEnh(Q2llW9MLZ)j50BO^p2b_aH$CO=$vHoB zY$p#KL|?}=16y=V8KnH8X;ohVoG_o$>3LNgymlJDcfat`lX4W5#9zD14EeoHU=$Zj zkPaA|m?(gaj;hkU91A;E&>uR2!{ON@jOnP|yK-;vq&hk}vPDGp6JuhGob*Q$9v7oN za&6uq`KqI(l^^!dD)8%1D$wiWlT|38=*oBOx7G9B+Fmct5Pg&8PAaG_%pdN&#L!+g z<> zNanIqo|Yi7^Z(^f{*I!D#Eok)(%)?4$HvG$S?}5jp`PoDI5vH2x2ZgJr9eSZSo(Z2E;)&R|Eo&x!q?;!K1@CMx)UFgvTO+ zDB%qLxPIXmz|I%Mh&`{hoP08NyM>3{b)P)NU=PC_cg%cxANoCvSAHS%9siGZe8#(Y zRYPpxR}tiM%bFc_RL+}4)%gZQ$fFB)kd)37yL;asBpi3faQFo?_m|xbv%vknQE{K8 zJ-d5%!ENf0 zq;cOQJwt^T<~(5vLDHhGZ4m|bGc|V7wzJ-++Zzx3GtJIv8xmd;V!VAh=BKC1+8Zu- z@scokBl8$L`#?@+DA-_Qo#}(KCw{b@S&zKfgNra4X6gijNAk z(_&KM&%JW>StJcm6m940Gv&3F7*Gh(XAz5fUnmjttHkHrVho#aq^nw*>N>dWkzOs3 zQW8z7>s3N_)uH|Ikvqj;L_X^4E`k(45E+Y2uGTa2eS+6o#OVEmtU9^bHI;l&#vdmh zyNz_3nwpJu;?h*Ef~9W=(nMJVbMR_#D)!!BWxp!it9t$GVVXi=qv!^e_I)xkHhr(7 zSZQNqYpB<8q87q^$}FdQs?uW2k*E0C6qcc@mQ1V9*M}zbHgwNlgitXE;0=lFA)Z-T zTcq$wTtlaYM&vUbsolmlvXn?FHhOS0yOX61$&0>^MMLHST2mA>;7HWb)PQCNRdPR* ziSeYNG(%w&2GR5HC+@}fDlIK4NaI)xycpW~9(>yvDf6-Zje`I{hsg#eNN?Npa^D_l z-n4ADJbz)Z>|S*ffgiYo+nh1H*M{to#nH*99`z!Jcpk-CHLrPn3%fq@%^YZ$(@$m7 zeB(3Ng+WrgN;{)Li9M!7X1!cDM=nhYqOzBEqW7HfCI;d?s6u{@B50}4LiP`43lhfQt5fq6gPZ$NFC-$<3-KQ`+N%EjjNKAl5rQ?X(TjSs$>c~d z>V+e-1Vuf(G51fOKB>MVg|+u7-K5qC$S#f$y1n+w5%@48Tp$X7Xvof~7dq9p<4_v%W`TEws zpJ`lSc^bK6v1|7OAiP05aIvnagr46fQRw!M11;0S+F`;W0#TQu~YlR zVw|}aG3QYEqWWlqs+)F6*|93@v^P`0C^BYR-C{)5P?DGp)sb^xv{0{}nwPR;k_ z{a&{C`rR+u>P1>v(AC@jF2E4k+}u1fBcrYK!|ht9W^#nh*f{|5=woAJ?E#P>DI^3T zasKuyDj|Ws-eosVDw?(%fL)Xtx=yh(jw5m#bw7W)(umr8IeCMQiCMAnf%o4XtwL{J zk55i6aE#lI+u`3-$6i|-%7{fcoE~p)Fi=QRhyoyJ^dgPl!)PFdo5y#u+(gFBt#)~N zd9Cv^QUVPP%|=0fe$NJp%fGf2B_bwcqx8;PKIgZG(@&uQ}hrw!Da7yoQ`I=-p3b==mL zWy`*V!qaMuLEw?Zt!ox<*Y4D98qGDh?E^;at(?$f+HE)p6P1u)l5A;dQBPq%nsbMFXVe`Z3O#o0vk5q)#(AHN^-Zu!w;H`EaoXb);YI_zJmBP;9{zqGvJdZP_@V(uU@@+&7Fk>k&}~)ij6f!!I@aNa~~J?l~dS1wp}Pd21>)2 zpIhq<2Tvba>)v|rghsn)3Vv+2BsvK|zo`xaesGj*fR&GrPm3e}za?(E4;Uvk!8s7^ z$kCwyq+4VAk?->Cpv+}gufuq{%4&Zl*#;x54F~CRuMPXoFiNvk2;WByJvSPvg?pqI zB7aThg%7dz`)O%rwqEZWNb0mnaAxCuKzuJ0h0Rn)Cj~F5dd|IoS^ta9tJ_Ek!k;v)OMN7ePdub&_Ip3Ha6 zj3)v_7>eHuzeW8$jR7ejMhSIwb*z);x1WG827L#=SN?NnaWK7to}S*$S6-}vB6=az zKqe2G>$FUc6pu&G!g3EyQ3CVzQC7U3vhiT##;{5VcvNK$x$_?%J;#AWFtf7mtXj?o zK32P|ZaSB%vYez;5ID&^TOw?V;ItS&oc-1>!5}n?nNs~vN{~P^Xryb;%y2&4uD;Xb zK&g@2U0lDzlb4&zzKu0Whq4y&aWz!xCd4*#`R3;{zG$!KSlQj3-zkyIX}E(joSyWp>$|2?|RSiW_2 zJl);hr6WDZ>p=A}k>3)8`=%B#s-hqzEbO;^XV%tPQrfO=vDWp@-|)OA4W=(b|FK@U zI&wJp@Zm%I30;@&Y`J8ksR}du78Js+kcS+yIe~}KU`NRx2P=QgZa_OYI7p6){ip(i zH&8O>>7L$wE;CNc2V*Q0)JM6*8 zTA4>p8I}A0liP+T&sp6}>F+M!mTeZ-}WLPN@*2 zi}XTW=&sMm9xfOMn&8}-Q?QlX7-KYSm_JT_OqA}g6(kP3bt!~CXR4HP6ELLIB^-Th?XYGl zjR*O}FI=q$@%oat{HY4yb#OPWEGk&fkr|P`K9nHcOKI`(-%Wl%j^rw!%OJp8u_2yd zKVQWpPd0gm-vih9fMM)!a*t=Yb7KBBim8v0Ysz2Kr%;1nblJ1I@DocjQVN9WSm>8o z!mRMMnOZUXm6Ru5^T}NFLXGQIc7-?Vd!ztba+v?(#flHDyo+R?qdrSt&o0Z)n@@cH ztIsph!7{e9e9Z7kdSki4l{_S^j-(*&xpH zh5LWc+;g#JY5{F6t(3Yit742T4OJ`Ul|{TQp2D)pao-OhA+q*zPrYELwH{FL=xn>2 z;PrR;z7lI5TXNVOcEL(L7xRWjz%YYPu%%&$PzK37hG6U!eQlubx)#vu_eliz`hru2z>)?KR{_~VfS!IVKEdK`&YZz7ncvR`NrNVW>TZl#` z=TVxTy|;8gZtrP67HUph=inLe&arD(W4SBy@m+zIIPfT)9tYV?A~PUIj?kG?OM|6x z3w-|+@ts5aiLy?#h$A^{z1RXsD`H8Ao2(6lWm*{BxHr~lmFGRW@TN41KrAN-LSt&G zPLry3G3e01n>7FioWOh zTE&`iIp}Sy=LrSRD5GvXZe7wVCc?+!v)9Cp4bi_l6XkH@L*Ts=G)@_2m-(+*!JH7z5 zMI(Uyk^K~8iSR|MJ*^!Yp4ljI55};G7rbE9{+j&^J6&Ts{&f#OC+C=9&WuM`8n}WE zcju-C{z>Bd>z6yX>t1@?BQt|PXQ)zk{fxU`*Xja`z#@ zD1ZOFKCc3wJkmz6%{xQN>$3wq$kdb;fCeIcgJ4*4`WF&1tTu^n)`768ri*BPAzi*~ zrLx1XPm5xzKsoa_6`+I1#>S$OlX=rktjr%$APOI{%#*Q8q_T|qhuHT6dQxE_kx9RHVkBB#q}soYd$XPpd~|E0y6FQx9-a|E z8R_A}=jI&}!c-thl6!wS!f*KW3=FuQciX>A;nQF@B+wLX&zi-(rkaLhYb9k3nH4LP z`!gW=`ecK{!X9-+@b740D298`klpAR=l+BLpA9i(z$hpv%1TO$hvgLf^!}^7P}&VI z63$|I>l$*2R^i)mysEo{uMKPDYPI>2rZWG>67Pld^wLz-)VR-OS*)l=V@?Oi`bQRW zNHi$o&5$IfFl%M3YUFDX{-Q`z(P)SpG#P+`w0ta@l$Df3lmpGlXBFBR_6xOt-|D@S zA(Qn|%U(Hg#Ov5)(e}Ol?(RdmP6i=4>Yq~Ar=8srEj^P~+Tv4tc6ppO38hQ%BPung z+1LQ^EiAKcxC7ju$|7~UYZ3Kyjs%!mBVeA+QbaL4d>ZSW!2d@`#WLXua1eyBO=5XT&dSdAr z86sun%ZXbV!-CzGQMLFzc^!melM}_wm4h$a_N#NGl1Sq-u!hAPgw{Q=6YI+*p z?0XB?xTR57+;yzQlVY*V)8*2meO{Jfem+&EpF6?_l?;fqHF_ZryhVZQ4TntNnp#=K zo}VJ_h~{#P&+rJ#)$UFaXXy*9ev__U3h|5=uR}#f&TZdUQd&7(dv^E{K!s%Plb))7 zlG%eWW>FavEMxp0Bp#yh5Ewi!xdD6m@Ecbu7YOg`01c+=v~+i3FV50BwI;%|2{?o zbl~L+v(GbmVs-Hvs0F*w|qO7mKJ39N!+?W$uN?(wOH_zzvQ>`kKrh;coANIk|&rj7_ zA!aP|Ass-brQFlLK_4}d%|aV>R4i-JHrc(XP`WiLf!B_WGr4X8RIMq!5A$6P55yfE zE0XLHh~4ADV?NmV1wil}!vaih%D;dhkhJ-y3R-DP9`n0$7xudc8AdKu+z8qpbG_o& zF-%)u_4b%kpmwC8XkoS{CCwH6IOnr)!`d+dz`S!vlLhLh%ZJ}9<`%dyPv(*jjW?`|Sh zr>vv(xhYKI!-o&iK>v@$IQoM<*HMEn_O=S-*I@5T#-GQB(BbD66{%%$rsi264&ASv7m7tZmX1P98k4){i%LvUM;Z)&`?fykP#4kuWfmVL*QUuwfd9|4 zV{#*z6cCSDw1^{2V?&Qgo@$WV8-K>#chAnsDot4-_Y4GJCRo+^CUhD=K@F)VCnw5k zYQ{}=;rCCnDC{RVGLCx0i!r%`X{cmtsrvD(Y|((rur!XZTl&-nZ$Wr{tINxhy1J>M z>R!-a<_a-p65A3PM?1;8-EO@eOZUNc;ZeK(=Vtc-QojIIDgKfeh4Hh)$i$dHojb1|60DX$U0mxcxleu?)zR)vGNJS+Y z54s28d9CJzWREB}q^=*-vGKZK14^kJLUV3z()BzS?ZSh0cZI^!%-V2}S$#O?uIQgE zBOn8^;4fXlw-6*P^>TZ)&&D#`nEk~=F8eZwwboL~H|0s=aHO?+rI__q=k7%&Z~r+! zA?%2u@VP1y5fPENAN!RV+_O|wHe>Xdq*+bTqBKd} zN^5Go55&@FB})|#w!$Wfyser6rx0OQwq)1O2G z@YN+_+&g~*A(!v*vGZiL4YY0PK!&CE?DEXRFQMH;QZWapt6Pvhz%nzb9}0T&S=4%b zs}9vhp}(N?`|OX_czJP3!^kKt&%6Efh1Tr{?Q8GvF)i184~qs`@H#tRPOUX7&0_;8 zzT4h7)35*N77xTuY+PL27kPx6Y;sz$8Ot^5Cq7M+be*J&uCdf3auMog zTi;3x;nv`#S5WIzKOcCk1~TR0dJgoyX!<$8tKoQ-dtaU-dZ^q1!9karhAz#sS;y#B z0y44^|F!;S^L_QdqE=OYNbMr{ObbK0KQBTas!2=8N^j3o+W;tpdbWejT#`)ifp6(} zM#qRHB)h~G4K%yEfo=~Rps`iblu{HVB?p7W#Kjq5CQ?$tbzdEqj;C$nFV9v5%?Tf= z65U{tQ*0 zkKnyWwW(KwyxykcgU)-O7G1Rv%6u-p6Q7zz73wu=4e)F-!>c-0^Ai*u#+!5F3%%1kN*R8lDPAGLh5 zShOl6_fR|#vn~umEQ>e2=i7-O%GvVray62`A??bllkSWX19t+JfO$o({%F zMr)ma`wi@l$g+_;Va&cv1sG9H0z56!o&)?}gfHAXymLC}Qq=KjWz&C>)Y-g4nw=~H zA8r(s#Ia~sq1k)2E;OE<9l+p#%thlg2;%c|F)#~Ii4~zY0$uOr9;Ol_v25!v#ojDU_KN5c=E z{s(FsJjWGMCqll%`&kH z4ROD2M}u$qKIqt8PDvqA`#88CM*ryTL4x};^R8VtSkln17~bMGcbGnly>|~O7E|xj zQ1Q-I=QNq-A`2mY!dnv8?CzHrpt0Mfm{?{p29i!e!--e@oO>XnPcP(LB-&R2+O|hu zr)Cac4ZqYgd}(B34D&-O#SaM99eYo-Ym_Yve%Xr-%g&0fC59_{g8SK!^=o(sWU0Ib9`Z zoY_Lu3pAm%Rq5{zHL+s#p~CSWeKQ^>YY6d!|W0kpzH9!~ZUXW2HM?34sxKr)vsKXVh(xUt{4|Veo z-hFH0ii#2Y?w`tV`(1$i`)i@KxQt5XZa|?daxtREwt=(b}e;Xb$ae*9i;LtrzY z;G@X>5Ek?U=nFp#(~&rL5v?P>2h~5rp{eG3s#LPNv+EG}2R*PixZ zd^@?`l?&8xBzG=tET4LzGBm~Wa;5jwyK*UlQOfD#QhG5>h8OQ%U!OhGUk+J z{QUg7IP3CM09X6}YV4Xskaaco-TLh#S%6Wt~h=w zTWQ!xH||AL3bk*Ae<7?OkU64NFpp2+u2+qNYEgz|uZcz|+1o#1B6^6l+h$dBdo)mA zfb2Jr14JpytE)`m*>KYcCWnb)-CrN?F{z`4X%aOg=Pp{C1=+e}mJJ111@AX0gp731 zDKnohF1@wi;p=Rt1BWhjyaS1u$q}J{qZGozxuNs+sNt`ld=>9WjCkMtrfA800 z*L&60vy8khJF2gpHb(Qni>Pg?o&XayIy$BFxTnyNP`=n{t@aY*&0=Gl9R{53IRV!Gg@KUGN-WciI(X8Z$iZ>0RNQvk-71e^E~t+@1I~(K>z2A~H~1)208wyAD2_zJRv%sv$|T zQB_prq+OXWj!MJP@$z%jy6|nHM9IAo&8sRk>bujQ zDwW+ISz1~enOguL?9=XPAa^&y!pHG@GtPfRTP$ysA5cGiDRW^q_;RR=oSv&(26(Q2 zR5maQkPY3q2T}iS?f3czZd;X@X4czb=?JnR8p1Sn`a3?Fi-RJM2fHYAEG+|pphYUg zcOBu=gqtJXcSuRS_qV3a_IJWWy?)v$&8mgc8gZ?6Zds9&W8m&&L+CuV-O`XlfWnJY zIN0hMT?C<%x00qQh&D`@mu-;O?w%+`=|0GQ#_#T#s^cMFETR@lNl8f!&>HMV0D}Er zjSVX;gfs2kyLZY;uPl4cK9GG{j;u@^9vwbsngi(c0q)9|aRaO)cNN)0owO2@OP?tjv!9PAD~4X3?BbE^ z8AD3mL&IaPrKP1&cLnN%oXBPaK=DH=Teo$sS4<&?L?r>*%>ZR)uSz=Uiz2z&XIucC z3`(6uew$Lm{zR$w4>N$VsQo(@O zUSUAw?m5Gc_{;L8_)bP9x?R*EiMIaPn_GCcxPTiI`Wij^V}=E0 z-<}?626}q-r|>X(gv4XGH7f%0sDK+15P0kTzbtqJ)mCbit$kCMLU6QKHOh-DRtiseq2gJHS=-=MfSkBUEoiD+ikPGDRBu21Ye&Qo-I1CvUmd{x6}n@m~(j;!LxiY87yhZyh^OpL98jy&j^;VmR#$rAs3@#3<_hF`n#)e3aR zNKYw{t^lId(xTKgL{doq^hp@w&YkUS7Gdsw!a2FvyVLlU^7T10ZNfYim1!sTXUkfr z&xWCyBQ`Q^iRkL$&b927OkCl{FRPJVJluc6*M>OMH1w7%O4ZlwS1c4{?$r5>7XMDV@}ZAJ6>o3Yp^)sFN$^rPIJ7o6Q9r&i7FI zUo|@qJ{O!2%tgI~b{}N{k`h)xFFE{;ACiWbUpB5seJ~4jp2@E_C zr1LM@LjSW*vjuv32rW1?Wchfejzc}olS)@>s_s^(Xx(zfL%4m5-)nTt&(LZ7^;mZJ zBNCFW%7*8*c6dqjgVF$A$5ma}zEjlWnK7$O0#A{VVukIwB{Qq~Y51VBTrT{8vG zt19%gl4s{qFFET2Y%R#S79M4JGWLm5WQl{DTa#8cLFmW&yLmd2G6!T#4$&g(|H9%uevYZ>`OZ2(40B}OT^?kHnZ49?B5*4EaVkHh97j!7`%1N8=? zdZx%5*GJpT;Tu47VQf9tQqs8sOYQ-I$vIm`VE`x7mH>H$gmK$t)+zoMw%fE-_4?SO zM?PnE02|qGB`X!{#5Pp-eEOf4`o5BHHceLw%x0PJj$qsrlpekn3iKiYy~iEnIrQU+ z_h3U$&xZF<$lE}1@E7rB3Z(Z(3<~^5F*EL)Mf<><+|>Y?bf@E1X{WSe#7T*u{@bqA z-%`LmYj7Ac(Z^4?;83jliA+S?c&7d&Q-IzLkCb$KcJR47-UDEq5;=EWAVVVjzUQ?B zvUwW)KX6b~beu6df6ADuW;=|hn{6CrJv zw<0bvyH^*_x6FXFq!JtH{%G~O_2^23lu0Ox!(#t(x_l}C#Vfj;gvRTfu;yT29i^km@!a-*iHZH`V|rjR^e zHi9{QZf*6hD}Q7wjubr7APpdF3}_9$-FnY}02rUz_3UKT(fZmu)_+(D$SS^&J59`R zVL?GT?>C?ez}Tp47R$|W)?RqK_Be%4>b+ID2fv@Q5(7Imb-T4TAaK{GHh2kXt><>y zP;~=zmGEDiB?vKf&o{rL85@nFwst|giG)O8Kb;UMLPJnCa-uq6v*t8>Ey_5Dp!XqN zteFM3m0qztEe%bcE1En1cKPc&^EALs!9!OgW94u9qW~6NVWmHr?$xUm0)pp0Jq$VQ zJdemtf9JqQFF?NKx!?7G29FEhJL8u9Jtoa4UDJzMt|xh7S0Ph8hjY3yO$z>>+IgFQhS2&qK zyG=?Ks?%NeyUrJ@&|*}#6zg0;MLpjW9jA}Fvzj2 z=)VJGP;tF5`Uu-w>#?t2zgAUtLzCDaimqLEkrU=HTn=UpM>xZt=oDy%PfzEwR5!FSsI9y#Y}Q z9+}OTFHKc^08?ZDg@}MhB^z~4tBtNDwhtco#>L%NlO740Z~*i~ZlZUd=I5dh+wi=Q zVe|>TZyJMVBbdi0W47@P2$rl=3lSjQ&j!8=f?htyh^9+jd7kym3;BcRe>Mg)0n)u` zRuc2ZA{okeX`R$?${=m#9N&6~5Tw3pCw(xPRA9s|F)=sKXUyVWcu{^;#V~=f&me0*#WLgB>!@JzpLBZkjWuQUxBq-`z8I zMX-2d+BQ)B?w>O3k9SH<)eTygtfCdgtPDp>!waKjsGH^M%wu4(K8OttGuEdmiUGy=<1ZFP>4PNWT0rdJ?eA%7 zn%mt&ejW`aqGZ)V8AQ{(WL;w7oj19eNHUQR2&=-(D|*rA%K2*H zaeBetks*ZlDAHV)&=Uc;a4J5)`#W4>GJ(UEkG9qb+`Js#H+<>XIwDw)I%&#{xU)hi zWgFpDV)FX+r+s(Isnn~ZqIb2qNkpeKJu|$XbHAy0gXcIx0w zz!zdw7|~Mj2sht%FCJ+~OBF0R@}F>+Lru+vvZGe zye@6$BacF!Ku2FQGc)0m9R4XlzVlY5IU7_|QW6i0&i3q~-DlOI2dYetnY6oqiiG$p z8DIXQbwP7*@W2a}R?@K$=Ek(($9wK8y_uzVv)|-XuU-usH$SDx@7yf~1oWC!mWk>4 zxK|sshW?EpJ;A=|WF`4-IG&R|gV5dYuSKr5Xio}^69DiCfJW<8bwK@l+e^g{w)5tV z;||5@P3NsBVt9Bn+ec4*&j4nWnx4KZ-&7hHQJ=BvBxTgE%p(;9RtJnu${{61Mp7j7 zq+jPYCN!W6#86@a3t{v+@=6yva4)VL*bJ^r(`eb`{JH4QBf?J&zaIW+E0vJmdt+8T~4WkEr~Hl7*K zxvwP4>`J~r79xwgvkH4waU1>yd^Kvz!E zPAq5+(~Tc@(fgclFYcfBRObM zlaVxJ#?b@kD@syQOy6!uTbqBdtjDnH5%-H#vg#)d#E-AWHBc2Y0-!OrU8Zu8v->;*pnwj0aP4Uy($Dgm*jlb8T z4=W@xm}N=}#s}!8jdtzfKZW}IjQx52SA*%&Oc7dF6Lt@XzyT=q-Vy0rE5Q8Gutg^D z`vS3=IG6{%n34J##K4;olWDBdI=p96O+mkzFESbc>F~I z)FJ?kXk85si7Xvl5qR0BSmk(7%{;mNaEs%721GMxT4hJF@~QWkYs)SvZ7ia3_nAN` z0-t>gNvz+c@Ep)%$T}JHn*dSqzrp=g!Ang!ufF7Gu+!i@^xvC7LJ66CTzK>}O7Tm! zfKZw@hpw|HS;jn7^JT=oYwN-KZVB0rLmLdHP;`_zQLexT1a>_UU<*3%DSn+_l@1&* zJ{5j)ZybXnY~*zrw#LkC;Sd3CMg#JQ^{Q#>@}#PHfWGDfoYH)IP}3xprs;HcH^jNy z`8PJOriMI;f0_2~C{5h5SHtcKYnoX;zT5!#kKA$hY`RGpcc`QEPp>wj9dXn0yXdZ5 zNCyf?x4w%?-^tV#Hd@@7tw)KCQanN16l`m4#XK~ywr{)ptP22jC{WsIKsHhMvQ*f* z7JmPTkX2dW6+bRt;qOWV2}ZFXX`WS>c~8p1!_~3;9%;qT6Y-sM|@Ss+q;Jg1(H-iSAgF z6&XN>GApof)YsFaEc0cH3*ZsSkxD2GE`kR;BPfL8f#NkWF_96;%h}nPtcZlyUu>i4 zeA@RKtOTYfM6rv=~BGiL|!TP z3`T{&Tw5)%vBdGDPy|TtOw~F`RvMnIo542gieDSK+ ziVj9TL=)mUS&oJSoodBRp;RdzAE5W2@01!%D_7>uMa?Xpg-MOarDJ2)=bG0VDfxw*nC4kVOXe0#annH0hfT1HU|D}(C zkMLyY5AVJ7PqCByKBO}GdZW?ggzJpGU4Mz4%IV$RyJ4Zf{k{+w1Vlg(>Fy2*>F$v34ha!Kqy(h9yGud@d~2iLd*8fw=gge}hkf>5 zd#yje@B0Z1{QM4o4UD?PsU_odcYvnWeVL<`grJkW?MQjlEqLTfIPkAbO{nAdGjcmR zcv6n~cop2qHnCLJF|+c+>{?N29+j;FwSYNGCT!Re$<_X?kzGjiVG~yvTSyKwF)!62 zsi77yEbU~d)X8Kkt~v%w>sJXr;cd@2&cy<1utwS{$M1*)0d?Mp*<A9000A45 z;FlqKc?!}51yq?BeywJ=dP5a=LQg5i=MAc~w6w!`^172mThgG-rpBwPDr|QNb#?h` zu`c{br2pjKpJ=?a(@JNWXyp*M%)Ns2`~Don1A2!bkwZ6|yGw%jxDOWzr1$P#On zfz$uFZemL~)?PdUOCJ?F$IVhLr3mfk>2k>&sG>AJ5#`iJ+0pV*kOT-okZ@!?5-Vn` zWGlXOKAA95^WcV2E|k6ejq_=l$7C`j5mLgUIC&}m{zBr&1vl=^dT*rWM&_G0HjBe1 zmkA~4_t=Ck9eSn*YbReO;x68tM-X}!Rd2gCY0?MffjYtn;HAD2||{BXp3}7G{d#EU28(e>g&5Fx*v!>mS{wxYqs>v-Swq_uaQzTm13Pi=Y^q5N zRU0+oAJ$7>3RFGgUVe!x2ery)#Eam3df|cc>~U-S7c!_m=!Jz8CST{-$S8c($S)#Y z^ffkwysd^bYbfLvJ{bwysLRb8U_CN>IV6u9$MpgV@|^>XoJ4 zpu@CzP!@=M-Jj|};o_Omd5%Zg-^8cPf5|brDE{2$&^i_>2?AWi9=8~S0^QWx(352j~2 z&L?|$(zZn(J;p+oU&RjD>Z?b4d>!@ADu^{Z9yxkQOUX=Pr$7r>AbZfAUG7CFT+{Mt z6<&b=`0yUVrwUF+*<=fa_~}Ka56)J)d33xrqPTsJ#t!W^1Afk+prR@b?c^{02GU7@ z+u#unHitY4VxOJVtbwuuYFloQI;l(Zq5kye9EqfG%Fl+-)dQm=}U^SkBU6@O_UU7$Es|CXvYR?vkFxN)^rc__31I zT+^ple!>)F@mKn@27_NtG`1sE4+u1oe?VC=XytnR%jM)9W^0E3L z6Kr7FFlu`3|M~d zqpz$t(j+8I>$3b-Ws;RwF8h~i?uoA!9ApRhHtPD;MME*l7?sPh`<-#|YJf@YW3MWQ>ZBJ6^+ zM)`%|ss*`wxDAF`SI3D!pkrvME-q#5JaIwl@ns62SWFF>xG6wodU5IW4y5t=w-cL z3?lVeI7UN5v)e(gF_@8d0F~LKtP(S-OT?}@ zKd4_kc>UykJ_mh?awNx$&dc>kMIIcmaDvwh$21Ogvy+*AUcU%m7}JQ(vuBTOSHCjb zwJX%?9ma6Xq`i!kogLV4kgcFdr#W=d--I%1L8M)91Dkido35$L6~2uN?bl*(*6(W|VkPBb+nPrPUkzP&Quwsqb( zyva4{NS>GXVZ*&B`2BSQgaOj;5Khd!O!dZz)Jwt;yR1UI z3cp-3RWkr9pNBA37Jj{2kzQpu8X(Luo2-@!B1hp~{-9lH5cE_pk=L;l4x-dTx?JOV z;N)4{&+UdvM`%W!$!nD5LM!Yf^Yy>a%&3Bb;o2e^#!iH-Jbh$+$J5sXo9cDz zjx=OsLb2bL?OZ#S5241-9v*E)spLKF=C%!{ zVkuS;urT!<+NoXN2Ldr(Gyn#2>{r*q9N~q5=>*Wy#h+=2xdHQR)^(4s3_BxVV;G3) z^$YxJ((LC3+9go5RWeJOy99U^IY4LxGFJE5y(?e6OmaIX8l+9!2^=`q)XWj?k~U{1 zsjg^WcObNK0-LBM3-TAkTl2bLKVb)kglr#M1>Ov(>zhLBnqq9)Z`Ell1r_U|9q}>e zT7c9&506^u4Uf+L&;~C{%g<5MwAPG#C{SNJ#&^!sVsQ9}d#ykXc4?Poz)K2mJ<<6z z*WE~b)>p3)*=L425fKpwhleSjs2A^_=b4$CtNnmi;0_1srLJ`}>W}dBZ#Ix#M$Ko) zbF0V{*@5N?D%v*!{PO(#NB6(p=%>4`Y&E?B_?o(=$6?X1rW6DpJ1E?I2Fj(_?`YDT zG6D2?vgk-j|LuqDY*9twp?q*@Rzh)Uhj-4Yd6MxdY&Ft-$xrDjl)mKdka0zdAzT-m z1(9aOK?`?k_CbdX5)fSkFeqB4j$jfYbfO<{EN$39kReRGxR_Qlw*O-L=YyhEoJxZ0 z7WlZ`%Z)_EG9vq_NX4|8sS-sSARyBc46W)w&!Qq!E=offln``3dodYmQrz{ zQ#d(ou>7=GsvWQ6BM{qmDILP~+9%jQ;0pY>Kj1QyJgwtA3QjyKDk`yS zLwpK7jn}meSMV$i0jzt%;F5;02wh^8ofBy@O@4KdLBfAJByIQA%5&ex-%q{RkdCat z|AO7cS`tO221x{gve@2 z+xH--SRKVW{4z>8QBE&4IoTVuj4UxMEqF@h)e@*k;XjyYNnYvRXm8*O+KwsK$^~>6 zhV`%;4)`0=n7T25hj4IkV6r*$O$_n~f=K*=;0WK+VIhfxxkY+qJ&v8^y;%OxkG*`{ z+oe2ba5eB?-cxclU6D*?Ek@cPff=g@f#StQ*b*z)s$9Y?7b>HXMdQ~B9Pk)HIl0j8 zm5Ha_S~U3>Pu%KYim#`Dbxk9 z%|B(SDF~5rwD1hPbqpGyf|Bh=W8*?lLsHqc^2Tw<;DyKg5vrv@!j+2~?I624XciU` zQS-urfyOgsk$ zB6=k+E-*4iI@c6)B5YHvb1R7bPX>zE0Rmv2zL2M28w1@kz)PZn1Dz?fJN<{7g0Vfe zTVvLf?5`>w;E$5Y7{zzP=^OZ%S`q>c4Sr%a+06p61l@564^vwfharyC=8I5>M;1;q zNQ*B={z8Q$WAO2ZUt&#hzlKuiiRCbZAV`W~K<6c>`%&+*>;piv;qA1u9;Db!l zlAeof)JY7M=BBq7>qzis@`W1q4@Z8vm|BObeKfT7z7=Qx)nm4#o}n0J)SzWwpRXH< zHy4y9s35a>_7I%Gbk`L(UF>}`B+Rr&i9w7Kg?Q%Uag>&p3Nfqdo|lN15_Vk>E*5HK zF%*gjSXd%cu>vc418eus8y$n-O27GJ^Dso&vZt!5`5O*dtyMYper6YxLbK;wQUqFG z1^Q&AmI2jUyvy3$UjhdU>zyA6*X>=X+lb1^u8TxoWJs&&43oX!V zMPV1w{&Vnkl7@vO`3@FN<3~e29s0m;?Utr4mYmkf?P=^$y+*<&*# zhKJwR6GVBq??fI1w{<=wyk_rDD}eoW`PEqh>dkrU%U>enBG{&6kMa1YQaNE$ekp*pO(zN5L9rI)@m!P?wgV&RJUTHQcXsz7PQxgYWfZcq1HB_o^+T#UKQ2bm0U zk6QPwNx;4x*ZcJ>%7WdBFSf$3vQpfogC6oV&)!D+yh0HU&vX{zlvGlR40*_{3`Fe8 zaz`J-OB8>r+`;33FX(6{xElg%@qw8cttt|qe!Jt_kUKs|;*!MPha*uhY)B$Gt1?Vhixg>B(<^NflpHw` za})~ojry%cE;Zy$hQceJ_|YIGybTUklcrupW*1Jq20H7`LrGd+1Yd-g0+v;+`cK|; z%I=#b>aH)Vj>A&{#MZQCQpWI5>1km8Q0cW7Z!Vzd>Lo7RkiAqEDj`}~)GfnWcr7K;tz&2sE++zo+Sx}SG!ZS5I zQbKWCq=rClpbIc1trgCnT%Of8~#E{T%FxE{{SLw{u9(Dhv^X+K4U zHfty;)GlXI(CO|gq#w1^JTH#CC^oOn1fy@t^rEmA9b#47`PdW92lBpro}`ub<6 z3dO-}wD3F9zJ`|)U6q$p8oe@`d93>&3Bi|8>lvIdjEbDjB&nEP zla&DDR#vIz3o^~dFLdzBON=flm7?X4=x$2xK8+u8)Ax`tTUn{8Uw!k-+gMPHJK8Gy z7zdDY!}6z9pfSKi-#1~1ZH%%l%C)MVeP!67Ct^)pgcRV}mibw*Ix?tK2%E4#d$ ziAtQlon|-mXsXUKUPXb=o++TU`PwGt0sD47ytUePmm1OO+iv|D@rsa)flr~%NX5dAEP^=2oFtmvu?y z*=LrTK31j{4L|tjhdysf;T5ApI6FW-uOucW2Ey9HycJdQ+cZ%}be{pcAnF*{*TmVOngB_hGF%?GZ?Pa&mfIHl0;X zqUi>Zg5?vmDJbZw=q8*Rur%9%8(<#^tCmi)fW*g_fj)1MV7_Zo!06C~wHvg&x-r1s zDJh#tAaS6`Cb1Qa@d!EfVyf}o^IzV?OiSSBFma|LGf8s)$yqUI94U=D234qJFQZ0AUr!f>gdtf&x1t74PV&M&XlVOC*IIFbds&2 z=*9Y5#RpPZ0NQ=6Dg-c2>Sa3gpy^!e2HFa=h3Au|W%j`cZK}*j!HQWkuXU9IYSF%{ z&>LT9O{%(DRM;;&0%8py)kx#^9!@_@lW!*1`LoB!fU)IU7PETL=GziQB?Ei0%OpDW zGKnaMCA4(U%mn}4sDs6H+9Nf4A@#NpGzr=qo5Z{v6&p(6mmhsv;*KeZDJJ&&Ba=xC z`R=6`ShvVVqsUQ6ci z87{Z`tNN6DHHO=_*+xmoCzVQ2TBGm#gft=k5ehB`l`a!0-zmy(w-BB1A~PN;?ItXK zx%acGpT7tmF8O5nt}V4S{L8V5MS>X!#$LS6VQFmmn!{pkp|9?n^eWv!BUJ=zC%1)s z{~wSBD|qtMcVA51-Xb6c$u8nxgt5m<(%1pP>TX{Qey)7Fh;CF<-h(&h6#i`K`5M(i zT66UuTX+U|k%GgtA9;WM+I$D&yfD07fAWIz-w9(JZJ+~iwo@Zmup#2{39s_@` z@&2zVUYzy(?xWC;6L^)CFf?90RG(rjGDSp0tQ+yl#~S(hf={H?FlAzgGBa%+<+lrC z@TpDt{BkiH@KuXM@wr{;=gw*tnTmp4xi|HTKYiAE)ZkTA;&h^Ov#oz(eUIbEJx9i_ z=+n#DQ*<~uyxxxe+%NG^GvpiWtuU|~(|H~H+S5`59@3XnT`}c>e$+TH<+edk;7gjNXGUc=!*FT ziUr5@Q+c-l&JBUaX>yf)bPLeYHf-}px7i+N2BSP2CiUw8kpZH)13+wnt>U7RWxlds zP3pMO45ocJOB!Y)pUZcq9fl&5IL6c3m=K~8Dw?s%G#5#$RJ5&lnmUYMIt}#^T*PC7 zx>(p9oUh#Tj3e&yhY<0q%csGOD^d_;(36TZV|?{&SbvB3cwmKH5Lp-(NMO)hg-<;b zafykK0l$as1_l|zEu@o?r!Uk-<%=n5#&jQF45eRXJAC4K%O;`F=lYyu$0F}@p1r%n z^4>$<<-%!~AvLKGTLwkc)GW>D=H{VUt|S-2Rlo0Qm`#`sa>3`Q5Go2KN&&;BC?yd{l`9&j@Hp<8IqH|Y3CFx6qcF19Xt)QPq3Le|FZtER zt39{p1=Aecg=l-}Yc^N%8gMef4-=$t(3ViU{e+HF61Yt=5q~FJl&0UpgkD16F$tE% ztsYzflndNyEV-<}kF;jZX3Pkq&egy!>fUfzYIy?CUJ?9P>A+@ca0;we1e;q%h_diiYLUM?M2VUf43s(V|v*HFia@qW*q)77fn z(68ykQvL6|8l?0>z}gYUIHP~0@v2Dz>C#wbb1hEf^5{lPaaK=Jk*~p8q!WF9erO8( zSC-85*CAr%RI12WlFlp@-tJK2%am1=cmY2nm0Ts8^F{b|_y;0D0@8VVM3?<}p;$MU ztM%(tpJOzB%gP9O%^Nc|W$|L}kN3T;BQG-~W_~TPb~} z;dpaI2F!Ue(7W+Qac8(7I)mdUHE;xRA4;-;cGX9{*ODcae!CHq7wp)0*5V$_$9S3< z@@Jf20N z-`P9mJQb48{S0X2L-vc09#H$Ia08u$UmH;UmVwR243tCZpSxJ)q_rf!E2z^7#xC?g zuGhrUH3*e)X$=h$St&=>$IQDSCktOc#_iUs2qNIDXc zz&1dbvfN`Xu_EZ;$eqS2I6I^NSQ%?;woD=tJIz<+PO3Zs#=C;Xi4R1*rTyW1fA5e1 zvFx@YO4r=gNnLKmVmwb_#ys9*O+e|Ea$Ecfl8E6eR---*%B3rSlrjXSl}j{?M4)u` z2L>va$o%(>q3%s$T-;n`$_+%3vzHwWWC~Q;+vU?*jpGNma6Z#a@4JY2C@@(Suu*u2zfa#E_FwU2-heerbIw#iR@pMCWBu)dab2jLRl9PP!2 zRIcf;HQK9>N8UywmqeMb;dj%NdXQ4cPS{OTqGF3iD_Fs-gG9AMVWqpE=hEP4SKWrH zpCyW@`I5g*tRCmGjK(7tcb+j!Szs^EUWQsYtR);g`t3)Su=fiQ*gMLBe)`H= zNC!Js?3RU6pw!kQy%}Xgk6kDFziJ6<$ zA@-@|PMT$mHLgCj)&Nva>&3{*@DtGRV4KIr$PacGNs0gx(8F zzU&It8LaY_vEjUS2Ov(4^?G{a(R3ojRzN4@=&UuLQeAHRVWy(2tg6aPzA}KR7xJP7 z;2zloLeiyLjFEnx?!^P_OBZ#(-$?U6fZ#67jhd?Q#cA7Z1T>z)%?U#+d z7@yEYiOi{CWoZ)ke`0D>YA45F>ylzs)Y0BvpW2Ay`K{!6gs=;Z+8b5^8vRAI92+3|^ zFo(7*@0d|k^vg$({jj|Jf(9ulRXPcK3B%V-`H~6mmF;Q4A_N?O?mX?{jN5Z-L&Kc& zrPbJ{I>uJQ_ha*wV>0~KDp;90I_d(8D8;=@_zi;l zC5rs=QFWM(0$?bEl76suYB}b~#!yG@R#U6uM8n4%w}Sd{Mvq@FE1jx_QzPHKVexQE z3>huFS07b}gC}f7RGbP_{xvh5d)Tu$kgaV+Y-}oZyFLM>2{pcRMC6fn4Y4@53W16e=EM0)v=QjX<5&k_wj@sTh$`xD3O7k7j^vuK zQ*SAJF&PzMZ4Z*)Dx|8mDe`-Ip^#}%HqEVHAx5kvG1l(D_XgXKM%vIN>r+GF8td_w zW2fsn6x3jbCP_3dJEe`G=+V&|Xqt^M6KC~Q!?>(GJD^~0RZFx&t6|*NcPra7Tv#pI-OA)0?)xJV!2uivIGOEQ zpIWJ{2D9FX=#JyoYy09d(O7Z~UczYMu2}8^jo*eBd;b>rqAM#rcdNTrMj}?NgF%Ai zN8g1)6Yo}H67k%BGIh5)W@hrdubXx%BVB%{dwJD+Ox5|T-?&L~&!@NbCL^@>TVP~p zcM2Jpj{OeG9auE_ZW3{VunYQlsX$3q>t|mA83YS^6uFri3mxpL3ilZZ-RHUABYomLCL6v4QH%MNC_hV0JIX44cwfbNwqvB}a72n(HPP=3gf@v?&gNB-+ z$s2R?UGU%W4HV*B&pOd~KcI$G{#y8TTuh9Utd+j(ShZU!FNTO6b$1<}dGzO7H%6q= zE!w+3c&N;|1=+l#%jGxH;EJRpX4K@hr*-@5CUQaHYtoJmxsXPK&AuYYv3TRV>Jx@L zkzXke4v&TC6V~lQ%$wzRTFFLeC>hS~I4>lUMGbc!N47K=>ktne6FdDgCB&-=S~aTs zEgfWn`PJ2`sPdN|3Vi$@>d}vpkDnT}cb$j?`A{CPv)5i7Wh4b_MxFIj7PE*5o5;&# zt6Q(j*1krv3(T@GuN|5+_VpwD8_z9)tMY}7pE6`?I4TR?^#t0q*rH;$2M z`|E(Kps@CSDhf4$i%9dsxu1p0D`pkz*lLmGC&P)aEOwSB<&6Rl9{kxjuc7jkT*u&= zi%-7a)W1N)Qt92NK{9(!B6D4O;w}d#^}0 zQ%Rj!_`TM8%em$_!ro@!`chI+Xba24c~*ZdM=Nx1juffw4<|6cTn36o`i2y& zaTk9D_(DO|d-8z`za4|H`fcr#hai^XrAGQ{Xz z9vTStlcWA*mTH>q7_WG#7Ss!7n&oebq}$QZ|ut@ez?O(>;V?>(Q^3W*uzK zq`4Ah;&Ag+l-gSDA;k}Yb^{fvjtj6VtvEFkGtZ__9rFEPWG1sMlaI7}JKFpIhN{6} zKe*4A3K=Zk@HW2MHERjw%+tusk!{uNlkFW0s!2UT3W{0Ze)dSD2A*mK#sC)$xykQp z^7j7xCeZdKJuQtP-Sev6n4Zp$ZnP)q&htyB=HCeyIQj48L2_jOikKVulVHQQ;kje; z*+4~0NkBV?*n+1-^kZ(9F+gTQpB8h<&QaNa^9 zLm5b6+*X&ClZyq+?5_h0)4!#cpxP)oXvE=p*V}TzD2rqBabZdYcVsSEXG0lSO4dSI z5)vhFV)o(Ickc(8i2+r}P_*ICt8$vKpI$m**!Vi8God|m$%B&{>x%=L{7NumLnBiu zv6{H3sKs@~zi}UMBfh|m5PmCG@Gkdj@r(FubeVHU*6ozt+n7&6PQ)~aF{^rc|DaN< z%1-C~Lqqq#^I7sr&H53gn^ozxwL?5EGrLmqX5V9Ks+wg~oJJ)Ae*Qg)?%?EDlsDR} zyj@;ddHl}!vwebvY}f8%wGkm3N?!3CY2k+Krc9>Bj+&67nCh)N%i=rs?qmAB_U5Nd z@tiJglN*N_PDp=TQG{R?WEH&?70j2v6!;6|lv9e{eI2<~Zbu&2sk6*O9XXw=jVezW zxHsA?8_Z?dP*9&#SG7_4HSM2G_9vA^_XxF}6D!0{_!-vT({(g3X@jW6j(<;;hL0ys zIw_78b+m7p>FYe|IAnwtO5unbKLD-S0&0fzgF!+r0jHhG3t0T_RBRl z#y&`*_6cd~pS@2YXzZwO#M%f2WKn|Hx}h11yeelpXi;bf$5X_No5W-1c&^vxgQ8^`rOn6+AD*52W3%Qe<4GR{3uY^bf z33X+0mcG+_YKkb@(N_zIgQh%;9wZy{F+4T?IGMKPaV!NzwP`~*=%ey{QAAy{GX=`a zLDm(2I6~k`d*Ij|^V^0$KRB$h;&viezx$efEZl=|iOCD)2e;mg=!`w(8->7KJX_pez@C?GSGp~YFUy$gDM?3=WH!N9qgm#UsVX{xk^%=QU& zAaOEBLpb@7TGWUkm=hWdj`67czs?Su2@(aCZ<|jytq~T^V-)LJP^qwy#7XVwuZaNk zK2vUrR+DT6=?YrUAX-tWpjhH`5SM|Jc7gS8m;z4XI9OMc@VDNz?&)|ZzVpMPYgjvK z+N)=A_9joMFJ13R|4I{!nyeQU7D?v!>LfrPwP~G1<>Vc8vN6wNC-eB@-2eoWdS0Vf zgQROuhfGnGfLx;L>zy(XGNo=fIG=p9#MA0Z_>?q&g5TNhtcsH|ftQt2 zJK8*duOJ%4E3vUSN?Z9=#8|t|bq&Yg^>+N$Wo2cDr_bFCiht|_IMts>#T1rLt-Z8z zIM6Wvb&wY0-8rW8bDrA|h1blnX|pX)_3MRfODF;#@qcl(us`bhG?^F?kuklUuMT4B zf9^;Q$X`_#NM4OAB(5q8yrc38824NM+MIzZAAl=AU}L5JxaSp!B$D>&qH5{+NJ@0( zVzNLQx$alPO8L31K53H><@7h~0^HRZG?PwzcCvL5vt&^*GPgrMfE0g7A?`pCXj;UvC4G>)VPchrP&9Y z-G5ToNRo5Ii&L#CD2(CJ?Njajq5s^J4k*-aQmzBRa8R37_vTJ@y(j6ml{(0BUQL&L zr2T;pNMxwZ0?P0ZbHH7qC@A^$#~`toRDb@Qz9*g$fTb89-Q}3r*e=tu57a=Rl!<7m zFJOP)%5cZ89Vh*7EewhkQDE=)`@0(VL2=^A0qUI`)wGE6ZpQ4wi%Oto+op#B28-e@ zstD`@T4nUxx9L9NX`WZkV6qXIA)rjfZ#_MjBU5vcp?TnlM_8P!F_Z`ZOMqk%2hv?7 zw}#G$fPZ|aQyc<)hWsI)=T(zUcrwY|9zy`R|3MwxkC_oj8z45+Bt$9fwQ0%(SUcvQ zUkM3$y8*S7?oAVq(yV@Hc58c|!9f^`^}kzN3Dj13oN2_v9zF)efVy&RVK0Z>=?Ogy z4M$YH*Ytv9vXPc5mS74R?xj9&pK+&oSf@Rodz7=M%g4XbEmZ5Lz|Occ+tmmSPxDsv zdn8K9%@4`h1KAp)6R)LL{b?m9TWgCwt#9toOKXM^a>^g)Il}I2Kpm0p7n@UG=PEd= zLDz4v&ho{^ctzHm1a^V2bf~lX`_mE#dyQy+SSlz8lyAGVEI&|zqCsRSs5d;}Kepht zTPFntnrP6CEI`QeM!r=jY3D953)P~41|+RAaV9%Gy&M3B>w5%Z=c7=!$~ewwJ#1n8 zXRAQ4G%&=lNogogA->9}Um8f-4HO!*G|e5IRrI)Tpc7G3i?jFNeUAbD z4&4c_!a}vqp_TlPgoj&P>tH}Sq z=DE*O3Es(fbUrfq_eEmvg9kvq!XicZ=Tg}FP$su`xH|Hm1)K+A(aj4AL4<$*bRL=r zIlIzZ^q;kC0Y(b_Ou`G{-#=|>1mEzXC;92Ww#?fLIAenSa0J9Z4g<<=9lcY98v@{N&76O(q3Wt)~KJb@kH8p9cxt~0P3b;L4 zeD3GfV0OJUnD*AQb_l~}BKHQUTWAPO7!mL2Pm;O7mum@^ zH^^;gfq-yFT}o6)HIguJvg%j`TCIkr`F3n+v_0_Pi;oQ?Y% zLr9ul=igJ8=Kpg*Bv8NI*vsM!Yx{TX6c{K8UQUr?*wTM~M?!@ef%F}ecPn*2A>lLY z`_bt%X_Vu}0Lh=&mJSk6I!MK;ec#l?!~l3T7SJt;joT=xo5e290$t4)Wc#2d)gy3q zfRVg#wZiBbIglmMlj=D8_!po?nxEJrqdo{l7+om?d}Y9Kr2u;6<)qJb%*{)T6M%9* zEfElI6ImYncvZ8!x|($I<0!xjC*%DFSo3%=&GcENLC`~fxAE2ZI)OQ>zTS^0^S34# zJ%7m5TP^sse}lc1VcS%Y5dv@y^U76mVPOV>i1}#U&%ZNI+V&ho z0Lc_U%E8j$08X10$TQ$}d^q1M^0_=SB}Bh(aDKA$r2L9i=)(@`vtY;X8Nl;%bDCLyfF`Ry-YARh{i`?|cbX+k^39kFOwAv|c^_iD0~ku@khoYQ>i7F6xMFiYbwPcnG*O1jZuht9taNSGa0xqQnIsNQ4v9vZpcdGjs6WpyW3)H0%ORqJ5>Bz(5p3)p0P=ySdA9 z4!I8r(pfhhD^)WM)V<&8yAKAJ79{O^xW;ocf22g<%*pbfws9#cE>$RSmr(4K_JC+EW^jap?-O>J5m(?LFIiY3=OFDV0b!d&AFdG zhlG_z#&z-E(2N3ZB0SC7(-P4Lkq->6f@mz8Wvj7Io^~T+z)3Z>J$9$LJwJ}6ygImd#l~3KS&Vi zP8)&tN9=(q=mX@U>Hy&}AA!=ZQ$YD1Hj4nBkVa5%w;3oN(d|B&=FF2%tsMWtNIBmF zn{USFw#l~Joqh&7j7YV^$&7O%VKY$(K2ey=X2e7xFQ&CWT6P7^g-9R>NkVdFq-Q?> z^SL^FtFJPuEW?pPTFUj>4CY(BX=Bk3r@?>%^%Ybxenk#!CR)S?$Po^x#s^R+ zd;YAL@IyoaOlZJGmu)nl^^zDRiE`d2V!nBxB*RLIyru)~4W$}N0hzE5Xlw!BW z%AN*j<>5{>*cZ{Z%$vP{hk>n#@WVXv6u00AQ#;@yi1EYss7U|LiU_Y8-X8%~6`JeI z`0=9BWrG(>@s>4IM6coZZ1qF+(arh%Su{2Y^(M^IQYeWxt8b3R*wW){;SGvYwzwbx z^`Crpj@0Y8R|EMi9@qlNh#Gtc+FE%eM*;QRNg^#k0aNh(-{}~T7jCJ7Az7g38(CL6 z{_EmNz5StRNi^{1zoyy?mIP2-ucH?YjQ(}r%>1;NP$9HPRhwyhsC$A z3SDhq0K@=Sjtblq03P~^+DmjWe{iVENFkO5lmbV6-qL^;F$myq53O@pOy?J#yMY~? zYktDNJzcM|LN|I!_B_~`{k}Wz9CRBkPr*H%cc(6LfuG!b5U_t`%^uBua5Y?LePgr! zjjZeISJj|=sQU$^LfCtexe+1*c{n&mt9#Fp2dlF4@~SkG*&jez_P#Natk=d+UAQm! zfeG6i*l;TTM*A)5WDfHvU=4=$Et(F*)owb0Lt#SVw+;kU7%e|u)^0p-C5b5H793)q zYWrjkR>4CU1W^L@ktv{_EO>+?X#65(927MZ-<%CgICKy>=69QxXx1nvLxYon1dq+Z zqS)~z&@6cRa}A8O2GjUh9Cx+xdF=8hPazFYV4S~~W`mdl3h+(dGy=BHg#E}2B#q}}xO?UPuM7l3ihElz6%%@iA&@k1rz7B}fw%A&2{RdplHtDW z>+g>TFH+0QSIZqJ2H;M8XUxBWjy0tSnG$-x-F}Y~R&JYRNs&D3>v2gBd_dq#W`TSQ zsNc+Ez#t`>iE=&PmKtI_yu4gLl+)v_vE6tnXX43M(<1Ug?I zll>b=Xu^kY8b31wu<{uU5k>Jm7~nEzLBKfbC!fId>ASF%k~=*mWp?vSuDb@!?^L82 zQX74`_pk#*O}bo28hNOWyiwmM2xc4Z zUtw#+;l(w^Yxh$cE~CE|lYumAYW-}G_W4@%6kTfx*6gyfUko(TWemp|q0Ra@**EcY zx9%8^& znGU9KI5Db;o4QVF1`^(y@t3tU<1eQpb6c~`G-ubKiZ`a$ottX|&jizN$o76@H}4uN zlGQ%+a5m1d|AA;|O*Z^ooJl;==ahgnYUvp+Nh)z9RhNQ(u>Js-1PWURl+;%Luxen~ z8HP+g`NhZDk86%E+pmrEKh2f)w@DOMMv)`;cX3SEH%iU7>V~vPXa?Pmix*fR@ zo+*P}=frTLP5(`^_Uc%n_Ua3@hu82Pu%4TfN)>FItlyQ8+^enBTSX6fW%T*d7!=KQ zOH#k8vMHT|iF!cpRZcYsMi104mrlC)Bh9)_B8ezH7iX6E=KE}uZIa*3dUa~fG1_R` zXul(}O%^pBcHU(*+bKvbLRvA2eLa;dsP>bAhg#o{x4ETRUs87M@dsZ-T_zWY7dec`oAbcEb<=iZ<-_7{w)VlD{aF8cYk$~gy|@QuA=o6bwCwXnP)pa+;#;Hw zX4)qYmm5>4H>=lb2nNzo%3_U|L4~f&9L-kZ*H_q+&S?g=$qzU#skl$n$~jTza$$d5 z827My87QYjAaslw)&oe2A$U_DGtq%|}ufHEG7$muC;&2e+{pTSa4AKwX zw%)#fe~en-jOBkGmJ6X4@PGV*n+yhn`0kSeTJHbnLE(*s7%8BqN>f|Gf8QrY+^CNB zMp;?X%q)j5@zW<9L?ooa{&#X}YT3ybXJ_JX-+uMj35Hd;n4h12A4Zmzo-U%MrbbRo zEU>V!K;S&Qx)B-EUuPrp>Ay!d_8>Tgz}bytD@G zv4Mw=pVpqtxGKfYc;2|@*lKflzp`H+Oe?mY7wqcmJNBco4ZUAmLV?CjNM=JrLvy|J zq2c=0*08p>c=+d?%@?(&DPO+4oN-!w#FRvmA#%4JbAgarL)1*fYhC}Rl(QZed2f`I zy89Bjm)BCmpylQ4 zYs$$Hhw&T)%rHWn6cnN~JkFNo6%{F%>QBE`J8qYabx%9aGWhxV*-V&Z(3sI!dZ9zN zbvY9`-hEB5>81%vo0;o}7uob4J3rc7o@??kozd$EeQX|&!|PIN5e3WTx%R~$;wrS- z8=rA}oUd9Ua=bN8Ci>JqTEk^M4dclZO8gg=(JyA*6t+te`914D4|#Dd3f-@y5801p zidUFons|YX7N`cXlw2eG+ZD6Hf_rn-_1H}vUHpYH^*Sx#m~XNmQ&3?(&a4PO zmiU_Q`gD=d{p;-Q%1UDDp4Sb@@@w*swq|Xd=hy6P4AQrq+w=I_exEGH$vcT{xNOU2 zz@)16sjcPdp?vi8q}_Bl^L2I@OCLw7r0qiS#%?R7>{j(o^=59q?!z#?^UN>TDuH*V z-&h5ywM5jyeDc<2={ZA9e7)|YkbnSz$2s7Sb5m8eF=ePvx)1yLwJmG+MV3QQa@Jm9 zYm#ewUX{75WF&h;-kc@hpl`E@85*YZoX+{!9QMB0JjufwmC3I^H#LaxGrGvDn90tK zbV5;@*eqz6DX$*t8yXsVg{kS{N|k6AX)Gv*fr0VMjKc}oVqr`>X4@4hg9zV|(=gA= zR69F6gj`>yx?hpip|;PwS+Ii!TndF}9VRU{;%=^HZxs7mXe2N%-gm-zULPip@ETpM z#wcq=z#%`OmZUmv_^NZWTX!-;w?@=w0{q#iHqqGdy&<`S1spzb-$+TmS??g&w0O@% za!PZe*mf*ewIupT5|dk#(kvkj?u~l>NShV;NUbvseAd|COa+gBGSIh%E=N59}7ILW4fT5PE(UlwFL88=E^cUSKl`h_AIj5CnNY05dswi$T`aU9-WW7{x(c4Lr? z#&HB!Cg2=fj2G#_Gt%`?A3IGv;h_K0cwXhS|MrUg*rVC>{A@Lu?jw<<@%z`)VZp&~ zl!O$P$4iXjQI2+}YaBN_X5CK`FRxD;lvjV|1bnUIAFpvND1MNQ{NNgsfWZ9mF4n%t z=H})jo^jV03Q4HS^s^97c6KFJlDyd#LJ6#`9O36`R+p#y%=Q~^#>>oNi_@FG2Gtc% zC0M^tupd?ZiYPSTn_@bId-KwXp;i7>U})%QeCv#k!t*v&zbL$)aedM!XVQ20^sE$8 zEAM4`!5))}>bp35ef(nC7xE6#=*tWw(~#y(H2S9*`O-O3XwU!(H1hSv#>TLtscAMw z?uPJ%tkuksfq_B#WcL^Nrd{ba^2nf|AgNf5gT&}){gDEb?>J+ys60CMsCtYvG_S{k zM}-V7(Lv8IrfmBWc@Fpeo7Ao9()iGB%Ac#}aoO*+GFN$}6}}2qQdr;CjN93dzdKJl zYlu#1AUO6dSU+pl?P;FlpL#J=c2;5;vdQ_!g3Xu&P%f1%xrxb10|5UvoCd#%Z{WYj zg40?FC_(&49#l?HP|t9qx6XTWdD!0*^q7v`3Uv+Vg5x=(LQ(Ires!poWD~NPnN=IB z#}IF@>ZA*?KcP#e+s)NUdJk`X$Y_fXn&(ftkEpo=KcliZ9mHj1LL1dJZ7ng>Nv2YT ze6Zz0xt$B!}T)}4LtocSSm`pS@nkpr06a{6_jQ5&dd> zZLO}jpAlC%jDVMJ;6>$PDE{D;|K90XLf)|T+ zoD<)zY9aa@LB>c;5LIY5mCW(}laOZWxLawVkOYJjWzG5thYSfUI(^O6Hg4HdOlGmB zO`^k+X*yHYF=JkH^~P)Y0Ox0G1=2mo&UeN|KBox;WObYFE?ee0_U!WK7e0-hhq*%c z?{xud)j)P#N(sDQgZIii*kQ<$XTCnd+4euW5A&vcyv9E0+Mw1F_@RRlT*B-!M1p8S z(j%(>c}xz7J;hwj8M1r&`GP6h5|2{?a)$Vw_8t~_yLB6$4wniB(X?f?JJ zg`u|i{)+4z#eDoYjd`n*$}lwO4hy^>ZvG(o@DpVoEiaGLdH>rWO|@7*@LNX4$qVI~ ze`8dfw_vM=tMbcVL$Vk+I6sYK37G_>S!z~3n=Jv}n>F#^9$a+RBzsn@n$OznA6QJV#@3lC*iTYR6rzvmWhhQWm4W=t-*vO(bOGyp@u7iz1wd-&qVs zb5(7Cs6lOd5%J$uSjEIqf|(c}r$K%~A6{L}Rkaw(y#(AH0|dMqSdKeWG&xFnk+*2b zSbzGq3OK{d<&%~}yNCbeG-8dzn}i;FR6b@Lza$)7#@khV}uSYm>L?@?%&ndMdaNZ32VhzhiCCTFkHb2HE32>%`I8szim z&*a?P>V;PWPkRcHeiSrZtL4`nt5t1e=jdNwo*fKIGIasb9L?>q5Ed1s6KiT}Qc5WN zWm#i2{~nn!9B@*ZE;SC@k?NLJZ5z1%EQMDAhOvps>xGik)D{c$hdCg3z&nl9_rnu9 z3Bah0F^Y1F`DS}mA z&s10?tEoB|J!q+h$GSk1Y94?XEVKq9Vf7UWqxzF8G!+4fmQGcY-#;dtVg*)tehk?U z#05s7S!x`?0|bA?M*W1ZtR~AX4%+dp5b{$SVXx=?iJ%)BrrzT??*xHxSKg(Oj_VTj zul@a!0acsaTwlE((UYZasfOId&t8f+>op8H!w z^d1)D*oX8xhEDVI!2g+zBN(9wm`u22(wh&8UY{EwaBy9juT!Nmc}01VdR zL9JAmW*eKE7x_!+jvwq%Gvk@(3jYF7<08V+^0K&vMP5e;K5RPZsB^6SWz^k4KV^mq z=+Dlk4SNMZMNvU0EY%&X@4W(d5}4q=n8w7F^Kw~GU;K1GIk!lG*RLa@V`7{yr!*IQ zm-dG_?(PCcgkuO!OG}fNmtT-8K+7R=+w)e-7o|O1AIjkVbt$Kq4riCyS*-bY&#f`M z4-RY|HxEXv6u!BsXtSKhRn_-DX5l8L>4t2N^CiXBKpEKObUmK7_`hDXA|j?M#JZo9_EwuyZ~bO0ep^UNe!fg#e^X@V_wUi% zyR{1J78B&6MDC>twtbw;dhNkY?3>Z6Gy;k5BSQWj=EgZhR#sLq2Z!Sn`ebNoKxioR zF`ZK9QdblO08$4~$*?NOuKeXz!ry~YjmXN*-hF*_kx0oWt-;MLExL0k4YR?w`=0FH ziuPWE(ULEYx1(gJvR?^nyBz1SRvGmgudi7%6=J3A9Px4B-R~9=*^lAjZ}iE1SjlJ! zVY$80FDfXyuxnD6cW(|H>9VI_H&Yz)52aV|^S`;?A6CgS+k)B;pj+51!i_W2=5?94bJUOkUK-QD^{>VL zK!ypB^;NS;KfQF3{r1GrB)YWJes@ zQ@#H#mGyw@?EV!ooS9s2#O zVtkWkTc0O7GjGy~lqi(*I-|TmCqYLhc-mI8SSfX{=h^QuOs!YJB-p#~i~ zRk0m36tDiQPRgUKQb5E>#ZnSU?&|TuJwAFt5`-GZ7fPxOe5XhZG|>4^Kr*uZ?9qjjj?^uIBw% z|3D080vlKB@0o{zMs8>x^jV2xMruI)oC~8|Sfnc2va& ztWc;w^xg_<0|8X6olZ13`_3rfb@p6-5-s!DE8p@SB99mbOlEvuLVUQ)js`)Q`}s7E zKoS`E6uq1+`i&&b9KFtbKPfS^uX^CdEfM%rDj$9Y*&pHS+}s-jp)@di+s!_evy+?^ z&|w^nw1iu`NR_9Tb1G9Lc$k`I^dFSL2lqWm-Yh5YLXJn%sjqQT^Ku@l+;&&+njmYv zxPK%$U|&Wb)Ha4OaCnba#Kud>Uhl4Bt9hN#@zOWe@;Pw>XUze$&;Hlj{lu_NKQ*^F zjDpwx9@+01Fi@lVt4E&G>h+gXd!vcr0@ofGxXg-L@jjnBMA1<}AkIrKS#TSDao&?C z8y3OqJkK9iC#jUELH*Gv=24G^#t0&SyqzW5_qGv62HIcGo!UuL4A|!s3F;QYg7>_U zDO=)O+%pYZTv+p>5qL_`ettg>KJmu5g+tI=H`DPD(~TNEw-0`$J-f=wolDP;_?n>L zVJa;aD)GC-<{1uvUI@%#b;&*q<3`_Pir>w}{@w0gq(`Yd<92J5$;euq}BH6c&dgDy;xq{u{q*EY)~^A)_RA>7<| z%rM3t1bE%g!}W*zRmWHQsuv#FeB0uB8%yVk@Z|KuADdW(DS+4#VDBleucvWiK4jwi z#{&?8gG=;x2ynNcDB(u>^HN7b)So(M)t`Iu$k32Li$a;cKg!FC@#=F4Dk&)`IUSuO z7`Emlj;rRXsZNWFRPcDDbAQZUE0EX zktKHuT|`7gP*jQfj6Z>gak0i9+!>9RGMcfuIe0oGKWkH%_L(Z-yaRO7Fqk z%b!bZmokM+;Rj4_!an%>=UgT2R4!R^+aSrQlk(i3%RO=M(a}+4Vq%_iCaR2^M+3j$ zj)y}jYndJQwXk1B7m;TSgWgd5hhQ@sn_@K^|Bf0eEF?KuCrJXbyKyvzV`S#!C@hrZ zm|4rbRCjFeZqV+H4oz;MPorebc_u0TE>DQrgTBg0Uti45?pJsz|CT$7j((FWs3P%b(yVK-&CZwR0G|6^K}I0Zv=prRs#uaL67>4inMi zZ{S4W4aAWYeDEy$4$|7!qR5O^xP~U@x{9;~u5)O9suDnEQCiB{8#TiMow7KS_nN?% z=e!%dmn>RlZf>*>JSvK5en>CbQW9J0a?O=t!6Aj(r!?CS)Za0{-A0CnE>n>;4Eq0P z?Oedi%gaF6!=LF4RfeaPJ-Hl|8$oHN*Q{mLmf^BAZl>4ma*u|NP*Z14mUzhdIPSLq z=;i^lm2_u1I!=huP^g5i?tBUtuN)e!BM+}g_GWd-LpXT*&N5&GWK^S%vZw0_kAG1( zPCCE--?5KjP%|< zbf2 zk6Bql|7Y3ozyaHcvW`x*sHLnGp>mQt+@7rPuKfF-Y^ua;IR=$F6V+LyBN?KA8)>7Pv~;gmhqfv{v7>392&bPef5kwWAU#7OZ)Mu$%!8#~$({1UwEuO$ zVN_mjJMbt3Xy1Mk76pDJoB&u1TX~cQ_Y=pDW))SYIh#Ve%6ZVLH zcC7ZiTIPS9*q#{p>C>lxSqTZXcy-*2$VS-Q9HxG&Dsv6trLC2={4r=6+HX!^9bd=0 zMh6VTHsk*cgW|``4CBSgZfttGx4*E9`k|e+#r!%SbCIfZHC0;~SB#{SQ>DIvf%7XJ zXVE5rgOCV5x?l9ENCBWwhmp*{zyOO!#4}C8Gh4K0m&{x)AX3;hM zZN?4t22P# z_;-_ef_GMrMoC9adSN>A%UKThK6r(*>YDCAWQyrotEOD zeO_BzTZ5DZ+m4EXgS{Tr!BIZJUM7*Ab&uOnkllR_MXEdn3Gh;6!jLhupNT4*tK;=5-MY*@JqVK#ujkP_#lduE0_XGdKlD0U`X%epaWfb)8 zx6)q1xz2m{h0(@dMB)r?n;O(_rDYdgdIg4^qBRS@Ix?hlBXat?W5VaW85TDmUAfHx ziDWu(DqVSYDFtA?f*c$krq$NE39xiCAws!XWlxH;b&f6r z&^2xL2i-XLe+I#njZF%@e*HQ!F0PB>WM=NCMk=Tbrdi>B94Dk+?n&0{+4=c|KN{<2 zFlkOqOxWVps)tNJ_yc~tuQ!55Zxeo4%L)}p6A|C{l;Ds7Oj9tX*?ovz=>_7MLM7lJ zwzs#3-EdEZDjk}9Ed5Ng&v4+cZ6K-E+*nL8jzUUJEyhqq)=u^D9YChFs}@n-!E56) z3>+z~6BGv96-=vdJr~IoYh+2R)iU`*^vUSDed0N|n3!a^xVUQR-zMgnlC<0gxSgn)-rwXosuoaD^y!9ZUf8W_ySl}Ijq$Ihkyrf$XD zPT*_v(~7SX$6;v>^i_K6iEYle6kqsC)K3KN2!oCrpTO9Tk{EH} zH+2~=bw<1&{!HHou#6iTN#-H$y#ApK>XdiP#hM=o{N2dNND^2HCdZ40((4v-XI+Kt9rJI@ z_`n{T1p3&rH#55e5y`oASKW={TyPCQ0H<`a--lHX(f?z^FlR%fN7?y-z#g~wYLnxt zsHJ_Ri|z9=3#pxTpGcv@+b&+x=GxddyT0&3g1}6~3X5Og%>+grTt z+Ce7TJyZMaEMsL|OLMG_YRFSKR-+UM5qL)5bx`zp6nzi1`y3b;2#s~-k-A+BMAn+S zyj`2Z3nv*44i4pGKPnJec>+Q5ai}GWk-k%nhGQQLr=49(iX3y|O3EJRvM!QbhK@ej zee_<3jw2Q<+xt>$)Lbg+(PY#w$`X0}_&!An71<&DC&Tjw!ZXmB|rdx16E|6b0$uKeI{h)SYPM zxbobs4~DfBI4>`+7$CUcy>avS0vCIe>?w^Fb@~u-BYd`i>zVO>Ty!+~Vn>(}qvMN< zB7gu4Y6u{vClLh5W{;SKjio5rQP=^&;C!_*iBQfJoT}4>kIOqXyU^l*r$Tgkba zrLZWem{NRC z{8WAr(AE6{#K2s`XD?jI05A7?@W&K`5Ezzgxp)Y*`+JrmN|~N2E{aI!ErExf z#;W;ELc{-HTWtUcIst4WAZcpI!_3Ug z+Ou9*UCzO3rBqG{yqlGR;?)yIjm%c656^+JYaF1PaXaXuvYGe8&TdenU-T<0Ev1I1 zxO}Cj`h-b~{xqc)(EDJeK&|hK&q7iud3n;fUUPQ(rKP3kU8x0z-Bh!!8(~u4vtu^_ zr@V&HVbcgyP0 z9gZ!HaoF53l?r8yXqhf=e zCogklu~eA&FSb}Xm!lPiIeF#)5sq$Fe!h~cAW(^LsQNW1xeimXw#R>m5Nco*OaIeS zHp-(H*;Xg7Izv!p!)q5TjZ#53GG|97&Nlm5XBcy{vr+D|EN#aRk&rfOFm@~1ymd9- zCqL7D&vW%_h<22UK3;6-XxH;b-A@OcCdpVO?6CFo3w@Hcz-M-g&r|O@o?1Q%_qpR< zw248ojvNH@vzDoC4h=@;Z*tUZh>~^P)@O>DPW>7Kaq+y{N)UmP16(#xp6Uiv1aB%o z0Az8Hfwc+;F)vW&qICtczi83>TdV+NKyy5h*^fY=h|6XgU3+~F)NI3qtOcC}z3>>^ zw@)soIXN*fISa3nen5UkcKl2dnSJj%hVKA_M1YpKzP|1rIj_y`{&oJ*pYw@>1w)@I zWY?@WwbT{r8D(2ad;o-JN*1W(8Qcr5GbM(l^-G}-ie?X$Kf;$Ug}zHqOH=hTDa9j~ z<%w)8+<`d~6C_~0i(SxR^zmESITYGSeYu1;z5|7vMpGzk*ZMV(b{t?+?VJdY3Y*WC z1fyHBi6uGF!^Elx@Is%!%lrv72xUN$>xJfOPn^ohXhX7w$HstEy!=S&#G;{y;a6F2 z*TKOBjf-1tiEKc5^wu)Y1;PFRjibmeL_y;Kht_9tTSG0a4@QFh4|K4 z4GKt&G8I}E`JDDrbZ^5T^n*P~)q~|Q!-f#?)XgP;cYw!wi#V#vfj5BKda&&@`y4Lw zq)wslF6}%gw{C*N?gTVz2GiB{7?_x;zH7T4C)_bO?E|Hs&nTJ>WEqlOU%v{Nnfs=pi(IzWYR z1DykZd%Q%HlN8rP=woE2O;tk`gLpv_*5ucNDx);^&9PuYVhEYMC0PmjM?gUWI!bix zjr-&Gy&iji`0xPGCGN~e>nnCGd`ssO*zx3(^x)7zf$-Z4=4sd)<_r6(akH!PjIQdM zo96~?i;Jf6p*wFs`rn%TFX@!8Uj;ewk2G7(`+xwVYPIUMyrP+e=QxE?f*fg&EdA($ ztNK`(Xxf_mM54FSy~+ zK!y3%;s*GHw4$Qd0BBR+>V_1zW%a;O);JO=;bxY&bLsMZcQU z-#EL|3DVoUK4}xJ=q_7b>U4rvFeObzmp5r|i;LY23HG*k^8pI*R<%Zbk^lLW#t=ke zg2B`MMYvh92W{I&2D^#`RTdd z2aG7Rm~@*N=hZG${!8LpxnHEkj)R78r>}7tz!EUfmY^TIAp{hiu*eGe-L{-GE=E zc?M9jd6)qD-uGruxY1tc!xdGn$cYIxe`b7(pHS+Xi&G9wH`3NYqCS3NqdrF|H&V}w zpGA6bG;Hh3mPZm!gUB#y06~QCCSngdKKbZ4Xno_rM5ivid(5~j7lQl zagxLlB=?=2o#iz(^Tu{}i7TjucT`!_Bxrq(Ol`yR!;xc`xR;hg-wh6kiFU%m11TaG z=%eBvdPavD;d=t7!uI&(QGsV(E5)&=miy62odevwi7LVLZq;%R$Jy?=or&4*j2|}6 z4;t*`&rG(V*`?;AJI`70#sRs=6@Vk#@F-S)&QGH?y4Togx^z6j2FeBR{QAs*?yTff z)sQ47Ud?hh+=7z`jM=XSY+S@~H0=p7d&Eye?A&;8Ab?){W#eM%ouj4&hqj*3)1pSY zCgbP9Lpwf&#mh6qCPz?xX;Ryh^?}okVP;{WASG>{!^{-{*I@!fNJK8ULo#&?uQJRF z-jMc_seOy!%ZrhRCZ_AhDJMh&6st)Z#2-CWcYa*1884wRDwP9?;4ljD%v}=aNa9tQ zbj!GHU6d+MOkOR;RSYgAJ`Hpksm$ET6#)u2M`p(;bH>p?y3EZpp3{FpuHy^XIJ(5W z!ika6>zQ-_Hd2_QYg#F-*p91Z^lbvB7>1)wr=0)Yo;nBpze!s&1KUjnYhZgfX(@2P zx~hswCNl-D$;lzn*QJQExWS)OSF*K0)}PChB?j%K86gM=F8#4>91UpI7s8n{Yo8nD zF5>_X>ToK$E6Y5@hxs=9y{l`TZ909Mcn;xairb`ES3S~$jAD%%*CW*Z4_@Li=c! z;zXpY)HlusH|_rT{EoJ^tgEEX;#NVh5P;-%)a%6-e}EAO1S2YM>QTilah=9c^@24n zc1ku`ozy5nhbPumK)?$lY0u7x#Cx7t0EUYodK~`G`Nbig6AMUlu;{uvt0<#5*ok~;u`NK40jBQNnPn|w|e?iF==E)dD%|Kt?j-WY%$ zJpBE8un-A!Zuy!TI>k^s^;FXa6%p}us0bhihJDJMOy>O(a34>x`1tNbbg)!jpOVhb z&g4~9O)AhKQ0+s9Z1c;X=0(AwYg#t^<_Y^0C#|i*24`En0|-STuixtFZHM|l7SnkK zB+&3eVf}w>xDkX%9FJZLR3|&NXz~%{wRYf|V63kwR`7HL7W z+=vs{m6-o6TtYz*Lg-Y{>X4QRPzlVKA)q00OG;4=83Fg)jCwa7s2CD)+I(y6=-9OQ zNvJdaRF64OcB*3^0Eut)^;$rg%A5$OY&`r7SYQfz@g1E~C=2SD>NNGGuyh5|Ih7q( z-RPy*Pl>+iGMO=SN;v(?g#V@C?|po>?WwM>uX#5F+|+^w2_HLoLms>Y>=145l=^P! zBy*jS7x2j)CeVI66N}A0ktP1Gl6`7&K*tLe` zwc;1dMx!L&*MMmpi~67ZVQF;GAOxy5R_25xH_i+~d}pIu-bpw^q{_*Obc-x_k3zt2 zF+xQ`m)>{$E9%2j%U^W_)xH8j)4yl?=2P`7I^N zG#p%#eEsb3-XfvLB_+*l+PHW=nyX4lNg-6!Df2tTKt_BB2N?aAly3IlK<@S#lp6?- zN?3}oLMXFZU?m-iJu5x3;lLCN|G=)hK!zqfDzs!b6VmC^yBJ#cwV(f{Ho>|X@w4(3 zLYX=0?&bDm1u}TFB)m}$fb*wF+2&Ed!viWr4h)t0YDNJ<4^GMYY3!^L30c!fvr>wa zVEv1tm;2!*2bKMa+{(whvrJ+9*OeG4tI3}AQVATdiLg<{8pm%rJ?ZG}-_GHb9ERgy z$yjSg#ic?S;B~VC`=zoh5QcM-oXo3=-5$U>bSw;8{jvc`QXEv0EeKO9Z z;qE(oeooGDYbOe!N5vS3l>q?Ae{3vK{|#*Yls|s_NP$jGPHcS?Z9Ue=Ghj0{*+e-7 z2(g}(=uR7kG()E6bFN0zkobU&G< ziq&+8+nOkoEb|Ka0r2X8$mrqG81W6&eAtu!j+xgBjLfX82p}!>exBa&ezL$)W`M8j zv)Hx+D-uvfIYgg4RM9KqO?<4C)$s0s5V11SOBW`{;6u%By*eP}B$JF~jJZvxL-4_X zw3a^x$b!46lHG2_pLWY`KVSSg%N#MFx2{i~JdtpAu9|j`r1e>9!Yg@(Iq>MX*?heC)waU=yD02GAkheWTOg&qdEn~3j2|!Bd8I~p;+fYw*k)uW96#ms zvi#EY-51UMb)Xi5P{69&3~4|9)tHQl;;aLCs4h@MZ@u4!-IIKCY2?j@C5irXH?UOm zwi}3?oV@cr9P$HpB)(UF5@t(5P^ieyO+?^T1}EOu&TDD(S(%7~IWpYeL>T#bWxtZ1 z&(a0KqiG?kk2kmUN*=oi@eso>QR=98y>Ci%oXLXDTh*T#PG9U6br44FFLv}yl$pgi z)?$||4F8@?Z32iO1Wl#BuC8u2uH0p~&P?LfS0Jw1L2*yAWbB=|UV9cWKe@@zZ95vO1#3w*lE9dLedhAZxCwZ}@1gM| zf|&7^S5_o|3gdKE?S)A#&*7+;i3N))L(NijoPo{pB`E{vM|aWGwKe0e&Q7^NjV*_E zB=Wg72*Hz-0M8F|hlL&!(9}>a2?LShy1qN@ll2R5s6K0U7HYU>LnH~eXV7Q{I`#;y za&Bi7PM8wZ91;JV4tlbG~9^&Th~Q0)taK95BE}Y z+L_H|1g|p8kpw>xajiViRYOieF+Q`viFnEb(*nkl+~MTpywxbv6*wkSiGqGVl<*ZO zX&a&7jk>y-oimU?mTrRYS(pu`EhA@JWZ|h+cgzJ z4i$Zp*vxx9fC}`ULBx5I;&gf26Q){X*ag@N-Qj9~Y~eFo1f(hc{Z`ENr>JOux=}4( zg5G2HY}ax2O`sH}u&UhprefspH{~HxrqJ7J?OG}2TATbr#TH?0v!W|vRJ3oh*431hdzatHEtxBj% zk$Vr`_E!!H3sctGc}Tna9=n&3_doC&)_0tBuej}hJjmd`62A&F^V`O$&QI#-oHs76spkzgAvHCuL$27uUo?%PIgK*bH}! zXY>L{BdE^zqs_+gC4nq1wZY{@$YAzha zKtqG;7G{3eyzoFAG%BOQt9wp8tgh#1}oLI8|3Dk>^(A&Z0+bI{fU zXwNLx@4^rld$!v1v{B_0;gA3OB@R-Ob*g;9&VH=gVYiqu^~_n{0*a;lNx{T0jlDaD z?tq-7?ON+Kxf-C7kDSvvJWMaYZOa4H&M1gKMsk!-CKfMt8wqj72e&-wy zKX{QT^_M&FJFnMaIUlBy_Xe}D^V!I+H!%h3hDe({d5s=IUjIh)YzqvlLNneWnu%SsDv+}sd z*1){_s_rY0Mwu2+)vE$v{sHQx0Lff07z#qVNb(ipep>#=FF%4v-Q?qpZ;t1y@@kJK z&~NffK>@v8P6m(^Cmi%JbJ}`DKpy;RP{xAFsPO2DeHj_T_i*8Wmn8;v+a2hChFtJ5 zATyIU9RyzP*{=4L{cW1C{sdri(b!Oc|Alw6WzK37M#%^>XZ|baN?C#toeC@8CqRIx z#=HF$Xic%E1?IUH@?z%aA~yJ7j`Z>PVi-T8LWYd}#@x@}T}xiOXkH_j^Vh+xN9Ma| z&K9;owdHN*M_B8Ta1GS4wokAmtmST$Waa!uFtv6{UC#UZaf~+jAOsjGBO}KO(N+D! zcNH^P5>Wp!z+fFev-!n-J@pmM`E;4Si;i8LH|nkWk_|)rz_;hehw!SMcfSiDFKN%* ze*`mW=hn{iNr0K#_o9u{{SM12FuX=eGBd@xySumAk62ZC$4r#^Lz7Qjnm0H-s|}Ad zRLDtQCL$?FN`AaNX}F02T1h2EMg2AG2430x8W7EK4OmCap?d3fTm7mG6=(pL0@Cwa z&)$-%4)jR`T@VomN;V*WJ^z4VEL^Au=Z1QO`SZ=^HwzNUkZA6MSEjmz4gY{^r{CW%u{d(H*RK zv@bvj`T%H87GkX36I5Wk72j2U0%pJpw8I2n8f+|Z7P|h9=ut_$V%WBhSP@&VKh*JS zm$>AYg>DAcCB-&vaJHKtm72pwr~%rYHy5WTbU-W24=U!fqTBUA_4a@>)^5oK0$(D} z%h%guoR@noRS`8za<#t=I0Zq6iIP4dCML!qu(bTFYvM#<>Cs1X5lYmP66{YWF2|!k zd=W8+>t&sWgw~oTg5)GK5^N-_Mx24b9T27i)^XZ%05s-*oO0c*1NxEjKLm$Nbv$)U zs6C!AyF?y(#S}4pdw{*TF&iBiTZ7oIY6fOiJi8HNMYVgwzaF5~;Vrl{w_N=gIOd&N zTv%ADzu1Yo4S1}B`DD4)$sg0oS%u%a9mZRDyt%a4BHU5Qngpm=;a9Joi#D$L=@4j2Mi;jz< zK}Sb-(M0G6PN)|DDh#kTuIPYEoi7R~jR#QgWf*QSP~UN!Q0EKJXmoDw3=}(mL4FO|0p*RB+l3`3SEHc#P@hwkLRn>TpM4WD|@)+_^ zbm3Juv(uCMvz2&WN=4w8P_$AtKfARJ;B!g{lN(8r!c%U5i~e6JU~JYgAm;SDghjM^ z!Ov8n@C|#eZPVev)S4(lYy2SQq%QeI-_JutoN_PHRqkVtw+&RyEWJQ}Ehr?keA~m% ze{N_T_wr-viueVTL*ZN!7S%&f|s&h3>tJeK6fF4xlZg}Kie~Yx|(QvC5C>@efU;*@63ST}Ei)p*^ZX0x4PS?A4B=NW4Dpe@Dh!mmGv@tHMi1OZ)Js8X$_D4TV0lvc})6 z<0cQJ9J{1bjrV_OCD{4!tONtm2?BFy1q0jiN(|Xo{k;)Mu{3e%1E@gZ4GTT}cLC%T z+A%HHJoA}a)jbPZZpWQy#T=zB0BkdlkBFBPfL}3DT=;oo?{{Bi;}Ik~JNu1>EZLVB z2|AypBB01qa}{yk=;On+WZqlz)Ol(<&A`8?MgOSvIWn;MtC#?)kOsE_zp4X{b0$J` z?9JR+Xum*Dwf*MON2Yo?(xKu<2>m^bHB!zKi!N?%wZ)aBPpQj6g}?W(5(*NeBWdI= zMjoeAd+6l6xhM>%^4^ z?+hLeGNBs5BQqPK^BDO8% z0>-ecZe6Z=u#F1jPeEtGe&7=D*azHR0!w5xYHGA)y3 zp`;XX7Yde%V{SuB1nOF1Kz4<~zm<9g#hSB`Ne=+GMx|flD($V>JLcZ5E*3N)ckMUd9{6B% z0ihKcDjuU!`ya)hmo3tq<5Q2(NqjgLv-*Mo?W7rI1>Q4SnZ{t&kEovVj7EKQ5n(zO z&$1GI=s}fkV&+?P@X!ieLr&D7fcjzMaf13l51VMwvk?$#qKbsqOMxCsO=UPVJj4Pt zuNAbk3V5r$4IMY>K=Q177$%QAa|rMdr4>%U0~`;UKVjw`5B$Y^=#s-jqz_S{4eynI zmKF?L^ov7q2mlg4NL!UmBKmZY1tKTNK)IHizt<^;-&oyzFobNXSpx|SPrgBtGgp7nDp7X8L?l>xHHLBc)>mEc|9>ogBw z!q3@a?Ju-myoPZ;8K(mzoc)vM8{Z|o;iuu3VtZI{<#++##*jrX3dgm~IT^7o6y(r9 z$_yG__u@MP1+UT(nZXMmWA62=&v&Hno{KwP6DlxMAln((c9s73tv{%+cLOpY=t+2Z zG!VB&)DIS%V%9gXscTIp&|7RR^V5RXM0R}=$k`{o=6r{78W5p$s6o7`0PfpWvh*i* zWMQg=up%m3;3u;WUUJv|Qn&Jl3h%U*E7ESCdcJ<{gAXWs-i>X0qfp=g5xnU;Ca8IS zVfjuyQ}F0Pj{R+{((j{C>iArcF0nF;KP35e56OLGX<}XmeaYidjtY~nR&aMP$!X&` zth79bokPJDE`;=pj=%W+EeyxjpHiUZ0J+aF)~u37Um8=d+})u1_eD+EFpomA4+K|Z zm8$EXE|#h*6_?)j7t0Pk(J(nGLs2i!k|S-|^jASaK~YGJo-;Qn+XTISbl4`dHwHW} z(%0j;w-{Z@s;>;okRj!dwIaeLiX100$vvF?#>v-0HbbY@YEUM{k8p|UMS<15C93C= z7H?5IXAnhMjt2OZ*~q;UHm(g)g!;4c$n#Nv;h-$%3G;g1NS z!7Uao_r#d;^Grf&kus{**@uvy<9wk{c#y#w1^QoarlwM4{#KF;f|$wT4;F>QkppKK zk>#=xWsY$SF_CS?GNPHwk{WtJ^^{7O&gPRoOSa7LOF);JDR`;w5RiZCvuJQhT`MGu z#(=cz-b}$l*S$S5#5qVwuj`po9llyeuw`u~1{>@M;Ofp`zW`g1|RnR_sJT z4>W^g*uw(P>y}o&3sB(ohR61Lhna@+bEv}x_GAvC-)ea!)?zBgS8VNF&HpzFbk(zC4!OePR{(%Du6`(DcC0lPP z15`szlSrKF(^{heaY-g6r$L-(@3=BniX(HEE)-G7NiupFNjY(W7ACh}C*i}U!?lrs z7GyqPrp-VFY^#7_6(q~W;Q1AXe@68C_m98Z%kGE@3AKbYbzH zhg9DxI^IbhEOi9h*B|M-V%-$!*SclUnq&Tri*JnT7IL#;Xb{8Rp8yPEbkYT&Wy(j% zkW*Eo-&-L4j}{yUE8B-M#c+w=s<}fVE|`C4W~g~{(nD!FH3y8oW8AZ$nmCcRZEynWQ%EC?uO?98?{6tsxJA+Umo z2$a8hF7H-b*ru2m7}%m}3A(p{q)gG3X9K^tae3kM%cVMz+boyN8@zeX%Q%4+I2-`1 z&mXBX&y#?6YKs)-`HU-*rvl)H;9N7qAp|6ke}WUavNK?5PLd@PVW@0OVmwFx7&{p* zXuH?L!ewC@=!?U`lrfj3j zvqQ*0jP@?kqP&0R=_|)+Lov5z=qYzRE$gRv4b2lZzi>TzB%X?l4+vvj>uVpRM7M=v zAz?5;P=WIINR*QhZ0lqSW?(5)-VR+ia%ng#M+qL7QiN#-x24_K)toBZMaoTeqfyG2 z9Q4mcZUK2gq`Z{WhyMMQR`6JUp`b0eTl`uU`iF7z2&VC4E@<PCkX+6Yt@M*w7>dw>Z1K<-wbt>;Fop8fn51erxV{$2<2 z7Nr@7&$`hNOCUcKXK5HCBE5Pzfez>EV!yT~@e3jiGvg;6;~{ZL)^2*&iIghnt=ZqU zKLW}_&~5;6e6gqnUD1`b*u24NmKQQ?14eAUy9r^{NRK{*b#`Pqo~!bSbPZXBM5UpW zma_n~9Z&$mDM}^KZb$k%!t`7+GBQ{)GUqF=Yh)p)=}DbcA`Mo&kfI1Ul;x@=fKK>6 za6jt;$u8pYW;AfGFgz4ScO*;C;uceBjAyJp5>{7+T8{76OvoK!g!eEoRJ*r!3vPnC zDqvRJs7~kf5qU3vDH@&%Rguu&a@7DN>rML(%$Umuh!OsW_kD)NOiUl8#!M710>*~} zdY71G1ZvsRQK$Y!Fe}-vrT@2~B#!#jwi`3E|8%Ck+!25sLKt*89}x?7kZdmvrb}+| zt%|ZO_kN<1<=*oxD=%OBoRgm)tslyx!dJ;{&FW71v)8lgnM{%=m9pvjt;39Fp-Dr) z&t}=Fvgv*Ks&Q%sK4uaJ8#~Gorf7T=7zhP2O{f_zGB?hEe1h){Y$!z7&Bt^M;e|sE zpt8L!lxXKE=Qf~LI|EXza*-1f3`t(Ir9rNnCCojEZ`s$Zdy8y|UpH zvaEF=q|9Z2<1_v18^{{wED%9LNEi>eTg!4o^&dXCrvwKFmzWOIh9=X}r(q^xrih{( zIeV1RscaqO<)94`A)~K{4V4v1WcJWUHo@gbc>7Fk0q(6~%yox=`yB{1nRPTFk%-(0 za0zx$_NiWFor;~>PUKmar&T}kc|l$;upWR`TuP6ER|4IWWUU_3jNe{%Pa=KA;;NCJ zz}6_H_xZy+BPbivjV9)Y@>;Q`A<(LKnRvY5B;NEES?UwJv?0d+98FfL{sx>+M{G>Y zI_@i1TiX143Tw~!E*aZ$)_wC_PKRl3v#?LAIZ-Z}$;!y6oK6=1g4#O#2uWgKeQ{>- z+X1^{js?M*8(fWs4>PXr3;{Bi)?@_z<4P)tS`qI4);L@)Bi-WZ%2G!@fAsE>Qp}pC09xAb>C!&Qxesa zV6cI(33Sbqsh*T$ssyTk(A@nwP61NbFvvkuq0SuG9W*H--)sF!oyn|}7R?c=4k)giifrs%Bc%U){M<}+eIY|rBmuo zEZ>`7(#q7-^n?hIO_Wl6*%LtCyig)^C)TvAKUDEPcJZVDrJg#^*6>Cl+KqpbBNaFr z+g1V4?|6udfb`k-;ulh`0qa|N#cm{Lce4odu^94vi`SBda{>5!h3>*W8Y4l;b|{-k zfD~Bbe(n$tbF?fx5SWnKJowexbWtx8fCs_uDMVn2FPr8WK;WAthDa{HRKjWDdN#}& z=N|8Wu*dNX-n#YNaIZ&UyzxM^li~bp4h`bmPQJTSSxaf+Id{JG9w=m*x!>L5FP9k7|kfHlB@CcbFDn-?CDYJXGzL@AP9NqoDc)T z7m?dq0t@m9Ej(f<=;=F9+rQRTFRCk|QRY3LdHz-&)PC4WFQl?I9;~p9YLY?XO^^?j zS3V;l5de%EaCL1S-`K!t0~O$Uw^gz&6+96M9IAo1cwkg)?BgTz!W=Zr&Aq7$!@8pn zqKdrZr!(QJ<;HLabOM{ zG}xz9fShw;Mf@&VONUxG_&$HIkkqrB1-+hvHE8232CNFNPe2Pr-+${}Ds8~UsO#sv z*Uy0Hwl6`Oyj_N!5bu8VMEF-~cJ`5f_EKZuh?yp1nSotWg$4hm)Yn#CSvh)M{z258 zT%IIY8NFzlp%F*)$*PL_8-?PB$k_%ieo0%D*cVWdjW~C$W?&okxiq z7cE~|rVx8j{d6KtqJmh~*VXDP~m=*tPF-E0?<92QLNEkbJ@RrTUZD1K%-_MP?nSl~91ANQLRO>$~cEB1}m} zc6&UC-CQ!FvVuxNF^Fro_IChdysO>21P{UDR*~|@CKAH}T~eG6-}(AJ^zeHC?Ith8 z4`7wp`rbnwKff?98Vkx+D!`wM0?MY6y#++5b7o@9{`>i}+u_;;Tn{PQ%kiO)p-u;4 zegR{O8%WDLl}zU6-8 zIE%tp_fQD`LRJ22JaY>T33R%!r2Z&EfQzNt)iUAP%-Ahx*)ODYQkoCkdyA2pOKTXv zzh9E~|B+P|A7a4Nj1BXpikZ5O?f++9jSufs5*r%}c8G;Vn@wIN&=24JxT{%7p`K&z zYs9~SE{^6bUck4*?cH7zj{W3GUP91A;Ta@`k?XW}1xgZm6)VI*evS%{Buii3QjPSK zCpgLhsh{a*)NWp0`H}Fk)w!S`K2fCCQDJ&Dg;<4UZv;U1k07hq1DFr+7;e)GGJmc-Sgd@+BZz7%TVX0GtGNvWWMTQ!q6azlcc>S zRe~1!u8sJk3milMJo6L~o=#!90cLH{&@{qv;PNMW9s~?sq9GLc> zuTeN}~!^N3wd_Q_yQM6sX!lRv0BJOZKH3%HBOGuc@b;8NcZji z2M;LmSy9Jz`J{!5QA zC&i0rcoq|>hKv(2)a7U+Z@4iYDKi-vHy;$enU>rVeZ6^a9{Db%nu5Nb-b0KZNOm{7 zfC?&Z5QNzU5E_J=qH+nEaoR;uY|0xi-=vv;w<+gfRsTH^4AAJSUQXa=+Z-55_fA0Bs9X2AqH4X>`QQe6Hp1u&Ml-9u!8DTr? ze)$ocVRO^HN(8%;Dh&$ol*2mq^^G`2&+(L%l{-`Y2~CHm(Kx1v0VEW$)E)cs)yj=c zpqDL(&(CA2UXsBVlEL|tZte)v%WfXCD$ttUGH7`rzCUBMH#qp3fg6&}53vTVoO}=^ zlg@q~uz*~6R8_^9$%Xedl9!ZJaD5}6p%CC1n76a$Ia;pUl+4V~&RuBB6l>Z*1~R#< zJdqA9gR&?fY&**r-%rKuF0F52xsZ>20#nCHvXwNj(})~cHpsfwaU6q&{8R)L6*V2W zeTxDwz-I18gv@j|z4?b=tgHe`m?%C$(M))4ulY zl~Iak=!Fr6wh|O%)#JvtKAKxd#G#s7^?|}IXoreeTECz+i*hg^RTw@X;Pa^C4;UF9 zrok<0_@iw6UzprAMo@b%daoY{C0Y)~T$!bClEnAFVGK+>dp*Aflq{v0%3T0Nq2TIM zn{l+m$H&j{rQ#m+uK_IIZdGk}3gAE{pN0efD-^cP2|>JHiU;a=bk=`lmw5j6V5>+a z#F@NCS+q&Ok)X5sct8%htDQe~6d zDx_jel=Iug)zsp!lLiJbOIlQmT0?jWti_ri5{p`J&0T@c$I_Qb8TM>6g)V;lSBEB9nT}SAOoSO!P zTK)N@jYEs@+&4V!D4;w-p%0=Ch)2e9>17-30QjPx$$fXnXJHSMfGm1{J9Do@K4@ND z(JHZ=8t@%ro@nPBIfLu7zj|k;c89;`Yc>)(kM+@;_I;>R1&DnR=AjrO2k>}Bt`!q_ z`}WFjPXUkC36e0#dbmERoy6p)ec^l0=Ws}g_^hO~R63LKv~B;nPdk}krudV|$6_L& zW=K!(a{GPYWMWya48z`I}1V3THaxaM%=Drd zxuLdJgp}^PC;R9n6=>atx3s^!Yq4Wx8OJ9~)k>B3HA!h|Sa3u99+%4X{Tu3Kbea2o zR>~<9QBzE3rp}qxwGVJm^F`siA01&e)0kAD&?f{;BL`*XQ#pF-pMVB*UFz1(1uz{` zW^3K`O}EXi_`&P)MgQvp2{+cVv9J8IY~}txa_?OS@X#|?eq4>ZWJRD0## z>bD|yJCuWk<0kB4TYG{J-~J6i1Psz5yETQcMw}2E5<3wyS=6?SgFRHv6~52eozupJn;`Jtw~-vDeZszRNY)eXyZA zfE;QGutRO*sW=9OVnCv>%P%@k{Nfzg?-(55@el+lEPPsm=$3Uc)u8EL^#TTM-VQB@ z(RiK10SY{vy)W*@89BTf9#$c?)^^czy}-+Oqa^vHB_ul5C%5(a=bVsa6+cLjU0y{! zrhHsM(Yd0L(^J4`nydz!1oP)cMkmaiM?z=;ch5}Nr(4~+>vc6K-fVx36%PYqg=d#{c|JZlV!wRBDe2-LvL$?c@i-bPg1nWZV!hQ8^5h+wAF5~ ze@McKOOVNh`}HRmZ%e|?lvZtAVP~;1^V6r{ikCUL1q#LNcnlikNX~zL%bY7XZ0sd2h1XgZa5RC{nH;x zJb=N>+WuJJH0dw?Wp7!`0SFd@4g*Um9+s{qiGxH-E*)yc# zNr6zk=w+YRdua=0hAt6~>KnoWF&x-3x8UMKk%gJinOh_alheL=4&-o(c ziTrT*oQp#=D`8CY?8P#N#Fysh?~yLrlicLlx7PDojfT!PJ7&2Idqhr;*zhPAPCpq{ z551VevpkB5it-{4X^#tQKuN>*mMZdK)F=}J=5b3hj?U=Ui_eb)G)icxor`ikB5-=j zc*&ieof4agFh`mF{rxXS{Yf$~)NU%_NBAr@BO->9@l!N>?j~VJoin{NpSvGaznKzw z#8)=9b&*)br10WvFFHJa$DR2=>{Kz`+we(=i45STM>fDap@-rqF?=LA>1>_CMUPX( z;kI2CK1v`d2v^mbTGzI>IYtfo(J0`+gz!mgCKB-rs>jm+ql~yMyXt^^G$Z@ptI0 zNGJ58iX(L3pbP|>in#R22}f{9Py4!ylBlWTQ99pMEK5m4xB0p08QJ!jdkf3{1$o6X z!RbK#w85_|63gP2%i;o@=Al@Vs3{jt*}tya97u?o*JCCql4nW`gNSL5l3cfoDKbSp zXTcnpYd>pkkJEJG%icQYgQGx^T37#uK<5X_lxhJ;+hSL;s1Hbw8(ADO5sLInDfMPV! z&$F;4-sFxTMu2EWweLU({G@N=1MlhV9D%l4XmALvDz%SQn0{$Sg-piGRo%sWqAsn! z(a^-^8Vy_5w~+TDoqd>aolg!ku}H7EJmmRuk(*v3RoW;XlU5$-^dVzgTU!@oVM1iZ zL!P{J9KG*(r4R>J;(u#&)67dF;KG2ubWde95AUq1nk#9I+>KpE4%zm}PtGX%U-GLriov5mu< zfQLuaFhS=iR=5_hE6Kr}PfpB0bEciw^WQaJ*K6mKD)PmD`vH=33sci4WhvRs9SHaK z&S>%SuxR4r-$R9!-=zSiKlWryo%b2CvTSSI6HhZPnLR`s2UL+{g)2&LLR=U>Gd9wy zHglf*GYvD9Jhjv~_uuEUs^ZnCC@4ROR0s?d6e3DwNS;;}oHY+fHLEsxHE0RQjLV!$N?U@HjG89QQ)Wk!R>&TOniAagIC1O#(9ffal zW?EHt+q8@Yu~=FM3X6~qWxAsAaafn$r8TK@t^cWhv+>C12)w;e5Tv62&orK7^d|}!5Z3ZHQ=ApjXoEq z@XdrBj_EG_Ae(9wf5<1w=r_yQ|9h5v%k@dYtX6&dw;$cUy5Dj%RKNK_um8oK_*2SaTUmCAg`C`;Kv*j>-<6wQ&><(#@5hq z=>mKRd0bX&Ph=3ZaGD%@)UL2+IRapHa+El~H>)OJ_r#HSUY@_s{*XY)_Owz=zg2lw z)0Da6xMBT0cH+2@Bsu$pb;>(`oh@q3O*K#{de?4&nNf1T!vv}X4fH!veJ;lUngRW3 zGDk$9<)1G}02VjqV?_cLmeV<;v%&m8(!BINRftxB@Vq#fuSx7>izvbj<`|ga0!g&{ zlKGgx%EUrmIF}2zV%dEON8|;iYUp^2f9m%a8+5{W6eS{8Oi6@~M*7B9T^<$YC5jBv zeIDFm+^B|;_!a+Z9rE*B9VvKa<~R;$Z`6@gvbcyEf3C_fuXt#;7iiUM>}ph6CQ7uq zgPZajLQIlO;`3~z6Trtq9`XGdx(iw5fYRFL<&!vM`t!jfL}1Bp*cyP<J^@sQnVf0BcO=C(0S@1~17W$4KICyar-#HZUY zVTUQCNV1M1MWuauG?GJp>4=}$Ez;mDQ2df_5Vwg0e*W95s7!S!gTt)l9mFhG>9JZ6 zek2JpuM%K;BFMdJ#xt34ABL%fSY)>lNR=dK(x|ic<1xa!-D#Jr)0M+ljI+6Ba_Q8{ z$o-!)aR~Y(1M(x0TY{o@H)qB#%M+{QLFHjndQO{_1!hroz0}ccMDa$O@BKS&>opms z9K6f!+}GFbp>SW=%to>_CXmp-5*e{$Tl>SsI1)2p4^rx0l8v}D=Ud!QuEJ1YA~71PRE_z13`Z{U)+7$^|T@5%NA;AbbwFL zhqVanz7&DCPl)fwigd-)Z!PNge$(1L^km5J`;k~2ZpdQqmM%4zbKg0l5(h)D2uC=R zkM4n?fdNv?6RBk0SIQ>%?B;QG`(1RV@!l;u)qfQy6LDUEB>VW;{DQO;T#WSMif=T| zPaM)8%0eW!5KB@CVZy|%D-b!LJ4fy%9%VA2jC`8yY#@2Bi?Linm5F|$@Q8W%>bj?R z!e-1%D*EDX{f+hNu~0EPBpD=GZWt!oh%!&I32{=p(GBVo=2Zz5v=r?d2%>NsT=oOw z5$AO#nS}1Y1Y{McxoYu_|HjQMZ0n1S$2nw6RX%=j^wF3ffG6s@VbAnh zFR{zvIt89&8Y`ab$BP%XrFdEw+Hw&djfnZI%f6}KSmfzKPmdlqhA~Mre8{=y;2|E} zE+w5~>vVr=6U?D0SzKAk&9YIGv-i$^39FZWxUl~xVi?t2 zMbBidy*1LexM)DZz1R2m6q3(92CLdIZ+u!yEQe&qaY@4oe;N@}_-qGG*y!UT9%lvz z3aVL@cRgK{>*YrQ3hWgDbt!l3LlnUPgLd|tS_CRbte^%>Os3)XoghlY%&X>)GM?q{ zyO746nMHWVGjHQ0O4#*`X7g~SZC8=|dy+T0*p%6sS`nEqS~h+FOeDVXKat!E@dEOX z;L{XZFF?W+WR$5R=G;TatL1wcjr;X#E!<$df=@b(yrE%cz>`o#JB1?fH-DO`4SCvC zRBP+EPQ24JH=YsdyoFea&=-0K-!%ux3 z!$15wlRnP|^wqaVq*wIG+mXf@Z_Z(JRk&8)$6KD5zT@u5VMN_kPih4eNM#Nax{G)J zM37w=NS+(X*pF|0(8Ec?N&ZAX?57?$1WnkF3Mt+b zMX9Iy1hThf07d9gX4(!Aq*TnBoP2o+E3Uxd;(o>UfvB2awNNYHNh*n39WrfGVYj*c z;ru3M1Lh<61%wEwBSX3b!jHN$3i;nlCnhpJKS2M|wM|B&uq15PCOq8T0dL4+DOP-M zLzPkfw={O)>;h1K$WgF6?#$$y=95`q3x6&(wpWAA>%E{LbIeQRn6`@qH0jmQh^Z;f z>fcxAhP@xzD%_|3?p*BMB(UF(H>F%DroLl-EJ9kxl|e)n@U2i*OgnHYSu}|bbTBi6 zB?iiTk;b2Clq&I$GTuqY#+i2WgzUq(Jg@3BVkgoi@sz8@h=^?Lf!P%eM=g~ZthjBM zn)eMKvnIG60U%F9lFRpY=TE}Jk1zxI2!(v2DG(&aY{hC#w;XS+XuRb+MZk>^SQKO1 zo_haqyQdy~An-||+9;O|e|Eb`E5h8gfPq>X;x( z)^)b<9t1;a-VGO>U`E!xg2o=|07f&KNbs4Nuh&{9WQ@FpCG3vqB8xSWWU9vNJBLjY z*sbyt+gw*Ct>=LoWjEl_SeWU~SG056ZH~$F1^@4v^FfDh0>!DJMhP#zNbBc2mgt(f zR)?20ebbNh#ht&nE58{y&=nEHzGNeJ1%=mlYC2kBM*`+|T!k(aJOmPAp74q|n8fti zt}G;=(~wliR1eGFu??uGC^h+2GZZv6w#H;;WE+~XYaW6g`saS|I)?5b9mo0R+n`5X z9N4E*s#OD9oTy>ua$=EBmk_M^@^ha$GZy%}hs&$Rb{TKk+ZUqr+Hd`04Ru@}k*R9o z2{br95vaR)i{Sr>Q=m_53Og;E>Azg{h1}5SP8vXy!f$8175ZbB;2j1!Sor&jo1FaQ@A%wk2PmI2#R$WazH9}C zn1+$KcSX-VNu}_UmC18-(K2&rp6L9znNQMT_GcRsp8yEw&TNA7@B-?$fsbZ9;uOAo zQOV?NEg7?*%5clem;Aib80FqV>Q?;leZ`%@fFyR3i?96XQ|n zeE-fV>kF{8xSqpvswfjMzL24!9tbRn%|w;gpMHwPU4xA^Kzzy8O=)AB*5^`qZ&roa z)TBzS8!GIDsqzyU27bQzvo6H&s$i493f~*LTK~w*Rgga|%-ARNagJLZlL-y2?{=ox zXS*HE^t^-sjTecBajQ*L!@(_~U>bTF4sJh^_5&9VUa!f2zb^)Am#(ah++M-T-^a|s zNd1wX+eBiQE@WDMZ(Wh(E!*gGp8y5yTPrFYY2Wh`vlODj!gRP>E&e?WwlV09epi{d zt*cV7%_bVfZW1yVv`ga7M3#xgl^L+H9--}CZkl=UahE<;X6u3|e|v1>_f}v~kfIq3 z=!T8KzrwZrcm7VGjZ3E+qbzLvz#n@lt0LrJbxk;$GP`&nTJjY+O{&Zt(}G{Qu4cG0 z(so+I#Wm49#+OUhx%w7Vnwxujd-;tdJJ)FV%@6DaNSVc*kX#|6?GLd8=OmmsUv|@S zv14a76C>29N0CW%H_ls zysAB$A`L7P$4nH%?;nhl*|Vkk`%wH|;Gt@e&w$1vB0M}5!Pey$Lv+;9WcsTM6Lt2T zwbwgEz{ArS=*%oupqXXB&5rjGXh~XVgF#byYQ=)Y{3Hr=baaNN`%4jVamKLrPiW); z{;R?zPUIm**G#yZ_xucVu9=U+Xx{rSq1;a#T#0NhMtL?ON$Dk3h%y%I2t3tGaFWjg zq2Xk6aWhHI%a1zy`(uF@7xiA?Wp@n2(EeM~Z?in+E@$Lw>cIPp8epRtC%?i-WN%gf=G9b;znh8dO=Nld#u3(D;u#-}Z>;e~X zCf^4z15Ix3o5oxV9(C@#M75R9e~BzV!fOit^q{sAJTAY!^F6O? zd55k$rsUOpW+JtXe$0uOT|ECW#x!qZEt2?o@bNPMnEX2<jCphL3`lR*zNfw&auphL*qM1% zJyvVKA-cB~h3$CLZw7@}Tr?a*ie=wDL<8Wn0%=Wcz*V?5UYdFDA#=*NT&#hR!vwG% z@|H*QE&jP;b_?$+XIyfLF-;DZdnE!wfGzoU!@1=GjYLuNU|>pG+`|=`lugFDzv(Dg zRAw3w05PauLu34wdmdHWtwl_#lHSJ7OYbcQ6XTGyq#qAb3fTQ5luG{b-(ZDE2L3yo zKKzkjK|4}i?pyDrI0ZJb|Lwb6u%tXwOcx+4^{q zf}GOSi06ns=^pRD!4|~CAb#EQ8NVVyBK2`47?I&&nYp^>@fX?!9I5X>|AC)UEdqxH zY8fPIz5ndQTu?L}9`uk2aMLFOv(B8T%w(eW$$vpM%xev*J9OWNJyXJ<*6WkugIi|! zbG>>Y`T+Z@tk4V$Mh7)667Ds5c`sN=zuX2_JapYCBJopHEf+(k?+V*&djsK6ztL~k!h-&g5C<8CVKp zPHyh)jU`azkcWqp;OIY;^K*+kMFO@+C=HVYFb7ucl`%5x-H4{sgB1!!MwvBCCM&ET zvFaLLcMf}s|C;%Muf+TUP+N?_K>fcZ5!l$oYS0GT=qaB4&l~uHNKeBro4`o|B$`pk zIFua#tVA>u7>E9L9q4t~tRy;4*f#>tIUoh5f|?%^-M=Qx3Xw+!io^MfFr9$g!4eq$ zT`J`02~hNI!0BBC?!nQGSBHh@?Enw!0eI9t0JUiVb{YezTEiF%Q&Yc=^n!oRu?qv8 zuyB7O4>d5Y+Pq!RxdqTpB6)%Eg@%bK7D#}*yl>roa^>W|?`vzGDgxKo0R>1d$L)ma zrmLgM#!jGb$nco&P3F^90Y$a1aoA{L(PJ_`UrKl-S%Ej8W=AP3ar=+M6SiML-n zdnp4vK~p@e7HTiA&UYpgTQH!@0Mb`o02RN=?8fG%IW(%&yqeF<%xvjs(kd1#Oh;)y zFCCcn8T;6>N+55ycEU!t1R7p{w(}EAPRxIg-3MGlK$oZ^Rmk69uF3oL`Ai8P`CLR3 zXjUP{^a4az0uU9aox5Y1@Se1LP8w$sKQsPL?0uMwyuKy3_cjozY5x`-*1g;AXTOR! z9<{ClHzWf<96^x8(g4=IO)jmX;O_I9t=?5g-Pao}c%{q%dKFQJS4Mp2@pXG`k7-+4 z0Ac0FQ?=vpZ-}$DNCR?~F{NH<`*3;5$!`0BA61bQzT|=)F4B_o@)#&46b74oJb_0U z=Lbt*$F<)<7CLsc(Jcj*%KW@a0O2*6*K98|KNj5T5-WX)TQ!yX?dXTKE&#NSh>gvp zPd?cOa-z{~ZV$lH##)`MER+b&43hmNEejvG1*Tnh09u;A^e}L0iIUd^&wEx7=3bd_ zoAuc!A zAs9D_$Cb9bzSKiE9$A=%{tGzz>!B{7OLKNP-RS9Q6l+a{9OvV;N95`Ba@J*o!5K8* zm1lJxy`vf#lY2}!yC-J_Rs$MhPw08^=1}_}M>%(~pmrOZ-ht0{St_fat=&if0Zago z*>PKe*(`NE0OJT$>BYQ+&>tWG;zXB*-H0m9rt$18X4LqGu1z^JzGnXj$e2#HsR zWR*h^FDnO!DrmABC4RO2Lh=G`#5+ja7 zZgPJHoQu{5KKla*NUh?>OXhx(b4yt`0r7x`?4oxUFgQkcCT)LG9boZe4q8-BQzChI z04@90^MD<;sr@#GlU-ebI*BX}K=rS(3WK3%qkqTD+XJa5%28=Je->sOk81_cz~q!C zgBkEKpI?OLsDeB%>t6Um(L?Vy3vHdd^DWA>j~A;ie+DrrCCM$`G9-g9#rAp%XA&ER zYX!QP6|>)J22kTAFz@Hz71ejAp4w6QP9B3Q=yNVw>C;RR_=B+VVu{IO<7v+s#p_0~ zrdJ37Ihu_g_0Q`~Op6&_R%9XE+nxzp2?zZc;zox38B%*fpN%lSz0t<2^7xvLhA=Mz zZ-|$pprS(A&vTsMvUV3s?(Q2GFtarK@D!Xg97H;hduIQTVkY)=K^>ZU6r9Q{X0*`4 z#3bBA#)dG+{HNoCco#m;stsSRZcL2$KA5K!xMM%`OFxyFT~)s*56IMf|KfPpX~czO zlZ_ewWl*H!zq|uvaK?ckWsvlB`Zq}v{N1KZkaM`dkL37IV)TFhMGXNs@7q8$n_qQ{ z3GzDj{ti+yd>7j;EKq8dJ%uNa5RFdqxID{_5&*W8cuL$5O(VUgW@4lkH0^S7c!9ra zg?k@6pf4!(>0Le?EPt4ry?TCn?YHt(5Y+Z+uisw+*aHa#LF^*br5~E2EE0s<35J*& zf(Ss1bqEfPL01$_#T(+g#Mtswz#i?0ZJOUD21HC1Gqan%6G+H#bnYDfy1t5Dlga@p zeyh>WOuZpkWT1`K-uq--Illrc$cf*0K*vv)l}_Z3M>IG}P2`$)1O~+Sv=x z{A$or?z%WVFx(s~ULOMrd@>NqeppcehAWHXwx%*F4+ujZR|m<8Sre<);2WAY5sl&5 z&hHg_g0B`3f-5)z2l>%cJ>PC#A+dEdinF<#(b0F!?ik%BfIwODC2et$ER>tH)TloO zIG5)RMxK>ZZ*hP_1`S^Zbzc{d<0(Ig2D&UwzIWHqp$}0F$SP$B-aLNC5ps zAq}6;eE&`iZWdJ{dsP=r&4gc@I9+BY$_WgOF$uFh4=wIqr-!G~w{K?u>1{eF+F6 zTMp;HFtTo=VNEL3g4$%uce}FTkb%o-S4T2-j}xi|;(WlT&}4Wgf_;i~8vz*91w+l& zISokTB_!y34pJeD79j&STabBK_7YSOba!+VS?H6ov#Ve}?Z3`%zw&zth<#<2+yp}d z`Q}%5a z@UisxGl%z3*&yiE1TvOI;LbD%W{{`^-x)ZxZlNM4FI(rWy9V-lpgiziX%p}N5<#zb zNY-ds? - %\VignetteIndexEntry{Statistical Models for 'SciViews::R'} + %\VignetteIndexEntry{'SciViews::R' - Statistical Models} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- @@ -18,6 +18,7 @@ knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.align = 'center', fig.width = 7, fig.height = 5, out.width = "100%") library(modelit) library(tabularise) +library(equatiomatic) library(chart) library(dplyr) ``` @@ -31,6 +32,7 @@ Load the required packages for this example. ```{r} library(modelit) library(tabularise) +library(equatiomatic) library(chart) library(dplyr) ``` @@ -42,7 +44,7 @@ data("Loblolly", package = "datasets") # convert feet to meters Loblolly$height <- round(Loblolly$height * 0.3048, 2) # Add labels and units -Loblolly <- data.io::labelise(Loblolly, +Loblolly <- svBase::labelise(Loblolly, label = list(height = "Heigth", age = "Age", Seed = "Seed"), units = list(height = "m", age = "years"))