dm_get_src() returns NULL for local data sources

cynkra · Jul 29, 2020 · c656961 · c656961
1 parent 4a36b58
commit c656961
Show file tree

Hide file tree

Showing 12 changed files with 54 additions and 53 deletions.
diff --git a/R/dm.R b/R/dm.R
@@ -244,7 +244,8 @@ debug_validate_dm <- function(dm) {
 #'
 #' @rdname dm
 #'
-#' @return For `dm_get_src()`: the \pkg{dplyr} source for a `dm` object.
+#' @return For `dm_get_src()`: the \pkg{dplyr} source for a `dm` object,
+#' or `NULL` if the `dm` objcet contains data frames.
 #'
 #' @export
 dm_get_src <- function(x) {
@@ -431,9 +432,9 @@ as_dm.default <- function(x) {
 
 tbl_src <- function(x) {
  if (is_empty(x) || is.data.frame(x)) {
- default_local_src()
+ NULL
  } else if (inherits(x, "tbl_sql")) {
- x$src
+ dbplyr::remote_src(x)
  } else {
  abort_what_a_weird_object(class(x)[[1]])
  }
@@ -462,22 +463,22 @@ show_dm <- function(x) {
  return()
  }
 
- cat_rule("Table source", col = "green")
  src <- dm_get_src(x)
- db_info <- NULL
+ if (!is.null(src)) {
+ cat_rule("Table source", col = "green")
+ db_info <- NULL
 
- if (!is.null(src$con)) {
  # FIXME: change to pillar::tbl_sum() once it's there
  tbl_str <- tibble::tbl_sum(def$data[[1]])
  if ("Database" %in% names(tbl_str)) {
  db_info <- paste0("src: ", tbl_str[["Database"]])
  }
- }
- if (is.null(db_info)) {
- db_info <- strsplit(format(src), "\n")[[1]][[1]]
- }
+ if (is.null(db_info)) {
+ db_info <- strsplit(format(src), "\n")[[1]][[1]]
+ }
 
- cat_line(db_info)
+ cat_line(db_info)
+ }
 
  cat_rule("Metadata", col = "violet")
 
@@ -722,8 +723,13 @@ copy_to.dm <- function(dest, df, name = deparse(substitute(df)), overwrite = FAL
  # src: if `df` on a different src:
  # if `df_list` is on DB and `dest` is local, collect `df_list`
  # if `df_list` is local and `dest` is on DB, copy `df_list` to respective DB
- df <- copy_to(dm_get_src(dest), df, unique_db_table_name(name), temporary = temporary, ...)
- # FIXME: should we allow `overwrite` argument?
+ dest_src <- dm_get_src(dest)
+ if (is.null(dest_src)) {
+ df <- as_tibble(collect(df))
+ } else {
+ # FIXME: should we allow `overwrite` argument?
+ df <- copy_to(dest_src, df, unique_db_table_name(name), temporary = temporary, ...)
+ }
  names_list <- repair_table_names(src_tbls(dest), name, repair, quiet)
  # rename old tables with potentially new names
  dest <- dm_rename_tbl(dest, !!!names_list$new_old_names)

diff --git a/R/format.R b/R/format.R
@@ -27,13 +27,6 @@ tick <- function(x) {
  paste0("`", x, "`")
 }
 
-default_local_src <- function() {
- structure(
- list(tbl_f = as_tibble, name = "<environment: R_GlobalEnv>", env = .GlobalEnv),
- class = c("src_local", "src")
- )
-}
-
 # next 2 are borrowed from {tibble}:
 tick_if_needed <- function(x) {
  needs_ticks <- !is_syntactic(x)

diff --git a/R/nest.R b/R/nest.R
@@ -1,7 +1,7 @@
 nest_join_zoomed_dm <- function(x, ...) {
  zoomed_dm <- x
  src_dm <- dm_get_src_impl(zoomed_dm)
- if (!inherits(src_dm, "src_local")) {
+ if (!is.null(src_dm)) {
  abort_only_for_local_src(src_dm)
  }
 

diff --git a/R/zzx-deprecated.R b/R/zzx-deprecated.R
@@ -60,7 +60,18 @@ check_cardinality <- function(parent_table, pk_column, child_table, fk_column) {
 #' @export
 cdm_get_src <- function(x) {
  deprecate_soft("0.1.0", "dm::cdm_get_src()", "dm::dm_get_src()")
- dm_get_src(x = x)
+ out <- dm_get_src(x = x)
+ if (is.null(out)) {
+ out <- default_local_src()
+ }
+ out
+}
+
+default_local_src <- function() {
+ structure(
+ list(tbl_f = as_tibble, name = "<environment: R_GlobalEnv>", env = .GlobalEnv),
+ class = c("src_local", "src")
+ )
 }
 
 #' @rdname deprecated

diff --git a/tests/testthat/helper-config-db.R b/tests/testthat/helper-config-db.R
@@ -1,5 +1,5 @@
 test_src_df <- function() {
- default_local_src()
+ NULL
 }
 
 test_src_sqlite <- function() {

diff --git a/tests/testthat/helper-skip.R b/tests/testthat/helper-skip.R
@@ -8,11 +8,11 @@ skip_if_error <- function(expr) {
 }
 
 skip_if_remote_src <- function(src = my_test_src()) {
- if (inherits(src, "src_dbi")) skip("works only locally")
+ if (is_db(src)) skip("works only locally")
 }
 
 skip_if_local_src <- function(src = my_test_src()) {
- if (inherits(src, "src_local")) skip("works only on a DB")
+ if (!is_db(src)) skip("works only on a DB")
  skip_if_not_installed("dbplyr")
 }
 

diff --git a/tests/testthat/helper-src.R b/tests/testthat/helper-src.R
@@ -38,7 +38,7 @@ copy_to_my_test_src <- function(rhs, lhs) {
  # message("Evaluating ", name)
 
  src <- my_test_src()
- if (inherits(src, "src_local")) {
+ if (is.null(src)) {
  rhs
  } else if (is_dm(rhs)) {
  # We want all dm operations to work with key constraints on the database
@@ -88,9 +88,12 @@ test_src_frame <- function(...) {
  src <- my_test_src()
 
  df <- tibble(...)
+ if (is.null(src)) {
+ return(df)
+ }
 
- if (inherits(src, "src_Microsoft SQL Server")) {
- name <- paste0("##", unique_db_table_name("test_frame"))
+ if (is_mssql(src)) {
+ name <- paste0("#", unique_db_table_name("test_frame"))
  temporary <- FALSE
  } else {
  name <- unique_db_table_name("test_frame")

diff --git a/tests/testthat/out/bind.txt b/tests/testthat/out/bind.txt
@@ -5,8 +5,6 @@ dm()
 dm()
 
 > dm_bind(dm_for_filter()) %>% collect()
--- Table source ----------------------------------------------------------------
-src: <environment: R_GlobalEnv>
 -- Metadata --------------------------------------------------------------------
 Tables: `tf_1`, `tf_2`, `tf_3`, `tf_4`, `tf_5`, `tf_6`
 Columns: 15
@@ -23,8 +21,6 @@ Message: New names:
 * tf_5 -> tf_5...5
 * ...
 
--- Table source ----------------------------------------------------------------
-src: <environment: R_GlobalEnv>
 -- Metadata --------------------------------------------------------------------
 Tables: `tf_1...1`, `tf_2...2`, `tf_3...3`, `tf_4...4`, `tf_5...5`, ... (17 total)
 Columns: 44
@@ -33,8 +29,6 @@ Foreign keys: 14
 
 > dm_bind(dm_for_filter(), dm_for_flatten(), dm_for_filter(), repair = "unique",
 + quiet = TRUE) %>% collect()
--- Table source ----------------------------------------------------------------
-src: <environment: R_GlobalEnv>
 -- Metadata --------------------------------------------------------------------
 Tables: `tf_1...1`, `tf_2...2`, `tf_3...3`, `tf_4...4`, `tf_5...5`, ... (17 total)
 Columns: 44

diff --git a/tests/testthat/out/output.txt b/tests/testthat/out/output.txt
@@ -3,8 +3,6 @@ dm()
 
 > nyc_flights_dm <- dm_nycflights13(cycle = TRUE)
 > nyc_flights_dm
--- Table source ----------------------------------------------------------------
-src: <environment: R_GlobalEnv>
 -- Metadata --------------------------------------------------------------------
 Tables: `airlines`, `airports`, `flights`, `planes`, `weather`
 Columns: 53
@@ -15,8 +13,6 @@ Foreign keys: 4
 dm: 5 tables, 53 columns, 3 primary keys, 4 foreign keys
 
 > nyc_flights_dm %>% dm_filter(flights, origin == "EWR")
--- Table source ----------------------------------------------------------------
-src: <environment: R_GlobalEnv>
 -- Metadata --------------------------------------------------------------------
 Tables: `airlines`, `airports`, `flights`, `planes`, `weather`
 Columns: 53

diff --git a/tests/testthat/test-dm.R b/tests/testthat/test-dm.R
@@ -41,11 +41,7 @@ test_that("'copy_to.dm()' works", {
  skip_if_src_not("df", "mssql")
 
  # `tibble()` call necessary, #322
- car_table <- copy_to(
- my_test_src(),
- tibble(mtcars),
- name = unique_db_table_name("mtcars_1")
- )
+ car_table <- test_src_frame(!!!mtcars)
 
  expect_equivalent_dm(
  copy_to(dm_for_filter(), mtcars, "car_table"),
@@ -63,21 +59,21 @@ test_that("'copy_to.dm()' works", {
 
 test_that("'copy_to.dm()' works (2)", {
  expect_dm_error(
- copy_to(dm_for_filter(), mtcars, c("car_table", "another_table")),
+ copy_to(dm(), mtcars, c("car_table", "another_table")),
  "one_name_for_copy_to"
  )
 
  # rename old and new tables if `repair = unique`
  expect_name_repair_message(
  expect_equivalent_dm(
- dm(mtcars) %>% copy_to(mtcars),
+ copy_to(dm(mtcars), mtcars),
  dm(mtcars...1 = mtcars, mtcars...2 = tibble(mtcars))
  )
  )
 
  expect_equivalent_dm(
  expect_silent(
- dm(mtcars) %>% copy_to(mtcars, quiet = TRUE)
+ copy_to(dm(mtcars), mtcars, quiet = TRUE)
  ),
  dm(mtcars...1 = mtcars, mtcars...2 = tibble(mtcars))
  )

diff --git a/tests/testthat/test-format.R b/tests/testthat/test-format.R
@@ -10,7 +10,3 @@ verify_output("out/commas.txt", {
  commas(letters, capped = TRUE)
  commas(letters, fun = tick)
 })
-
-test_that("default_local_src() works", {
- expect_s3_class(default_local_src(), "src")
-})
diff --git a/tests/testthat/test-zzx-deprecated.R b/tests/testthat/test-zzx-deprecated.R
@@ -3,9 +3,11 @@ test_that("cdm_add_tbl() works", {
  skip_if_remote_src()
  local_options(lifecycle_verbosity = "quiet")
 
+ mtcars_tbl <- test_src_frame(!!!mtcars)
+
  expect_equivalent_dm(
- cdm_add_tbl(dm_for_filter(), cars_table = copy_to(my_test_src(), mtcars, name = unique_db_table_name("mtcars"))),
- dm_add_tbl(dm_for_filter(), cars_table = copy_to(my_test_src(), mtcars, name = unique_db_table_name("mtcars")))
+ cdm_add_tbl(dm_for_filter(), cars_table = mtcars_tbl),
+ dm_add_tbl(dm_for_filter(), cars_table = mtcars_tbl)
  )
 })
 
@@ -130,7 +132,7 @@ test_that("cdm_get_con() works", {
  class = "is_not_dm"
  )
 
- if (inherits(my_test_src(), "src_local")) {
+ if (is.null(my_test_src())) {
  expect_dm_error(
  cdm_get_con(dm_for_filter()),
  class = "con_only_for_dbi"
@@ -372,3 +374,7 @@ test_that("dm_zoom_to() and related functions work", {
  dm_zoom_to(dm_for_filter(), tf_1) %>% dm_discard_zoomed()
  )
 })
+
+test_that("default_local_src() works", {
+ expect_s3_class(default_local_src(), "src")
+})