tests/testthat/test_lwgeom.R

In lwgeom: Bindings to Selected 'liblwgeom' Functions for Simple Features

context("lwgeom")

test_that("st_make_valid works", {
	library(sf)
	x = st_sfc(st_polygon(list(rbind(c(0,0),c(0.5,0),c(0.5,0.5),c(0.5,0),c(1,0),c(1,1),c(0,1),c(0,0)))))
	fls = suppressWarnings(sf::st_is_valid(x, FALSE))
	expect_false(fls)

   	y = st_make_valid(x)
	expect_true(st_is_valid(y))
   	expect_true(st_is_valid(st_make_valid(x[[1]])))
   	expect_true(st_is_valid(lwgeom_make_valid(x)))
   	expect_true(st_is_valid(st_make_valid(st_sf(a = 1, geom = x))))
	expect_equal(lwgeom::st_geohash(st_sfc(st_point(c(1.5,3.5)), st_point(c(0,90))), 2), c( "s0","up"))
	expect_equal(lwgeom::st_geohash(st_sfc(st_point(c(1.5,3.5)), st_point(c(0,90))), 10),
		c("s095fjhkbx","upbpbpbpbp"))
	l = st_as_sfc('MULTILINESTRING((10 10, 190 190), (15 15, 30 30, 100 90))')
	pt = st_sfc(st_point(c(30,30)))
	expect_silent(lwgeom::st_split(l, pt)) # sfc
	expect_silent(lwgeom::st_split(l[[1]], pt)) # sfg
	expect_silent(lwgeom::st_split(st_sf(a = 1, geom = l), pt)) # sf
	# https://github.com/r-spatial/sf/issues/509 :
	p1 = st_point(c(7,52))
	geom.sf = st_sfc(p1, crs = 4326)
	x <- st_transform_proj(geom.sf, "+proj=wintri")
	if (sf_extSoftVersion()["proj.4"] >= "6.0.0") {
		x2 <- st_transform_proj(geom.sf, c("EPSG:4326", "+proj=wintri"))
	}
	x3 <- st_transform_proj(geom.sf, st_crs(3857))
	p = st_crs(4326)$proj4string
	x <- st_transform_proj(structure(geom.sf[[1]], proj4string = p), "+proj=wintri")
	nc = st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE)
	st_transform_proj(nc[1,], "+proj=wintri +over")
	lwgeom_extSoftVersion()
})

#test_that("st_minimum_bounding_circle works", {
#  library(sf)
#  x = st_multipoint(matrix(c(0,1,0,1),2,2))
#  y = st_multipoint(matrix(c(0,0,1,0,1,1),3,2))
#  plot(st_minimum_bounding_circle(x), axes=TRUE); plot(x, add=TRUE)
#  plot(st_minimum_bounding_circle(y), axes=TRUE); plot(y, add=TRUE)
#  nc = st_read(system.file("shape/nc.shp", package="sf"), quiet = TRUE)
#  state = st_union(st_geometry(nc))
#  st_minimum_bounding_circle(state)
#  st_minimum_bounding_circle(st_sf(st = "nc", geom = state))
#})

test_that("st_subdivide works", {
	library(sf)
	x = st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE)
	expect_silent(st_subdivide(x, 10))
	expect_silent(st_subdivide(st_geometry(x), 10))
	expect_silent(st_subdivide(st_geometry(x)[[1]], 10))
})

test_that("st_snap_to_grid_works", {
	# make data
	library(sf)
	x = st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE) %>%
			st_transform(3395)
	# snap to grid
	err <- try(y1 <- st_snap_to_grid(x, 5000), silent = TRUE)
	if (inherits(err, "try-error")) # not available in liblwgeom < 2.5.0
		skip("snap_to_grid not available in this liblwgeom version")
	y2 = st_snap_to_grid(st_geometry(x), 5000)
	y3 = st_snap_to_grid(st_geometry(x)[[1]], 5000)
	# check that output class match inputs
	expect_is(y1, "sf")
	expect_is(y2, "sfc")
	expect_is(y3, "sfg")
	# check that outputs contain correct number of geometries
	expect_equal(nrow(x), nrow(y1))
	expect_equal(nrow(x), length(y2))
	# check that outputs have correct crs
	expect_equal(st_crs(x), st_crs(y1))
	expect_equal(st_crs(x), st_crs(y2))
	# check that outputs have been snapped correctly, 
	# i.e. the coordinates of the geometries divided by the tolerance (5000)
	# should not yield a remainder
	y1_m <- do.call(rbind, lapply(st_cast(st_geometry(y1), "MULTIPOINT"), as.matrix))
	expect_true(all(c(y1_m %% 5000) == 0))
	y2_m <- do.call(rbind, lapply(st_cast(y2, "MULTIPOINT"), as.matrix))
	expect_true(all(c(y2_m %% 5000) == 0))
	expect_true(all(c(as.matrix(st_cast(y3, "MULTIPOINT")) %% 5000) == 0))
})

#test_that("st_transform_proj finds sf's PROJ files", {
#  # skip_on_os("mac") # FIXME: in sf rather than here
#  library(sf)
#  nc <- st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE)
#  bb1 = st_bbox(nc)
#  bb2 = st_bbox(st_transform(nc, "+proj=longlat"))
#  bb3 = st_bbox(st_transform_proj(nc, "+proj=longlat"))
#  bb4 = st_bbox(st_transform_proj(nc, st_crs(4326)$proj4string))
#  # expect_false(any(bb1 == bb2))
#  # expect_true(all.equal(as.numeric(bb2), as.numeric(bb3)))
#  # expect_true(all.equal(as.numeric(bb4), as.numeric(bb3)))
#})

test_that("st_linesubstring warns on 4326", {
  library(sf)
  lines = st_sfc(st_linestring(rbind(c(0,0), c(1,2), c(2,0))), crs = 4326)
  library(lwgeom)
  expect_warning(spl <- st_linesubstring(lines, 0.2, 0.8))
  expect_silent(spl <- st_linesubstring(lines[[1]], 0.2, 0.8)) # sfg has no crs
  expect_warning(spl <- st_linesubstring(st_sf(lines), 0.2, 0.8))
  plot(st_geometry(lines), col = 'red', lwd = 3)
  plot(spl, col = 'black', lwd = 3, add = TRUE)
})

#test_that("st_startpoint works", {
#  library(sf)
#  library(lwgeom)
#  sp = st_startpoint(st_sfc(st_linestring(matrix(1:10,,2)), st_linestring(matrix(3:12,,2)),crs=4326))
#})

test_that("st_wrap_x works", {
  library(sf)
  library(lwgeom)
  
  nc <- st_read(system.file("gpkg/nc.gpkg", package="sf"), quiet = TRUE)
  
  splitline <- -78
  offset <- 10
  
  x <- st_wrap_x(nc, splitline, offset)
  
  expect_equal(nrow(x), nrow(nc))
  expect_equal(st_bbox(x)$xmin, splitline, check.attributes = FALSE)
  expect_equal(st_bbox(x)$xmax, splitline + offset, check.attributes = FALSE)
})