R/as_flextable.R

In flextable: Functions for Tabular Reporting

#' @title Method to transform objects into flextables
#' @description This is a convenient function
#' to let users create flextable bindings
#' from any objects. Users should consult documentation
#' of corresponding method to understand the details and
#' see what arguments can be used.
#' @param x object to be transformed as flextable
#' @param ... arguments for custom methods
#' @export
#' @family as_flextable methods
as_flextable <- function(x, ...) {
  UseMethod("as_flextable")
}


#' @title Add row separators to grouped data
#'
#' @description Repeated consecutive values of group columns will
#' be used to define the title of the groups and will
#' be added as a row title.
#'
#' @param x dataset
#' @param groups columns names to be used as row separators.
#' @param columns columns names to keep
#' @param expand_single if FALSE, groups with only one
#' row will not be expanded with a title row. If TRUE (the
#' default), single row groups and multi-row groups are all
#' restructured.
#' @examples
#' # as_grouped_data -----
#' library(data.table)
#' CO2 <- CO2
#' setDT(CO2)
#' CO2$conc <- as.integer(CO2$conc)
#'
#' data_co2 <- dcast(CO2, Treatment + conc ~ Type,
#'   value.var = "uptake", fun.aggregate = mean
#' )
#' data_co2
#' data_co2 <- as_grouped_data(x = data_co2, groups = c("Treatment"))
#' data_co2
#' @seealso [as_flextable.grouped_data()]
#' @export
as_grouped_data <- function(x, groups, columns = NULL, expand_single = TRUE) {
  if (inherits(x, "data.table") || inherits(x, "tbl_df") || inherits(x, "tbl") || is.matrix(x)) {
    x <- as.data.frame(x, stringsAsFactors = FALSE)
  }

  stopifnot(is.data.frame(x), ncol(x) > 0)

  if (is.null(columns)) {
    columns <- setdiff(names(x), groups)
  }

  z <- x[, c(groups, columns), drop = FALSE]
  setDT(z)

  z[, c("rleid") := list(do.call(rleid, as.list(.SD))), .SDcols = groups]
  z <- merge(
    z,
    z[, list(rlen = .N), by = "rleid"],
    by = "rleid"
  )

  subsets <- list()
  for (grp_i in seq_along(groups)) {
    grp_comb <- groups[seq_len(grp_i)]
    if (!expand_single) {
      subdat <- unique(z[z$rlen > 1, .SD, .SDcols = c(grp_comb, "rleid")], by = "rleid")
    } else {
      subdat <- unique(z[, .SD, .SDcols = c(grp_comb, "rleid")], by = "rleid")
    }
    subdat[, c("rleid") := list(.SD$rleid - 1 + grp_i * .1)]
    void_cols <- setdiff(colnames(subdat), c(groups[grp_i], "rleid"))
    if (length(void_cols)) {
      subdat[, c(void_cols) := lapply(.SD, function(w) {
        w[] <- NA
        w
      }), .SDcols = void_cols]
    }
    subsets[[length(subsets) + 1]] <- subdat
  }

  if (!expand_single) {
    z[z$rlen > 1, c(groups) := lapply(.SD, function(w) {
      w[] <- NA
      w
    }), .SDcols = groups]
  } else {
    z[, c(groups) := lapply(.SD, function(w) {
      w[] <- NA
      w
    }), .SDcols = groups]
  }
  z$rlen <- NULL

  subsets[[length(subsets) + 1]] <- z

  x <- rbindlist(subsets, use.names = TRUE, fill = TRUE)
  setorderv(x, cols = "rleid")
  x$rleid <- NULL
  setDF(x)
  class(x) <- c("grouped_data", class(x))
  attr(x, "groups") <- groups
  attr(x, "columns") <- columns
  x
}

