tests/testthat/helper.r

In autodb: Automatic Database Normalisation for Data Frames

# re-implementation of expect_no_error that hedgehog doesn't complain about
# (it doesn't register usage of expect_no_ as an expectation)
expect_errorless <- function(object) {
  expect(
    class(try(object))[1] != "try-error",
    failure_message = "object returned an error"
  )
}

expect_valid_functional_dependency <- function(x) {
  expect_s3_class(x, "functional_dependency")
  attrs <- attrs_order(x)
  expect_true(all(lengths(unclass(x)) == 2L))
  expect_silent(dependant(x))
  expect_true(all(lengths(dependant(x)) == 1L))
  expect_true(all(vapply(detset(x), is.character, logical(1))))
  lhs <- detset(x)

  expect_true(all(is.element(unlist(x), attrs)))
  expect_true(all(
    mapply(\(dets, dep) !is.element(dep, dets), detset(x), dependant(x))
  ))
  expect_true(all(vapply(
    lhs,
    \(detset) !is.unsorted(match(detset, attrs)),
    logical(1)
  )))
}

expect_valid_minimal_functional_dependency <- function(x) {
  expect_valid_functional_dependency(x)
  expect_true(all(outer(x, x, "<=") == diag(length(x))))
}

expect_valid_key_set <- function(x) {
  expect_identical(class(x), "list")
  expect_true(all(vapply(x, \(y) class(y)[[1]], character(1)) == "character"))
  expect_gt(length(x), 0) # every relation has at least one key
  expect_true(all(outer(x, x, Vectorize(\(y, z) all(is.element(y, z)))) == diag(length(x))))
}

expect_valid_relation_schema <- function(x, unique = FALSE, single_empty_key = FALSE) {
  expect_s3_class(x, "relation_schema")
  expect_true(is.character(names(x)))
  expect_true(!anyDuplicated(names(x)))
  expect_true(all(nchar(names(x)) > 0L))
  expect_true(all(lengths(unclass(x)) == 2))
  attrs <- attrs(x)
  keys <- keys(x)
  key_els <- lapply(keys, \(ks) unique(unlist(ks)))
  expect_identical(
    Map(\(as, n) as[seq_len(n)], attrs, lengths(key_els)),
    key_els
  )
  nonprime_attrs <- Map(
    \(as, n) as[setdiff(seq_along(as), seq_len(n))],
    attrs,
    lengths(key_els)
  )
  expect_true(all(vapply(
    keys,
    \(ks) all(vapply(ks, \(k) !is.unsorted(match(k, attrs_order(x))), logical(1))),
    logical(1)
  )))
  expect_true(all(vapply(
    nonprime_attrs,
    \(as) all(vapply(as, \(a) !is.unsorted(match(a, attrs_order(x))), logical(1))),
    logical(1)
  )))
  expect_true(all(vapply(keys, Negate(anyDuplicated), logical(1))))
  if (single_empty_key)
    expect_lte(sum(vapply(keys, identical, logical(1), list(character()))), 1L)

  if (unique) {
    expect_true(!anyDuplicated(x))

    implied_fds <- functional_dependency(
      unlist(
        Map(
          \(ks, as) {
            unlist(
              lapply(ks, \(k) lapply(setdiff(as, k), \(a) list(k, a))),
              recursive = FALSE
            )
          },
          keys,
          attrs
        ),
        recursive = FALSE
      ),
      attrs_order(x)
    )
    expect_true(!anyDuplicated(implied_fds))
  }
}

strexpect_valid_references <- function(
  x,
  same_attr_name = FALSE,
  single_key_pairs = FALSE
) {
  msg <- character()

  references <- references(x)
  if (length(references) == 0L)
    return(msg)

  attrs <- attrs(x)
  lab <- rlang::quo_get_expr(rlang::enquo(x))

  # former condition is temporary until references are properly grouped
  if (single_key_pairs && anyDuplicated(references))
    msg <- c(msg, paste(lab, "has duplicate references"))

  fks_are_lists <- vapply(references, inherits, logical(1), "list")
  if (any(!fks_are_lists))
    msg <- c(msg, paste(lab, "has non-list references"))

  fks_are_length_four <- lengths(references) == 4
  if (any(!fks_are_length_four))
    msg <- c(msg, paste(lab, "has non-length-four references"))

  formed_refs <- references[fks_are_lists & fks_are_length_four]

  formed_child_names_char <- vapply(
    formed_refs,
    \(x) is.character(x[[1]]),
    logical(1)
  )
  formed_child_names_scalar <- vapply(
    formed_refs,
    \(x) length(x[[1]]) == 1,
    logical(1)
  )

  formed_parent_names_char <- vapply(
    formed_refs,
    \(x) is.character(x[[3]]),
    logical(1)
  )
  formed_parent_names_scalar <- vapply(
    formed_refs,
    \(x) length(x[[3]]) == 1,
    logical(1)
  )

  formed_child_attrs_char <- vapply(
    formed_refs,
    \(x) is.character(x[[2]]),
    logical(1)
  )
  formed_parent_attrs_char <- vapply(
    formed_refs,
    \(x) is.character(x[[4]]),
    logical(1)
  )
  formed_attrs_length_match <- vapply(
    formed_refs,
    \(x) length(x[[2]]) == length(x[[4]]),
    logical(1)
  )

  if (any(!formed_child_names_char))
    msg <- c(msg, paste(lab, "has non-character reference child names"))
  if (any(!formed_child_attrs_char))
    msg <- c(msg, paste(lab, "has non-character reference child attributes"))
  if (any(!formed_parent_names_char))
    msg <- c(msg, paste(lab, "has non-character reference parent names"))
  if (any(!formed_parent_attrs_char))
    msg <- c(msg, paste(lab, "has non-character reference parent attributes"))

  if (any(!formed_child_names_scalar))
    msg <- c(msg, paste(lab, "has non-length-one reference child names"))
  if (any(!formed_parent_names_scalar))
    msg <- c(msg, paste(lab, "has non-length-one reference parent names"))
  if (any(!formed_attrs_length_match))
    msg <- c(msg, paste(lab, "has non-matching child/parent attribute set lengths"))

  elformed_refs <- formed_refs[
    formed_child_names_char & formed_parent_names_char &
      formed_child_attrs_char & formed_parent_attrs_char &
      formed_child_names_scalar & formed_parent_names_scalar &
      formed_attrs_length_match
  ]

  relnames_exist <- vapply(
    elformed_refs,
    \(ref) all(c(ref[[1]], ref[[3]]) %in% names(x)),
    logical(1)
  )
  if (any(!relnames_exist))
    msg <- c(msg, paste(lab, "has references over non-present relation names"))

  # this could be relaxed
  nonself_reference <- vapply(elformed_refs, \(ref) ref[[1]] != ref[[3]], logical(1))
  if (any(!nonself_reference))
    msg <- c(msg, paste(lab, "has self-references in references"))

  if (same_attr_name) {
    same_attr_names <- vapply(
      elformed_refs,
      \(ref) identical(ref[[2]], ref[[4]]),
      logical(1)
    )
    if (any(!same_attr_names))
      msg <- c(msg, paste(lab, "has non-matching attribute names in references"))
  }

  unique_child_attrs <- vapply(
    elformed_refs,
    \(ref) !anyDuplicated(ref[[2]]),
    logical(1)
  )
  if (any(!unique_child_attrs))
    msg <- c(msg, paste(lab, "has references with non-unique child attribute names"))

  unique_parent_attrs <- vapply(
    elformed_refs,
    \(ref) !anyDuplicated(ref[[2]]),
    logical(1)
  )
  if (any(!unique_parent_attrs))
    msg <- c(msg, paste(lab, "has references with non-unique parent attribute names"))

  nonempty_attr_sets <- vapply(
    elformed_refs,
    \(ref) all(lengths(ref[c(2, 4)]) > 0),
    logical(1)
  )
  if (any(!nonempty_attr_sets))
    msg <- c(msg, paste(lab, "has references with zero-length attribute sets"))

  child_attrs_exist <- vapply(
    elformed_refs,
    \(ref) all(ref[[2]] %in% attrs[[ref[[1]]]]),
    logical(1)
  )
  if (any(!child_attrs_exist))
    msg <- c(msg, paste(lab, "has invalid child attribute names in references"))

  parent_attrs_exist <- vapply(
    elformed_refs,
    \(ref) all(ref[[2]] %in% attrs[[ref[[1]]]]),
    logical(1)
  )
  if (any(!parent_attrs_exist))
    msg <- c(msg, paste(lab, "has invalid parent attribute names in references"))

  if (single_key_pairs) {
    relnames_df <- as.data.frame(do.call(
      rbind,
      lapply(references, \(r) unlist(r[c(1L, 3L)]))
    ))
    if (anyDuplicated(relnames_df))
      msg <- c(msg, paste(lab, "has reference pairs with multiple keys"))
  }

  msg
}

