tests/testthat/test-pivot-long-SpatVector.R

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

test_that("can pivot all cols to long", {
  df <- tibble::tibble(x = 1:2, y = 3:4)
  df$lat <- 1
  df$lon <- 1

  df <- terra::vect(df, crs = "EPSG:3857")

  expect_s4_class(df, "SpatVector")

  pv <- pivot_longer(df, x:y)

  expect_named(pv, c("name", "value"))
  expect_equal(pv$name, rep(names(df), 2))
  expect_equal(pv$value, c(1, 3, 2, 4))

  expect_s4_class(pv, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv))
})

test_that("values interleaved correctly", {
  df <- tibble::tibble(
    x = c(1, 2),
    y = c(10, 20),
    z = c(100, 200),
  )
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")
  expect_s4_class(df, "SpatVector")

  pv <- pivot_longer(df, 1:3)

  expect_equal(pv$value, c(1, 10, 100, 2, 20, 200))
  expect_s4_class(pv, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv))
})


test_that("preserves original keys", {
  df <- tibble::tibble(x = 1:2, y = 2, z = 1:2)
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")
  expect_s4_class(df, "SpatVector")

  pv <- pivot_longer(df, y:z)

  expect_named(pv, c("x", "name", "value"))
  expect_equal(pv$x, rep(df$x, each = 2))
  expect_s4_class(pv, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv))
})

test_that("can drop missing values", {
  df <- data.frame(x = c(1, NA), y = c(NA, 2))
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")
  expect_s4_class(df, "SpatVector")

  pv <- pivot_longer(df, x:y, values_drop_na = TRUE)

  expect_equal(pv$name, c("x", "y"))
  expect_equal(pv$value, c(1, 2))
  expect_s4_class(pv, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv))
})

test_that("can handle missing combinations", {
  df <- tibble::tribble(
    ~id, ~x_1, ~x_2, ~y_2,
    "A",    1,    2,  "a",
    "B",    3,    4,  "b",
  )
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")
  expect_s4_class(df, "SpatVector")
  expect_snapshot(
    pv <- pivot_longer(
      df, -id,
      names_to = c(".value", "n"),
      names_sep = "_"
    )
  )


  expect_named(pv, c("id", "n", "x", "y"))
  expect_equal(pv$x, c(1:4))
  expect_equal(pv$y, c(NA, "a", NA, "b"))
  expect_s4_class(pv, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv))
})

test_that("mixed columns are automatically coerced", {
  df <- data.frame(x = factor("a"), y = factor("b"))
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")

  pv <- pivot_longer(df, x:y)

  expect_equal(pv$value, factor(c("a", "b")))
  expect_s4_class(pv, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv))
})

test_that("original col order is preserved", {
  df <- tibble::tribble(
    ~id, ~z_1, ~y_1, ~x_1, ~z_2, ~y_2, ~x_2,
    "A", 1, 2, 3, 4, 5, 6,
    "B", 7, 8, 9, 10, 11, 12,
  )
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")
  expect_snapshot(
    pv <- pivot_longer(df, -id, names_to = c(".value", "n"), names_sep = "_")
  )
  expect_named(pv, c("id", "n", "z", "y", "x"))
  expect_s4_class(pv, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv))
})

test_that("can pivot duplicated names to .value", {
  df <- tibble::tibble(x = 1, a_1 = 1, a_2 = 2, b_1 = 3, b_2 = 4)
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")

  expect_snapshot(
    pv1 <- pivot_longer(df, -x, names_to = c(".value", NA), names_sep = "_")
  )

  expect_named(pv1, c("x", "a", "b"))
  expect_equal(pv1$a, c(1, 2))
  expect_s4_class(pv1, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(pv1))
})



test_that("grouping is preserved", {
  df <- tibble::tibble(g = 1, x1 = 1, x2 = 2)
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")

  out <- df %>%
    group_by(g) %>%
    pivot_longer(x1:x2, names_to = "x", values_to = "v")
  expect_equal(dplyr::group_vars(out), "g")
  expect_s4_class(out, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(out))
})


test_that("`cols_vary` can adjust the resulting row ordering (#1312)", {
  df <- tibble::tibble(x = c(1, 2), y = c(3, 4))
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")

  out <- pivot_longer(df, c(x, y), cols_vary = "fastest")
  expect_s4_class(out, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(out))

  tib <- as_tibble(out)
  attr(tib, "crs") <- NULL

  expect_identical(
    tib,
    tibble::tibble(name = c("x", "y", "x", "y"), value = c(1, 3, 2, 4))
  )

  out <- pivot_longer(df, c(x, y), cols_vary = "slowest")
  expect_s4_class(out, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(out))

  tib <- as_tibble(out)
  attr(tib, "crs") <- NULL

  expect_identical(
    tib,
    tibble::tibble(name = c("x", "x", "y", "y"), value = c(1, 2, 3, 4))
  )
})