#' @export
#' @title Transform a 'grouped_data' object into a flextable
#' @description Produce a flextable from a table
#' produced by function [as_grouped_data()].
#' @param x 'grouped_data' object to be transformed into a "flextable"
#' @param col_keys columns names/keys to display. If some column names are not in
#' the dataset, they will be added as blank columns by default.
#' @param hide_grouplabel if TRUE, group label will not be rendered, only
#' level/value will be rendered.
#' @param ... unused argument
#' @examples
#' library(data.table)
#' CO2 <- CO2
#' setDT(CO2)
#' CO2$conc <- as.integer(CO2$conc)
#'
#' data_co2 <- dcast(CO2, Treatment + conc ~ Type,
#'   value.var = "uptake", fun.aggregate = mean
#' )
#' data_co2 <- as_grouped_data(x = data_co2, groups = c("Treatment"))
#'
#' ft <- as_flextable(data_co2)
#' ft <- add_footer_lines(ft, "dataset CO2 has been used for this flextable")
#' ft <- add_header_lines(ft, "mean of carbon dioxide uptake in grass plants")
#' ft <- set_header_labels(ft, conc = "Concentration")
#' ft <- autofit(ft)
#' ft <- width(ft, width = c(1, 1, 1))
#' ft
#' @family as_flextable methods
#' @seealso [as_grouped_data()]
as_flextable.grouped_data <- function(x, col_keys = NULL, hide_grouplabel = FALSE, ...) {
  if (is.null(col_keys)) {
    col_keys <- attr(x, "columns")
  }
  groups <- attr(x, "groups")
  if (hide_grouplabel) {
    col_keys <- setdiff(col_keys, groups)
  }
  z <- flextable(x, col_keys = col_keys)

  j2 <- length(col_keys)
  for (grp_name in groups) {
    i <- !is.na(x[[grp_name]])
    gnames <- x[[grp_name]][i]
    if (!hide_grouplabel) {
      z <- compose(z,
        i = i, j = 1,
        value = as_paragraph(as_chunk(grp_name), ": ", as_chunk(gnames))
      )
    } else {
      z <- compose(z, i = i, j = 1, value = as_paragraph(as_chunk(gnames)))
    }

    z <- merge_h_range(z, i = i, j1 = 1, j2 = j2)
    z <- align(z, i = i, align = "left")
  }

  z
}




pvalue_format <- function(x) {
  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
}

#' @export
#' @importFrom stats naprint quantile
#' @importFrom utils tail
#' @title Transform a 'glm' object into a flextable
#' @description produce a flextable describing a
#' generalized linear model produced by function `glm`.
#'
#' You can remove significance stars by setting options
#' `options(show.signif.stars = FALSE)`.
#' @param x glm model
#' @param ... unused argument
#' @examples
#' if (require("broom")) {
#'   dat <- attitude
#'   dat$high.rating <- (dat$rating > 70)
#'   probit.model <- glm(high.rating ~ learning + critical +
#'     advance, data = dat, family = binomial(link = "probit"))
#'   ft <- as_flextable(probit.model)
#'   ft
#' }
#' @family as_flextable methods
as_flextable.glm <- function(x, ...) {
  if (!requireNamespace("broom", quietly = TRUE)) {
    stop(sprintf(
      "'%s' package should be installed to create a flextable from an object of type '%s'.",
      "broom", "glm"
    ))
  }

  data_t <- broom::tidy(x)
  sum_obj <- summary(x)
  show_signif <- !is.null(getOption("show.signif.stars")) && getOption("show.signif.stars")

  ft <- flextable(data_t, col_keys = c(
    "term", "estimate",
    "std.error", "statistic", "p.value", if (show_signif) "signif"
  ))
  ft <- colformat_double(ft, j = c(
    "estimate", "std.error",
    "statistic"
  ), digits = 3)
  ft <- colformat_double(ft, j = c("p.value"), digits = 4) # nolint
  if (show_signif) {
    ft <- mk_par(ft,
      j = "signif",
      value = as_paragraph(pvalue_format(p.value))
    )
  }

  ft <- set_header_labels(ft,
    term = "", estimate = "Estimate",
    std.error = "Standard Error", statistic = "z value",
    p.value = "Pr(>|z|)"
  )

  digits <- max(3L, getOption("digits") - 3L)

  ft <- add_footer_lines(ft, values = c(
    if (show_signif) "Signif. codes: 0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05",
    if (show_signif) " ",
    paste("(Dispersion parameter for ", x$family$family, " family taken to be ", format(sum_obj$dispersion), ")", sep = ""),
    sprintf("Null deviance: %s on %s degrees of freedom", formatC(sum_obj$null.deviance), formatC(sum_obj$df.null)),
    sprintf("Residual deviance: %s on %s degrees of freedom", formatC(sum_obj$deviance), formatC(sum_obj$df.residual)),
    {
      mess <- naprint(sum_obj$na.action)
      if (nzchar(mess)) {
        paste("  (", mess, ")\n", sep = "")
      } else {
        character(0)
      }
    }
  ))
  if (show_signif) {
    ft <- align(ft, i = 1, align = "right", part = "footer")
    ft <- italic(ft, i = 1, italic = TRUE, part = "footer")
  }
  ft <- hrule(ft, rule = "auto")
  ft <- autofit(ft, part = c("header", "body"))
  if (show_signif) {
    ft <- width(ft, j = "signif", width = .4)
  }

  ft
}