expect_valid_references <- function(
  x,
  same_attr_name = FALSE,
  single_key_pairs = FALSE
) {
  msg <- strexpect_valid_references(x, same_attr_name, single_key_pairs)
  if (length(msg) == 0)
    succeed()
  else
    fail(paste(msg, collapse = "\n"))
}

expect_valid_database_schema <- function(
  x,
  unique = FALSE,
  single_empty_key = FALSE,
  same_attr_name = FALSE,
  single_key_pairs = FALSE
) {
  if (!inherits(x, "database_schema"))
    return(fail(paste("x is not a relation; classes are", toString(class(x)))))
  expect_valid_relation_schema(x, unique, single_empty_key)
  expect_valid_references(x, same_attr_name, single_key_pairs)
}

strexpect_valid_relation <- function(x, unique = FALSE, single_empty_key = FALSE) {
  if (!inherits(x, "relation"))
    return(paste("x is not a relation; classes are", toString(class(x))))

  msg <- character()

  if (!is.character(names(x))) {
    msg <- c(msg, paste("names are not character:", class(names(x))))
  }else{
    if (anyDuplicated(names(x)))
      msg <- c(msg, paste("there are duplicate names in", toString(names(x))))
    if (any(nchar(names(x)) == 0L))
      msg <- c(msg, "there are length-zero names")
  }

  rel_keys <- keys(x)
  rel_key_els <- lapply(rel_keys, \(ks) unique(unlist(ks)))
  rel_attrs <- attrs(x)

  key_attrs_first <- mapply(
    \(ks, as) identical(as[seq_along(ks)], ks),
    rel_key_els,
    rel_attrs
  )
  if (!all(key_attrs_first))
    msg <- c(msg, "there are relations with their key attrs not given first")

  if (!all(vapply(
    rel_keys,
    \(ks) all(vapply(ks, \(k) !is.unsorted(match(k, attrs_order(x))), logical(1))),
    logical(1)
  )))
    msg <- c(msg, "there are relation keys with attributes not in order")

  nonprime_attrs <- Map(
    \(ks, as) as[-seq_along(ks)],
    rel_key_els,
    rel_attrs
  )
  if (!all(vapply(
    nonprime_attrs,
    \(as) all(vapply(as, \(a) !is.unsorted(match(a, attrs_order(x))), logical(1))),
    logical(1)
  )))
    msg <- c(msg, "there are relations with non-key attributes not in order")

  expect_true(all(vapply(rel_keys, Negate(anyDuplicated), logical(1))))
  if (!all(vapply(rel_keys, Negate(anyDuplicated), logical(1))))
    msg <- c(msg, "there are duplicate keys")

  if (
    single_empty_key &&
    sum(vapply(rel_keys, identical, logical(1), list(character()))) > 1
  )
    msg <- c(
      msg,
      "single_empty_key = TRUE, and there are multiple relations with an empty key"
    )

  if (!all(mapply(
    \(recs, ks) all(vapply(
      ks,
      \(k) !df_anyDuplicated(recs[, k, drop = FALSE]),
      logical(1)
    )),
    records(x),
    rel_keys
  )))
    msg <- c(
      msg,
      "there are violated keys"
    )

  if (unique) {
    if (anyDuplicated(x))
      msg <- c(msg, "unique = TRUE and there are duplicate relations")

    implied_fds <- functional_dependency(
      unlist(
        Map(
          \(ks, as) {
            unlist(
              lapply(ks, \(k) lapply(setdiff(as, k), \(a) list(k, a))),
              recursive = FALSE
            )
          },
          rel_keys,
          rel_attrs
        ),
        recursive = FALSE
      ),
      attrs_order(x)
    )
    if (anyDuplicated(implied_fds))
      msg <- c(msg, "there are duplicate implied FDs")
  }

  msg
}

