tests/testthat/test-bind-rows-SpatVector.R

In dieghernan/tidyterra: 'tidyverse' Methods and 'ggplot2' Helpers for 'terra' Objects

# Adapted from dplyr

test_that("bind_spat_rows() handles simple inputs", {
  df1 <- data.frame(x = 1:2, y = letters[1:2], lat = 1:2, lon = 1:2)
  df2 <- data.frame(x = 3:4, y = letters[3:4], lat = 1:2, lon = 1:2)
  df1 <- terra::vect(df1)
  df2 <- terra::vect(df2)
  out <- bind_spat_rows(df1, df2)
  expect_equal(as.data.frame(out), data.frame(x = 1:4, y = letters[1:4]))
})

test_that("bind_spat_rows() handles simple inputs with CRS", {
  df1 <- data.frame(x = 1:2, y = letters[1:2], lat = 1:2, lon = 1:2)
  df2 <- data.frame(x = 3:4, y = letters[3:4], lat = 1:2, lon = 1:2)
  df1 <- terra::vect(df1, crs = "EPSG:4326")
  df2 <- terra::vect(df2, crs = "EPSG:4326")
  out <- bind_spat_rows(df1, df2)
  expect_equal(as.data.frame(out), data.frame(x = 1:4, y = letters[1:4]))
})

test_that("bind_spat_rows() reorders columns to match first df", {
  df1 <- data.frame(x = 1, y = 2)
  df2 <- data.frame(y = 1, x = 2)
  df1 <- terra::vect(df1, geom = c("x", "y"), keepgeom = TRUE)
  df2 <- terra::vect(df2, geom = c("x", "y"), keepgeom = TRUE)

  expect_named(bind_spat_rows(df1, df2), c("x", "y"))
})

test_that("bind_spat_rows() returns union of columns", {
  df1 <- data.frame(x = 1, lat = 1, lon = 1)
  df2 <- data.frame(y = 2, lat = 1, lon = 1)
  df1 <- terra::vect(df1)
  df2 <- terra::vect(df2)
  out <- bind_spat_rows(df1, df2)

  expect_equal(as.data.frame(out), data.frame(x = c(1, NA), y = c(NA, 2)))
})

test_that("bind_spat_rows() returns union of columns with CRS", {
  df1 <- data.frame(x = 1, lat = 1, lon = 1)
  df2 <- data.frame(y = 2, lat = 1, lon = 1)
  df1 <- terra::vect(df1, crs = "EPSG:4326")
  df2 <- terra::vect(df2, crs = "EPSG:4326")
  out <- bind_spat_rows(df1, df2)

  expect_equal(as.data.frame(out), data.frame(x = c(1, NA), y = c(NA, 2)))
})


test_that("bind_spat_rows() creates a column of identifiers", {
  df1 <- data.frame(x = 1:2, lat = 1:2, lon = 1:2)
  df2 <- data.frame(x = 3, lat = 1, lon = 1)
  df1 <- terra::vect(df1, crs = "EPSG:4326")
  df2 <- terra::vect(df2, crs = "EPSG:4326")


  # with
  out <- bind_spat_rows(a = df1, b = df2, .id = "id")
  expect_equal(
    as.data.frame(out),
    data.frame(id = c("a", "a", "b"), x = 1:3)
  )

  out <- bind_spat_rows(list(a = df1, b = df2), .id = "id")
  expect_equal(
    as.data.frame(out),
    data.frame(id = c("a", "a", "b"), x = 1:3)
  )

  # or without names
  out <- bind_spat_rows(df1, df2, .id = "id")
  expect_equal(
    as.data.frame(out),
    data.frame(id = c("1", "1", "2"), x = 1:3)
  )

  out <- bind_spat_rows(list(df1, df2), .id = "id")
  expect_equal(
    as.data.frame(out),
    data.frame(id = c("1", "1", "2"), x = 1:3)
  )
})


test_that("bind_spat_rows respects groups", {
  df <- data.frame(
    e = 1,
    f = factor(c(1, 1, 2, 2), levels = 1:3),
    g = c(1, 1, 2, 2),
    x = c(1, 2, 1, 4)
  )
  df <- terra::vect(df, geom = c("g", "x"), keepgeom = TRUE)
  df <- group_by(df, e, f, g, .drop = FALSE)

  gg <- bind_spat_rows(df, df)
  expect_equal(group_size(gg), c(4L, 4L, 0L))
})