#' @export
#' @title Transform a 'lm' object into a flextable
#' @description produce a flextable describing a
#' linear model produced by function `lm`.
#'
#' You can remove significance stars by setting options
#' `options(show.signif.stars = FALSE)`.
#' @param x lm model
#' @param ... unused argument
#' @examples
#' if (require("broom")) {
#'   lmod <- lm(rating ~ complaints + privileges +
#'     learning + raises + critical, data = attitude)
#'   ft <- as_flextable(lmod)
#'   ft
#' }
#' @family as_flextable methods
as_flextable.lm <- function(x, ...) {
  if (!requireNamespace("broom", quietly = TRUE)) {
    stop(sprintf(
      "'%s' package should be installed to create a flextable from an object of type '%s'.",
      "broom", "lm"
    ))
  }

  data_t <- broom::tidy(x)
  data_g <- broom::glance(x)

  show_signif <- !is.null(getOption("show.signif.stars")) && getOption("show.signif.stars")
  col_keys <- c(
    "term", "estimate", "std.error", "statistic", "p.value",
    if (show_signif) "signif"
  )

  ft <- flextable(data_t, col_keys = col_keys)
  ft <- colformat_double(ft, j = c("estimate", "std.error", "statistic"), digits = 3)
  ft <- colformat_double(ft, j = c("p.value"), digits = 4)

  if (show_signif) {
    ft <- mk_par(ft, j = "signif", value = as_paragraph(pvalue_format(p.value)))
  }

  ft <- set_header_labels(ft,
    term = "", estimate = "Estimate",
    std.error = "Standard Error", statistic = "t value",
    p.value = "Pr(>|t|)", signif = ""
  )
  dimpretty <- dim_pretty(ft, part = "all")

  ft <- add_footer_lines(ft, values = c(
    if (show_signif) "Signif. codes: 0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05",
    if (show_signif) "",
    sprintf("Residual standard error: %s on %.0f degrees of freedom", formatC(data_g$sigma), data_g$df.residual),
    sprintf("Multiple R-squared: %s, Adjusted R-squared: %s", formatC(data_g$r.squared), formatC(data_g$adj.r.squared)),
    sprintf("F-statistic: %s on %.0f and %.0f DF, p-value: %.4f", formatC(data_g$statistic), data_g$df.residual, data_g$df, data_g$p.value)
  ))

  if (show_signif) {
    ft <- align(ft, i = 1, align = "right", part = "footer")
    ft <- italic(ft, i = 1, italic = TRUE, part = "footer")
  }
  ft <- hrule(ft, rule = "auto")
  ft <- autofit(ft, part = c("header", "body"))
  if (show_signif) {
    ft <- width(ft, j = "signif", width = .4)
  }
  ft
}