expect_valid_relation <- function(x, unique = FALSE, single_empty_key = FALSE) {
  msg <- strexpect_valid_relation(x, unique, single_empty_key)
  if (length(msg) == 0)
    succeed()
  else
    fail(paste(msg, collapse = "\n"))
}

strexpect_valid_database <- function(
  x,
  unique = FALSE,
  single_empty_key = FALSE,
  same_attr_name = FALSE,
  single_key_pairs = FALSE
) {
  if (!inherits(x, "database"))
    return(paste("x is not a database; classes are", toString(class(x))))

  msg <- strexpect_valid_relation(x, unique, single_empty_key)

  fks <- references(x)
  valid_reftest <- try(
    expect_valid_references(x, same_attr_name, single_key_pairs),
    silent = TRUE
  )
  if (class(valid_reftest)[[1]] == "try-error")
    msg <- c(
      msg,
      attr(x, "condition")$message
    )

  recs <- records(x)
  for (n in seq_along(fks)) {
    fk <- fks[[n]]
    joined_child <- df_unique(recs[[fk[[1]]]][, fk[[2]], drop = FALSE])
    joined_parent <- recs[[fk[[3]]]][, fk[[4]], drop = FALSE]
    child_nrow <- nrow(joined_child)
    parent_nrow <- nrow(joined_parent)
    join <- df_join(
      joined_child,
      joined_parent,
      by.x = fk[[2]],
      by.y = fk[[4]]
    )
    # not removing duplicates causes issues when a factor is merged with
    # a non-factor, since multiple NA instances can appear
    join <- unique(join)
    join_nrow <- nrow(join)
    if (!identical(child_nrow, join_nrow))
      msg <- c(
        msg,
        paste(
          "foreign key",
          n,
          paste0(fk[[1]], ".{", toString(fk[[2]]), "} -> ", fk[[3]], ".{", toString(fk[[4]]), "}"),
          "has differing child/join record counts:",
          child_nrow,
          "and",
          parent_nrow,
          "records join to give",
          join_nrow
        ),
        if (
          all(vapply(joined_child, is.atomic, logical(1))) &&
          child_nrow < 10 &&
          parent_nrow < 10
        )
          c(
            paste(
              "child:",
              tuple_classes(joined_child),
              toString(vapply(
                df_records(joined_child),
                tuple_string,
                character(1)
              ))
            ),
            paste(
              "parent:",
              tuple_classes(joined_parent),
              toString(vapply(
                df_records(joined_parent),
                tuple_string,
                character(1)
              ))
            ),
            paste(
              "join:",
              toString(vapply(
                df_records(join),
                tuple_string,
                character(1)
              ))
            )
          )
      )
  }

  fk_children <- vapply(fks, "[[", character(1), 1L)
  fk_parents <- vapply(fks, "[[", character(1), 3L)
  fk_parent_sets <- split(fk_parents, fk_children)
  children <- names(fk_parent_sets)
  nonchildren <- setdiff(names(x), children)

  msg
}

tuple_classes <- function(x) {
  paste0(
    "<",
    toString(vapply(
      x,
      \(y) {
        cl <- class(y)[[1]]
        if (is.factor(y))
          return(paste0(
            cl,
            "[",
            toString(levels(y)),
            "]"
          ))
        if (inherits(y, "list"))
          return(paste0(
            cl,
            "[",
            tuple_classes(y),
            "]"
          ))
        cl
      },
      character(1)
    )),
    ">"
  )
}

tuple_string <- function(x) {
  paste0(
    "{",
    toString(lapply(
      x,
      \(y) if (is.factor(y))
        paste0(as.integer(y), ":", as.character(y))
      else
        y
    )),
    "}"
  )
}

expect_valid_database <- function(
  x,
  unique = FALSE,
  single_empty_key = FALSE,
  same_attr_name = FALSE,
  single_key_pairs = FALSE
) {
  msg <- strexpect_valid_database(
    x,
    unique,
    single_empty_key,
    same_attr_name,
    single_key_pairs
  )
  if (length(msg) == 0)
    succeed()
  else
    fail(paste(msg, collapse = "\n"))
}

expect_identical_unordered_table <- function(new, original) {
  expect_true(df_equiv(new, original, digits = NA))
}

gen_df_and_type_change <- function(
  nrow,
  ncol,
  remove_dup_rows = FALSE
) {
  changes <- list(
    logical = c("integer", "numeric", "character"),
    integer = c("numeric", "character"),
    numeric = c("character"),
    character = c("logical"),
    factor = c("integer", "numeric", "character"),
    list = character(),
    matrix = character(),
    data.frame = character()
  )
  gen_df(nrow, ncol, minrow = 1L, mincol = 1L, remove_dup_rows) |>
    gen.and_then(\(df) list(df, gen.sample(ncol(df)))) |>
    gen.and_then(uncurry(\(df, attr) {
      change_sets <- match(names(changes), class(df[[attr]]))
      attr_class <- class(df[[attr]])[[1]]
      if (all(is.na(change_sets)))
        stop(paste("no change set for", attr_class, "class"))
      change_ind <- which.min(change_sets)
      stopifnot(length(change_ind) == 1, !is.na(change_ind))
      change_set <- changes[[change_ind]]
      list(
        gen.pure(df),
        gen.pure(attr),
        if (length(change_set) == 0)
          gen.pure(attr_class)
        else
          gen.element(change_set)
      )
    })) |>
    gen.with(uncurry(\(df, attr, new_class) {
      permed <- df
      permed[[attr]] <- as(permed[[attr]], new_class)
      list(df, permed)
    }))
}

gen_df <- function(
  nrow,
  ncol,
  minrow = 0L,
  mincol = 0L,
  remove_dup_rows = FALSE,
  digits = NA,
  variant = c("data.frame", "tibble"),
  atomic = FALSE
) {
  list(
    gen.element(seq.int(min(mincol, ncol), ncol)) |>
      gen.and_then(\(n) list(
        classes = gen.df_colclass(atomic) |> gen.c(of = n),
        nms = gen_attr_names(n, 9)
      )),
    n_records = gen.element(seq.int(min(minrow, nrow), nrow)),
    variant = gen.element(variant)
  ) |>
    gen.with(\(lst) c(lst[[1]], lst[2], list(remove_dup_rows = remove_dup_rows), lst[3])) |>
    gen.and_then(uncurry(with_args(gen.df_fixed_ranges, digits = digits)))
}