test_that("bind_spat_rows respects rowwise", {
  df_init <- data.frame(
    e = 1,
    f = factor(c(1, 1, 2, 2), levels = 1:3),
    g = c(1, 1, 2, 2),
    x = c(1, 2, 1, 4)
  )
  df2 <- terra::vect(df_init, geom = c("g", "x"), keepgeom = TRUE)
  df2 <- rowwise(df2)
  expect_true(is_rowwise_spatvector(df2))

  expect_snapshot(gg <- bind_spat_rows(df2, df_init))
  expect_true(is_rowwise_spatvector(gg))
  expect_equal(group_size(gg), rep(1, nrow(gg)))
  expect_equal(group_vars(gg), character(0))
})

test_that("bind_spat_rows respects named rowwise", {
  df_init <- data.frame(
    e = 1,
    f = factor(c(1, 1, 2, 2), levels = 1:3),
    g = c(1, 1, 2, 2),
    x = c(1, 2, 1, 4)
  )
  df2 <- terra::vect(df_init, geom = c("g", "x"), keepgeom = TRUE)
  df2 <- rowwise(df2, g)
  expect_true(is_rowwise_spatvector(df2))

  expect_snapshot(gg <- bind_spat_rows(df2, df_init))
  expect_true(is_rowwise_spatvector(gg))
  expect_equal(group_size(gg), rep(1, nrow(gg)))
  expect_equal(group_vars(gg), "g")
})

# Column coercion --------------------------------------------------------------

test_that("bind_spat_rows() promotes integer to double", {
  df1 <- data.frame(a = 1L, b = 1L)
  df2 <- data.frame(a = 1, b = 1L)

  df1 <- terra::vect(df1, geom = c("a", "b"), keepgeom = TRUE)
  df2 <- terra::vect(df2, geom = c("a", "b"), keepgeom = TRUE)
  res <- bind_spat_rows(df1, df2)
  expect_type(res$a, "double")
  expect_type(res$b, "double")
})

# Geometry  handling ----------------------------------------------------------

test_that("bind_spat_rows() return empty point", {
  empt <- bind_spat_rows()
  expect_identical(
    as_tibble(empt, geom = "WKT"),
    as_tibble(terra::vect("POINT EMPTY"), geom = "WKT")
  )
})

test_that("bind_spat_rows() can bind SpatVectors", {
  v <- terra::vect(system.file("extdata/cyl.gpkg", package = "tidyterra"))
  expect_silent(vend <- bind_spat_rows(v[1, ], v[2, ]))
  expect_s4_class(vend, "SpatVector")
})

test_that("bind_spat_rows() can bind SpatVectors and sf", {
  v <- terra::vect(system.file("extdata/cyl.gpkg", package = "tidyterra"))
  sf2 <- as_sf(v[2, ])

  expect_silent(vend <- bind_spat_rows(v[1, ], sf2))
  expect_s4_class(vend, "SpatVector")
})

# Errors and messages ----------------------------------------------------------

test_that("bind_spat_rows() give informative errors", {
  expect_snapshot({
    "invalid .id"
    df1 <- data.frame(x = 1:3, lat = 1:3, lon = 1:3)
    df2 <- data.frame(x = 4:6, lat = 1:3, lon = 1:3)
    df1 <- terra::vect(df1)
    df2 <- terra::vect(df2)
    (expect_error(bind_spat_rows(df1, df2, .id = 5)))

    "invalid type"
    ll <- list(data.frame(a = 1:5))
    (expect_error(bind_spat_rows(ll)))

    (expect_error(bind_spat_rows(df1, ll)))
  })
})


test_that("bind_spat_rows() give informative message", {
  expect_snapshot({
    "different crs SpatVector"
    v <- terra::vect(system.file("extdata/cyl.gpkg", package = "tidyterra"))
    v1 <- v[1, ]
    v2 <- terra::project(v[2, ], "EPSG:3857")
    (expect_message(vend <- bind_spat_rows(v1, v2)))
    expect_s4_class(vend, "SpatVector")
    expect_identical(pull_crs(vend), pull_crs(v1))

    "different crs sf"
    v2_sf <- as_sf(v2)
    expect_s3_class(v2_sf, "sf")

    (expect_message(vend2 <- bind_spat_rows(v1, v2_sf)))
    expect_s4_class(vend2, "SpatVector")
    expect_identical(pull_crs(vend2), pull_crs(v1))

    "different crs sf and df"
    df1 <- data.frame(x = 1:3, lat = 1:3, lon = 1:3)

    (expect_message(vend3 <- bind_spat_rows(v1, v2_sf, df1)))
    expect_s4_class(vend3, "SpatVector")
    expect_identical(pull_crs(vend3), pull_crs(v1))
  })
})