test_tidy.R
In sf: Simple Features for R

suppressMessages(require(dplyr, quietly = TRUE))
nc <- st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)

test_that("select works", {
  skip_if_not_installed("dplyr")
  expect_true(nc %>% select_("AREA", attr(., "sf_column"))  %>% inherits("sf"))
  expect_true(nc %>% select(AREA) %>% inherits("sf"))
})

test_that("filter to sfc works", {
  skip_if_not_installed("dplyr")
  tbl = tibble(a = c("A", "B", "C"),
              geometry = st_sfc(st_point(c(1, 1)),
                                st_point(),
                                st_linestring()))
  d = st_sf(tbl)
  expect_identical(d %>% filter(!st_is_empty(geometry)) %>% st_cast(),
                   d[1, ])
  expect_identical(d %>% filter(st_is(geometry, "POINT")) %>% st_cast(),
                   d[1:2, ])
})

suppressMessages(require(tidyr, quietly = TRUE))
test_that("separate and unite work", {
  skip_if_not_installed("dplyr")
  skip_if_not_installed("tidyr")
  expect_true(nc %>% separate(CNTY_ID, c("a", "b"), sep = 2) %>% inherits("sf"))
  expect_true(nc %>% separate(CNTY_ID, c("a", "b"), sep = 2) %>%
	unite(CNTY_ID_NEW, c("a", "b"), sep = "") %>% inherits("sf"))
})

test_that("separate_rows work", {
  skip_if_not_installed("dplyr")
  skip_if_not_installed("tidyr")
  d <- st_as_sf(data.frame(
    x = seq_len(3),
    y = c("a", "d,e,f", "g,h"),
    geometry = st_sfc(st_point(c(1, 1)),
                      st_point(c(2, 2)),
                      st_point(c(3, 3))),
    stringsAsFactors = FALSE))
  expect_true(d %>%
                separate_rows(y, convert = TRUE) %>%
                inherits("sf"))
  expect_identical(d %>%
      separate_rows(y, convert = TRUE) %>%
      st_geometry(),
    st_sfc(st_point(c(1, 1)),
           st_point(c(2, 2)),
           st_point(c(2, 2)),
           st_point(c(2, 2)),
           st_point(c(3, 3)),
           st_point(c(3, 3))))
})

test_that("group/ungroup works", {
 skip_if_not_installed("dplyr")
 tbl = tibble(a = c(1,1,2,2), g = st_sfc(st_point(0:1), st_point(1:2), st_point(2:3), st_point(3:4)))
 d = st_sf(tbl)
 e <- d %>% group_by(a) %>% ungroup
 expect_equal(as.data.frame(d), as.data.frame(e))
})

test_that("sample_n etc work", {
  skip_if_not_installed("dplyr")
  tbl = tibble(a = c(1,1,2,2), g = st_sfc(st_point(0:1), st_point(1:2), st_point(2:3), st_point(3:4)))
  d = st_sf(tbl)

  expect_sampled <- function(x) {
    expect_true(inherits(x, c("sf", "tbl_df")))
    expect_named(x, c("a", "g"))
    expect_equal(nrow(x), 2)
    expect_true(inherits(x$g, "sfc_POINT"))
  }

  expect_sampled(sample_n(d, 2))
  expect_sampled(sample_frac(d, .5))
})

test_that("nest() works", {
	skip_if_not_installed("dplyr")
	skip_if_not_installed("tidyr")
	tbl = tibble(a = c(1,1,2,2), g = st_sfc(st_point(0:1), st_point(1:2), st_point(2:3), st_point(3:4)))
	d = st_sf(tbl)
	out = d %>% group_by(a) %>% nest()

	exp_data = list(d[1:2, "g"], d[3:4, "g"])

	# Work around issues of tibble comparison in dplyr 0.8.5 (faulty
	# all.equal.tbl_df() method)
	if (utils::packageVersion("dplyr") < "0.8.99") {
		dfs = lapply(out$data, function(x) st_sf(as.data.frame(x)))
		exp_data = lapply(exp_data, function(x) st_sf(as.data.frame(x)))
		expect_identical(dfs, exp_data)
	} else {
		exp = tibble(a = c(1, 2), data = exp_data) %>% group_by(a)
		expect_identical(out, exp)
	}
})