gen.df_colclass <- function(atomic) {
  asable_classes <- c(
    "logical",
    "integer",
    "numeric",
    "character",
    "factor",
    if (!atomic) "list",
    if (!atomic) "matrix",
    if (!atomic) "data.frame"
  )
  gen.element(asable_classes)
}

gen.df_fixed_ranges <- function(
  classes,
  nms,
  n_records,
  remove_dup_rows,
  digits = getOption("digits"),
  variant = c("data.frame", "tibble")
) {
  variant <- match.arg(variant)
  variant <- switch(
    variant,
    data.frame = identity,
    tibble = with_args(tibble::as_tibble, .name_repair = "minimal")
  )
  as_fns <- list(
    logical = gen.element(c(FALSE, TRUE, NA)) |>
      gen.c(of = n_records) |>
      gen.with(as.logical),
    integer = gen.choice(
      gen.shrink(
        function(x) as.integer(shrink.towards(0L)(x)),
        gen.element(-5:5)
      ),
      gen.pure(NA_integer_),
      prob = c(10, 1)
    ) |>
      gen.c(of = n_records) |>
      gen.with(as.integer),
    numeric = gen.numeric() |>
      gen.c(of = n_records) |>
      gen.with(as.numeric) |>
      gen.and_then(with_args(gen.float_coincide, digits = digits)),
    character = gen.element(c("FALSE", "TRUE", NA_character_)) |>
      gen.c(of = n_records) |>
      gen.with(as.character),
    factor = gen.element(c("FALSE", "TRUE", NA_character_)) |>
      gen.c(of = n_records) |>
      gen.with(with_args(factor, levels = c("FALSE", "TRUE"))),
    list = gen.list_element() |>
      gen.list(of = n_records),
    matrix = gen.element(0:2) |>
      gen.and_then(\(n) {
        gen.choice(
          gen.element(c(FALSE, TRUE, NA)) |>
            gen.c(of = n*n_records) |>
            gen.with(as.logical),
          gen.element(c(-5:5, NA_integer_)) |>
            gen.c(of = n*n_records) |>
            gen.with(as.integer),
          gen.numeric() |>
            gen.c(of = n*n_records) |>
            gen.with(as.numeric),
          gen.element(c("FALSE", "TRUE", NA_character_)) |>
            gen.c(of = n*n_records) |>
            gen.with(as.character),
          gen.element(c("FALSE", "TRUE", NA_character_)) |>
            gen.c(of = n*n_records) |>
            gen.with(with_args(factor, levels = c("FALSE", "TRUE")))
        )
      }) |>
      gen.with(with_args(matrix, nrow = n_records)),
    data.frame = gen_df(
      nrow = n_records,
      ncol = 3,
      minrow = n_records,
      mincol = 0
    )
  )
  if (length(classes) == 0L)
    return(
      if (remove_dup_rows)
        gen.pure(data.frame(a = NA)[rep(1L, min(n_records, 1L)), FALSE, drop = FALSE])
      else
        gen.pure(data.frame(a = NA)[rep(1L, n_records), FALSE, drop = FALSE])
    )
  lapply(
    classes,
    \(cl) {
      # gen.sample only shrinks by reordering,
      # and gen.c incorrectly returns NULL when size = 0,
      # so we need to unlist "manually"
      as_fns[[cl]]
    }
  ) |>
    gen.with(
      with_args(as.general.df, len = n_records) %>>%
        with_args(setNames, nm = nms) %>>%
        (if (remove_dup_rows) df_unique else identity)
    ) |>
    gen.with(variant)
}

as.general.df <- function(len, cols) {
  res <- data.frame(seq_len(len))[, FALSE, drop = FALSE]
  for (n in seq_along(cols)) {
    res[[n]] <- cols[[n]]
  }
  names(res) <- names(cols)
  res
}

gen.list_element <- function() {
  gen.choice( # list where each element is NULL or one of the other types
    gen.pure(NULL),
    gen.element(c(FALSE, TRUE, NA)) |>
      gen.c(from = 0, to = 2),
    gen.element(c(-5:5, NA_integer_)) |>
      gen.c(from = 0, to = 2),
    gen.numeric() |>
      gen.c(from = 0, to = 2),
    gen.element(c("FALSE", "TRUE", NA_character_)) |>
      gen.c(from = 0, to = 2),
    gen.element(c("FALSE", "TRUE", NA_character_)) |>
      gen.c(from = 0, to = 2) |>
      gen.with(with_args(factor, levels = c("FALSE", "TRUE"))),
    gen.list_element() |>
      gen.list(from = 0, to = 2)
  )
}

gen.float_coincide <- function(x, digits) {
  x <- coarsen_if_float(x, digits)
  len <- length(x)
  given <- which(!is.na(x))
  plen <- length(given)
  mag <- ifelse(!is.na(x) & x == 0, 0, floor(log(abs(x[given]), 10)))
  if (len == 0 || is.na(digits))
    return(gen.sample_resampleable(x, of = len))
  gen.sample_resampleable(seq_len(len), of = len) |>
    gen.and_then(\(inds) {
      mag_inds <- match(inds, given)
      mag_inds <- mag_inds[!is.na(mag_inds)]
      list(
        gen.pure(x),
        gen.pure(inds),
        gen.unif(-0.5, 0.5) |>
          gen.c(of = length(mag_inds)) |>
          gen.with(with_args(`*`, 10^(mag[mag_inds] + 1 - digits)))
      )
    }) |>
    gen.with(uncurry(\(x, inds, y) {
      res <- x[inds]
      given <- which(!is.na(res))
      if (length(given) != length(y)) {
        stop(
          "x: ", toString(x),
          "\ninds: ", toString(inds),
          "\ngiven: ", toString(given),
          "\nmag_inds: ", toString(match(inds, which(!is.na(x)))),
          "\nmag: ", toString(mag),
          "\ndigits: ", digits,
          "\nexp: ", toString(mag[match(inds, which(!is.na(x)))] + 1 - digits),
          "\nmult: ", toString(10^(mag[match(inds, which(!is.na(x)))] + 1 - digits)),
          "\ny: ", toString(y)
        )
      }
      res[given] <- res[given] + y
      res
    }))
}