test_that("`cols_vary` works with id columns not part of the pivot process", {
  df <- tibble::tibble(id = c("a", "b"), x = c(1, 2), y = c(3, 4))
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")

  out <- pivot_longer(df, c(x, y), cols_vary = "fastest")
  expect_identical(out$id, c("a", "a", "b", "b"))
  expect_identical(
    as_tibble(out[c("name", "value")]),
    as_tibble(pivot_longer(df[c("x", "y")], c(x, y), cols_vary = "fastest"))
  )

  out <- pivot_longer(df, c(x, y), cols_vary = "slowest")
  expect_identical(out$id, c("a", "b", "a", "b"))
  expect_identical(
    as_tibble(out[c("name", "value")]),
    as_tibble(pivot_longer(df[c("x", "y")], c(x, y), cols_vary = "slowest"))
  )
})

test_that("adjusting `cols_vary` works fine with `values_drop_na`", {
  df <- tibble::tibble(id = c("a", "b"), x = c(1, NA), y = c(3, 4))
  df$lat <- 1
  df$lon <- 1
  df <- terra::vect(df, crs = "EPSG:3857")

  out <- pivot_longer(df, c(x, y), cols_vary = "slowest", values_drop_na = TRUE)

  expect_s4_class(out, "SpatVector")
  expect_identical(pull_crs(df), pull_crs(out))

  tib <- as_tibble(out)
  attr(tib, "crs") <- NULL

  expect_identical(
    tib,
    tibble::tibble(
      id = c("a", "a", "b"),
      name = c("x", "y", "y"),
      value = c(1, 3, 4)
    )
  )
})


# Helpers ----
test_that("Check tidyselect: var1:var10", {
  tbl <- tibble::tibble(
    a = 1,
    geometry = "1",
    gy = 1,
    char = "1",
    s = 1,
    a2 = NA,
    eom = "fun"
  )

  ## No message
  expect_silent(out <- remove_geom_col(tbl, gy:s, "test_that"))
  expect_type(out, "character")
  expect_length(out, 3)
  expect_identical(out, c("gy", "char", "s"))

  ## Message
  expect_snapshot(out <- remove_geom_col(tbl, a:char, "test_that"))
  expect_type(out, "character")
  expect_length(out, 3)
  expect_identical(out, c("a", "gy", "char"))
})

test_that("Check tidyselect: start_with", {
  tbl <- tibble::tibble(
    a = 1,
    geometry = "1",
    gy = 1,
    char = "1",
    s = 1,
    a2 = NA,
    eom = "fun"
  )

  ## No message
  expect_silent(out <- remove_geom_col(
    tbl, dplyr::starts_with("a"),
    "test_that"
  ))
  expect_type(out, "character")
  expect_length(out, 2)
  expect_identical(out, c("a", "a2"))

  ## Message
  expect_snapshot(out <- remove_geom_col(
    tbl, dplyr::starts_with("g"),
    "test_that"
  ))

  expect_type(out, "character")
  expect_length(out, 1)
  expect_identical(out, "gy")
})

test_that("Check tidyselect: ends_with", {
  tbl <- tibble::tibble(
    a = 1,
    geometry = "1",
    gy = 1,
    char = "1",
    s = 1,
    a2 = NA,
    eom = "fun"
  )

  ## No message
  expect_silent(out <- remove_geom_col(
    tbl, dplyr::ends_with("m"),
    "test_that"
  ))
  expect_type(out, "character")
  expect_length(out, 1)
  expect_identical(out, c("eom"))

  ## Message
  expect_snapshot(out <- remove_geom_col(
    tbl, dplyr::ends_with("y"),
    "test_that"
  ))

  expect_type(out, "character")
  expect_length(out, 1)
  expect_identical(out, "gy")
})

test_that("Check tidyselect: ends_with", {
  tbl <- tibble::tibble(
    a = 1,
    geometry = "1",
    gy = 1,
    char = "1",
    s = 1,
    a2 = NA,
    eom = "fun"
  )

  ## No message
  expect_silent(out <- remove_geom_col(
    tbl, dplyr::ends_with("m"),
    "test_that"
  ))
  expect_type(out, "character")
  expect_length(out, 1)
  expect_identical(out, c("eom"))

  ## Message
  expect_snapshot(out <- remove_geom_col(
    tbl, dplyr::ends_with("y"),
    "test_that"
  ))

  expect_type(out, "character")
  expect_length(out, 1)
  expect_identical(out, "gy")
})

test_that("Check tidyselect: whereis", {
  tbl <- tibble::tibble(
    a = 1,
    geometry = "1",
    gy = 1,
    char = "1",
    s = 1,
    a2 = NA,
    eom = "fun"
  )

  ## No message
  expect_silent(out <- remove_geom_col(
    tbl, dplyr::where(is.numeric),
    "test_that"
  ))
  expect_type(out, "character")
  expect_length(out, 3)
  expect_identical(out, c("a", "gy", "s"))

  ## Message
  expect_snapshot(out <- remove_geom_col(
    tbl, dplyr::where(is.character),
    "test_that"
  ))

  expect_type(out, "character")
  expect_length(out, 2)
  expect_identical(out, c("char", "eom"))
})