- dm_add_pk(), dm_rm_pk(), dm_add_fk() and dm_rm_fk() are now…

… stricter when keys exists or when attempting to remove keys that don't exist. A more relaxed mode of operation may be added later (#214).

Closes #214.

R/foreign-keys.R

@@ -73,8 +73,20 @@ dm_add_fk_impl <- function(dm, table, column, ref_table) {
  def <- dm_get_def(dm)
 
  i <- which(def$table == ref_table)
+
+ fks <- def$fks[[i]]
+
+ existing <- fks$table == table & !is.na(vctrs::vec_match(fks$column, list(column)))
+ if (any(existing)) {
+ if (dm_is_strict_keys(dm)) {
+ abort_fk_exists(table, column, ref_table)
+ }
+
+ return(dm)
+ }
+
  def$fks[[i]] <- vctrs::vec_rbind(
- def$fks[[i]],
+ fks,
  new_fk(table, list(column))
  )
 
@@ -217,32 +229,35 @@ dm_rm_fk <- function(dm, table, columns, ref_table) {
 
  fk_cols <- dm_get_fk_impl(dm, table_name, ref_table_name)
  if (is_empty(fk_cols)) {
- return(dm)
+ # FIXME: Simplify, check is already done in dm_rm_fk_impl()
+ abort_is_not_fkc(table_name, fk_cols, ref_table_name)
  }
 
  if (quo_is_null(column_quo)) {
  cols <- fk_cols
  } else {
  # FIXME: Add tidyselect support
  cols <- as_name(ensym(columns))
- if (!all(cols %in% fk_cols)) {
- abort_is_not_fkc(table_name, cols, ref_table_name, fk_cols)
- }
  }
 
  dm_rm_fk_impl(dm, table_name, cols, ref_table_name)
 }
 
 dm_rm_fk_impl <- function(dm, table_name, cols, ref_table_name) {
-
  # FIXME: compound keys
  cols <- as.list(cols)
 
  def <- dm_get_def(dm)
  i <- which(def$table == ref_table_name)
 
  fks <- def$fks[[i]]
- fks <- fks[fks$table != table_name | is.na(vctrs::vec_match(fks$column, cols)), ]
+
+ ii <- fks$table != table_name | is.na(vctrs::vec_match(fks$column, cols))
+ if (all(ii)) {
+ abort_is_not_fkc(table_name, cols, ref_table_name)
+ }
+
+ fks <- fks[ii, ]
  def$fks[[i]] <- fks
 
  new_dm3(def)
@@ -402,22 +417,37 @@ check_fk <- function(t1, t1_name, colname, t2, t2_name, pk) {
 
 # Errors ------------------------------------------------------------------
 
-abort_is_not_fkc <- function(child_table_name, wrong_fk_colnames,
- parent_table_name, actual_fk_colnames) {
+abort_fk_exists <- function(child_table_name, colnames, parent_table_name) {
+ abort(
+ error_txt_fk_exists(
+ child_table_name, colnames, parent_table_name
+ ),
+ .subclass = dm_error_full("fk_exists")
+ )
+}
+
+error_txt_fk_exists <- function(child_table_name, colnames, parent_table_name) {
+ glue(
+ "({commas(tick(colnames))}) is alreay a foreign key of table ",
+ "{tick(child_table_name)} into table {tick(parent_table_name)}."
+ )
+}
+
+abort_is_not_fkc <- function(child_table_name, colnames,
+ parent_table_name) {
  abort(
  error_txt_is_not_fkc(
- child_table_name, wrong_fk_colnames, parent_table_name, actual_fk_colnames
+ child_table_name, colnames, parent_table_name
  ),
  .subclass = dm_error_full("is_not_fkc")
  )
 }
 
-error_txt_is_not_fkc <- function(child_table_name, wrong_fk_colnames,
- parent_table_name, actual_fk_colnames) {
+error_txt_is_not_fkc <- function(child_table_name, colnames,
+ parent_table_name) {
  glue(
- "({commas(tick(wrong_fk_colnames))}) is not a foreign key of table ",
- "{tick(child_table_name)} into table {tick(parent_table_name)}. ",
- "Foreign key columns are: ({commas(tick(actual_fk_colnames))})."
+ "({commas(tick(colnames))}) is not a foreign key of table ",
+ "{tick(child_table_name)} into table {tick(parent_table_name)}. "
  )
 }
 

R/primary-keys.R

@@ -71,6 +71,11 @@ dm_add_pk_impl <- function(dm, table, column, force) {
  i <- which(def$table == table)
 
  if (!force && NROW(def$pks[[i]]) > 0) {
+ if (!dm_is_strict_keys(dm) &&
+ identical(def$pks[[i]]$column[[1]], column)) {
+ return(dm)
+ }
+
  abort_key_set_force_false(table)
  }
 
@@ -212,14 +217,25 @@ dm_rm_pk <- function(dm, table, rm_referencing_fks = FALSE) {
  table_name <- as_name(ensym(table))
  check_correct_input(dm, table_name)
 
- def <- dm_get_def(dm)
-
  if (!rm_referencing_fks && dm_is_referenced(dm, !!table_name)) {
  affected <- dm_get_referencing_tables(dm, !!table_name)
  abort_first_rm_fks(table_name, affected)
  }
- def$pks[def$table == table_name] <- list(new_pk())
- def$fks[def$table == table_name] <- list(new_fk())
+
+ dm_rm_pk_impl(dm, table_name)
+}
+
+dm_rm_pk_impl <- function(dm, table_name) {
+ def <- dm_get_def(dm)
+
+ i <- which(def$table == table_name)
+
+ if (nrow(def$pks[[i]]) == 0 && dm_is_strict_keys(dm)) {
+ abort_pk_not_defined(table_name)
+ }
+
+ def$pks[[i]] <- new_pk()
+ def$fks[[i]] <- new_fk()
 
  new_dm3(def)
 }
@@ -310,6 +326,14 @@ check_pk <- function(table, column) {
 
 # Error -------------------------------------------------------------------
 
+abort_pk_not_defined <- function(table) {
+ abort(error_txt_pk_not_defined(table), .subclass = dm_error_full("pk_not_defined"))
+}
+
+error_txt_pk_not_defined <- function(table) {
+ glue("Table {tick(table)} does not have a primary key.")
+}
+
 abort_key_set_force_false <- function(table) {
  abort(error_txt_key_set_force_false(table), .subclass = dm_error_full("key_set_force_false"))
 }

R/strict.R

@@ -0,0 +1,11 @@
+# Infrastructure for "strict mode" of a dm
+# where re-adding existing keys gives an error
+#
+# Idea: "strict mode" is set during construction of a dm
+#
+# For now, strict mode only, easier to relax later
+# than to strengthen after the fact
+
+dm_is_strict_keys <- function(dm) {
+ TRUE
+}

R/zzx-deprecated.R

@@ -317,8 +317,7 @@ cdm_rm_fk <- function(dm, table, columns, ref_table) {
  cols <- as_name(ensym(columns))
  if (!all(cols %in% fk_cols)) {
  abort_is_not_fkc(
- table_name, cols, ref_table_name,
- fk_cols
+ table_name, cols, ref_table_name
  )
  }
  }

tests/testthat/test-foreign-keys.R

@@ -5,10 +5,19 @@ test_that("dm_add_fk() works as intended?", {
  )
 
  expect_true(
- dm_add_pk(dm_test_obj(), dm_table_4, c) %>%
+ dm_test_obj() %>%
+ dm_add_pk(dm_table_4, c) %>%
  dm_add_fk(dm_table_1, a, dm_table_4) %>%
  dm_has_fk(dm_table_1, dm_table_4)
  )
+
+ expect_dm_error(
+ dm_test_obj() %>%
+ dm_add_pk(dm_table_4, c) %>%
+ dm_add_fk(dm_table_1, a, dm_table_4) %>%
+ dm_add_fk(dm_table_1, a, dm_table_4),
+ class = "fk_exists"
+ )
 })
 
 test_that("dm_has_fk() and dm_get_fk() work as intended?", {
@@ -101,6 +110,15 @@ test_that("dm_rm_fk() works as intended?", {
  dm_rm_fk(dm_table_2, z, dm_table_4),
  class = "is_not_fkc"
  )
+
+ expect_dm_error(
+ dm_test_obj() %>%
+ dm_add_pk(dm_table_4, c) %>%
+ dm_add_fk(dm_table_2, c, dm_table_4) %>%
+ dm_rm_fk(dm_table_2, c, dm_table_4) %>%
+ dm_rm_fk(dm_table_2, c, dm_table_4),
+ class = "is_not_fkc"
+ )
 })
 
 

tests/testthat/test-primary-keys.R

@@ -9,10 +9,17 @@ test_that("dm_add_pk() works as intended?", {
  class = "wrong_col_names"
  )
  expect_dm_error(
- dm_add_pk(dm_test_obj(), dm_table_1, a) %>%
+ dm_test_obj() %>%
+ dm_add_pk(dm_table_1, a) %>%
  dm_add_pk(dm_table_1, b),
  class = "key_set_force_false"
  )
+ expect_dm_error(
+ dm_test_obj() %>%
+ dm_add_pk(dm_table_1, a) %>%
+ dm_add_pk(dm_table_1, a),
+ class = "key_set_force_false"
+ )
  expect_dm_error(
  dm_add_pk(dm_test_obj(), dm_table_2, c, check = TRUE),
  class = "not_unique_key"
@@ -27,13 +34,14 @@ test_that("dm_rm_pk() works as intended?", {
  dm_add_pk(dm_test_obj(), dm_table_1, a) %>%
  dm_rm_pk(dm_table_1)
  )
- expect_true(
- dm_add_pk(dm_test_obj(), dm_table_1, a) %>%
- dm_rm_pk(dm_table_2) %>% # still does its job, even if there was no key in the first place :)
-  dm_has_pk(dm_table_1)
+ expect_dm_error(
+ dm_test_obj() %>%
+ dm_rm_pk(dm_table_1),
+ class = "pk_not_defined"
  )
  expect_dm_error(
- dm_add_pk(dm_test_obj(), dm_table_1, a) %>%
+ dm_test_obj() %>%
+ dm_add_pk(dm_table_1, a) %>%
  dm_rm_pk(dm_table_5),
  class = "table_not_in_dm"
  )
@@ -47,13 +55,15 @@ test_that("dm_rm_pk() works as intended?", {
  # test logic if argument `rm_referencing_fks = TRUE`
  expect_equivalent_dm(
  dm_rm_pk(dm_for_filter(), tf_4, rm_referencing_fks = TRUE),
- dm_rm_fk(dm_for_filter(), tf_5, l, tf_4) %>%
+ dm_for_filter() %>%
+ dm_rm_fk(tf_5, l, tf_4) %>%
  dm_rm_pk(tf_4)
  )
 
  expect_equivalent_dm(
  dm_rm_pk(dm_for_filter(), tf_3, rm_referencing_fks = TRUE),
- dm_rm_fk(dm_for_filter(), tf_4, j, tf_3) %>%
+ dm_for_filter() %>%
+ dm_rm_fk(tf_4, j, tf_3) %>%
  dm_rm_fk(tf_2, e, tf_3) %>%
  dm_rm_pk(tf_3)
  )