gen.numeric <- function(weights = c(0.8, 0.2))
  list(
    gen.choice(gen.unif(-5, 5), gen.pure(NA_real_), prob = weights),
    gen.element(-5:5)
  ) |>
  gen.and_then(uncurry(\(x, y) x*10^y))

gen_attr_name <- function(len) {
  gen.sample_resampleable(c(letters, LETTERS, "_", " ", "."), to = len) |>
    gen.and_then(\(chars) {
      if (all(chars == " ")) {
        gen.element(c(letters, "_", "."))
      }else{
        gen.pure(chars)
      }
    }) |>
    gen.with(\(attr_name) paste(attr_name, collapse = ""))
}

gen_attr_names <- function(n, len) {
  gen_attr_name(len) |>
    gen.c(of = n) |>
    # as.character for length-0 NULL value
    gen.with(as.character %>>% make.unique)
}

gen_unique_dets <- function(n_attrs, n, max_dets) {
  # should also check no redundancy
  gen.subsequence(setdiff(seq_len(n_attrs), n)) |>
    gen.list(from = 0, to = min(max_dets, n_attrs - 1)) |>
    gen.with(unique)
}

gen_detset_lists <- function(n_attrs, max_dets) {
  md <- min(max_dets, n_attrs - 1)
  gen.structure(lapply(
    seq_len(n_attrs),
    function(n) {
      gen_unique_dets(n_attrs, n, md)
    }
  ))
}

gen_named_flat_deps_fixed_size <- function(attrs, n, max_detset_size, unique = TRUE) {
  list(
    gen.sample(attrs, n, replace = TRUE),
    gen.sample(attrs, gen.element(0:max_detset_size)) |>
      gen.list(of = n)
  ) |>
    gen.with(\(lst) functional_dependency(
      Map(\(x, y) list(setdiff(x, y), y), lst[[2]], lst[[1]]),
      attrs,
      unique = unique
    ))
}

gen_named_flat_deps <- function(
  attrs,
  max_detset_size,
  from = 0L,
  to = NULL,
  of = NULL
) {
  max_detset_size <- min(max_detset_size, length(attrs) - 1L)
  (
    if (missing(of) || is.null(of))
      gen.element(seq.int(from, to))
    else
      gen.pure(of)
  ) |>
    gen.and_then(\(m) gen_named_flat_deps_fixed_size(attrs, m, max_detset_size))
}

gen_flat_deps_fixed_names <- function(
  n_attrs,
  max_detset_size,
  from = 0L,
  to = NULL,
  of = NULL
) {
  attrs <- LETTERS[seq.int(n_attrs)]
  gen_named_flat_deps(attrs, max_detset_size, from, to, of)
}

gen_flat_deps <- function(
  n_attrs,
  max_detset_size,
  max_attr_nchar = 9,
  from = 0L,
  to = NULL,
  of = NULL
) {
  gen_attr_names(n_attrs, max_attr_nchar) |>
    gen.and_then(\(attrs) gen_named_flat_deps(attrs, max_detset_size, from, to, of))
}

gen.keys <- function(attrs) {
  gen.subsequence(attrs) |>
    gen.list(to = 3) |>
    gen.with(\(keys) {
      uniq <- unique(keys)
      superset <- outer(
        uniq,
        uniq,
        Vectorize(\(sup, sub) {
          all(is.element(sub, sup)) && !all(is.element(sup, sub))
        })
      )
      rem <- uniq[!apply(superset, 1, any)]
      rem[keys_order(lapply(rem, match, attrs))]
    })
}
gen.relation_schema <- function(x, from, to, single_empty_key = FALSE) {
  gen.subsequence(x) |>
    gen.and_then(\(attrs) {
      list(gen.pure(attrs), gen.keys(attrs)) |>
        gen.list(from = from, to = to)
    }) |>
    gen.with(\(schemas) {
      if (single_empty_key) {
        # only one schema can have an empty key
        rels_with_empty_keys <- which(vapply(
          schemas,
          \(schema) any(lengths(schema[[2]]) == 0L),
          logical(1)
        ))
        if (length(rels_with_empty_keys) > 1L)
          schemas <- schemas[-rels_with_empty_keys[-1]]
      }

      nms <- make.names(
        vapply(schemas, \(rel) name_dataframe(rel[[2]][[1]]), character(1)),
        unique = TRUE
      )
      list(setNames(schemas, nms), x)
    }) |>
    gen.with(\(lst) {
      do.call(relation_schema_nocheck, lst)
    })
}
gen.relation_schema_empty_keys <- function(x, from, to, min_empty) {
  if (min_empty > from)
    stop("can't guarantee more empty keys than minimum schema count")
  gen.relation_schema(x, from, to) |>
    gen.and_then(\(rs) {
      gen.element(floor(max(0L, min_empty)):length(rs)) |>
        gen.and_then(\(n_empty) {
          if (n_empty == 0)
            return(gen.pure(rs))
          gen.sample(seq_along(rs), n_empty, replace = FALSE) |>
            gen.with(\(empty) {
              keys(rs)[empty] <- rep(list(list(character())), n_empty)
              rs
            })
        })
    })
}

# references are included to ensure attributes that reference each other have
# the same class
gen.attrs_class <- function(nm, references = list()) {
  groups <- seq_along(nm)
  for (rel in references) {
    child_attrs <- match(rel[[2]], nm)
    parent_attrs <- match(rel[[4]], nm)
    stopifnot(!anyNA(c(child_attrs, parent_attrs)))
    for (n in seq_along(child_attrs)) {
      grp <- groups[c(child_attrs[[n]], parent_attrs[[n]])]
      groups[is.element(groups, grp)] <- min(grp)
    }
  }
  gen.element(list(
    "logical",
    "integer",
    "numeric",
    "character",
    "factor"
  )) |>
    gen.list(of = length(unique(groups))) |>
    gen.with(\(group_classes) group_classes[match(groups, sort(unique(groups)))]) |>
    gen.with(with_args(setNames, nm = nm))
}

gen.relation <- function(
  x,
  from,
  to,
  rows_from = 0L,
  rows_to = 10L,
  single_empty_key = FALSE,
  variant = c("data.frame", "tibble")
) {
  list(
    gen.relation_schema(x, from, to, single_empty_key = single_empty_key),
    gen.element(variant)
  ) |>
    gen.and_then(uncurry(
      \(rs, var) gen.relation_from_schema(rs, rows_from, rows_to, variant = var)
    ))
}