#' @export
#' @title Transform a 'htest' object into a flextable
#' @description produce a flextable describing an
#' object oof class `htest`.
#' @param x htest object
#' @param ... unused argument
#' @examples
#' if (require("stats")) {
#'   M <- as.table(rbind(c(762, 327, 468), c(484, 239, 477)))
#'   dimnames(M) <- list(
#'     gender = c("F", "M"),
#'     party = c("Democrat", "Independent", "Republican")
#'   )
#'   ft_1 <- as_flextable(chisq.test(M))
#'   ft_1
#' }
#' @family as_flextable methods
as_flextable.htest <- function(x, ...) {
  ret <- x[c("estimate", "statistic", "p.value", "parameter")]
  if (length(ret$estimate) > 1) {
    names(ret$estimate) <- paste0("estimate", seq_along(ret$estimate))
    ret <- c(ret$estimate, ret)
    ret$estimate <- NULL
    if (x$method == "Welch Two Sample t-test") {
      ret <- c(
        estimate = ret$estimate1 - ret$estimate2,
        ret
      )
    }
  }
  if (length(x$parameter) > 1) {
    ret$parameter <- NULL
    if (is.null(names(x$parameter))) {
      warning("Multiple unnamed parameters in hypothesis test; dropping them")
    } else {
      message(
        "Multiple parameters; naming those columns ",
        paste(make.names(names(x$parameter)), collapse = ", ")
      )
      ret <- append(ret, x$parameter, after = 1)
    }
  }
  ret <- Filter(Negate(is.null), ret)
  if (!is.null(x$conf.int)) {
    ret <- c(ret, conf.low = x$conf.int[1], conf.high = x$conf.int[2])
  }
  if (!is.null(x$method)) {
    ret <- c(ret, method = as.character(x$method))
  }
  if (!is.null(x$alternative)) {
    ret <- c(ret, alternative = as.character(x$alternative))
  }
  dat <- as.data.frame(ret, stringsAsFactors = FALSE)
  z <- flextable(dat)
  z <- colformat_double(z)

  show_signif <- !is.null(getOption("show.signif.stars")) && getOption("show.signif.stars")

  if ("p.value" %in% colnames(dat)) {
    z <- colformat_double(z, j = "p.value", digits = 4)

    if (show_signif) {
      z <- append_chunks(
        x = z, j = "p.value", part = "body",
        dumb = as_chunk(p.value, formatter = pvalue_format)
      )
      z <- add_footer_lines(z, values = c(
        "Signif. codes: 0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05"
      ))
    }
  }
  z <- autofit(z)
  z
}



