R/utils.R

In ateucher/rmapshaper: Client for 'mapshaper' for 'Geospatial' Operations

#' 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."