gen.relation_from_schema <- function(
  rs,
  rows_from = 0L,
  rows_to = 10L,
  digits = getOption("digits"),
  variant = c("data.frame", "tibble")
) {
  variant <- match.arg(variant)
  used_classes <- gen.df_colclass(atomic = TRUE) |>
    gen.c(of = length(attrs_order(rs))) |>
    gen.with(as.character) |>
    gen.with(with_args(stats::setNames, nm = (attrs_order(rs))))
  used_classes |>
    gen.and_then(\(classes) {
      r_attrs <- attrs(rs)
      r_ncols <- lengths(r_attrs)
      r_keys <- keys(rs)
      lapply(
        setNames(seq_along(rs), names(rs)),
        \(n) {
          ks <- r_keys[[n]]
          as <- r_attrs[[n]]
          cls <- classes[as]
          gen.element(rows_from:rows_to) |>
            gen.and_then(with_args(
              gen.df_fixed_ranges,
              classes = cls,
              nms = as,
              remove_dup_rows = TRUE,
              digits = digits,
              variant = variant
            )) |>
            gen.with(\(df) list(
              df = remove_key_violations(df, ks),
              keys = ks
            ))
        }
      ) |>
        gen.with(\(rels) {
          empty_rel <- create(rs)
          relation_nocheck(rels, attrs_order = attrs_order(empty_rel))
        })
    })
}

remove_key_violations <- function(df, keys) {
  Reduce(
    \(df, key) df[!df_duplicated(df[, key, drop = FALSE]), , drop  = FALSE],
    keys,
    init = df
  )
}

remove_insertion_key_violations <- function(df, relation) {
  Reduce(
    \(df, n) {
      recs <- records(relation)
      Reduce(
        \(df, key) {
          r_df <- recs[[n]]
          r_attrs <- names(r_df)
          remove <- if (length(key) == 0L) {
            negind <- if (nrow(r_df) == 0)
              TRUE
            else
              -seq_len(nrow(r_df))
            if (length(r_attrs) == 0L)
              rep(FALSE, nrow(df))
            else{
              single_adds <- lapply(
                seq_len(nrow(df)),
                \(n) df_rbind(r_df, df[n, r_attrs, drop = FALSE])
              )
              record_new <- vapply(
                single_adds,
                \(sa) {
                  nondups <- !duplicated(sa)
                  if (length(nondups) != nrow(r_df) + 1L)
                    stop(paste(print(1), print(relation[[n]]), print(df)))
                  res <- nondups[negind]
                  if (length(res) != 1)
                    stop(paste(print(2), print(relation[[n]]), print(df)))
                  res
                },
                logical(1)
              )
              record_new
            }
          }else{
            negind <- if (nrow(r_df) == 0)
              TRUE
            else
              -seq_len(nrow(r_df))
            comb <- df_rbind(r_df, df[, r_attrs, drop = FALSE])
            key_dups <- df_duplicated(comb[, key, drop = FALSE])[negind]
            single_adds <- lapply(
              seq_len(nrow(df)),
              \(n) df_rbind(r_df, df[n, r_attrs, drop = FALSE])
            )
            record_new <- vapply(
              single_adds,
              \(sa) {
                nondups <- !duplicated(sa)
                if (length(nondups) != nrow(r_df) + 1L)
                  stop(paste(print(1), print(relation[[n]]), print(df)))
                res <- nondups[negind]
                if (length(res) != 1)
                  stop(paste(print(2), print(relation[[n]]), print(df)))
                res
              },
              logical(1)
            )
            key_dups & record_new
          }
          df[!remove, , drop = FALSE]
        },
        keys(relation)[[n]],
        init = df
      )
    },
    seq_along(relation),
    init = df
  )
}

remove_violated_references <- function(references, relation) {
  recs <- records(relation)
  references[vapply(
    references,
    \(rel) {
      child <- recs[[rel[[1]]]][, rel[[2]], drop = FALSE]
      parent <- recs[[rel[[3]]]][, rel[[4]], drop = FALSE]
      child[] <- lapply(child, \(x) if (is.factor(x)) as.character(x) else x)
      parent[] <- lapply(parent, \(x) if (is.factor(x)) as.character(x) else x)
      both <- try(df_rbind(child, parent))
      if (class(both)[[1]] == "try-error")
        return(FALSE)
      child <- both[seq_len(nrow(child)), , drop = FALSE]
      parent <- both[setdiff(seq_len(nrow(both)), seq_len(nrow(child))), , drop = FALSE]
      identical(
        nrow(child),
        nrow(df_join(
          child,
          parent,
          by.x = rel[[2]],
          by.y = rel[[4]]
        ))
      )
    },
    logical(1)
  )]
}

gen.references_same_attrs <- function(rs, single_key_pairs) {
  gen.references_for_index_and_key <- function(rs, n, k) {
    contains_key <- setdiff(
      which(vapply(
        attrs(rs),
        \(as) all(is.element(k, as)),
        logical(1)
      )),
      n
    )
    gen.subsequence(contains_key) |>
      gen.with(\(citers) {
        lapply(
          citers,
          \(citer) list(
            names(rs)[[citer]],
            k,
            names(rs)[[n]],
            k
          )
        )
      })
  }
  gen.references_for_index <- function(rs, n) {
    ks <- keys(rs)[[n]]
    lapply(
      ks[lengths(ks) > 0L],
      gen.references_for_index_and_key,
      rs = rs,
      n = n
    ) |>
      gen.with(\(lst) {
        if (length(lst) == 0L) list() else unlist(lst, recursive = FALSE)
      }) |>
      gen.with(\(rels) {
        if (single_key_pairs)
          rels[!duplicated(lapply(rels, \(r) c(r[[1]], r[[3]])))]
        else
          rels
      })
  }
  lapply(seq_along(rs), gen.references_for_index, rs = rs) |>
    gen.with(\(lst) if (length(lst) == 0L) list() else unlist(lst, recursive = FALSE))
}

