#' Determine amount of disagreement
#'
#' @description
#'
#' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("experimental")}
#'
#' @param x [readr::cols()] column-specification, or `data.frame`
#' @param y [readr::cols()] column-specification, or `data.frame`
#'
#' @return object with S3 class `col_spec_diff`
#' @export
#'
col_spec_compare <- function(x, y) {
# what to do if no names?
col_spec_x <- readr::as.col_spec(x)
col_spec_y <- readr::as.col_spec(y)
names_x <- names(col_spec_x$cols)
names_y <- names(col_spec_y$cols)
# local variant
cs_sel_local <- function(spec, names) {
col_spec_select(spec, tidyselect::all_of(names))
}
names <-
list(
identical = identical(names_x, names_y),
equivalent = identical(sort(names_x), sort(names_y)),
x_not_y = cs_sel_local(col_spec_x, names_x[!(names_x %in% names_y)]),
y_not_x = cs_sel_local(col_spec_y, names_y[!(names_y %in% names_x)])
)
names_common <- intersect(names_x, names_y)
cols_x_common <- cs_sel_local(col_spec_x, names_common)
cols_y_common <- cs_sel_local(col_spec_y, names_common)
is_same <- purrr::map2_lgl(cols_x_common$cols, cols_y_common$cols, identical)
names_not_same <- names_common[!is_same]
specs_common <-
list(
identical = ifelse(length(is_same) > 0, all(is_same), as.logical(NA)),
x_diff_y = cs_sel_local(cols_x_common, names_not_same),
y_diff_x = cs_sel_local(cols_y_common, names_not_same)
)
col_spec_diff(
identical = identical(col_spec_x, col_spec_y),
names = names,
specs_common = specs_common
)
}
# use like dplyr::select
col_spec_select <- function(x, ...) {
# ref: https://tidyselect.r-lib.org/articles/tidyselect.html#simple-selections-with-dots
expr <- rlang::expr(c(...))
pos <- tidyselect::eval_select(expr, data = x$cols)
x$cols <- rlang::set_names(x$cols[pos], names(pos))
x
}
has_cols <- function(x) {
length(x$cols) > 0
}
#' @export
print.col_spec_diff <- function(x, ...) {
bold <- function(x) cli::style_bold(x)
# determine the amount of space to give names so that everything lines up
col_names <- function(x) {
names(x$cols)
}
# is there a way to do this with purrr and a predicate?
cols <- list(
x$names$x_not_y,
x$names$y_not_x,
x$specs_common$x_diff_y,
x$specs_common$y_diff_x
)
# find the longest name for a "problem" column
get_max_size <- function(x) {
if (identical(length(x$cols), 0L)) {
return(0L)
}
names <- names(x$cols)
max(nchar(names))
}
size <- purrr::map_int(cols, ~get_max_size(.x))
size <- max(size)
cli::cli_h1("Column comparison")
if (x$identical) {
cli::cli_alert_success("Column names and specifications are identical and have same order.")
return(invisible(x))
}
if (x$names$identical) {
cli::cli_alert_success("Column names are identical and have same order.")
}
if (!x$names$identical && x$names$equivalent) {
cli::cli_alert_info("Column names are identical but have different order.")
}
if (has_cols(x$names$x_not_y)) {
cli::cli_alert_warning("Column names in {bold('x')} but not {bold('y')}:")
cols_out(x$names$x_not_y, size)
}
if (has_cols(x$names$y_not_x)) {
cli::cli_alert_warning("Column names in {bold('y')} but not {bold('x')}:")
cols_out(x$names$y_not_x, size)
}
if (identical(x$specs_common$identical, TRUE)) {
cli::cli_alert_success(
c(
"Column names in both {bold('x')} and {bold('y')} ",
"have identical specifications."
)
)
return(invisible(x))
}
if (is.na(x$specs_common$identical)){
cli::cli_alert_warning(
"There are no column names common to both {bold('x')} and {bold('y')}."
)
return(invisible(x))
}
if (has_cols(x$specs_common$x_diff_y)) {
cli::cli_alert_warning(
"Column specifications different in {bold('x')}:"
)
cols_out(x$specs_common$x_diff_y, size)
}
if (has_cols(x$specs_common$y_diff_x)) {
cli::cli_alert_warning(
"Column specifications different in {bold('y')}:"
)
cols_out(x$specs_common$y_diff_x, size)
}
return(invisible(x))
}
col_cli <- function(x, name, size) {
fname <- sprintf(glue::glue("%{size}s"), name)
type <- sub(".*_", "", class(x)[1])
fspec <- glue::glue("col_{type}()")
cli::cat_bullet(glue::glue("{cli::style_bold(fname)} {fspec}"))
}
cols_out <- function(x, size = NULL) {
tbl <- cols_parse(x)
size <- size %||% max(nchar(tbl$name))
fout <- function(name, spec, size) {
fname <- sprintf(glue::glue("%{size+3}s"), name)
cat(glue::glue("{cli::style_bold(fname)} {spec}"), "\n")
}
purrr::pwalk(tbl, fout, size)
}
cols_parse <- function(x) {
fmt <- format(x)
content <- sub("^cols\\((.*)\\)\n$", "\\1", fmt)
content <- trimws(content)
lines <- strsplit(content, ",\n")[[1]]
lines <- purrr::map_chr(lines, trimws)
regex <- "^([^=]*)( = )(.*)$"
name <- sub(regex, "\\1", lines)
spec <- sub(regex, "\\3", lines)
tibble::tibble(name, spec)
}
col_spec_diff <- function(identical, names, specs_common) {
structure(
list(identical = identical, names = names, specs_common = specs_common),
class = "col_spec_diff"
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.