#' @export
#' @title Continuous columns summary
#' @description create a data.frame summary for continuous variables
#' @param dat a data.frame
#' @param columns continuous variables to be summarized. If NULL all
#' continuous variables are summarized.
#' @param by discrete variables to use as groups when summarizing.
#' @param hide_grouplabel if TRUE, group label will not be rendered, only
#' level/value will be rendered.
#' @param digits the desired number of digits after the decimal point
#' @examples
#' ft_1 <- continuous_summary(iris, names(iris)[1:4],
#'   by = "Species",
#'   hide_grouplabel = FALSE
#' )
#' ft_1
continuous_summary <- function(dat, columns = NULL,
                               by = character(0),
                               hide_grouplabel = TRUE,
                               digits = 3) {
  if (!is.data.table(dat)) {
    x <- as.data.table(dat)
  }
  if (is.null(columns)) {
    columns <- colnames(dat)[sapply(dat, function(z) is.double(z) || is.integer(z))]
  }

  fun_list <- c(
    "N", "MIN", "Q1", "MEDIAN",
    "Q3", "MAX", "MEAN", "SD", "MAD", "NAS"
  )
  agg <- x[,
    c(
      lapply(.SD, N),
      lapply(.SD, MIN),
      lapply(.SD, Q1),
      lapply(.SD, MEDIAN),
      lapply(.SD, Q3),
      lapply(.SD, MAX),
      lapply(.SD, MEAN),
      lapply(.SD, SD),
      lapply(.SD, MAD),
      lapply(.SD, NAS)
    ),
    .SDcols = columns,
    by = by
  ]

  gen_cn <- lapply(fun_list, function(fun, col) paste0(col, "_", fun), columns)
  colnames(agg) <- c(by, unlist(gen_cn))

  agg <- melt(agg, measure = c(gen_cn), value.name = fun_list)
  levels(x = agg[["variable"]]) <- columns
  z <- as_grouped_data(agg, groups = "variable", columns = setdiff(names(agg), "variable"))
  is_label <- !is.na(z$variable)
  ft <- as_flextable(z, hide_grouplabel = hide_grouplabel)


  ft <- colformat_int(ft, j = c("N", "NAS"))
  ft <- colformat_double(ft, j = setdiff(fun_list, c("N", "NAS")), digits = digits)
  ft <- set_header_labels(ft, values = c(
    "MIN" = "min.", "MAX" = "max.",
    "Q1" = "q1", "Q3" = "q3",
    "MEDIAN" = "median", "MEAN" = "mean", "SD" = "sd",
    "MAD" = "mad",
    "NAS" = "# na"
  ))
  ft <- hline(ft, i = is_label, border = officer::fp_border(width = .5))
  ft <- italic(ft, italic = TRUE, i = is_label)
  ft <- merge_v(ft, j = by)
  ft <- valign(ft, j = by, valign = "top")
  ft <- vline(ft, j = length(by), border = officer::fp_border(width = .5), part = "body")
  ft <- vline(ft, j = length(by), border = officer::fp_border(width = .5), part = "header")
  fix_border_issues(ft)
}