gen.references_different_attrs <- function(rs, single_key_pairs) {
  gen.references_for_index_and_key <- function(rs, n, k) {
    contains_key_length <- setdiff(
      which(vapply(
        attrs(rs),
        \(as) length(as) >= length(k),
        logical(1)
      )),
      n
    )
    gen.subsequence(contains_key_length) |>
      gen.and_then(\(citers) {
        lapply(
          citers,
          \(citer) {
            gen.sample(attrs(rs)[[citer]], length(k)) |>
              gen.with(\(attrs) {
                list(
                  names(rs)[[citer]],
                  attrs,
                  names(rs)[[n]],
                  k
                )
              })
          }
        )
      })
  }
  gen.references_for_index <- function(rs, n) {
    ks <- keys(rs)[[n]]
    lapply(
      ks[lengths(ks) > 0L],
      gen.references_for_index_and_key,
      rs = rs,
      n = n
    ) |>
      gen.with(\(lst) {
        if (length(lst) == 0L) list() else unlist(lst, recursive = FALSE)
      }) |>
      gen.with(\(rels) {
        if (single_key_pairs)
          rels[!duplicated(lapply(rels, \(r) c(r[[1]], r[[3]])))]
        else
          rels
      })
  }
  lapply(seq_along(rs), gen.references_for_index, rs = rs) |>
    gen.with(\(lst) if (length(lst) == 0L) list() else unlist(lst, recursive = FALSE))
}

gen.references <- function(rs, single_key_pairs) {
  gen.choice(
    gen.references_same_attrs(rs, single_key_pairs),
    gen.references_different_attrs(rs, single_key_pairs)
  )
}

gen.database_schema <- function(
  x,
  from,
  to,
  single_empty_key = FALSE,
  same_attr_name = FALSE,
  single_key_pairs = FALSE
) {
  gen.relation_schema(x, from, to, single_empty_key = single_empty_key) |>
    gen.and_then(\(rs) {
      list(
        gen.pure(rs),
        if (same_attr_name)
          gen.references_same_attrs(rs, single_key_pairs)
        else
          gen.references(rs, single_key_pairs))
    }) |>
    gen.with(\(lst) do.call(database_schema_nocheck, lst))
}
gen.database_schema_empty_keys <- function(
  x,
  from,
  to,
  min_empty,
  same_attr_name = FALSE,
  single_key_pairs = FALSE
) {
  gen.relation_schema_empty_keys(x, from, to, min_empty) |>
    gen.and_then(\(rs) {
      list(
        gen.pure(rs),
        if (same_attr_name)
          gen.references_same_attrs(rs, single_key_pairs)
        else
          gen.references(rs, single_key_pairs))
    }) |>
    gen.with(\(lst) do.call(database_schema_nocheck, lst))
}

gen.database <- function(
  x,
  from,
  to,
  single_empty_key = FALSE,
  same_attr_name = TRUE,
  single_key_pairs = TRUE,
  rows_from = 0L,
  rows_to = 10L,
  variant = c("data.frame", "tibble")
) {
  list(
    gen.database_schema(
      x,
      from,
      to,
      single_empty_key = single_empty_key,
      same_attr_name = same_attr_name,
      single_key_pairs = single_key_pairs
    ),
    gen.element(variant)
  ) |>
    gen.and_then(uncurry(\(ds, var) {
      gen.relation_from_schema(ds, rows_from, rows_to, variant = var) |>
        gen.with(
          with_args(
            remove_reference_violations,
            references = references(ds)
          ) %>>%
            with_args(database_nocheck, references = references(ds))
        )
    }))
}

remove_reference_violations <- function(relation, references) {
  if (length(references) == 0L)
    return(relation)
  change <- TRUE
  recs <- records(relation)
  while (change) {
    change <- FALSE
    for (ref in references) {
      child_name <- ref[[1]]
      child <- recs[[child_name]][, ref[[2]], drop = FALSE]
      if (nrow(child) > 0L) {
        child_records <- df_records(child)
        parent_name <- ref[[3]]
        parent <- recs[[parent_name]][, ref[[4]], drop = FALSE]
        parent_keys <- keys(relation)[[parent_name]]
        stopifnot(is.element(list(ref[[4]]), parent_keys))
        parent_records <- df_records(parent)
        valid <- !row_violates_reference(child, parent)
        recs[[child_name]] <- recs[[child_name]][valid, , drop = FALSE]
        if (!all(valid))
          change <- TRUE
      }
    }
  }
  records(relation) <- recs
  relation
}

remove_insertion_reference_violations <- function(df, database) {
  if (length(references(database)) == 0L)
    return(df)
  recs <- records(database)
  change <- TRUE
  while (change) {
    change <- FALSE
    for (ref in references(database)) {
      child_name <- ref[[1]]
      child <- df_rbind(
        recs[[child_name]][, ref[[2]], drop = FALSE],
        df[, ref[[2]], drop = FALSE]
      )
      if (nrow(child) > 0L) {
        parent_name <- ref[[3]]
        parent <- df_rbind(
          recs[[parent_name]][, ref[[4]], drop = FALSE],
          df[, ref[[4]], drop = FALSE]
        )
        valid <- vapply(
          seq_len(nrow(child)),
          \(n) nrow(df_join(
            child[n, , drop = FALSE],
            parent,
            by.x = ref[[2]],
            by.y = ref[[4]]
          )) > 0L,
          logical(1)
        )
        df <- df[valid[-seq_len(nrow(recs[[child_name]]))], , drop = FALSE]
        if (!all(valid))
          change <- TRUE
      }
    }
  }
  df
}