test_that("st_intersection of tbl returns tbl", {
 nc = read_sf(system.file("shape/nc.shp", package="sf"))
 nc = st_transform(nc[1:3,], 3857)
 st_agr(nc) = "constant"
 expect_s3_class(nc, "tbl_df")
 expect_s3_class(st_intersection(nc[1:3], nc[4:6]), "tbl_df")
})

test_that("unnest works", {
  skip_if_not_installed("dplyr")
  skip_if_not_installed("tidyr")
  skip_if_not(utils::packageVersion("tidyr") > "0.7.2")
  nc = read_sf(system.file("shape/nc.shp", package = "sf")) %>%
    slice(1:2) %>%
    transmute(y = list(c("a"), c("b", "c")))
  unnest_explicit = unnest(nc, y)
  # The second row is duplicated because the "b" and "c" become separate rows
  expected = nc[c(1,2,2), ] %>% mutate(y = c("a", "b", "c"))
  # Would use expect_equal, but doesn't work with geometry cols
  expect_identical(unnest_explicit, expected)
})

test_that("bind_rows() returns type of first input", {
	skip_if_not_installed("dplyr", "0.8.99")
	skip_if_not_installed("vctrs", "0.3.0.9000")

	sf1 = st_sf(x = 1, y = st_sfc(st_point(0:1)))
	sf2 = st_sf(z = st_sfc(st_point(2:3)), x = 2)

	# Avoid as.data.frame.sfc() method
	data_frame = function(...) {
		df = tibble(...)
		class(df) = "data.frame"
		df
	}

	# Output is a data frame if first input is a data frame
	out = bind_rows(data.frame(x = 1), sf2)
	exp = data_frame(
		x = c(1, 2),
		z = st_sfc(NA, st_point(2:3))
	)
	expect_identical(out, exp)

	out = bind_rows(sf1, data.frame(x = 1))
	exp = st_as_sf(data_frame(
		x = c(1, 1),
		y = st_sfc(st_point(0:1), NA)
	))
	expect_identical(out, exp)

	out = bind_rows(sf1, sf2)
	exp = st_as_sf(data_frame(
		x = c(1, 2),
		y = st_sfc(st_point(0:1), NA),
		z = st_sfc(NA, st_point(2:3))
	))
	expect_identical(out, exp)

	out = bind_rows(sf2, sf1)
	exp = st_as_sf(sf_column_name = "z", data_frame(
		x = c(2, 1),
		z = st_sfc(st_point(2:3), NA),
		y = st_sfc(NA, st_point(0:1))
	))
	expect_identical(out, exp)
})

test_that("bind_cols() returns type of first input", {
	skip_if_not_installed("dplyr", "0.8.99")

	sf1 = st_sf(x = 1, y = st_sfc(st_point(0:1)))
	sf2 = st_sf(z = st_sfc(st_point(2:3)), w = 2)

	# Avoid as.data.frame.sfc() method
	data_frame = function(...) {
		df = tibble(...)
		class(df) = "data.frame"
		df
	}

	# Output is a data frame if first input is a data frame
	out = bind_cols(data.frame(x = 1), sf2)
	exp = data_frame(
		x = 1,
		w = 2,
		z = st_sfc(st_point(2:3))
	)
	expect_identical(out, exp)

	out = bind_cols(sf1, data.frame(w = 2))
	exp = st_as_sf(data_frame(
		x = 1,
		w = 2,
		y = st_sfc(st_point(0:1))
	))
	expect_identical(out, exp)

	out = bind_cols(sf1, sf2)
	exp = st_as_sf(data_frame(
		x = 1,
		w = 2,
		y = st_sfc(st_point(0:1)),
		z = st_sfc(st_point(2:3))
	))
	expect_identical(out, exp)

	out = bind_cols(sf2, sf1)
	exp = st_as_sf(data_frame(
		w = 2,
		x = 1,
		z = st_sfc(st_point(2:3)),
		y = st_sfc(st_point(0:1))
	))
	expect_identical(out, exp)
})