#' @export
#' @title Transform a mixed model into a flextable
#' @description produce a flextable describing a
#' mixed model. The function is only using package 'broom.mixed'
#' that provides the data presented in the resulting flextable.
#'
#' You can remove significance stars by setting options
#' `options(show.signif.stars = FALSE)`.
#' @param x a mixed model
#' @param add.random TRUE or FALSE, if TRUE random effects are
#' added to the table.
#' @param ... unused argument
#' @examples
#' if (require("broom.mixed") && require("nlme")) {
#'   m1 <- lme(distance ~ age, data = Orthodont)
#'   ft <- as_flextable(m1)
#'   ft
#' }
#' @family as_flextable methods
as_flextable.merMod <- function(x, add.random = TRUE, ...) {
  if (!requireNamespace("broom.mixed", quietly = TRUE)) {
    stop(sprintf(
      "'%s' package should be installed to create a flextable from an object of type '%s'.",
      "broom.mixed", "mixed model"
    ))
  }

  data_t <- broom::tidy(x)
  data_t$effect[data_t$effect %in% "fixed"] <- "Fixed effects"
  data_t$effect[data_t$effect %in% c("ran_pars", "ran_vals", "ran_coefs")] <- "Random effects"

  data_g <- broom::glance(x)

  has_pvalue <- if ("p.value" %in% colnames(data_t)) TRUE else FALSE
  show_signif <- !is.null(getOption("show.signif.stars")) && getOption("show.signif.stars")

  col_keys <- c(
    "effect", "group", "term", "estimate",
    "std.error", "df", "statistic",
    if (has_pvalue) c("p.value"),
    if (has_pvalue && show_signif) "signif"
  )

  if (add.random) {
    data_t <- as_grouped_data(x = data_t, groups = "effect", )
    ft <- as_flextable(data_t,
      col_keys = col_keys,
      hide_grouplabel = TRUE
    )
  } else {
    data_t <- data_t[data_t$effect %in% "Fixed effects", ]
    ft <- flextable(data_t, col_keys = setdiff(col_keys, c("effect", "group")))
  }

  ft <- colformat_double(ft, j = c("estimate", "std.error", "statistic"), digits = 3)
  ft <- colformat_double(ft, j = c("df"), digits = 0)
  if (has_pvalue) {
    ft <- colformat_double(ft, j = "p.value", digits = 4)
  }
  ft <- set_header_labels(ft,
    term = "", estimate = "Estimate",
    std.error = "Standard Error",
    p.value = "p-value"
  )
  ft <- autofit(ft, part = c("header", "body"))

  if (has_pvalue && show_signif) {
    ft <- mk_par(ft, j = "signif", value = as_paragraph(pvalue_format(p.value)))
    ft <- width(ft, j = "signif", width = .4)
  }
  ft <- align(ft, i = ~ !is.na(effect), align = "center")

  if (has_pvalue && show_signif) {
    ft <- add_footer_lines(ft, values = c(
      "Signif. codes: 0 <= '***' < 0.001 < '**' < 0.01 < '*' < 0.05",
      ""
    ))
  }

  mod_stats <- c("sigma", "logLik", "AIC", "BIC")
  mod_gl <- data.frame(
    stat = mod_stats,
    value = as.double(unlist(data_g[mod_stats])),
    labels = c(
      "square root of the estimated residual variance",
      "data's log-likelihood under the model",
      "Akaike Information Criterion",
      "Bayesian Information Criterion"
    )
  )
  mod_qual <- paste0(
    c(
      "square root of the estimated residual variance",
      "data's log-likelihood under the model",
      "Akaike Information Criterion",
      "Bayesian Information Criterion"
    ),
    ": ",
    format_fun(unlist(data_g[mod_stats]))
  )
  ft <- add_footer_lines(ft, values = mod_qual)
  ft <- align(ft, align = "left", part = "footer")
  if (has_pvalue && show_signif) {
    ft <- align(ft, i = 1, align = "right", part = "footer")
  }
  ft <- hrule(ft, rule = "auto")
  ft
}

#' @export
#' @rdname as_flextable.merMod
as_flextable.lme <- as_flextable.merMod

#' @export
#' @rdname as_flextable.merMod
as_flextable.gls <- as_flextable.merMod

#' @export
#' @rdname as_flextable.merMod
as_flextable.nlme <- as_flextable.merMod

#' @export
#' @rdname as_flextable.merMod
as_flextable.brmsfit <- as_flextable.merMod

#' @export
#' @rdname as_flextable.merMod
as_flextable.glmmTMB <- as_flextable.merMod

#' @export
#' @rdname as_flextable.merMod
as_flextable.glmmadmb <- as_flextable.merMod