# naively inserting data into a database can give reference errors,
# which sets of relations are legal to insert into?
minimal_legal_insertion_sets <- function(db, df) {
  refs <- references(db)
  ref_mat <- matrix(FALSE, nrow = length(db), ncol = length(db))
  dimnames(ref_mat) <- list(child = names(db), parent = names(db))
  for (ref in refs) {
    ref_mat[ref[[1]], ref[[3]]] <- TRUE
  }

  # 1. If df doesn't have all attributes for a relation, inserting does nothing:
  # it's a legal insertion set, that relation can't be inserted into to nake
  # insertion into a parent legal.
  have_attrs <- vapply(
    attrs(db),
    \(x) all(x %in% names(df)),
    logical(1)
  )
  # 2. Otherwise, if a relation already has the given data, it's a legal
  # insertion set.
  already_present <- rep(FALSE, length(db))
  already_present[have_attrs] <- vapply(
    records(db[have_attrs]),
    \(r) {
      # assumes df rows are already unique
      nrow(df_join(r, df[, names(r), drop = FALSE])) == nrow(df)
    },
    logical(1)
  )
  # take out rels with data already, since sets by themselves and can't affect
  # legality of children
  legal_sets <- as.list(c(
    rownames(ref_mat)[!have_attrs],
    rownames(ref_mat)[already_present]
  ))
  ref_mat <- ref_mat[!already_present, !already_present, drop = FALSE]

  # 3. Otherwise, if inserting into that relation would cause a key violation,
  # the relation can't be inserted into.
  violates_key <- rep(NA, length(db))
  violates_key[have_attrs][!already_present] <- vapply(
    names(db)[have_attrs][!already_present],
    \(nm) {
      nr <- df_rbind(records(db)[[nm]], df[, attrs(db)[[nm]], drop = FALSE])
      any(vapply(
        keys(db)[[nm]],
        \(key) as.logical(df_anyDuplicated(nr[, key, drop = FALSE])),
        logical(1)
      ))
    },
    logical(1)
  )

  # 4. Otherwise, check whether all the relation's parents have legal insertion
  # sets. If they do, the relation has a legal insertion set that includes
  # itself, plus the insertion sets of the parents that don't already contain
  # the data themselves.

  # First, we determine whether a relation can be inserted into when ignoring
  # foreign keys.
  legal <- (have_attrs & !violates_key)[!already_present]

  # Then, we find all the relations it refers to, directly and indirectly. This
  # includes itself.
  family_mat <- ref_mat
  old_val <- NA & family_mat
  while (!identical(old_val, family_mat)) {
    old_val <- family_mat
    family_mat <- family_mat | (family_mat %*% ref_mat)
  }
  diag(family_mat) <- TRUE

  # Check whether it depends on anything illegal.
  eventually_illegal <- apply(family_mat[, !legal, drop = FALSE], 1, any)

  # Keep dependency set otherwise.
  legal_sets <- c(
    legal_sets,
    apply(
      family_mat[!eventually_illegal, , drop = FALSE],
      1,
      \(lgs) rownames(ref_mat)[lgs],
      simplify = FALSE
    )
  )

  unique(legal_sets)
}

# error arising from x[[indices]], assuming there is one
single_subset_failure_type <- function(x, indices) {
  if (length(indices) > 1)
    "attempt to select more than one element in vectorIndex"
  else {
    if (
      length(indices) == 1 &&
      all(indices < 0) &&
      length(indices) + 1 < length(x)
    ) {
      if (is.logical(indices))
        "attempt to select more than one element in get1Index"
      else
        "attempt to select more than one element in integerOneIndex"
    }else{
      if (length(indices) == 1)
        "attempt to select less than one element in integerOneIndex"
      else
        "attempt to select less than one element in get1index"
    }
  }
}

# generating key / determinant set lists
gen.nonempty_list <- function(generator, to)
  gen.list(generator, from = 1, to = to)
gen.emptyable_list <- function(generator, to)
  gen.list(generator, from = 0, to = to)
gen.list_with_dups <- function(generator, n_unique)
  gen.nonempty_list(generator, n_unique) |>
  gen.and_then(\(lst) gen.sample(lst, ceiling(1.5*length(lst)), replace = TRUE))

# gen.sample with replace=TRUE, but allowing changing the sample
# when shrinking, not just re-ordering
gen.sample_resampleable <- function(x, from = 1, to = NULL, of = NULL) {
  if ((!missing(from) || !missing(to)) && !missing(of))
    stop("Specify `to` and `from`, or `of`")
  if (!missing(of)) {
    if (of == 0) {
      gen.pure(x[FALSE])
    }else{
      gen.element(x) |>
        gen.list(of = of) |>
        gen.and_then(function(xs) do.call(c, xs))
    }
  }else {
    gen.element(from:to) |>
      gen.and_then(\(of) {
        if (of == 0) {
          gen.pure(x[FALSE])
        }else{
          gen.element(x) |>
            gen.list(of = of) |>
            gen.and_then(function(xs) do.call(c, xs))
        }
      })
  }
}

rel2df <- function(rel, relations) {
  records(rel)[relations] <- lapply(records(rel)[relations], as.data.frame)
  rel
}

# functional utility functions for tests
`%>>%` <- function(fn1, fn2) function(...) fn2(fn1(...))
biapply <- function(fn1, fn2) function(x) list(fn1(x), fn2(x))
bi <- function(fn, fn1, fn2) {
  function(x) fn(fn1(x), fn2(x))
}
expect_bi <- function(logical_fn, fn1, fn2) {
  function(x) expect_true(logical_fn(fn1(x), fn2(x)))
}
expect_biequal <- function(fn1, fn2) function(x) expect_equal(fn1(x), fn2(x))
expect_biidentical <- function(fn1, fn2)
  function(...) expect_identical(fn1(...), fn2(...))
split_by <- function(fn, ...) function(x) split(x, fn(x), ...)
subset_by <- function(fn) function(x) x[fn(x)]
if_discard_else <- function(cond, fn)
  function(...) if (cond(...)) discard() else fn(...)
uncurry <- function(fn) function(x) do.call(fn, x)
with_args <- function(fn, ...) {
  lst <- list(...)
  function(...) do.call(fn, c(list(...), lst))
}
apply_both <- function(fn1, fn2) function(x) {fn1(x); fn2(x)}
dup <- function(x) list(x, x)
onLeft <- function(f) function(x) list(f(x[[1]]), x[[2]])
onRight <- function(f) function(x) list(x[[1]], f(x[[2]]))
fand <- function(f, g) function(...) f(...) & g(...)

concatenate_keeps_attribute_order <- function(...) {
  lst <- list(...)

  # expect c(...) silent
  res <- tryCatch(
    c(...),
    error = identity,
    warning = identity,
    message = identity
  )
  if (inherits(res, "condition"))
    return(fail("concatenation was not silent"))
  expect_true(all(mapply(
    identical,
    lapply(lst, attrs_order),
    lapply(lst, \(x) intersect(attrs_order(res), attrs_order(x)))
  )))
}

make.unique_after <- function(x, pre) {
  if (length(pre) == 0)
    return(x)
  stopifnot(!anyDuplicated(pre))
  make.unique(c(pre, x))[-seq_along(pre)]
}
with_timeout <- function(expr, timeout = 5) {
  R.utils::withTimeout(
    expr,
    timeout = timeout,
    onTimeout = "silent"
  )
}