test_that("can rename geometry column with `select()`", {
    skip_if_not_installed("dplyr")
	sf = st_sf(
		x = 1,
		geo = st_sfc(st_point(1:2)),
		y = "foo"
	)
	out = dplyr::select(sf, foo = geo)
	expect_identical(out, st_sf(foo = sf$geo))

	# geometry column is sticky
	out = dplyr::select(sf, y)
	expect_identical(out, st_sf(geo = sf$geo, y = sf$y))
})

test_that("can rename geometry column with `rename()` (#1431)", {
  skip_if_not_installed("dplyr")
  geo_pt = st_sfc(st_point())
  geo_ln = st_sfc(st_linestring())
  sf = st_sf(x = 1, geo2 = geo_pt, geo1 = geo_ln, sf_column_name = "geo1")

  expect_identical(
    dplyr::rename(sf, y = x),
    st_sf(y = 1, geo2 = geo_pt, geo1 = geo_ln, sf_column_name = "geo1")
  )

  expect_identical(
    dplyr::rename(sf, foo = geo1),
    st_sf(x = 1, geo2 = geo_pt, foo = geo_ln, sf_column_name = "foo")
  )
  expect_identical(
    dplyr::rename(sf, foo = geo1, y = x),
    st_sf(y = 1, geo2 = geo_pt, foo = geo_ln, sf_column_name = "foo")
  )
  expect_identical(
    dplyr::rename(sf, foo = geo1, y = x, bar = geo2),
    st_sf(y = 1, bar = geo_pt, foo = geo_ln, sf_column_name = "foo")
  )
})

test_that("`select()` and `transmute()` observe back-stickiness of geometry column (#1425)", {
	skip_if_not_installed("dplyr")
	sf = read_sf(system.file("shape/nc.shp", package = "sf"))
	exp = sf[, c("NAME", "FIPS")]
	expect_identical(dplyr::select(sf, NAME, FIPS), exp)
	expect_identical(dplyr::transmute(sf, NAME, FIPS), exp)
})

test_that("rowwise_df class is retained on row slice", {
	skip_if_not_installed("dplyr")
	expect_true(nc %>% rowwise() %>% slice(1) %>% inherits("rowwise_df"))
})

test_that("grouped_df class is retained on row slice", {
	skip_if_not_installed("dplyr")
	expect_true(nc %>% group_by(PERIMETER > 2) %>% slice(1) %>% inherits("grouped_df"))
})

test_that("rowwise_df class is retained on filtered rows", {
	skip_if_not_installed("dplyr")
	expect_true(nc %>% rowwise() %>% filter(AREA > .1) %>% inherits("rowwise_df"))
})

test_that("`group_split.sf()` ignores `.keep` for rowwise_df class", {
	skip_if_not_installed("dplyr")
	expect_no_warning(nc %>% rowwise() %>% group_split())
})

test_that("group_split.sf()` does not ignore `.keep` for grouped_df class", {
	skip_if_not_installed("dplyr")

	nc_kept <- nc %>%
		group_by(CNTY_ID) %>%
		group_split(.keep = TRUE)

	nc_notkept <- nc %>%
		group_by(CNTY_ID) %>%
		group_split(.keep = FALSE)

	expect_identical(names(nc_kept[[1]]), names(nc))
	expect_identical(names(nc_notkept[[1]]), setdiff(names(nc), "CNTY_ID"))
})