#' @export
#' @title Transform a 'kmeans' object into a flextable
#' @description produce a flextable describing a
#' kmeans object. The function is only using package 'broom'
#' that provides the data presented in the resulting flextable.
#' @param x a [kmeans()] object
#' @param digits number of digits for the numeric columns
#' @param ... unused argument
#' @examples
#' if (require("stats")) {
#'   cl <- kmeans(scale(mtcars[1:7]), 5)
#'   ft <- as_flextable(cl)
#'   ft
#' }
#' @importFrom rlang sym
#' @family as_flextable methods
as_flextable.kmeans <- function(x, digits = 4, ...) {
  if (!requireNamespace("broom", quietly = TRUE)) {
    stop(sprintf(
      "'%s' package should be installed to create a flextable from an object of type '%s'.",
      "broom", "kmeans"
    ))
  }

  ## kmeans body ----
  clusters_stat <- broom::tidy(x)
  setDT(clusters_stat)
  keys <- c("withinss", "size", setdiff(colnames(clusters_stat), c("cluster", "withinss", "size")))
  key_type <- rep("Centers", length(keys))
  key_type[1:2] <- "Statistics"
  clusters_stat[, c(keys) := lapply(.SD, as.double), .SDcols = keys]

  clusters_stat <- melt.data.table(
    data = clusters_stat, id.vars = "cluster",
    measure.vars = setdiff(colnames(clusters_stat), c("cluster")),
    value.name = "value"
  )
  clusters_stat$variable <- factor(clusters_stat$variable, levels = keys)
  setorderv(clusters_stat, cols = c("variable"))
  setDF(clusters_stat)

  ## kmeans footer ----
  data_g <- broom::glance(x)
  w_labels <- c(
    "Total sum of squares",
    "Total within-cluster sum of squares",
    "Total between-cluster sum of squares",
    "BSS/TSS ratio",
    "Number of iterations"
  )
  totss <- data_g$totss
  tot.withinss <- data_g$tot.withinss
  betweenss <- data_g$betweenss
  ratio <- betweenss / totss
  w_labels <- paste0(
    w_labels, ": ",
    c(
      format_fun(totss),
      format_fun(tot.withinss),
      format_fun(betweenss),
      format_fun(ratio * 100, suffix = "%"),
      as.character(x$iter)
    )
  )

  ## tabulate ----
  ct <- tabulator(
    x = clusters_stat, rows = c("variable"), columns = "cluster",
    hidden_data = data.frame(
      variable = keys,
      key_type = key_type
    ),
    zz = as_paragraph(as_chunk(value))
  )

  ## flextable ----
  ft <- as_flextable(ct)
  ft <- add_footer_lines(ft, c("(*) Centers", w_labels))

  zz_labs <- tabulator_colnames(ct, type = "columns", columns = "zz")
  value_labq <- tabulator_colnames(ct, type = "hidden", columns = "value")

  for (j in seq_along(zz_labs)) {
    sym_val <- sym(value_labq[j])
    ft <- mk_par(ft,
      i = ~ variable %in% "size",
      j = zz_labs[j],
      value = as_paragraph(
        as_chunk(
          !!sym_val,
          formatter = function(x) sprintf("%.0f", x)
        )
      )
    )
    ft <- mk_par(ft,
      i = ~ !variable %in% c("size", "withinss"),
      j = zz_labs[j],
      value = as_paragraph(
        as_chunk(
          !!sym_val,
          formatter = function(x) format_fun(x, digits = digits)
        )
      )
    )
  }
  ft <- append_chunks(ft,
    j = 1, part = "body",
    i = ~ key_type %in% "Centers",
    as_chunk("*")
  )
  ft <- hline(ft,
    j = c("variable", zz_labs), i = ~ variable %in% "size",
    border = fp_border_default()
  )
  ft <- autofit(ft, part = c("header", "body"))
  ft <- align(ft, align = "right", part = "footer")
  ft <- align(ft,
    align = "left", i = 1,
    part = "footer"
  )
  ft <- hrule(ft, rule = "auto")
  ft <- bold(ft, part = "header", bold = TRUE)
  ft
}

