#' Apply a mapshaper command string to a geojson object
#'
#' @param data character containing geojson or path to geojson file. If a file
#' path, \code{sys} must be true.
#' @param command valid mapshaper command string
#' @param force_FC should the output be forced to be a FeatureCollection (or sf
#' object or Spatial*DataFrame) even if there are no attributes? Default
#' \code{TRUE}. If FALSE and there are no attributes associated with the
#' geometries, a GeometryCollection (or Spatial object with no dataframe, or
#' sfc) will be output.
#' @param sys Should the system mapshaper be used instead of the bundled
#' mapshaper? Gives better performance on large files. Requires the mapshaper
#' node package to be installed and on the PATH.
#' @param sys_mem How much memory (in GB) should be allocated if using the
#' system mapshaper (`sys = TRUE`)? Default 8. Ignored if `sys = FALSE`. This
#' can also be set globally with the option `"mapshaper.sys_mem"`
#' @param quiet If `sys = TRUE`, should the mapshaper messages be silenced?
#' Default `FALSE`. This can also be set globally with the option
#' `"mapshaper.sys_quiet"`
#' @param gj2008 Generate output that is consistent with the pre-RFC 7946
#' GeoJSON spec (dating to 2008). Polygon rings are CW and holes are CCW,
#' which is the opposite of the default RFC 7946-compatible output. This should
#' be rarely needed, though may be useful when preparing data for D3-based
#' data visualizations (such as `plotly::plot_ly()`). Default `FALSE`
#'
#' @return geojson
#' @export
#' @examples
#'
#' nc <- sf::read_sf(system.file("gpkg/nc.gpkg", package = "sf"))
#' rmapshaper::apply_mapshaper_commands(geojsonsf::sf_geojson(nc), "-clean")
#'
apply_mapshaper_commands <- function(
data,
command,
force_FC = TRUE,
sys = FALSE,
sys_mem = getOption("mapshaper.sys_mem", default = 8),
quiet = getOption("mapshaper.sys_quiet", default = FALSE),
gj2008 = FALSE
) {
if (!is.logical(force_FC)) stop("force_FC must be TRUE or FALSE", call. = FALSE)
if (!is.logical(sys)) stop("sys must be TRUE or FALSE", call. = FALSE)
if (!is.numeric(sys_mem)) stop("sys_mem must be numeric", call. = FALSE)
if (!is.logical(gj2008)) stop("gj2008 must be TRUE or FALSE", call. = FALSE)
data <- as.character(data)
if (!is.numeric(sys_mem) )
if (nchar(data) < 1000L && file.exists(data) && !sys) {
stop("'data' points to a file on disk but you did not specify to use
the system mapshaper. To do so set sys = TRUE")
}
# command <- paste(ms_compact(command), collapse = " ")
if (sys) {
ret <- sys_mapshaper(data = data, command = command, force_FC = force_FC,
sys_mem = sys_mem, quiet = quiet, gj2008 = gj2008)
} else {
out_flags <- NULL
if (force_FC || gj2008) {
add_id <- if (force_FC) fc_command() else NULL
gj2008 <- if (gj2008) "gj2008" else NULL
out_flags <- paste("-o", add_id, gj2008)
}
command <- c(
command,
out_flags
)
command <- paste(ms_compact(command), collapse = " ")
ms <- ms_make_ctx()
## Create a JS object to hold the returned data
ms$eval("var return_data;")
ms$call("mapshaper.applyCommands", command, data,
V8::JS(callback()))
# TODO: New syntax for applyCommands:
# Useful for clip and erase so can define two inputs
# cmd <- paste("-i input.geojson", command, "-o output.geojson")
#
# ms$call("mapshaper.applyCommands", cmd, V8::JS("{'input.geojson': input}"),
# V8::JS("function(err, output) {
# return_data = output['output.geojson'];
# }"))
ret <- ms$get("return_data")
ret <- class_geo_json(ret)
}
ret
}
ms_make_ctx <- function() {
ctx <- V8::v8()
ctx$source(system.file("mapshaper/mapshaper-browserify.min.js",
package = "rmapshaper"))
ctx
}
sys_mapshaper <- function(data, data2 = NULL, command, force_FC = TRUE, # default FALSE as in most cases it is added in apply_mapshaper_commands
sys_mem = getOption("mapshaper.sys_mem", default = 8),
quiet = getOption("mapshaper.sys_quiet", default = FALSE),
gj2008 = FALSE) {
# Get full path to sys mapshaper, use mapshaper-xl
ms_path <- paste0(check_sys_mapshaper("mapshaper-xl", verbose = FALSE))
# Check if need to read/write the file or if it's been written already
# by write_sf or writeOGR
read_write <- !file.exists(data)
in_data_file <- data
in_data_file2 <- data2
if (read_write) {
in_data_file <- temp_geojson()
readr::write_file(data, in_data_file)
on.exit(unlink(in_data_file))
if (!is.null(data2)) {
in_data_file2 <- temp_geojson()
readr::write_file(data2, in_data_file2)
on.exit(unlink(in_data_file2), add = TRUE)
}
}
out_data_file <- temp_geojson()
out_fc <- if (force_FC) fc_command() else NULL
gj2008 <- if (gj2008) "gj2008" else NULL
cmd_args <- c(
sys_mem,
shQuote(in_data_file),
command <- paste(ms_compact(command), collapse = " "),
shQuote(in_data_file2), # will be NULL if no data2/in_data_file2
"-o", shQuote(out_data_file),
out_fc, # will be NULL if force_FC is FALSE
gj2008, # will be NULL if gj2008 is FALSE
if (quiet) "-quiet"
)
system2(ms_path, cmd_args)
if (read_write) {
on.exit(unlink(out_data_file), add = TRUE)
# Read the geojson object and return it
ret <- class_geo_json(readr::read_file(out_data_file))
} else {
# Return the path to the file
ret <- out_data_file
}
ret
}
ms_get_raw <- function(x) {
rawToChar(as.raw(x[["data"]]))
}
## create a JS callback function
callback <- function() {
"function(Error, data) {
if (Error) console.error('Error in V8 context: ' + Error.stack);
return_data = data;
}"
}
ms_sp <- function(input, call, sys = FALSE, force_FC = TRUE,
sys_mem = getOption("mapshaper.sys_mem", default = 8),
quiet = getOption("mapshaper.sys_quiet", default = FALSE),
gj2008 = FALSE) {
has_data <- .hasSlot(input, "data")
if (has_data) {
classes <- col_classes(input@data)
}
geojson <- sp_to_GeoJSON(input, file = sys)
ret <- apply_mapshaper_commands(data = geojson, command = call, force_FC = force_FC,
sys = sys, sys_mem = sys_mem, quiet = quiet,
gj2008 = gj2008)
ret <- GeoJSON_to_sp(ret, crs = attr(geojson, "crs"))
# remove data slot if input didn't have one (default out_class is the class of the input)
if (!has_data) {
ret <- as(ret, gsub("DataFrame$", "", class(ret)[1]))
} else {
ret@data <- restore_classes(ret@data, classes)
}
ret
}
GeoJSON_to_sp <- function(geojson, crs = NULL) {
x_sf <- GeoJSON_to_sf(geojson, crs)
if (nrow(x_sf) == 0) {
stop("Cannot convert result to a Spatial* object.
It is likely too much simplification was applied and all features
were reduced to null.", call. = FALSE)
}
as(x_sf, "Spatial")
}
sp_to_GeoJSON <- function(sp, file = FALSE){
crs <- methods::slot(sp, "proj4string")
if (file) {
js <- sp_to_tempfile(sp)
} else {
js_tmp <- sp_to_tempfile(sp)
js <- readr::read_file(js_tmp, locale = readr::locale())
on.exit(unlink(js_tmp))
}
structure(js, crs = crs)
}
## Utilties for sf
ms_sf <- function(input, call, sys = FALSE, force_FC = TRUE,
sys_mem = getOption("mapshaper.sys_mem", default = 8),
quiet = getOption("mapshaper.sys_quiet", default = FALSE),
gj2008 = FALSE) {
has_data <- inherits(input, "sf")
if (has_data) {
classes <- col_classes(input)
geom_name <- attr(input, "sf_column")
input <- ms_de_unit(input)
} else {
input <- unname(input)
}
geojson <- sf_to_GeoJSON(input, file = sys)
ret <- apply_mapshaper_commands(data = geojson, command = call, force_FC = force_FC,
sys = sys, sys_mem = sys_mem, quiet = quiet,
gj2008 = gj2008)
if (!sys & grepl('^\\{"type":"GeometryCollection"', ret)) {
stop("Cannot convert result to an sf object.
It is likely too much simplification was applied and all features
were reduced to null.", call. = FALSE)
}
ret <- GeoJSON_to_sf(ret, crs = attr(geojson, "crs"))
## Only return sfc if that's all that was input
if (!has_data) {
ret <- sf::st_geometry(ret)
} else {
ret <- restore_classes(ret, classes)
names(ret)[names(ret) == attr(ret, "sf_column")] <- geom_name
sf::st_geometry(ret) <- geom_name
}
##maintain tbl_df
if (all(class(input) == c("sf", "tbl_df", "tbl", "data.frame"))) {
class(ret) <- c("sf", "tbl_df", "tbl", "data.frame")
}
ret
}
GeoJSON_to_sf <- function(geojson, crs = NULL) {
sf <- geojsonsf::geojson_sf(geojson)
if (!is.null(crs)) {
suppressWarnings(sf::st_crs(sf) <- crs)
}
curly_brace_na(sf)
}
sf_to_GeoJSON <- function(sf, file = FALSE) {
crs <- sf::st_crs(sf)
js <- if (inherits(sf, "sf")) {
geojsonsf::sf_geojson(sf, simplify = FALSE)
} else {
json <- geojsonsf::sfc_geojson(sf)
paste0("{\"type\":\"GeometryCollection\",\"geometries\":[",
paste(json, collapse = ","),
"]}")
}
if (file) {
path <- tempfile(fileext = ".geojson")
writeLines(js, con = path)
js <- path
}
structure(js, crs = crs)
}
sp_to_tempfile <- function(obj) {
obj <- sf::st_as_sf(sp_to_spdf(obj))
path <- tempfile(fileext = ".geojson")
sf::st_write(obj, path, driver = "GeoJSON", quiet = TRUE, delete_dsn = TRUE)
normalizePath(path, winslash = "/", mustWork = TRUE)
}
sp_to_spdf <- function(obj) {
non_df_classes <- c("SpatialLines", "SpatialPolygons", "SpatialPoints")
cls <- inherits(obj, non_df_classes, which = TRUE)
if (!any(cls)) {
return(obj)
}
as(obj, paste0(non_df_classes[as.logical(cls)], "DataFrame"))
}
#' Check the system mapshaper
#'
#' @param command either "mapshaper-xl" (default) or "mapshaper"
#' @param verbose Print a message stating mapshaper's current version? Default `TRUE`
#'
#' @return character path to mapshaper executable if appropriate version is installed, otherwise throws an error
#' @export
check_sys_mapshaper <- function(command = "mapshaper-xl", verbose = TRUE) {
if (!command %in% c("mapshaper-xl", "mapshaper")) {
stop("command must be one of 'mapshaper-xl' or 'mapshaper'", call. = FALSE)
}
ms_path <- sys_ms_path(command)
sys_ms_version <- package_version(sys_ms_version())
min_ms_version <- package_version(bundled_ms_version()) # Update when updating bundled mapshaper.js
if (sys_ms_version < min_ms_version) {
stop("You need to upgrade your system mapshaper library.\n",
"Update it with: 'npm update -g mapshaper")
}
if (verbose) {
message("mapshaper version ", sys_ms_version, " is installed and on your PATH")
}
ms_path
}
sys_ms_path <- function(command) {
err_msg <- paste0("The mapshaper node library must be installed and on your PATH.\n",
"Install node.js (https://nodejs.org/en/) and then install mapshaper with:\n",
" npm install -g mapshaper")
ms_path <- Sys.which(command)
if (!nzchar(ms_path)) {
# try to find it:
if (nzchar(Sys.which("npm"))) {
npm_prefix <- system2("npm", "get prefix", stdout = TRUE)
ms_path <- file.path(npm_prefix, "bin", command)
if (!file.exists(ms_path)) stop(err_msg, call. = FALSE)
} else {
stop(err_msg, call. = FALSE)
}
}
ms_path
}
sys_ms_version <- function() {
system2(sys_ms_path("mapshaper"), "--version", stdout = TRUE)
}
bundled_ms_version <- function() {
# ms <- ms_make_ctx()
# ms$get("mapshaper.internal.VERSION")
"0.6.25"
}
ms_compact <- function(l) Filter(Negate(is.null), l)
fc_command <- function() {
"geojson-type=FeatureCollection"
}
class_geo_json <- function(x) {
if (is.null(x)) {
warning("The command returned an empty response. Please check your inputs", call. = FALSE)
x <- list()
}
if (is.raw(x)) {
x <- rawToChar(x)
}
structure(x, class = c("geojson", "json"))
}
check_character_input <- function(x) {
## Collapse to character vector of length one if many lines (e.g., if used readLines)
if (length(x) > 1) {
x <- paste0(x, collapse = "")
}
if (!jsonify::validate_json(x)) stop("Input is not valid geojson")
x
}
## Convert empty curly braces that come out of V8 to NA (that is what they go in as)
curly_brace_na <- function(x) {
UseMethod("curly_brace_na")
}
curly_brace_na.data.frame <- function(x) {
chr_or_factor <- vapply(x, inherits, c("character", "factor"), FUN.VALUE = logical(1))
if (any(chr_or_factor)) {
x[, chr_or_factor][x[, chr_or_factor] == "{ }"] <- NA
}
x
}
curly_brace_na.Spatial <- function(x) {
x@data <- curly_brace_na(x@data)
x
}
# This method basically just removes the sf class and then
# restores it after the data.frame method does its work, because
# the sf column is 'sticky' with `[`.sf methods, so would be
# included in the { } substitution if the sf class was kept
curly_brace_na.sf <- function(x) {
sf_col <- attr(x, "sf_column")
class(x) <- setdiff(class(x), "sf")
x <- curly_brace_na(x)
sf::st_as_sf(x, sf_column_name = sf_col)
}
col_classes <- function(df) {
classes <- lapply(df, function(x) {
out <- list()
if (inherits(x, "POSIXlt")) {
stop("POSIXlt classes not supported. Please convert to POSIXct", call. = FALSE)
}
out$class <- class(x)
if (is.factor(x)) {
out$levels <- levels(x)
if (is.ordered(x)) {
out$ordered <- TRUE
} else {
out$ordered <- FALSE
}
}
out
})
classes
}
restore_classes <- function(df, classes) {
in_classes <- lapply(df, class)
keep_in_both <- intersect(names(in_classes), names(classes))
in_classes <- in_classes[keep_in_both]
class_matches <- vapply(names(in_classes), function(n) {
if ("sfc" %in% classes[[n]]$class) return(TRUE)
isTRUE(all.equal(classes[[n]]$class, in_classes[[n]]))
}, FUN.VALUE = logical(1))
mismatches <- which(!class_matches)
if (length(mismatches) == 0) return(df)
for (n in names(mismatches)) {
cls <- classes[[n]]$class
if ("factor" %in% cls) {
df[[n]] <- factor(df[[n]], levels = classes[[n]]$levels,
ordered = classes[[n]]$ordered)
} else if (!"units" %in% cls) { # Skip units columns... TODO: Fix units parsing on return
as_fun <- paste0("as.", cls[1])
tryCatch({
df[[n]] <- eval(call(as_fun, df[[n]]))
}, error = function(e) {
warning("Could not convert column ", names(df)[n], " to class ",
cls, ". Returning as ", paste(in_classes[[n]], collapse = ", "))
}
)
}
}
df
}
stop_for_old_v8 <- function() {
if (v8_version() < "6") {
# nocov start
stop(
"Warning: v8 Engine is version ", V8::engine_info()[["version"]],
" but version >=6 is required for this function. See",
" https://github.com/jeroen/V8 for help installing a modern version",
" of v8 on your operating system.")
}
# nocov end
}
v8_version <- function() {
V8::engine_info()[["numeric_version"]]
}
temp_geojson <- function() {
# This option is really just to allow testing strange paths like #107
tmpdir <- getOption("ms_tempdir", default = tempdir())
dir.create(tmpdir, showWarnings = FALSE)
normalizePath(tempfile(
tmpdir = tmpdir,
fileext = ".geojson"
), mustWork = FALSE)
}
upkeep_bullets <- function() "Update bundled mapshaper node library."
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.