From ec68f40514045b7e6ec3bc9de150c7141d56ffdb Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Tue, 13 Dec 2022 11:50:13 +0100 Subject: [PATCH 01/15] first shot at implementing sfc_POINT with matrix --- NAMESPACE | 1 + R/arith.R | 5 +++ R/bbox.R | 8 ++++- R/bind.R | 6 +++- R/geom-transformers.R | 10 ++++-- R/m_range.R | 6 ++++ R/plot.R | 3 +- R/sf.R | 15 +++++--- R/sfc.R | 55 +++++++++++++++++++++++++----- R/sfg.R | 2 ++ R/tidyverse.R | 4 ++- R/z_range.R | 8 ++++- man/geos_unary.Rd | 2 +- src/wkb.cpp | 79 ++++++++++++++++++++++++++++++++++++------- 14 files changed, 170 insertions(+), 34 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0471258d6..428103ef7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ S3method("$<-",sf) S3method("[",sf) S3method("[",sfc) S3method("[<-",sfc) +S3method("[[",sfc) S3method("[[<-",sf) S3method("st_agr<-",sf) S3method("st_crs<-",bbox) diff --git a/R/arith.R b/R/arith.R index 5f1b2b336..68e6bc79a 100644 --- a/R/arith.R +++ b/R/arith.R @@ -128,6 +128,11 @@ Ops.sfc <- function(e1, e2) { if (length(e1) == 0) # empty set return(e1) + if (inherits(e1, "sfc")) # realize + e1 = e1[] + if (inherits(e2, "sfc")) + e2 = e2[] + if (is.numeric(e2) && !is.matrix(e2) && length(e2) <= 2 && .Generic %in% c("+", "-")) { if (.Generic == "-") e2 <- -e2 diff --git a/R/bbox.R b/R/bbox.R index 5f2343deb..320197926 100644 --- a/R/bbox.R +++ b/R/bbox.R @@ -9,6 +9,10 @@ bb_wrap = function(bb) { structure(as.double(bb), names = c("xmin", "ymin", "xmax", "ymax"), class = "bbox") } +bbox.pointmatrix = function(obj, ...) { + bb_wrap(as.vector(t(apply(obj[,1:2,drop=FALSE], 2, range)))) +} + bbox.Set = function(obj, ...) { sel = !sfc_is_empty(obj) if (! any(sel)) @@ -134,7 +138,9 @@ print.bbox = function(x, ...) { } compute_bbox = function(obj) { - switch(class(obj)[1], + if (!is.null(pts <- attr(obj, "points"))) + bbox.pointmatrix(pts) + else switch(class(obj)[1], sfc_POINT = bb_wrap(bbox.Set(obj)), sfc_MULTIPOINT = bb_wrap(bbox.MtrxSet(obj)), sfc_LINESTRING = bb_wrap(bbox.MtrxSet(obj)), diff --git a/R/bind.R b/R/bind.R index fc3af3a9a..dc0ea8896 100644 --- a/R/bind.R +++ b/R/bind.R @@ -29,7 +29,11 @@ rbind.sf = function(..., deparse.level = 1) { if (!all(equal_crs)) stop("arguments have different crs", call. = FALSE) } - ret = st_sf(rbind.data.frame(...), crs = crs0, sf_column_name = sf_column) + for (i in seq_along(dots)) { + if (all(sapply(unclass(st_geometry(dots[[i]])), is.null))) + st_geometry(dots[[i]]) = st_geometry(dots[[i]])[] # realize + } + ret = st_sf(do.call(rbind.data.frame, dots), crs = crs0, sf_column_name = sf_column) st_geometry(ret) = st_sfc(st_geometry(ret)) # might need to reclass to GEOMETRY bb = do.call(rbind, lapply(dots, st_bbox)) bb = bb_wrap(c(min(bb[,1L], na.rm = TRUE), min(bb[,2L], na.rm = TRUE), diff --git a/R/geom-transformers.R b/R/geom-transformers.R index 10a7cb48b..c253a2f22 100644 --- a/R/geom-transformers.R +++ b/R/geom-transformers.R @@ -384,7 +384,7 @@ st_minimum_rotated_rectangle.sf = function(x, dTolerance, ...) { #' n = 100 #' pts = st_as_sf(data.frame(matrix(runif(n), , 2), id = 1:(n/2)), coords = c("X1", "X2")) #' # compute Voronoi polygons: -#' pols = st_collection_extract(st_voronoi(do.call(c, st_geometry(pts)))) +#' pols = st_collection_extract(st_voronoi(st_combine(pts))) #' # match them to points: #' pts$pols = pols[unlist(st_intersects(pts, pols))] #' plot(pts["id"], pch = 16) # ID is color @@ -651,8 +651,12 @@ st_segmentize.sf = function(x, dfMaxLength, ...) { #' @examples #' nc = st_read(system.file("shape/nc.shp", package="sf")) #' st_combine(nc) -st_combine = function(x) - st_sfc(do.call(c, st_geometry(x)), crs = st_crs(x)) # flatten/merge +st_combine = function(x) { + x = st_geometry(x) + if (inherits(x, "sfc_POINT") && !is.null(attr(x, "points"))) + x = x[] + st_sfc(do.call(c, x), crs = st_crs(x)) # flatten/merge +} # x: object of class sf # y: object of class sf or sfc diff --git a/R/m_range.R b/R/m_range.R index 5dde0f951..5a526525f 100644 --- a/R/m_range.R +++ b/R/m_range.R @@ -9,6 +9,10 @@ mb_wrap = function(mb) { structure(mb, names = c("mmin", "mmax"), class = "m_range") } +m_range.pointmatrix = function(obj, ...) { + mb_wrap(range(obj[,ncol(obj)])) +} + m_range.Set = function(obj, ...) { sel = vapply(obj, function(x) { length(x) && !all(is.na(x)) }, TRUE) if (! any(sel)) @@ -130,6 +134,8 @@ print.m_range = function(x, ...) { } compute_m_range = function(obj) { + if (!is.null(pts <- attr(obj, "points"))) + m_range.pointmatrix(pts) switch(class(obj)[1], sfc_POINT = mb_wrap(m_range.Set(obj)), sfc_MULTIPOINT = mb_wrap(m_range.MtrxSet(obj)), diff --git a/R/plot.R b/R/plot.R index 43a472143..0af0e6a6c 100644 --- a/R/plot.R +++ b/R/plot.R @@ -312,7 +312,8 @@ plot.sfc_POINT = function(x, y, ..., pch = 1, cex = 1, col = 1, bg = 0, lwd = 1, col = rep(col, length.out = npts) bg = rep(bg, length.out = npts) cex = rep(cex, length.out = npts) - mat = t(matrix(unlist(x, use.names = FALSE), ncol = length(x))) #933 + #mat = t(matrix(unlist(x, use.names = FALSE), ncol = length(x))) #933 + mat = st_coordinates(x) if (!is.null(mat)) { ne = !is.na(rowMeans(mat)) ## faster than apply; #933 points(mat[ne,, drop = FALSE], pch = pch[ne], col = col[ne], bg = bg[ne], diff --git a/R/sf.R b/R/sf.R index 510cc2083..0fb2ca0d6 100644 --- a/R/sf.R +++ b/R/sf.R @@ -48,14 +48,20 @@ st_as_sf.data.frame = function(x, ..., agr = NA_agr_, coords, wkt, if (na.fail && any(is.na(cc))) stop("missing values in coordinates not allowed") # classdim = getClassDim(rep(0, length(coords)), length(coords), dim, "POINT") - x$geometry = structure( points_rcpp(as.matrix(cc), dim), + # x$geometry = structure( points_rcpp(attr(x, "points"), dim), + if (length(coords) == 2) + dim = "XY" + stopifnot(length(coords) == nchar(dim), dim %in% c("XY", "XYZ", "XYZM", "XYM")) + x$geometry = structure(vector("list", length = nrow(cc)), + points = as.matrix(cc), + points_dim = dim, n_empty = 0L, precision = 0, crs = NA_crs_, bbox = structure( c(xmin = min(cc[[1]], na.rm = TRUE), ymin = min(cc[[2]], na.rm = TRUE), xmax = max(cc[[1]], na.rm = TRUE), ymax = max(cc[[2]], na.rm = TRUE)), class = "bbox"), - class = c("sfc_POINT", "sfc" ), names = NULL) + class = c("sfc_POINT", "sfc"), names = NULL) if (is.character(coords)) coords = match(coords, names(x)) @@ -406,9 +412,10 @@ print.sf = function(x, ..., n = getOption("sf_max_print", default = 10)) { app = paste0(app, "\n", "Active geometry column: ", attr(x, "sf_column")) print(st_geometry(x), n = 0, what = "Simple feature collection with", append = app) if (n > 0) { - if (inherits(x, "tbl_df")) + if (inherits(x, "tbl_df")) { + st_geometry(x) = x[[attr(x, "sf_column")]][] # note the extra []: this reloads points NextMethod() - else { + } else { y <- x if (nrow(y) > n) { cat(paste("First", n, "features:\n")) diff --git a/R/sfc.R b/R/sfc.R index 0098d470c..6686df6d4 100644 --- a/R/sfc.R +++ b/R/sfc.R @@ -48,14 +48,24 @@ st_sfc = function(..., crs = NA_crs_, precision = 0.0, check_ring_dir = FALSE, d lst = lst[[1]] stopifnot(is.numeric(crs) || is.character(crs) || inherits(crs, "crs")) + points_in_attr <- !is.null(attr(lst, "points")) + # check for NULLs: a = attributes(lst) - is_null = sfc_is_null(lst) + is_null = if (points_in_attr) + rep(FALSE, length(lst)) + else + sfc_is_null(lst) lst = unclass(lst) - lst = lst[! is_null] + if (!points_in_attr) + lst = lst[! is_null] + attributes(lst) = a - dims_and_types = sfc_unique_sfg_dims_and_types(lst) + dims_and_types = if (points_in_attr) + list(class_dim = attr(lst, "points_dim"), class_type = "POINT") + else + sfc_unique_sfg_dims_and_types(lst) cls = if (length(lst) == 0) # empty set: no geometries read c("sfc_GEOMETRY", "sfc") @@ -140,8 +150,12 @@ st_sfc = function(..., crs = NA_crs_, precision = 0.0, check_ring_dir = FALSE, d "[.sfc" = function(x, i, j, ..., op = st_intersects) { if (!missing(i) && (inherits(i, "sf") || inherits(i, "sfc") || inherits(i, "sfg"))) i = lengths(op(x, i, ...)) != 0 - st_sfc(NextMethod(), crs = st_crs(x), precision = st_precision(x), - dim = if(length(x)) class(x[[1]])[1] else "XY") + if (inherits(x, "sfc_POINT") && !is.null(attr(x, "points"))) + st_sfc(restore_points(x, i), crs = st_crs(x), precision = st_precision(x), + dim = if(length(x)) class(x[[1]])[1] else "XY") + else + st_sfc(NextMethod() , crs = st_crs(x), precision = st_precision(x), + dim = if(length(x)) class(x[[1]])[1] else "XY") } @@ -487,8 +501,11 @@ st_coordinates.sfc = function(x, ...) { return(matrix(nrow = 0, ncol = 2)) ret = switch(class(x)[1], - sfc_POINT = matrix(unlist(x, use.names = FALSE), nrow = length(x), byrow = TRUE, - dimnames = NULL), + sfc_POINT = if (is.null(attr(x, "points"))) { + matrix(unlist(x, use.names = FALSE), nrow = length(x), byrow = TRUE, dimnames = NULL) + } else { + attr(x, "points") + }, sfc_MULTIPOINT = , sfc_LINESTRING = coord_2(x), sfc_MULTILINESTRING = , @@ -496,7 +513,10 @@ st_coordinates.sfc = function(x, ...) { sfc_MULTIPOLYGON = coord_4(x), stop(paste("not implemented for objects of class", class(x)[1])) ) - Dims = class(x[[1]])[1] + Dims = if (!is.null(attr(x, "points_dim"))) + attr(x, "points_dim") + else + class(x[[1]])[1] ncd = nchar(Dims) colnames(ret)[1:ncd] = vapply(seq_len(ncd), function(i) substr(Dims, i, i), "") ret @@ -579,3 +599,22 @@ st_as_sfc.bbox = function(x, ...) { box = st_polygon(list(matrix(x[c(1, 2, 3, 2, 3, 4, 1, 4, 1, 2)], ncol = 2, byrow = TRUE))) st_sfc(box, crs = st_crs(x)) } + +#' @export +`[[.sfc` = function(x, i, j, ..., exaxt = TRUE) { + if (inherits(x, "sfc_POINT") && !is.null(attr(x, "points"))) + restore_point(x, i) + else + NextMethod() +} + +restore_point = function(x, i = TRUE) { + restore_points(x, i)[[1]] +} + +restore_points = function(x, i = TRUE) { + a = attributes(x) + structure(points_rcpp(a$points[i,,drop=FALSE], a$points_dim), + n_empty = 0L, precision = a$precision, crs = a$crs, + bbox = a$bbox, class = a$class, points = NULL, points_dim = NULL) +} diff --git a/R/sfg.R b/R/sfg.R index f31f0817c..ebddb01d7 100644 --- a/R/sfg.R +++ b/R/sfg.R @@ -258,6 +258,8 @@ c.sfg = function(..., recursive = FALSE, flatten = TRUE) { Paste0 = function(lst) lapply(lst, unclass) Paste1 = function(lst) do.call(c, lapply(lst, unclass)) lst = list(...) + if (length(lst) && is.null(lst[[1]])) + stop("to combine POINTs into MULTIPOINT, use st_combine(), or realize them first using x[]") if (flatten) { cls = vapply(lst, function(x) class(x)[2], "") ucls = unique(cls) diff --git a/R/tidyverse.R b/R/tidyverse.R index ac00e5df6..506629327 100644 --- a/R/tidyverse.R +++ b/R/tidyverse.R @@ -497,6 +497,8 @@ nest.sf = function (.data, ...) { if (!requireNamespace("tidyr", quietly = TRUE)) stop("tidyr required: install first?") + if (inherits(g <- st_geometry(.data), "sfc_POINT") && !is.null(attr(g, "points"))) + st_geometry(.data) = g[] # realize class(.data) <- setdiff(class(.data), "sf") ret = tidyr::nest(.data, ...) lst = which(sapply(ret, inherits, "list"))[1] @@ -582,7 +584,7 @@ type_sum.sfc <- function(x, ...) { #' Summarize simple feature item for tibble #' @name tibble obj_sum.sfc <- function(x) { - vapply(x, function(sfg) format(sfg, width = 15L), "") + vapply(x[], function(sfg) format(sfg, width = 15L), "") } #' @name tibble diff --git a/R/z_range.R b/R/z_range.R index a6d19a6df..ae1d550d7 100644 --- a/R/z_range.R +++ b/R/z_range.R @@ -9,6 +9,10 @@ zb_wrap = function(zb) { structure(zb, names = c("zmin", "zmax"), class = "z_range") } +z_range.pointmatrix = function(obj, ...) { + zb_wrap(range(obj[,3])) +} + z_range.Set = function(obj, ...) { sel = vapply(obj, function(x) { length(x) && !all(is.na(x)) }, TRUE) if (! any(sel)) @@ -129,7 +133,9 @@ print.z_range = function(x, ...) { } compute_z_range = function(obj) { - switch(class(obj)[1], + if (!is.null(pts <- attr(obj, "points"))) + z_range.pointmatrix(pts) + else switch(class(obj)[1], sfc_POINT = zb_wrap(z_range.Set(obj)), sfc_MULTIPOINT = zb_wrap(z_range.MtrxSet(obj)), sfc_LINESTRING = zb_wrap(z_range.MtrxSet(obj)), diff --git a/man/geos_unary.Rd b/man/geos_unary.Rd index b0ed67257..f694a2593 100644 --- a/man/geos_unary.Rd +++ b/man/geos_unary.Rd @@ -227,7 +227,7 @@ if (compareVersion(sf_extSoftVersion()[["GEOS"]], "3.5.0") > -1) { n = 100 pts = st_as_sf(data.frame(matrix(runif(n), , 2), id = 1:(n/2)), coords = c("X1", "X2")) # compute Voronoi polygons: - pols = st_collection_extract(st_voronoi(do.call(c, st_geometry(pts)))) + pols = st_collection_extract(st_voronoi(st_combine(pts))) # match them to points: pts$pols = pols[unlist(st_intersects(pts, pols))] plot(pts["id"], pch = 16) # ID is color diff --git a/src/wkb.cpp b/src/wkb.cpp index c91277ff2..09debef7a 100644 --- a/src/wkb.cpp +++ b/src/wkb.cpp @@ -430,7 +430,32 @@ Rcpp::List CPL_read_wkb(Rcpp::List wkb_list, bool EWKB = false, bool spatialite output.attr("n_empty") = (int) n_empty; if ((EWKB || spatialite) && srid != 0) output.attr("srid") = (int) srid; - return output; + if (n_types <= 1 && type == SF_Point) { // xxx + using namespace Rcpp; // so that later on the (i,_) works + NumericVector pt = output[0]; + CharacterVector cls = pt.attr("class"); + int nc = 2; + if (cls[0] == "XYZ" || cls[0] == "XYM") + nc = 3; + if (cls[0] == "XYZM") + nc = 4; + NumericMatrix m(wkb_list.size(), nc); + for (int i = 0; i < wkb_list.size(); i++) { + NumericVector nv = output[i]; + m(i, _) = nv; + } + Rcpp::List ret(wkb_list.size()); + ret.attr("points") = m; + CharacterVector points_dim(1); + points_dim(0) = cls(0); + ret.attr("points_dim") = points_dim; + ret.attr("single_type") = n_types <= 1; // if 0, we have only empty geometrycollections + ret.attr("n_empty") = (int) n_empty; + if ((EWKB || spatialite) && srid != 0) + ret.attr("srid") = (int) srid; + return ret; + } else + return output; } // @@ -700,18 +725,39 @@ Rcpp::List CPL_write_wkb(Rcpp::List sfc, bool EWKB = false) { } } - for (int i = 0; i < sfc.size(); i++) { - Rcpp::checkUserInterrupt(); - std::ostringstream os; - if (have_classes) - cls = classes[i]; - write_data(os, sfc, i, EWKB, endian, cls, dm, precision, srid); - Rcpp::RawVector raw(os.str().size()); // os -> raw: - std::string str = os.str(); - const char *cp = str.c_str(); - for (size_t j = 0; j < str.size(); j++) - raw[j] = cp[j]; - output[i] = raw; // raw vector to list + if (sfc.attr("points") != R_NilValue) { + using namespace Rcpp; // so that later on the (i,_) works + Rcpp::NumericMatrix m = sfc.attr("points"); + unsigned int sf_type = make_type(cls, dm, EWKB, NULL, srid); + for (int i = 0; i < m.nrow(); i++) { + std::ostringstream os; + add_byte(os, (char) endian); + add_int(os, sf_type); + if (EWKB && srid != 0) + add_int(os, srid); + for (int j = 0; j < m.ncol(); j++) + add_double(os, m(i, j), precision); + Rcpp::RawVector raw(os.str().size()); // os -> raw: + std::string str = os.str(); + const char *cp = str.c_str(); + for (size_t j = 0; j < str.size(); j++) + raw[j] = cp[j]; + output[i] = raw; // raw vector to list + } + } else { + for (int i = 0; i < sfc.size(); i++) { + Rcpp::checkUserInterrupt(); + std::ostringstream os; + if (have_classes) + cls = classes[i]; + write_data(os, sfc, i, EWKB, endian, cls, dm, precision, srid); + Rcpp::RawVector raw(os.str().size()); // os -> raw: + std::string str = os.str(); + const char *cp = str.c_str(); + for (size_t j = 0; j < str.size(); j++) + raw[j] = cp[j]; + output[i] = raw; // raw vector to list + } } return output; } @@ -725,6 +771,13 @@ Rcpp::List get_dim_sfc(Rcpp::List sfc) { Rcpp::Named("_cls") = Rcpp::CharacterVector::create("XY"), Rcpp::Named("_dim") = Rcpp::IntegerVector::create(2) ); + if (sfc.attr("points") != R_NilValue) { + Rcpp::NumericMatrix m = sfc.attr("points"); + return Rcpp::List::create( + Rcpp::Named("_cls") = sfc.attr("points_dim"), + Rcpp::Named("_dim") = Rcpp::IntegerVector::create(m.ncol()) + ); + } // we have data: Rcpp::CharacterVector cls = sfc.attr("class"); From d9c5de0a653cafee8fa944d2cd9bafa24368ee51 Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Tue, 13 Dec 2022 18:42:46 +0100 Subject: [PATCH 02/15] pass check with points in matrix attribute --- R/m_range.R | 2 +- R/sf.R | 4 +++- R/sfc.R | 8 +++++--- tests/testthat/test_postgis_RPostgres.R | 2 +- tests/testthat/test_tm.R | 2 ++ tests/testthat/test_wkb.R | 2 +- tests/wkb.R | 2 +- tests/wkb.Rout.save | 8 ++++---- 8 files changed, 18 insertions(+), 12 deletions(-) diff --git a/R/m_range.R b/R/m_range.R index 5a526525f..b7b666935 100644 --- a/R/m_range.R +++ b/R/m_range.R @@ -136,7 +136,7 @@ print.m_range = function(x, ...) { compute_m_range = function(obj) { if (!is.null(pts <- attr(obj, "points"))) m_range.pointmatrix(pts) - switch(class(obj)[1], + else switch(class(obj)[1], sfc_POINT = mb_wrap(m_range.Set(obj)), sfc_MULTIPOINT = mb_wrap(m_range.MtrxSet(obj)), sfc_LINESTRING = mb_wrap(m_range.MtrxSet(obj)), diff --git a/R/sf.R b/R/sf.R index 0fb2ca0d6..85a4609c9 100644 --- a/R/sf.R +++ b/R/sf.R @@ -52,8 +52,10 @@ st_as_sf.data.frame = function(x, ..., agr = NA_agr_, coords, wkt, if (length(coords) == 2) dim = "XY" stopifnot(length(coords) == nchar(dim), dim %in% c("XY", "XYZ", "XYZM", "XYM")) + points = as.matrix(cc) + dimnames(points) = NULL x$geometry = structure(vector("list", length = nrow(cc)), - points = as.matrix(cc), + points = points, points_dim = dim, n_empty = 0L, precision = 0, crs = NA_crs_, bbox = structure( diff --git a/R/sfc.R b/R/sfc.R index 6686df6d4..a4cdbbb14 100644 --- a/R/sfc.R +++ b/R/sfc.R @@ -502,7 +502,7 @@ st_coordinates.sfc = function(x, ...) { ret = switch(class(x)[1], sfc_POINT = if (is.null(attr(x, "points"))) { - matrix(unlist(x, use.names = FALSE), nrow = length(x), byrow = TRUE, dimnames = NULL) + matrix(unlist(x, use.names = FALSE), nrow = length(x), byrow = TRUE, dimnames = NULL) } else { attr(x, "points") }, @@ -614,7 +614,9 @@ restore_point = function(x, i = TRUE) { restore_points = function(x, i = TRUE) { a = attributes(x) - structure(points_rcpp(a$points[i,,drop=FALSE], a$points_dim), + points = a$points[i, , drop=FALSE] + structure(points_rcpp(points, a$points_dim), n_empty = 0L, precision = a$precision, crs = a$crs, - bbox = a$bbox, class = a$class, points = NULL, points_dim = NULL) + bbox = bbox.pointmatrix(points), class = a$class, + points = NULL, points_dim = NULL) } diff --git a/tests/testthat/test_postgis_RPostgres.R b/tests/testthat/test_postgis_RPostgres.R index 7b29412e0..da88bcca1 100644 --- a/tests/testthat/test_postgis_RPostgres.R +++ b/tests/testthat/test_postgis_RPostgres.R @@ -132,7 +132,7 @@ test_that("sf can write non-sf tables with geometries", { df <- as.data.frame(pts) expect_silent(st_write(df, pg, "df")) expect_silent(dfx <- st_read(pg, "df")) - expect_equal(df[["geometry"]], dfx[["geometry"]]) + expect_equal(df$geometry, dfx$geometry) expect_silent(DBI::dbRemoveTable(pg, "df")) }) diff --git a/tests/testthat/test_tm.R b/tests/testthat/test_tm.R index 53f70c46d..a1e4104f0 100644 --- a/tests/testthat/test_tm.R +++ b/tests/testthat/test_tm.R @@ -11,6 +11,7 @@ test_that("st_read and write handle date and time", { st_write(x[-4], shp[1], quiet = TRUE) x2 = st_read(shp[1], quiet = TRUE) + x2$geometry = x2$geometry[] # realize expect_equal(x[-4], x2, check.attributes=FALSE) # WKT2 CRS do not roundtrip for ESRI Shapefile @@ -31,6 +32,7 @@ test_that("st_read and write handle date and time", { st_write(x[-4], shp[1], quiet = TRUE) x2 = st_read(shp[1], quiet = TRUE) + x2$geometry = x2$geometry[] # realize expect_equal(x[-4], x2, check.attributes=FALSE) # WKT2 CRS do not roundtrip for ESRI Shapefile diff --git a/tests/testthat/test_wkb.R b/tests/testthat/test_wkb.R index d94d07fa7..35be10bbd 100644 --- a/tests/testthat/test_wkb.R +++ b/tests/testthat/test_wkb.R @@ -36,7 +36,7 @@ test_that("Reading of big-endian and little-endian gives the same result", { y = structure(list("0x00200000010000714041061A800000000041145CAC00000000"), class = "WKB") expect_identical(st_as_sfc(x, EWKB = TRUE), st_as_sfc(y, EWKB = TRUE)) expect_identical(st_as_sfc(x, EWKB = TRUE, pureR = TRUE), st_as_sfc(y, EWKB = TRUE, pureR = TRUE)) - expect_identical(st_as_sfc(x, EWKB = TRUE), st_as_sfc(y, EWKB = TRUE, pureR = TRUE)) + expect_identical(st_as_sfc(x, EWKB = TRUE)[], st_as_sfc(y, EWKB = TRUE, pureR = TRUE)) # [] realize }) test_that("Reading of truncated buffers results in a proper error", { diff --git a/tests/wkb.R b/tests/wkb.R index 82f1e0b46..87e0bf76e 100644 --- a/tests/wkb.R +++ b/tests/wkb.R @@ -6,7 +6,7 @@ round_trip = function(x, EWKB = FALSE, pureR = FALSE) { class(wkb) = "WKB" # print(wkb) y = st_as_sfc(wkb, EWKB = EWKB, pureR = pureR) - a = all.equal(x, y) + a = all.equal(x[], y[]) # realize both if (length(a) == 1 && is.logical(a) && a) TRUE else { diff --git a/tests/wkb.Rout.save b/tests/wkb.Rout.save index 75e6dda4c..fd6738323 100644 --- a/tests/wkb.Rout.save +++ b/tests/wkb.Rout.save @@ -1,6 +1,6 @@ -R version 3.6.2 (2019-12-12) -- "Dark and Stormy Night" -Copyright (C) 2019 The R Foundation for Statistical Computing +R version 4.2.2 Patched (2022-11-10 r83330) -- "Innocent and Trusting" +Copyright (C) 2022 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. @@ -23,7 +23,7 @@ Type 'q()' to quit R. + class(wkb) = "WKB" + # print(wkb) + y = st_as_sfc(wkb, EWKB = EWKB, pureR = pureR) -+ a = all.equal(x, y) ++ a = all.equal(x[], y[]) # realize both + if (length(a) == 1 && is.logical(a) && a) + TRUE + else { @@ -99,4 +99,4 @@ POINT (0 0) > > proc.time() user system elapsed - 0.505 0.036 0.532 + 1.022 0.741 0.874 From 721020122bc63c9c18638e55cce7372de95a608a Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Tue, 13 Dec 2022 23:17:14 +0100 Subject: [PATCH 03/15] speed up st_combine --- R/geom-transformers.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/geom-transformers.R b/R/geom-transformers.R index c253a2f22..1e2ed82be 100644 --- a/R/geom-transformers.R +++ b/R/geom-transformers.R @@ -653,9 +653,11 @@ st_segmentize.sf = function(x, dfMaxLength, ...) { #' st_combine(nc) st_combine = function(x) { x = st_geometry(x) - if (inherits(x, "sfc_POINT") && !is.null(attr(x, "points"))) - x = x[] - st_sfc(do.call(c, x), crs = st_crs(x)) # flatten/merge + if (inherits(x, "sfc_POINT") && !is.null(pts <- attr(x, "points"))) { + mp = structure(list(st_multipoint(pts, attr(x, "point_dim"))), bbox = st_bbox(x)) + st_sfc(mp, crs = st_crs(x)) + } else + st_sfc(do.call(c, x), crs = st_crs(x)) # flatten/merge } # x: object of class sf From b16648ec8df23151010660c95d94031e95638d94 Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Wed, 14 Dec 2022 12:21:43 +0100 Subject: [PATCH 04/15] fix as(x, "Spatial") for points in matrix attr --- R/sp.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/sp.R b/R/sp.R index 5551361dc..1eb1ee90c 100644 --- a/R/sp.R +++ b/R/sp.R @@ -287,7 +287,11 @@ as_Spatial = function(from, cast = TRUE, IDs = paste0("ID", seq_along(from))) { sfc2SpatialPoints = function(from, IDs) { if (!requireNamespace("sp", quietly = TRUE)) stop("package sp required, please install it first") - sp::SpatialPoints(do.call(rbind, from), proj4string = as(st_crs(from), "CRS")) + m = if (!is.null(pts <- attr(from, "points"))) + pts + else + do.call(rbind, from) + sp::SpatialPoints(m, proj4string = as(st_crs(from), "CRS")) } sfc2SpatialMultiPoints = function(from) { From 1bfb7eae5a35bf4a124fe27fb3d9d5e57c94f48b Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Wed, 14 Dec 2022 17:22:50 +0100 Subject: [PATCH 05/15] update st_as_sfc.SpatialPoints; see also #2060 --- R/sp.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/sp.R b/R/sp.R index 1eb1ee90c..d3921e3bf 100644 --- a/R/sp.R +++ b/R/sp.R @@ -91,9 +91,10 @@ handle_bbox = function(sfc, sp) { st_as_sfc.SpatialPoints = function(x, ..., precision = 0.0) { cc = x@coords dimnames(cc) = NULL - lst = lapply(seq_len(nrow(cc)), function(x) st_point(cc[x,])) - handle_bbox(do.call(st_sfc, append(lst, list(crs = st_crs(x@proj4string), - precision = precision))), x) + lst = vector("list", length = nrow(cc)) + attr(lst, "points") = cc + attr(lst, "points_dim") = "XY" + handle_bbox(structure(st_sfc(lst, crs = st_crs(x@proj4string), precision = precision), n_empty = 0), x) } #' @name st_as_sfc From fc83931096ed295e2379518260b042f586f1df4a Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Fri, 23 Dec 2022 23:00:57 +0100 Subject: [PATCH 06/15] merge main --- tests/testthat/test_tm.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test_tm.R b/tests/testthat/test_tm.R index fd8b1a157..61f32f712 100644 --- a/tests/testthat/test_tm.R +++ b/tests/testthat/test_tm.R @@ -9,6 +9,7 @@ test_that("st_read and write handle date and time", { st_write(x[-4], shp[1], quiet = TRUE) x2 = st_read(shp[1], quiet = TRUE) + x2$geometry = x2$geometry[] # realize expect_equal(x[-4], x2, check.attributes=FALSE) # WKT2 CRS do not roundtrip for ESRI Shapefile @@ -29,6 +30,7 @@ test_that("st_read and write handle date and time", { st_write(x[-4], shp[1], quiet = TRUE) x2 = st_read(shp[1], quiet = TRUE) + x2$geometry = x2$geometry[] # realize expect_equal(x[-4], x2, check.attributes=FALSE) # WKT2 CRS do not roundtrip for ESRI Shapefile From d81f8ca0b60c15569462fadcd1907d6530b8c40e Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Mon, 13 Mar 2023 11:59:14 +0100 Subject: [PATCH 07/15] remove min/max warnings on empty point sets --- R/bbox.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/bbox.R b/R/bbox.R index 320197926..b92620f2d 100644 --- a/R/bbox.R +++ b/R/bbox.R @@ -10,7 +10,10 @@ bb_wrap = function(bb) { } bbox.pointmatrix = function(obj, ...) { - bb_wrap(as.vector(t(apply(obj[,1:2,drop=FALSE], 2, range)))) + if (nrow(obj) == 0) + bb_wrap(rep(NA_real_, 4)) + else + bb_wrap(as.vector(t(apply(obj[,1:2,drop=FALSE], 2, range)))) } bbox.Set = function(obj, ...) { From 3ec76b872491b7ee1e89f47c2da06f9a88dacd4c Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Thu, 29 Jun 2023 20:51:55 +0200 Subject: [PATCH 08/15] modifications handling c() and st_distance --- R/bbox.R | 4 ++-- R/geom-measures.R | 1 + R/sfc.R | 9 +++++++++ 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/R/bbox.R b/R/bbox.R index e65a48073..dcc9e4e8f 100644 --- a/R/bbox.R +++ b/R/bbox.R @@ -10,10 +10,10 @@ bb_wrap = function(bb) { } bbox.pointmatrix = function(obj, ...) { - if (nrow(obj) == 0) + if (nrow(obj) == 0 || all(is.na(obj))) bb_wrap(rep(NA_real_, 4)) else - bb_wrap(as.vector(t(apply(obj[,1:2,drop=FALSE], 2, range)))) + bb_wrap(as.vector(t(apply(obj[,1:2,drop=FALSE], 2, range, na.rm = TRUE)))) } bbox.Set = function(obj, ...) { diff --git a/R/geom-measures.R b/R/geom-measures.R index 2851f0c7d..90852c7ec 100644 --- a/R/geom-measures.R +++ b/R/geom-measures.R @@ -181,6 +181,7 @@ st_distance = function(x, y, ..., dist_fun, by_element = FALSE, else CPL_geos_dist(x, y, which, par) } + d[is.nan(d)] = NA_real_ if (!is.null(u <- st_crs(x)$ud_unit)) units(d) = u d diff --git a/R/sfc.R b/R/sfc.R index 3b94911b0..2973e7092 100644 --- a/R/sfc.R +++ b/R/sfc.R @@ -186,8 +186,17 @@ c.sfc = function(..., recursive = FALSE) { else c(ucls, "sfc") + points_attr = sapply(lst, function(x) !is.null(attr(x, "points"))) + if (any(points_attr) && !all(points_attr)) { + for (i in seq_along(lst)) + lst[[i]] = lst[[i]][] # realize + points_attr = FALSE + } + ret = unlist(lapply(lst, unclass), recursive = FALSE) attributes(ret) = attributes(lst[[1]]) # crs + if (all(points_attr)) + attr(ret, "points") = do.call(rbind, lapply(lst, attr, "points")) class(ret) = cls attr(ret, "bbox") = compute_bbox(ret) # dispatch on class attr(ret, "n_empty") = sum(sapply(lst, attr, which = "n_empty")) From b8dc2b32a9686209c3b5323b5bbd174d882ad5ac Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Fri, 30 Jun 2023 20:49:47 +0200 Subject: [PATCH 09/15] address comment from @bart1 --- R/sf.R | 13 +++++++++---- R/sfc.R | 18 +++++++++++++++--- R/tidyverse.R | 7 ++++++- 3 files changed, 30 insertions(+), 8 deletions(-) diff --git a/R/sf.R b/R/sf.R index 1675bd62b..cff93b130 100644 --- a/R/sf.R +++ b/R/sf.R @@ -44,14 +44,19 @@ st_as_sf.data.frame = function(x, ..., agr = NA_agr_, coords, wkt, else x$geometry = st_as_sfc(as.character(x[[wkt]])) } else if (! missing(coords)) { - cc = as.data.frame(lapply(x[coords], as.numeric)) + cc = if (length(coords) == 1) { + stopifnot(is.matrix(x[[coords]]), is.numeric(x[[coords]])) + x[[coords]] + } else { + if (length(coords) == 2) + dim = "XY" + stopifnot(length(coords) == nchar(dim), dim %in% c("XY", "XYZ", "XYZM", "XYM")) + as.data.frame(lapply(x[coords], as.numeric)) + } if (na.fail && anyNA(cc)) stop("missing values in coordinates not allowed") # classdim = getClassDim(rep(0, length(coords)), length(coords), dim, "POINT") # x$geometry = structure( points_rcpp(attr(x, "points"), dim), - if (length(coords) == 2) - dim = "XY" - stopifnot(length(coords) == nchar(dim), dim %in% c("XY", "XYZ", "XYZM", "XYM")) points = as.matrix(cc) dimnames(points) = NULL x$geometry = structure(vector("list", length = nrow(cc)), diff --git a/R/sfc.R b/R/sfc.R index 2973e7092..307d2be41 100644 --- a/R/sfc.R +++ b/R/sfc.R @@ -162,12 +162,24 @@ st_sfc = function(..., crs = NA_crs_, precision = 0.0, check_ring_dir = FALSE, d #' @export -#"[<-.sfc" = function (x, i, j, value) { "[<-.sfc" = function (x, i, value) { - if (is.null(value) || inherits(value, "sfg")) + if (is.null(value) || inherits(value, "sfg")) { + is_points = inherits(value, "POINT") value = list(value) + } else + is_points = inherits(value, "sfc_POINT") + if (inherits(x, "sfc_POINT") && !is.null(attr(x, "points"))) { + if (is_points) { + repl = if (!is.null(pts <- attr(value, "points"))) + pts + else + do.call(rbind, value) + attr(x, "points")[i, ] = repl + return(structure(x, n_empty = sum(is.na(attr(x, "points")[,1])))) # RETURNS + } else + x = x[] # realize + } x = unclass(x) # becomes a list, but keeps attributes - ret = st_sfc(NextMethod(), recompute_bbox = TRUE) structure(ret, n_empty = sum(sfc_is_empty(ret))) } diff --git a/R/tidyverse.R b/R/tidyverse.R index 56d3093cf..270800650 100644 --- a/R/tidyverse.R +++ b/R/tidyverse.R @@ -52,8 +52,13 @@ group_split.sf <- function(.tbl, ..., .keep = TRUE) { #' } filter.sf <- function(.data, ..., .dots) { agr = st_agr(.data) + g = st_geometry(.data) class(.data) <- setdiff(class(.data), "sf") - .re_sf(NextMethod(), sf_column_name = attr(.data, "sf_column"), agr) + if (inherits(g, "sfc_POINT") && !is.null(pts <- attr(g, "points"))) { + .data[[ attr(.data, "sf_column") ]] = pts + st_as_sf(NextMethod(), coords = attr(.data, "sf_column"), agr = agr, remove = FALSE) # FIXME: doesn't handle tibble? + } else + .re_sf(NextMethod(), sf_column_name = attr(.data, "sf_column"), agr) } #' @name tidyverse From 203187d0b6a2337a2217f91bc83f22b0ba75ab29 Mon Sep 17 00:00:00 2001 From: Edzer Pebesma Date: Fri, 30 Jun 2023 22:58:32 +0200 Subject: [PATCH 10/15] filter empty point; #2059 --- R/sf.R | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) diff --git a/R/sf.R b/R/sf.R index cff93b130..a16b01fb5 100644 --- a/R/sf.R +++ b/R/sf.R @@ -44,31 +44,24 @@ st_as_sf.data.frame = function(x, ..., agr = NA_agr_, coords, wkt, else x$geometry = st_as_sfc(as.character(x[[wkt]])) } else if (! missing(coords)) { - cc = if (length(coords) == 1) { - stopifnot(is.matrix(x[[coords]]), is.numeric(x[[coords]])) - x[[coords]] - } else { - if (length(coords) == 2) - dim = "XY" - stopifnot(length(coords) == nchar(dim), dim %in% c("XY", "XYZ", "XYZM", "XYM")) - as.data.frame(lapply(x[coords], as.numeric)) - } - if (na.fail && anyNA(cc)) - stop("missing values in coordinates not allowed") - # classdim = getClassDim(rep(0, length(coords)), length(coords), dim, "POINT") - # x$geometry = structure( points_rcpp(attr(x, "points"), dim), - points = as.matrix(cc) - dimnames(points) = NULL + if (length(coords) == 1) { + stopifnot(is.matrix(x[[coords]]), is.numeric(x[[coords]])) + cc = x[[coords]] + } else { + if (length(coords) == 2) + dim = "XY" + stopifnot(length(coords) == nchar(dim), dim %in% c("XY", "XYZ", "XYZM", "XYM")) + cc = do.call(cbind, lapply(x[coords], as.numeric)) + if (na.fail && anyNA(cc)) + stop("missing values in coordinates not allowed") + } + dimnames(cc) = NULL x$geometry = structure(vector("list", length = nrow(cc)), - points = points, + points = cc, points_dim = dim, n_empty = 0L, precision = 0, crs = NA_crs_, - bbox = structure( - c(xmin = min(cc[[1]], na.rm = TRUE), - ymin = min(cc[[2]], na.rm = TRUE), - xmax = max(cc[[1]], na.rm = TRUE), - ymax = max(cc[[2]], na.rm = TRUE)), class = "bbox"), - class = c("sfc_POINT", "sfc"), names = NULL) + bbox = bbox.pointmatrix(cc), + class = c("sfc_POINT", "sfc"), names = NULL) if (is.character(coords)) coords = match(coords, names(x)) From 4ecabf04fbc068e70d9f7ad39ced5ed5a8953872 Mon Sep 17 00:00:00 2001 From: edzer Date: Wed, 30 Aug 2023 14:38:46 +0200 Subject: [PATCH 11/15] keep crs in dplyr::filter address https://github.com/r-spatial/sf/pull/2059#issuecomment-1616825196 --- R/tidyverse.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/tidyverse.R b/R/tidyverse.R index c73a875c8..a4e603e81 100644 --- a/R/tidyverse.R +++ b/R/tidyverse.R @@ -56,7 +56,8 @@ filter.sf <- function(.data, ..., .dots) { class(.data) <- setdiff(class(.data), "sf") if (inherits(g, "sfc_POINT") && !is.null(pts <- attr(g, "points"))) { .data[[ attr(.data, "sf_column") ]] = pts - st_as_sf(NextMethod(), coords = attr(.data, "sf_column"), agr = agr, remove = FALSE) # FIXME: doesn't handle tibble? + st_as_sf(NextMethod(), coords = attr(.data, "sf_column"), agr = agr, remove = FALSE, + crs = st_crs(g)) # FIXME: doesn't handle tibble? } else .re_sf(NextMethod(), sf_column_name = attr(.data, "sf_column"), agr) } From 4ce501e49509d02c6655f4fb977c417071989a25 Mon Sep 17 00:00:00 2001 From: edzer Date: Tue, 23 Jan 2024 11:24:07 +0100 Subject: [PATCH 12/15] update for this branch --- R/geom-measures.R | 2 +- man/st_graticule.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/geom-measures.R b/R/geom-measures.R index 4c020ce3d..f71cba8f7 100644 --- a/R/geom-measures.R +++ b/R/geom-measures.R @@ -258,6 +258,6 @@ st_line_project = function(line, point, normalized = FALSE) { point = st_cast(point, "POINT") if (isTRUE(st_is_longlat(line))) message_longlat("st_project_point") - recycled = recycle_common(list(line, point)) + recycled = recycle_common(list(line, point[])) CPL_line_project(recycled[[1]], recycled[[2]], normalized) } diff --git a/man/st_graticule.Rd b/man/st_graticule.Rd index 4119b2917..8c906f943 100644 --- a/man/st_graticule.Rd +++ b/man/st_graticule.Rd @@ -66,7 +66,7 @@ bbox = st_linestring(rbind(c( bb[1],bb[2]),c( bb[3],bb[2]), c( bb[3],bb[4]),c( bb[1],bb[4]),c( bb[1],bb[2]))) g = st_graticule(usa) -plot(usa, xlim = 1.2 * c(-2450853.4, 2186391.9)) +plot(usa, xlim = 1.2 * c(-2450853.4, 2186391.9), reset = FALSE) plot(g[1], add = TRUE, col = 'grey') plot(bbox, add = TRUE) points(g$x_start, g$y_start, col = 'red') From 5126cd6363ab56e28c37ce1717ac2006f4a45ea3 Mon Sep 17 00:00:00 2001 From: Bart Date: Fri, 16 Feb 2024 13:19:49 +0000 Subject: [PATCH 13/15] Fix value replacement for sfc_POINT --- R/sfc.R | 6 +++++- tests/testthat/test_sfc.R | 10 ++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/R/sfc.R b/R/sfc.R index 622218073..e9b5e0cf7 100644 --- a/R/sfc.R +++ b/R/sfc.R @@ -181,10 +181,14 @@ st_sfc = function(..., crs = NA_crs_, precision = 0.0, check_ring_dir = FALSE, d else do.call(rbind, value) attr(x, "points")[i, ] = repl - return(structure(x, n_empty = sum(is.na(attr(x, "points")[,1])))) # RETURNS + return(structure(x, + n_empty = sum(is.na(attr(x, "points")[,1])), + bbox = bbox.pointmatrix(attr(x, "points")) + )) # RETURNS } else x = x[] # realize } + value = value[] # realize in case sfc_POINT while x is not x = unclass(x) # becomes a list, but keeps attributes ret = st_sfc(NextMethod(), recompute_bbox = TRUE) structure(ret, n_empty = sum(sfc_is_empty(ret))) diff --git a/tests/testthat/test_sfc.R b/tests/testthat/test_sfc.R index ce609621e..139c419b1 100644 --- a/tests/testthat/test_sfc.R +++ b/tests/testthat/test_sfc.R @@ -119,3 +119,13 @@ test_that("c.sfc n_empty returns sum of st_is_empty(sfg)", { test_that("st_is_longlat warns on invalid bounding box", { expect_warning(st_is_longlat(st_sfc(st_point(c(0,-95)), crs = 4326))) }) + +test_that("value replacement works for sfc_POINT",{ + pts1<-st_geometry(st_as_sf(data.frame(x=1:3,y=1:3), coords = c("x","y"))) + pts2<-st_geometry(st_as_sf(data.frame(x=4:5,y=4:5), coords = c("x","y"))) + expect_identical(replace(pts1[],2:3,pts2), replace(pts1[],2:3,pts2[])) + expect_identical(replace(pts1,2:3,pts2[])[], replace(pts1[],2:3,pts2[])) + expect_identical(replace(pts1,2:3,pts2)[], replace(pts1[],2:3,pts2[])) + expect_identical(st_bbox(replace(pts1,2:3,pts2)), + st_bbox(replace(pts1[],2:3,pts2[])))# check if bbox is correct without realization +}) From f68795667c7f489e739a2cb21458c3c40ed24215 Mon Sep 17 00:00:00 2001 From: Bart Date: Wed, 28 Feb 2024 10:51:26 +0100 Subject: [PATCH 14/15] ensure vctrs operations work --- R/tidyverse-vctrs.R | 3 +-- tests/testthat/test_vctrs.R | 6 ++++++ 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/R/tidyverse-vctrs.R b/R/tidyverse-vctrs.R index 45096bb25..47c57ff7f 100644 --- a/R/tidyverse-vctrs.R +++ b/R/tidyverse-vctrs.R @@ -3,14 +3,13 @@ # time, this declares `sfc` lists as vectors which is necessary # because vctrs generally treats S3 lists as scalars. vec_proxy.sfc = function(x, ...) { - x + x[] } # This restores `sfc` attributes after manipulation of the proxy # (e.g. slicing or combination) vec_restore.sfc = function(x, to, ...) { # Ensure restoration of `n_empty` by `st_sfc()` attr(x, "n_empty") = NULL - st_sfc(x, crs = st_crs(to), precision = st_precision(to)) } diff --git a/tests/testthat/test_vctrs.R b/tests/testthat/test_vctrs.R index 5c2fd8232..42c6dfa24 100644 --- a/tests/testthat/test_vctrs.R +++ b/tests/testthat/test_vctrs.R @@ -8,6 +8,12 @@ test_that("`sfc` vectors can be sliced", { expect_identical(vctrs::vec_slice(x, 0), x[0]) }) +test_that("`sfc` vectors with point matrix can be sliced", { + x = st_geometry(st_as_sf(data.frame(x=1:2, y=4:3), coords = 1:2)) + expect_identical(vctrs::vec_slice(x, 1), x[1]) + expect_equal(vctrs::vec_slice(x, 0), st_sfc(x[0], recompute_bbox=TRUE)) +}) + test_that("`n_empty` attribute of `sfc` vectors is restored", { pt1 = st_sfc(st_point(c(NA_real_, NA_real_))) pt2 = st_sfc(st_point(0:1)) From 82fe2103b3bfd054fc60d93b3da48e32de2ff62d Mon Sep 17 00:00:00 2001 From: edzer Date: Thu, 10 Oct 2024 12:25:04 +0200 Subject: [PATCH 15/15] align with main --- R/geom-measures.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/geom-measures.R b/R/geom-measures.R index 4e9fa2686..b353215f5 100644 --- a/R/geom-measures.R +++ b/R/geom-measures.R @@ -255,9 +255,9 @@ st_line_project = function(line, point, normalized = FALSE) { is.logical(normalized), length(normalized) == 1, st_crs(line) == st_crs(point)) line = st_cast(line, "LINESTRING") - point = st_cast(point, "POINT") + point = st_cast(point[], "POINT") if (isTRUE(st_is_longlat(line))) message_longlat("st_project_point") - recycled = recycle_common(list(line, point[])) + recycled = recycle_common(list(line, point)) CPL_line_project(recycled[[1]], recycled[[2]], normalized) }