#' @export
#' @title Transform a 'pam' object into a flextable
#' @description produce a flextable describing a
#' pam object. The function is only using package 'broom'
#' that provides the data presented in the resulting flextable.
#' @param x a [cluster::pam()] object
#' @param digits number of digits for the numeric columns
#' @param ... unused argument
#' @examples
#' if (require("cluster")) {
#'   dat <- as.data.frame(scale(mtcars[1:7]))
#'   cl <- pam(dat, 3)
#'   ft <- as_flextable(cl)
#'   ft
#' }
#' @family as_flextable methods
as_flextable.pam <- function(x, digits = 4, ...) {
  if (!requireNamespace("broom", quietly = TRUE)) {
    if (!requireNamespace("broom", quietly = TRUE)) {
      stop(sprintf(
        "'%s' package should be installed to create a flextable from an object of type '%s'.",
        "broom", "pam"
      ))
    }
  }

  clus_stat_names <- c(
    "size", "max.diss", "avg.diss", "diameter",
    "separation", "avg.width"
  )

  ## kmeans body ----
  clusters_stat <- broom::tidy(x)
  setDT(clusters_stat)
  keys <- colnames(clusters_stat)
  clusters_stat <- melt.data.table(
    data = clusters_stat, id.vars = "cluster",
    measure.vars = setdiff(colnames(clusters_stat), c("cluster")),
    value.name = "value"
  )

  ## tabulate ----
  ct <- tabulator(
    x = clusters_stat, rows = c("variable"), columns = "cluster",
    zz = as_paragraph(as_chunk(value))
  )

  ## flextable ----
  ft <- as_flextable(ct)
  ft <- add_footer_lines(ft, "(*) Centers")

  zz_labs <- tabulator_colnames(ct, type = "columns", columns = "zz")
  value_labq <- tabulator_colnames(ct, type = "hidden", columns = "value")

  for (j in seq_along(zz_labs)) {
    sym_val <- sym(value_labq[j])
    ft <- mk_par(ft,
      i = ~ variable %in% "size",
      j = zz_labs[j],
      value = as_paragraph(
        as_chunk(
          !!sym_val,
          formatter = function(x) sprintf("%.0f", x)
        )
      )
    )
    ft <- mk_par(ft,
      i = ~ !variable %in% c(
        "size", "max.diss", "avg.diss", "diameter",
        "separation", "avg.width"
      ),
      j = zz_labs[j],
      value = as_paragraph(
        as_chunk(
          !!sym_val,
          formatter = function(x) {
            format_fun(x, digits = digits)
          }
        )
      )
    )
  }

  data_g <- broom::glance(x)

  ft <- append_chunks(ft,
    j = 1, part = "body",
    i = ~ !variable %in% c(
      "size", "max.diss", "avg.diss", "diameter",
      "separation", "avg.width"
    ),
    as_chunk("*")
  )
  ft <- hline(ft,
    j = c("variable", zz_labs), i = ~ variable %in% "avg.width",
    border = fp_border_default()
  )

  ft <- autofit(ft, part = c("header", "body"))
  ## kmeans footer ----
  ft <- add_footer_lines(
    x = ft,
    values = paste0(
      "The average silhouette width is ",
      formatC(data_g$avg.silhouette.width)
    )
  )

  ft <- align(ft, j = 1, align = "left", part = "footer")
  ft <- hrule(ft, rule = "auto")
  ft <- bold(ft, part = "header", bold = TRUE)
  ft
}


#' @export
#' @title set model automatic printing as a flextable
#' @description Define [as_flextable()] as
#' print method in an R Markdown document for models
#' of class:
#'
#' * lm
#' * glm
#' * models from package 'lme' and 'lme4'
#' * htest (t.test, chisq.test, ...)
#' * gam
#' * kmeans and pam
#'
#'
#' In a setup run chunk:
#'
#' ```
#' flextable::use_model_printer()
#' ```
#' @seealso [use_df_printer()], [flextable()]
use_model_printer <- function() {
  fun <- function(x, ...) knitr::knit_print(as_flextable(x))
  registerS3method("knit_print", "lm", fun)
  registerS3method("knit_print", "glm", fun)
  registerS3method("knit_print", "lme", fun)
  registerS3method("knit_print", "htest", fun)
  registerS3method("knit_print", "merMod", fun)
  registerS3method("knit_print", "gls", fun)
  registerS3method("knit_print", "nlme", fun)
  registerS3method("knit_print", "brmsfit", fun)
  registerS3method("knit_print", "glmmTMB", fun)
  registerS3method("knit_print", "glmmadmb", fun)
  registerS3method("knit_print", "gam", fun)
  registerS3method("knit_print", "pam", fun)
  registerS3method("knit_print", "kmeans", fun)
  invisible()
}

utils::globalVariables(c("p.value", "value", "Type", ".row_title"))