diff --git a/DESCRIPTION b/DESCRIPTION index 01eb9b0..8641863 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,16 +1,17 @@ Package: ursa Type: Package Title: Non-Interactive Spatial Tools for Raster Processing and Visualization -Version: 3.9.11 +Version: 3.10.1 Authors@R: person(given="Nikita",family="Platonov",role=c("aut","cre"),email="platonov@sevin.ru",comment=c(ORCID="0000-0001-7196-7882")) Author: Nikita Platonov [aut, cre] () Maintainer: Nikita Platonov -Description: S3 classes and methods for manipulation with georeferenced raster data: reading/writing, processing, multi-panel visualization. SWU. +Description: S3 classes and methods for manipulation with georeferenced raster data: reading/writing, processing, multi-panel visualization. License: GPL (>= 2) URL: https://github.com/nplatonov/ursa BugReports: https://github.com/nplatonov/ursa/issues Depends: R (>= 4.1.0) -Imports: utils, graphics, grDevices, stats, rgdal, png, jpeg -Suggests: jsonlite, proj4, sf (>= 0.6-1), raster, ncdf4, locfit, knitr, rmarkdown, tcltk, sp, methods, fasterize, IRdisplay, caTools, shiny, rgeos, tools, webp, htmlwidgets, htmltools, leaflet, leafem, leafpop, RColorBrewer, ragg, widgetframe, geojsonsf (>= 2.0.0), leaflet.providers, magick, terra, stars, vapour, sys, RSQLite +Imports: utils, graphics, grDevices, stats, sf (>= 0.6-1), png +Suggests: jsonlite, proj4, raster, ncdf4, locfit, knitr, rmarkdown, tcltk, sp, methods, fasterize, IRdisplay, caTools, shiny, tools, jpeg, webp, htmlwidgets, htmltools, leaflet, leafem, leafpop, RColorBrewer, ragg, widgetframe, geojsonsf (>= 2.0.0), leaflet.providers, magick, terra, stars, vapour, gdalraster, sys, RSQLite NeedsCompilation: yes ByteCompile: no +RoxygenNote: 7.2.3 diff --git a/NEWS.md b/NEWS.md index 7baa98f..a979422 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -2023-08-24 +2023-10-06 -### version 3.9.11 +### Version 3.10.1 + +- Packages **`rgdal`** and **`jpeg`** are removed from ‘Imports’. + +- Package **`jpeg`** is added to ‘Suggests’ (from ‘Imports’). + +- Package **`sf`** is removed from ‘Suggests’. + +- Package **`sf`** is added to ‘Imports’ (from ‘Suggests’). + +- Package **`gdalraster`** is added to ‘Suggests’ for experimental + purposes with partial raster reading. + +- Coastline is updated to version 2023-10-06T03:39. + +### Version 3.10 (interim) + +- MAJOR: packages **`rgdal`** and **`rgeos`** are rejected. + +### Version 3.9.11 - Repaired parsing of Nominatim responses. @@ -18,7 +37,7 @@ - Coastline is updated to version 2023-08-24T03:31. -### version 3.9.10 +### Version 3.9.10 - Foreign functions are symbolic instead of character after [R-devel BUG FIXES @@ -26,7 +45,7 @@ - Coastline is updated to version 2023-03-23T05:08. -### version 3.9.9 +### Version 3.9.9 - Added `quantile_global()`, `quantile_band()` and `quantile_local` functions based on `stats::quantile()`. @@ -37,7 +56,7 @@ development purpose. New function `as_stars()` creates object of class `stars` without **`stars`** package. -### version 3.9.8 +### Version 3.9.8 - Minor changes in `ursa.c` file for removing warnings during `r-devel-linux` compilation (`-Wstrict-prototypes`). @@ -50,7 +69,7 @@ - Coastline is updated to version 2022-11-16T04:45. -### version 3.9.7 +### Version 3.9.7 - New function `palettize()` as a wrapper `ursa_colortable(colorize(...))`. @@ -64,7 +83,7 @@ - New function `spatial_levelsplit()` trasforms nested polygons (e.g., polygonized isolines) to intervaled non-overlapped polygons. -### version 3.9.6 +### Version 3.9.6 - Package **`magick`** is added as suggested and used for color depth decreasing and in SVG whitespace clipping. @@ -82,7 +101,7 @@ - Coastline is updated to version 2022-03-07T04:39. -### version 3.9.5 +### Version 3.9.5 - Test building for development R 4.2.0. @@ -104,11 +123,11 @@ - New coersion (yet simplified) from `SpatRaster` class (package **terra**). -### version 3.9.4 +### Version 3.9.4 - Fixed example of `segmentize()` for non-Windows systems. -### version 3.9.3 +### Version 3.9.3 - Test building for R 4.1.0. @@ -134,7 +153,7 @@ - Coastline is updated to version 2021-05-20T05:37. -### version 3.9.2 +### Version 3.9.2 - Argument `expand` in `regrid()` now supports length 1 or 2 (or, coerced to length 2). Grid expansion is proportional to the side of @@ -147,7 +166,7 @@ - Improved handling for systems with unsupported “cairo” graphic system. -### version 3.9.1 +### Version 3.9.1 - Consistence with imported package **sp** (>=1.4-4) and suggested package **`sf`** (>=0.9-6) is in progress with focus to @@ -166,7 +185,7 @@ - Coastline is updated to version 2020-11-08T06:14 -### version 3.9 (interim) +### Version 3.9 (interim) - MAJOR: Field `$proj4` in `ursaGrid` objects is renamed to `$crs` due to activity with PROJ library, but **`ursa`** internally still @@ -174,7 +193,7 @@ be extracted or replaced by `ursa_crs()` (or `ursa_proj4()`, synonym to `ursa_crs()`) functions. -### version 3.8.20 +### Version 3.8.20 - Consistence with imported package **sp** (>=1.4-0) and suggested package **`sf`** (>=0.9-3) is in progress. @@ -204,18 +223,18 @@ - In `allocate()` added argument `resetGrid` with default value `FALSE` for resetting session grid before raster formation. -### version 3.8.19 +### Version 3.8.19 - Minor adjustments for timing of examples. -### version 3.8.18 +### Version 3.8.18 - `spatial_write()`: fixed deprecated (**`sf`** >= 0.9-0) argument `update`->`append` in suggested `sf::sf_write()`. - Re-check “don’t test” examples. -### version 3.8.17 +### Version 3.8.17 - Fixed for suggested package **`proj4`** (>=1.0.10). @@ -226,7 +245,7 @@ - Added argument `title` in function `print()` for objects of class `ursaRaster` for optional header printing. -### version 3.8.16 +### Version 3.8.16 - C-level: `memcpy` is replaced by `memmove` for overlapped memory areas. @@ -249,13 +268,13 @@ - Coastline is updated to version 2020-01-09T05:30 -### version 3.8.15 +### Version 3.8.15 - Fixed behaviour for using in rmarkdown for self-contained documents - Path to R is taken from `R.home("bin")` -### version 3.8.14 +### Version 3.8.14 - Fixed appeared “length > 1 in coercion to logical” in examples during CRAN check. @@ -279,7 +298,7 @@ - Coastline is updated to version 2019-09-21T05:39. -### version 3.8.13 +### Version 3.8.13 - R function are used for reading of large binary files, if their size overflows ‘long’ capacity. @@ -300,7 +319,7 @@ - Coastline is updated to version 2018-12-13 09:34. -### version 3.8.12 +### Version 3.8.12 - Default style for web basemaps is OSM Mapnik tiles insead of OSM static map. @@ -313,7 +332,7 @@ - Coastline is updated to version 2018-11-17 09:50. -### version 3.8.11 +### Version 3.8.11 - Package **tools** is added as *Suggested* for MD5 manipulations. @@ -334,7 +353,7 @@ session. Now, figures are opened outsize of GUI, by default. Use `session_pngviewer(FALSE)` for restoring of previous behaviour. -### version 3.8.10 +### Version 3.8.10 - Forced UTF-8 encoding for non-shapefiles for “sp” engine @@ -344,7 +363,7 @@ - Accepting `sf::st_set_geometry(x,NULL)` for extracting `spatial_data()` of `sf` objects -### version 3.8.9 +### Version 3.8.9 - Version 3.8.8 is removed from CRAN @@ -356,7 +375,7 @@ - Added recipe to use visualization in **shiny** (`imageOutput`/`renderImage`) -### version 3.8.8 +### Version 3.8.8 - Initial submission to CRAN @@ -374,14 +393,14 @@ Swetlana Herbrandt review). Packages `caTools`, `ggmap` are added as ‘Suggested’ for running of examples. -### version 3.8.7 +### Version 3.8.7 - Support importing of 3-dimensional ‘[stars](https://github.com/r-spatial/stars)’ arrays - Improvement of character encoding for attributes of spatial objects -### version 3.8.6 +### Version 3.8.6 - Coastline is updated to version 2018-03-27 09:31 @@ -391,7 +410,7 @@ - Package `fasterize` is suggested. Version of suggested package `sf` should be `>=0.6-1`. -### version 3.8.5 +### Version 3.8.5 - Imporing results of `sf::gdal_read`. @@ -406,7 +425,7 @@ - Coastline is updated 2018-03-07 -### version 3.8.4 +### Version 3.8.4 - Added argument `coords` for function `allocate`. @@ -421,13 +440,13 @@ - In `panel_coastline` improved detection of polygons’ coodrinates spreading in result of reprojection -### version 3.8-3 +### Version 3.8-3 - Visualization output is included to R-markdown document and R-Jupyter code without additional controls. Currently, some outputs are not supported (e.g., bookdown::gitbook) -### version 3.8-2 +### Version 3.8-2 - Changed registration of native routines. @@ -447,7 +466,7 @@ - In `read_envi` and `open_envi` added argument `cache` to use cache for compressed files. -### version 3.8-1 +### Version 3.8-1 - Internal land polygons (coastline) data are replaced from GSHHG to OSM. Function `update_coastline` is added to update coastline data @@ -463,7 +482,7 @@ from non-raster spatial objects: simple features (package **sf**) and Spatial abstract class (package **sp**). -### version 3.7-19 +### Version 3.7-19 - Argument ‘attr’ is replaced to ‘field’ in internal functions `.spatialize` and `.glance`. @@ -476,7 +495,7 @@ - in `polygonize` added choice of “engine” by means applying functions from either **sp** or **sf** packages. -### version 3.7-18 +### Version 3.7-18 - Improved consistence beetween ‘dim’ interity in non-public `.regrid()` @@ -486,11 +505,11 @@ - Back to patch of failure with ‘rgdal’ of Unix build machine at r-forge -### version 3.7-17 +### Version 3.7-17 - Correction for bounding around 180 degree longitude -### version 3.7-16 +### Version 3.7-16 - minor improvement to spatial allocation of vector objects with crossing of 180 degree longitude @@ -499,7 +518,7 @@ - background for future functionality -### version 3.7-15 +### Version 3.7-15 - added possibility of image annotation; argument ‘label’ in ‘panel\_annotation’ can be object of class ‘array’ @@ -509,11 +528,11 @@ - ‘ggmap’, ‘foreign’ are removed from the list of suggested packages; ‘ncdf4’ is added to the list of suggested packages. -### version 3.7-14 +### Version 3.7-14 - fixed export to Raster(Layer|Brick|Stack) with NA nodata -### version 3.7-13 +### Version 3.7-13 - gentle requirements to “chessboard” grid in ‘panel\_new()’ @@ -521,27 +540,27 @@ - in suggestion, sf (>= 0.5-0) -### version 3.7-12 +### Version 3.7-12 - Minor changes for geocoded glance() -### version 3.7-11 +### Version 3.7-11 - ‘nominatim’ geocoding for 180-longitute-objects is more correct, but traffic is higher - alternate geocoding service in the case of base one failure -### version 3.7-10 +### Version 3.7-10 - Adaptation glance() for condition if argument “dsn” is “point” ‘c(lon,lat)’ and “boundary” ‘c(minx,miny,maxx,maxy)’ -### version 3.7-9 +### Version 3.7-9 - Vectors without data table - fixed -### version 3.7-8 +### Version 3.7-8 - Bypass for ‘rgdal’ usage diring examples on r-forge UNIX building machine. E.g.: Error in dyn.load(file, DLLpath = DLLpath, …) : @@ -549,22 +568,22 @@ ‘/home/rforge/lib/R/3.4/rgdal/libs/rgdal.so’: libgdal.so.1: cannot open shared object file: No such file or directory -### version 3.7-7 +### Version 3.7-7 - Better matching for floating-point coordinates -### version 3.7-6 +### Version 3.7-6 - Minor fixes for categories after resample - ‘glance()’ is recoded -### version 3.7-5 +### Version 3.7-5 - Adaptation for R-exts’ “5.4 Registering native routines” for R-3.4.0. -### version 3.7-4 +### Version 3.7-4 - Non-ascii for geocoding in ‘glance’ @@ -572,11 +591,11 @@ - Added package ‘jpeg’ in the category ‘Imported’. -### version 3.7-3 +### Version 3.7-3 - Non-ascii for geocoding in ‘glance’ -### version 3.7-2 +### Version 3.7-2 - Introduce geocode to ‘glance’. There is no relation between data and geocoded place. @@ -595,23 +614,23 @@ - Rename ‘panel\_gridline’ to ‘panel\_graticule’. -### version 3.7-1 +### Version 3.7-1 - Public wrapper ‘glance()’ for non-public ‘.glance()’: quick-look of GIS raster and vector data -### version 3.6-3 +### Version 3.6-3 - Documentation for ‘ursaProgressBar’ -### version 3.6-2 +### Version 3.6-2 - Added argument “…” to function ‘read\_gdal’. Now, if ‘as.ursa(uri)’ or ‘display(uri)’, then additional arguments can be passed to ‘download.file’. For example, if you need ‘mode=“wb”’ or ignore certificate for HTTPS -### version 3.6-1 +### Version 3.6-1 - Added ‘session\_pngviewer()’ and ‘session\_tempdir()’ to follow CRAN policy. If “Rscript”, then external software is used to open PNG; @@ -619,7 +638,7 @@ CMD BATCH”, no external software for PNG; ‘tempdir()’ is used to write files -### version 3.5-2 +### Version 3.5-2 - Initial submission to R-Forge diff --git a/R/_RogerBivand.R b/R/_RogerBivand.R new file mode 100644 index 0000000..9891718 --- /dev/null +++ b/R/_RogerBivand.R @@ -0,0 +1,533 @@ +'.open_rgdal' <- function(fname,engine="sf",verbose=FALSE) { + .rgdal_requireNamespace() + # if (verbose) + # .elapsedTime("rgdal has been loaded") + opW <- options(warn=0-!verbose,show.error.messages=TRUE) ## to prevent 'GeoTransform values not available' + on.exit(options(opW)) + if (devel <- F) { + # a <- vapour:::gdalinfo_internal(fname,json=TRUE,stats=FALSE) + # a <- jsonlite::fromJSON(a) + } + a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE + ,returnColorTable=TRUE,returnCategoryNames=TRUE),silent=TRUE) + if (inherits(a,"try-error")) { + fname <- normalizePath(fname) + a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE + ,returnColorTable=TRUE,returnCategoryNames=TRUE),silent=TRUE) + if (inherits(a,"try-error")) { + if ((TRUE)||(!.isPackageInUse())) + cat(geterrmessage()) + # * using R version 3.4.0 Patched (2017-05-16 r72684) + # * using platform: x86_64-pc-linux-gnu (64-bit) + # > ### Name: open_gdal + # > ### Title: Open GDAL file + # > ### Aliases: open_gdal + # > ### Keywords: connection + # > + # > ### ** Examples + # > + # > session_grid(NULL) + # > fname1 <- system.file("pictures/cea.tif",package="rgdal") + # > message(fname1) + # /tmp/RtmpdrKt9J/RLIBS_310d3548ed74/rgdal/pictures/cea.tif + # > a1 <- open_gdal(fname1) + # > print(a1) + # NULL + # > print(a1[]) + # NULL + # > close(a1) + # Error in UseMethod("close") : + # no applicable method for 'close' applied to an object of class "NULL" + # Calls: close + ## 20170529 patch for failure with 'rgdal' at r-forge + if (.Platform$OS.type=="unix"){ + message(paste("Unable to open GDAL file. Failure for" + ,"R-forge buildig machine (Unix OS) since May 2017")) + if ((!.lgrep("\\.(rds)$",fname))&&(file.exists(fname))) {## 20170529 + return(ursa_new()) + } + } + return(NULL) + } + } + a1 <- as.numeric(a) + g1 <- regrid() + g1$rows <- as.integer(a1[1]) + g1$columns <- as.integer(a1[2]) + nl <- as.integer(a1[3]) + g1$minx <- a1[4] + g1$miny <- a1[5] + g1$resx <- a1[6] + g1$resy <- a1[7] + g1$maxx <- with(g1,minx+resx*columns) + g1$maxy <- with(g1,miny+resy*rows) + g1$crs <- attr(a,"projection") + if (is.na(g1$crs)) + g1$crs <- "" + b1 <- .grep("band",attr(a,"mdata"),value=TRUE) + patt <- "^Band_(\\d+)=\\t*(.+)$" + bname <- .gsub(patt,"\\2",b1) + bname[as.integer(.gsub(patt,"\\1",b1))] <- bname + c1 <- attr(a,"df") + hasndv <- unique(c1$hasNoDataValue) + nodata <- unique(c1$NoDataValue) + nodata <- if ((length(hasndv)==1)&&(length(nodata)==1)&&(hasndv)) nodata + else NA + # print(length(attr(a,"ColorTable"))) + ct <- attr(a,"ColorTable") + ca <- attr(a,"CATlist") + if ((length(ct))&&(!is.null(ct[[1]]))) { + ct <- ct[[1]] + if ((length(ca))&&(!is.null(ca[[1]]))) { + nval <- ca[[1]] + ct <- ct[seq(length(nval))] + } + else + nval <- NULL #seq(length(ct)) + names(ct) <- nval + } + else if ((length(ca))&&(!is.null(ca[[1]]))) { + nval <- ca[[1]] + ct <- rep(NA,length(nval)) + names(ct) <- nval + } + else + ct <- character() + class(ct) <- "ursaColorTable" + dset <- methods::new("GDALReadOnlyDataset",fname) + dima <- dim(dset) + if (length(dima)==2) + dima <- c(dima,1L) + if (!length(bname)) { + bname <- paste("Band",if (length(dima)==3) seq(dima[3]) else 1L) + } + session_grid(g1) + res <- .raster.skeleton() + res$dim <- c(dima[1]*dima[2],dima[3]) + con <- .con.skeleton() + con$driver <- "RGDAL" + con$samples <- g1$columns + con$lines <- g1$rows + con$bands <- length(bname) + con$indexC <- seq(g1$columns) + con$indexR <- seq(g1$rows) + con$indexZ <- seq_along(bname) + con$seek <- FALSE + con$fname <- fname + con$handle <- dset + res$con <- con + ursa_grid(res) <- g1 + ursa_colortable(res) <- ct + class(res$value) <- ifelse(length(ct),"ursaCategory","ursaNumeric") + ursa_nodata(res) <- nodata + names(res) <- bname + res +} +'.shp.read' <- function(fname,reproject=TRUE,encoding="1251",resetGrid=FALSE + ,verbose=0L,...) +{ + ## b <- sf::st_read("gde-1-1-15.shp",quiet=TRUE) + ## b <- sf::st_transform(b,ursa_proj(a)) + # print(fname) + .rgdal_requireNamespace() + if (resetGrid) + reproject <- FALSE + # require(methods) + if (.lgrep("\\.zip$",basename(fname))) + fname <- .gsub("\\.zip$","",fname) + fpath <- dirname(fname) + z <- file.path(fpath,paste0(.shp.layer(fname),".zip")) # ,. + if (!file.exists(z)) + z <- file.path(fpath,paste0(.shp.layer(fname),".shp.zip")) + if (file.exists(z)) + { + a <- utils::unzip(z,exdir=fpath,junkpaths=TRUE) + on.exit(file.remove(a)) + } + if (verbose>1) + .elapsedTime("readOGR:start") + cpgname <- file.path(fpath,paste0(.shp.layer(fname),".cpg")) + e_opt <- if (file.exists(cpgname)) readLines(cpgname,warn=FALSE) else "" + i_opt <- if (grepl("UTF(-)*8",e_opt)) TRUE else FALSE + # print(data.frame(e_opt=e_opt,i_opt=i_opt)) + opW <- options(warn=0) + res <- rgdal::readOGR(.shp.file(fname),.shp.layer(fname),pointDropZ=TRUE + ,encoding=e_opt,use_iconv=i_opt + ,verbose=as.logical(verbose),...) + options(opW) + if (verbose>1) + .elapsedTime("readOGR:finish") + proj4 <- session_grid()$crs + if ((reproject)&&(nchar(proj4))&&(!is.na(sp::proj4string(res)))) { + if (verbose>1) + .elapsedTime("spTransform:start") + res <- sp::spTransform(res,proj4) + if (verbose>1) + .elapsedTime("spTransform:finish") + } + if (resetGrid) + session_grid(NULL) + res +} +'.shp.write' <- function(obj,fname,compress=FALSE,zip=NULL) +{ + requireNamespace("methods",quietly=.isPackageInUse()) + ## Error: inherits(obj, "Spatial") is not TRUE + # require("methods") + .rgdal_requireNamespace() + # suppressMessages(require(rgdal)) ## should be already loaded + if (!is.null(zip)) + compress <- zip + fpath <- dirname(fname) + layer <- .shp.layer(fname) + suppressWarnings({ + first <- TRUE + op <- options(warn=2) + repeat({ + if (!file.exists(.shp.file(fname))) + break + if (file.remove(.shp.file(fname))) + break + if (first) { + cat(paste("Waiting for permitted writting",.sQuote(basename(fname)))) + first <- FALSE + } + cat(".") + Sys.sleep(1) + }) + if (!first) + cat(" ok!\n") + options(op) + }) + opW <- options(warn=0) + rgdal::writeOGR(obj,fpath,layer,driver="ESRI Shapefile" + # ,encoding=encoding + ,overwrite=TRUE) + options(opW) + writeLines("1251",file.path(fpath,paste0(layer,".cpg"))) + if (!compress) + return(NULL) + f <- .dir(path=dirname(fname) + ,pattern=paste0("^",.shp.layer(fname),"\\.(cpg|dbf|prj|qpj|shp|shx)$") + ,full.names=TRUE) + z <- paste0(.shp.file(fname),".zip") + opW <- options(warn=-1) + first <- TRUE + while(file.exists(z)) { + if (file.remove(z)) + break + if (first) { + cat(paste("Waiting for deleting",.sQuote(z))) + first <- FALSE + } + cat(".") + Sys.sleep(1) + } + if (!first) + cat(" ok!\n") + options(opW) + utils::zip(z,f,flags="-qm9j") ## verbose output ## 'myzip(z,f,keys="-m -9 -j")' +} +'.rgdal_close_Transient' <- function(con,bname) { + .rgdal_requireNamespace() + dr <- rgdal::getDriverName(rgdal::getDriver(con$handle)) + op <- NULL + if (dr=="GTiff") + op=c(paste0("COMPRESS=",c("DEFLATE","ZSTD","LZW")[1]) + ,paste0("PREDICTOR=",ifelse(con$mode=="numeric",3,2)) + ,"TILED=NO" + ,"ZLEVEL=9" + ,"ZSTD_LEVEL=9" + ,paste0("INTERLEAVE=",switch(con$interleave,bil="PIXEL","BAND"))) + else if (dr=="HFA") { + op=c("COMPRESSED=YES") + } + else if (dr=="ENVI") { + # print(con$interleave) + op <- paste0("INTERLEAVE=",toupper(con$interleave)) + } + rgdal::saveDataset(con$handle,con$fname,options=op) + # rgdal::closeDataset(con$handle) + rgdal::GDAL.close(con$handle) + con$handle <- NA + # if (FALSE) { + standardname <- paste("Band",seq_along(bname)) + if ((TRUE)&&(!is.na(bname[1]))&&(!identical(standardname,bname))) { + metafile <- paste0(con$fname,".aux.xml") + if (!is.na(con$posZ[1])) + bname <- bname[con$posZ] + added3 <- rep("",length(bname)) + for (i in seq_along(bname)) + added3[i] <- paste0(" ",bname[i],"") + added2 <- c(" ",added3," ") + added1 <- c("",added2,"") + if (!file.exists(metafile)) { + Fmeta <- file(metafile,"wt") + writeLines(added1,Fmeta) + close(Fmeta) + } + else { + meta <- readLines(metafile) + # i1 <- .grep("",meta) + ##~ i2 <- .grep("",meta) + ##~ i2 <- i2[i2>i1][1] + i3 <- .grep("",meta) + metaBefore <- meta[1:(i3-1)] + metaAfter <- meta[i3:length(meta)] + writeLines(c(metaBefore,added2,metaAfter),metafile) + # op <- options(warn=0) + # warning("Band names was not written. TODO insert lines to *.aux.xml") + # options(op) + } + } + invisible(NULL) +} +'.rgdal_close_ReadOnly' <- function(con) { + .rgdal_requireNamespace() + # print(class(con$handle)) + # rgdal::closeDataset(con$handle) + rgdal::GDAL.close(con$handle) +} +'.read_gdal' <- function(fname,fileout=NULL,verbose=!FALSE,...) { + if (!is.character(fname)) + return(NULL) + # suppressMessages(require("rgdal")) + .rgdal_requireNamespace() + if (verbose) + .elapsedTime("rgdal has been loaded") + # print(geterrmessage()) + op <- options(warn=0-!verbose) + a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE + ,returnColorTable=TRUE,returnCategoryNames=TRUE)) + options(op) + if (inherits(a,"try-error")) { + fname <- normalizePath(fname) + op <- options(warn=0-!verbose) + a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE + ,returnColorTable=TRUE,returnCategoryNames=TRUE)) + options(op) + if (verbose) + str(a) + if (inherits(a,"try-error")) { + if (verbose) { + message("It looks like file ",.dQuote(fname) + ," is not found or not GDAL-recognized") + } + return(NULL) + } + } + a1 <- as.numeric(a) + g1 <- regrid() + g1$rows <- as.integer(a1[1]) + g1$columns <- as.integer(a1[2]) + nl <- as.integer(a1[3]) + g1$minx <- a1[4] + g1$miny <- a1[5] + g1$resx <- a1[6] + g1$resy <- a1[7] + g1$maxx <- with(g1,minx+resx*columns) + g1$maxy <- with(g1,miny+resy*rows) + g1$crs <- attr(a,"projection") + if (is.na(g1$crs)) + g1$crs <- "" + b1 <- attr(a,"mdata") + ln <- .gsub("^Band_\\d+=\\t*(.+)$","\\1",.grep("band",b1,value=TRUE)) + c1 <- attr(a,"df") + hasndv <- unique(c1$hasNoDataValue) + nodata <- unique(c1$NoDataValue) + nodata <- if ((length(hasndv)==1)&&(length(nodata)==1)&&(hasndv)) nodata + else NA + # print(length(attr(a,"ColorTable"))) + ct <- attr(a,"ColorTable") + if ((length(ct))&&(!is.null(ct[[1]]))) { + ct <- ct[[1]] + ca <- attr(a,"CATlist") + if ((length(ca))&&(!is.null(ca[[1]]))) { + nval <- ca[[1]] + ct <- ct[seq(length(nval))] + } + else + nval <- NULL #seq(length(ct)) + names(ct) <- nval + } + else + ct <- character() + class(ct) <- "ursaColorTable" + session_grid(g1) + dset <- methods::new("GDALReadOnlyDataset",fname) + if (!length(ln)) { + dima <- dim(dset) + ln <- paste("Band",if (length(dima)==3) seq(dima[3]) else 1L) + } + if (!is.character(fileout)) { + val <- rgdal::getRasterData(dset) + dima <- dim(val) + if (length(dima)==2) + dim(val) <- c(dima,1L) + val <- val[,rev(seq(dim(val)[2])),,drop=FALSE] ## added 20160330 + res <- as.ursa(value=val,bandname=ln,ignorevalue=nodata) + } + else { + res <- create_envi(fileout,bandname=ln,ignorevalue=nodata,...) + for (i in seq_along(ln)) + { + res[i]$value[] <- rgdal::getRasterData(dset,band=i) + } + } + rgdal::closeDataset(dset) + res$colortable <- ct + class(res$value) <- ifelse(length(ct),"ursaCategory","ursaNumeric") + res +} +'.rgdal_goodies' <- function() { + # if (!length(obj$colortable)) { + # rgdal::setCPLConfigOption("GDAL_PAM_ENABLED","FALSE") ## doesnt work 20180327 + # } + invisible(NULL) +} +'.rgdal_prepare_con' <- function(x) { + .rgdal_requireNamespace() + opW <- options(warn=ifelse(.isPackageInUse(),0,1)) # + rgdal::GDALcall(x$con$handle,"SetProject",x$grid$crs) + options(opW) + rgdal::GDALcall(x$con$handle,"SetGeoTransform" + ,with(x$grid,c(minx,resx,0,maxy,0,-resy))) + nodata <- ursa_nodata(x) + ct <- ursa_colortable(x) + isCT <- (nband(x)==1)&&(length(ct)>0) + hasColor <- (isCT)&&(all(!is.na(ct))) + hasNames <- (isCT)&&(all(!is.na(names(ct)))) + # print(c(has_nodata=!is.na(nodata),isCT=isCT,hasColor=hasColor,hasNames=hasNames)) + if (any(!is.na(nodata),isCT,hasColor,hasNames)) { + for (i in seq(nband(x))) { + bset <- methods::new("GDALRasterBand",x$con$handle,i) + if (!is.na(nodata)) + rgdal::GDALcall(bset,"SetNoDataValue",nodata) + if (hasColor) + rgdal::GDALcall(bset,"SetRasterColorTable",as.character(ct)) + if (hasNames) + rgdal::GDALcall(bset,"SetCategoryNames",names(ct)) + # if (isCT) + # rgdal::putRasterData(dset,as.array(colorize(obj[i]),flip=TRUE,drop=TRUE),band=i) + # else + # rgdal::putRasterData(dset,as.array(obj[i],flip=TRUE,drop=TRUE),band=i) + } + } + invisible(NULL) +} +'.rgdal_showWKT' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::showWKT(...) +} +'.rgdal_showP4' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::showP4(...) +} +'.rgdal_writeOGR' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::writeOGR(...) +} +'.rgdal_getRasterData' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::getRasterData(...) +} +'.rgdal_putRasterData' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::putRasterData(...) +} +'.rgdal_CRSargs' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::CRSargs(...) +} +'.rgdal_ogrListLayers' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::ogrListLayers(...) +} +'.rgdal_readOGR' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::readOGR(...) +} +'.rgdal_ogrInfo' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::ogrInfo(...) +} +'.rgdal_CRSargs' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::CRSargs(...) +} +'.rgdal_project' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgdal::project(...) +} +'.rgdal_requireNamespace' <- function() { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + requireNamespace("rgdal",quietly=.isPackageInUse()) +} +'.rgeos_requireNamespace' <- function() { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + requireNamespace("rgeos",quietly=.isPackageInUse()) +} +'.rgeos_readWKT' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::readWKT(...) +} +'.rgeos_gLength' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gLength(...) +} +'.rgeos_gIntersection' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gIntersection(...) +} +'.rgeos_gDifference' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gDifference(...) +} +'.rgeos_gSymdifference' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + .rgeos::gSymdifference(...) +} +'.rgeos_gBuffer' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gBuffer(...) +} +'.rgeos_gUnaryUnion' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gUnaryUnion(...) +} +'.rgeos_gUnion' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gUnion(...) +} +'.rgeos_gSimplify' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gSimplify(...) +} +'.rgeos_gIsValid' <- function(...) { + if (isTRUE(getOption("ursaPackageInUse"))) + .DeadEnd() + rgeos::gIsValid(...) +} diff --git a/R/_rename20a660d5.R b/R/_rename20a660d5.R index d4273d4..9cb17bc 100644 --- a/R/_rename20a660d5.R +++ b/R/_rename20a660d5.R @@ -33,6 +33,10 @@ src <- "crs==" dst <- "ZZZ==" } + else if (stage6 <- T) { + src <- ".DeadRoad" + dst <- ".DeadEnd" + } else { stop("please select stage") } diff --git a/R/classColorTable.R b/R/classColorTable.R index 46c1c61..7cb660f 100644 --- a/R/classColorTable.R +++ b/R/classColorTable.R @@ -23,11 +23,17 @@ if ((all("transparent" %in% x$fill))&&(length(x$name)==length(unique(x$border)))) { if (verbose) print("LINESTRING") - ind <- match(x$name,names(x$border)) - if (inherits(x$border,"ursaColorTable")) - return(x$border[ind]) - ret <- x$border[ind] - names(ret) <- x$name + if (is.null(names(x$border))) { + names(x$border) <- x$name + ret <- x$border + } + else { + ind <- match(x$name,names(x$border)) + if (inherits(x$border,"ursaColorTable")) + return(x$border[ind]) + ret <- x$border[ind] + names(ret) <- x$name + } class(ret) <- "ursaColorTable" return(ret) } diff --git a/R/classRaster.Extract.R b/R/classRaster.Extract.R index bc1f31e..fb2ccf2 100644 --- a/R/classRaster.Extract.R +++ b/R/classRaster.Extract.R @@ -130,6 +130,7 @@ res$con$compress <- 0L grid <- res$grid con <- res$con + indF <- length(con$fname) opW <- options(warn=-1) intOverflow <- is.na(with(con,samples*lines*bands*sizeof)) options(opW) @@ -170,36 +171,38 @@ } if ((missingJ)&&(missingI)) ## read full { - if (con$driver=="ENVI") { + if (con$driver %in% c("ENVI","EGDAL")) { n <- prod(with(con,samples*lines*bands)) xdim <- with(con,c(lines,samples,bands)) if ((con$seek)&&(con$interleave %in% c("bsq","bil"))&& (externalReading)&&(TRUE)) { seek(con,where=0L,origin="start",rw="r") if (con$interleave=="bsq") { - if (con$mode=="integer") + if (con$mode=="integer") { res$value <- with(con,.Cursa(C_readBsqBandInteger - ,fname=fname,dim=xdim,index=seq(bands),n=bands + ,fname=con$fname[indF],dim=xdim,index=seq(bands),n=bands ,datatype=datatype,swap=swap ,res=integer(bands*samples*lines)))$res + } else res$value <- with(con,.Cursa(C_readBsqBandDouble - ,fname=fname,dim=xdim,index=seq(bands),n=bands + ,fname=con$fname[indF],dim=xdim,index=seq(bands),n=bands ,datatype=datatype,swap=swap ,res=double(bands*samples*lines)))$res } else if (con$interleave=="bil") { if (con$mode=="integer") { res$value <- with(con,.Cursa(C_readBilLineInteger2 - ,fname=fname,dim=xdim,index=seq(lines),n=lines + ,fname=con$fname[indF],dim=xdim,index=seq(lines),n=lines ,datatype=datatype,swap=swap ,res=integer(bands*samples*lines)))$res } else { - res$value <- with(con,.Cursa(C_readBilLineDouble2,fname,dim=xdim - ,lines=seq(lines) - ,nline=lines,datatype=datatype,swap=swap - ,res=double(with(con,lines*samples*bands))))$res + res$value <- with(con,.Cursa(C_readBilLineDouble2 + ,con$fname[indF],dim=xdim + ,lines=seq(lines) + ,nline=lines,datatype=datatype,swap=swap + ,res=double(with(con,lines*samples*bands))))$res } } dim(res$value) <- with(con,c(samples,lines,bands)) @@ -226,13 +229,44 @@ ," incorrect interleave type") } } - else if (con$driver=="GDAL") { ## read full - res$value <- rgdal::getRasterData(con$handle) + else if (con$driver=="RGDAL") { ## read full + res$value <- .rgdal_getRasterData(con$handle) + dim(res$value) <- with(con,c(samples,lines,bands)) + } + else if (con$driver=="GDALRASTER") { ## read full + if (con$datatype %in% c(4,5)) + res$value <- array(NA_real_,dim=res$dim) + else + res$value <- array(NA_integer_,dim=res$dim) + if (verbose) + cat("read") + for (b2 in seq_len(con$bands)) { + if (verbose) + cat(".") + res$value[,b2] <- con$handle$read(band=b2 + ,xoff=0,yoff=0 + ,xsize=con$samples,ysize=con$lines + ,out_xsize=con$samples,out_ysize=con$lines + ) + } + if (verbose) + cat(" done!\n") + dim(res$value) <- with(con,c(samples,lines,bands)) + } + else if (con$driver=="SF") { ## read full + if (con$datatype %in% c(4,5)) { + res$value <- attr(sf::gdal_read(con$handle$filename,read_data=TRUE),"data") + attr(res$value,"units") <- NULL + } + else { + res$value <- as.integer(attr(sf::gdal_read(con$handle$filename + ,read_data=TRUE),"data")) + } dim(res$value) <- with(con,c(samples,lines,bands)) } else if (con$driver=="NCDF") { ## read full # stop("NCDF -- read full") - nc <- ncdf4::nc_open(con$fname) + nc <- ncdf4::nc_open(con$fname[indF]) varName <- con$handle flip <- attr(varName,"flip") permute <- attr(varName,"permute") @@ -331,7 +365,7 @@ minI <- min(i) toWarp <- with(con,(!is.na(indexR)[1])&&(length(indexR)!=lines)|| (!is.na(indexC)[1])&&(length(indexC)!=samples)) - if (con$driver=="ENVI") { + if (con$driver %in% c("ENVI","EGDAL")) { if (con$interleave=="bil") { if (externalReading) @@ -340,11 +374,11 @@ seek(con,where=0L,origin="start",rw="r") xdim <- with(con,c(lines,samples,bands)) if (con$mode=="integer") - val <- .Cursa(C_readBilBandInteger,con$fname,dim=xdim,index=i + val <- .Cursa(C_readBilBandInteger,con$fname[indF],dim=xdim,index=i ,n=nb,datatype=con$datatype,swap=con$swap ,res=integer(with(con,nb*samples*lines)))$res else { - val <- .Cursa(C_readBilBandDouble,con$fname,dim=xdim,index=i + val <- .Cursa(C_readBilBandDouble,con$fname[indF],dim=xdim,index=i ,n=nb,datatype=con$datatype,swap=con$swap ,res=double(with(con,nb*samples*lines)))$res } @@ -407,20 +441,19 @@ # val <- array(NA,dim=c(con$samples*nline,nb)) if ((externalReading)&&(TRUE)) { - # cat("isDll\n") if (con$seek) seek(con,where=0L,origin="start",rw="r") xdim <- with(con,c(lines,samples,bands)) # str(list(i=i,dim=xdim,nb=nb,fname=con$fname)) if (con$mode=="integer") { - val <- .Cursa(C_readBsqBandInteger,fname=con$fname,dim=xdim,index=i + val <- .Cursa(C_readBsqBandInteger,fname=con$fname[indF],dim=xdim,index=i ,n=nb,datatype=con$datatype,swap=con$swap ,res=integer(with(con,nb*samples*lines)))$res } else { - val <- .Cursa(C_readBsqBandDouble,fname=con$fname,dim=xdim,index=i + val <- .Cursa(C_readBsqBandDouble,fname=con$fname[indF],dim=xdim,index=i ,n=nb,datatype=con$datatype,swap=con$swap ,res=double(with(con,nb*samples*lines)))$res } @@ -460,8 +493,41 @@ stop("Error in input header file ",con$interleave ," incorrect interleave type") } - else if (con$driver=="GDAL") { ## read band - val <- rgdal::getRasterData(con$handle,band=i) + else if (con$driver=="RGDAL") { ## read band + val <- .rgdal_getRasterData(con$handle,band=i) + dim(val) <- with(con,c(samples,nline,nb)) + } + else if (con$driver=="GDALRASTER") { ## read band + if (con$datatype %in% c(4,5)) + val <- array(NA_real_,dim=c(res$dim[1],length(i))) + else + val <- array(NA_integer_,dim=c(res$dim[1],length(i))) + if (verbose) + cat("read chunk band") + for (b2 in seq_along(i)) { + if (verbose) + cat(".") + val[,b2] <- con$handle$read(band=i[b2] + ,xoff=0,yoff=0 + ,xsize=con$samples,ysize=con$lines + ,out_xsize=con$samples,out_ysize=con$lines + ) + } + if (verbose) + cat(" done!\n") + dim(val) <- with(con,c(samples,nline,nb)) + } + else if (con$driver=="SF") { ## read band + rasterio <- list(bands=i) + if (con$datatype %in% c(4,5)) { + val <- attr(sf::gdal_read(con$handle$filename,read_data=TRUE + ,RasterIO_parameters=rasterio),"data") + attr(val,"units") <- NULL + } + else { + val <- as.integer(attr(sf::gdal_read(con$handle$filename,read_data=TRUE + ,RasterIO_parameters=rasterio),"data")) + } dim(val) <- with(con,c(samples,nline,nb)) } else if (con$driver=="NCDF") { ## read band @@ -589,19 +655,19 @@ j <- as.integer(seq(min(j),max(j))) nline <- length(j) minJ <- (min(j)-1L)+min(con$indexR-1L) - if (con$driver %in% "ENVI") { + if (con$driver %in% c("ENVI","EGDAL")) { if (con$interleave=="bil") ##bil[col,band,row] -> R[col,row,band] { if ((externalReading)&&(TRUE)) { xdim <- with(con,c(lines,samples,bands)) if (con$mode=="integer") - val <- .Cursa(C_readBilLineInteger,con$fname,dim=xdim + val <- .Cursa(C_readBilLineInteger,con$fname[indF],dim=xdim ,lines=j+as.integer(min(con$indexR-1L)) ,nline=nline,datatype=con$datatype,swap=con$swap ,res=integer(with(con,nline*samples*bands)))$res else - val <- .Cursa(C_readBilLineDouble,con$fname,dim=xdim + val <- .Cursa(C_readBilLineDouble,con$fname[indF],dim=xdim ,lines=j+as.integer(min(con$indexR-1L)) ,nline=nline,datatype=con$datatype,swap=con$swap ,res=double(with(con,nline*samples*bands)))$res @@ -634,11 +700,11 @@ { xdim <- with(con,c(lines,samples,bands)) if (con$mode=="integer") - val <- .Cursa(C_readBsqLineInteger,con$fname,dim=xdim,lines=j + val <- .Cursa(C_readBsqLineInteger,con$fname[indF],dim=xdim,lines=j ,nline=nline,datatype=con$datatype,swap=con$swap ,res=integer(with(con,nline*samples*bands)))$res else - val <- .Cursa(C_readBsqLineDouble,con$fname,dim=xdim,lines=j + val <- .Cursa(C_readBsqLineDouble,con$fname[indF],dim=xdim,lines=j ,nline=nline,datatype=con$datatype,swap=con$swap ,res=double(with(con,nline*samples*bands)))$res } @@ -658,15 +724,54 @@ # val <- aperm(val,c(1,2,3)) } } - else if (con$driver=="GDAL") { ## read line + else if (con$driver=="RGDAL") { ## read line nline <- length(j) minJ <- (min(j)-1L)+min(con$indexR-1L) - val <- rgdal::getRasterData(con$handle,offset=c(minJ,0) + val <- .rgdal_getRasterData(con$handle,offset=c(minJ,0) ,region.dim=c(nline,con$samples)) dim(val) <- with(con,c(samples,nline,bands)) } + else if (con$driver=="GDALRASTER") { ## read line + nline <- length(j) + minJ <- (min(j)-1L)+min(con$indexR-1L) + if (con$datatype %in% c(4,5)) + val <- array(NA_real_,dim=c(con$samples*nline,res$dim[2])) + else + val <- array(NA_integer_,dim=c(con$samples*nline,res$dim[2])) + if (verbose) + cat("read chunk line") + for (b2 in seq_len(con$bands)) { + if (verbose) + cat(".") + val[,b2] <- con$handle$read(band=b2 + ,xoff=0,yoff=minJ + ,xsize=con$samples,ysize=nline + ,out_xsize=con$samples,out_ysize=nline + ) + } + if (verbose) + cat(" done!\n") + dim(val) <- with(con,c(samples,nline,bands)) + } + else if (con$driver=="SF") { ## read line + nline <- length(j) + minJ <- (min(j)-1L)+min(con$indexR-1L) + rasterio <- list(nXOff=1,nYOff=minJ+1L,nXSize=con$samples,nYSize=nline + # ,nBufXSize=2,nBufYSize=2 + ) + if (con$datatype %in% c(4,5)) { + val <- attr(sf::gdal_read(con$handle$filename,read_data=TRUE + ,RasterIO_parameters=rasterio),"data") + attr(val,"units") <- NULL + } + else { + val <- as.integer(attr(sf::gdal_read(con$handle$filename,read_data=TRUE + ,RasterIO_parameters=rasterio),"data")) + } + dim(val) <- with(con,c(samples,nline,bands)) + } else if (con$driver=="NCDF") { ## read line - nc <- ncdf4::nc_open(con$fname) + nc <- ncdf4::nc_open(con$fname[indF]) varName <- con$handle # str(con$offset) flip <- attr(varName,"flip") diff --git a/R/classRaster.Replace.R b/R/classRaster.Replace.R index 104726d..3d05b18 100644 --- a/R/classRaster.Replace.R +++ b/R/classRaster.Replace.R @@ -245,7 +245,7 @@ myname[ind] <- paste0("band",ind) x$name <- myname dimx <- x$dim - if (x$con$driver=="ENVI") { + if (x$con$driver %in% c("ENVI","EGDAL")) { .write.hdr(x) if (TRUE) { ## added 20161226 nb <- ifelse(is.na(x$con$posZ[1]),x$con$bands,length(con$posZ)) @@ -300,7 +300,7 @@ } dim(value$value) <- with(con,c(samples,nl,bands)) dimz <- dim(value$value) - if (con$driver=="ENVI") { + if (con$driver %in% c("ENVI","EGDAL")) { if (con$interleave=="bil") { if ((0)&&(TRUE)) @@ -369,18 +369,18 @@ # print(c(onexit=with(con,seek(handle,w=0,pos="current")))) } } - else if (con$driver=="GDAL") { # write lines + else if (con$driver=="RGDAL") { # write lines minJ <- min(j)-1 if (toRound) { for (b in seq(dimz[3])) { - rgdal::putRasterData(con$handle + .rgdal_putRasterData(con$handle ,.round(value$value[,,b,drop=TRUE]) ,offset=c(minJ,0),band=b) } } else { for (b in seq(dimz[3])) { - rgdal::putRasterData(con$handle,value$value[,,b,drop=TRUE] + .rgdal_putRasterData(con$handle,value$value[,,b,drop=TRUE] ,offset=c(minJ,0),band=b) } } @@ -405,7 +405,7 @@ else dim(value$value) <- with(con,c(samples,lines,dimy[2])) dimz <- dim(value$value) - if (con$driver=="ENVI") { + if (con$driver %in% c("ENVI","EGDAL")) { if (con$interleave=="bil") { posZ <- as.integer(value$con$posZ) @@ -523,17 +523,17 @@ else stop("unknown interleave") } - else if (con$driver=="GDAL") { ## write bands + else if (con$driver=="RGDAL") { ## write bands if (toRound) { for (r in seq_along(i)) { - rgdal::putRasterData(con$handle + .rgdal_putRasterData(con$handle ,.round(value$value[,,r,drop=TRUE]) ,band=i[r]) } } else { for (r in seq_along(i)) { - rgdal::putRasterData(con$handle,value$value[,,r,drop=TRUE] + .rgdal_putRasterData(con$handle,value$value[,,r,drop=TRUE] ,band=i[r]) } } @@ -560,7 +560,7 @@ } value <- decompress(value) dim(value$value) <- with(con,c(samples,lines,bands)) - if (con$driver=="ENVI") { + if (con$driver %in% c("ENVI","EGDAL")) { Fout <- con$handle if (con$seek) seek(con,origin="start",where=con$offset,rw="w") @@ -607,17 +607,17 @@ } } } - else if (con$driver=="GDAL") { # write full + else if (con$driver=="RGDAL") { # write full dimz <- dim(value$value) if (toRound) { for (b in seq(dimz[3])) - rgdal::putRasterData(con$handle + .rgdal_putRasterData(con$handle ,.round(value$value[,,b,drop=TRUE]) ,band=b) } else { for (b in seq(dimz[3])) { - rgdal::putRasterData(con$handle,value$value[,,b,drop=TRUE] + .rgdal_putRasterData(con$handle,value$value[,,b,drop=TRUE] ,band=b) } } diff --git a/R/classRaster_close.R b/R/classRaster_close.R index 615d88c..32fe09d 100644 --- a/R/classRaster_close.R +++ b/R/classRaster_close.R @@ -13,9 +13,14 @@ str(args[[i]]) str(con) } - if (con$fname %in% showConnections()[,"description"]) + if (any(con$fname %in% showConnections()[,"description"])) close(con$handle) con$handle <- NA + if ((con$driver=="EGDAL")&&(length(con$fname)==2)) { + with(con,.envi2gdal(src=fname[2],dst=fname[1],datatype=datatype,bands=bands)) + envi_remove(con$fname[2]) + con$compress <- 0L + } if (con$compress==-1L) file.remove(con$fname) else if (con$compress==-2L) @@ -78,63 +83,12 @@ } } else if (inherits(con$handle,"GDALTransientDataset")) { - dr <- rgdal::getDriverName(rgdal::getDriver(con$handle)) - op <- NULL - if (dr=="GTiff") - op=c(paste0("COMPRESS=",c("DEFLATE","ZSTD","LZW")[1]) - ,paste0("PREDICTOR=",ifelse(con$mode=="numeric",3,2)) - ,"TILED=NO" - ,"ZLEVEL=9" - ,"ZSTD_LEVEL=9" - ,paste0("INTERLEAVE=",switch(con$interleave,bil="PIXEL","BAND"))) - else if (dr=="HFA") { - op=c("COMPRESSED=YES") - } - else if (dr=="ENVI") { - # print(con$interleave) - op <- paste0("INTERLEAVE=",toupper(con$interleave)) - } - rgdal::saveDataset(con$handle,con$fname,options=op) - # rgdal::closeDataset(con$handle) - rgdal::GDAL.close(con$handle) - con$handle <- NA bname <- args[[i]]$name - # if (FALSE) { - standardname <- paste("Band",seq_along(bname)) - if ((TRUE)&&(!is.na(bname[1]))&&(!identical(standardname,bname))) { - metafile <- paste0(con$fname,".aux.xml") - if (!is.na(con$posZ[1])) - bname <- bname[con$posZ] - added3 <- rep("",length(bname)) - for (i in seq_along(bname)) - added3[i] <- paste0(" ",bname[i],"") - added2 <- c(" ",added3," ") - added1 <- c("",added2,"") - if (!file.exists(metafile)) { - Fmeta <- file(metafile,"wt") - writeLines(added1,Fmeta) - close(Fmeta) - } - else { - meta <- readLines(metafile) - # i1 <- .grep("",meta) - ##~ i2 <- .grep("",meta) - ##~ i2 <- i2[i2>i1][1] - i3 <- .grep("",meta) - metaBefore <- meta[1:(i3-1)] - metaAfter <- meta[i3:length(meta)] - writeLines(c(metaBefore,added2,metaAfter),metafile) - # op <- options(warn=0) - # warning("Band names was not written. TODO insert lines to *.aux.xml") - # options(op) - } - } + .rgdal_close_Transient(con,bname) } else if (inherits(con$handle,"GDALReadOnlyDataset")) { # print(class(con$handle)) - rgdal::GDAL.close(con$handle) - # rgdal::closeDataset(con$handle) + .rgdal_close_ReadOnly(con) con$handle <- NA } } diff --git a/R/compose_panel.R b/R/compose_panel.R index cfdeaed..d963da0 100644 --- a/R/compose_panel.R +++ b/R/compose_panel.R @@ -12,6 +12,7 @@ if ((is.ursa(img))||(!length(arglist))) { panel_new(...) panel_decor(...) + panel_annotation(...) } else { aname <- names(arglist) @@ -50,7 +51,7 @@ } return(invisible(ret)) } - # annotation <- .getPrm(arglist,name="annotation",default=NA)#_character_) + annotation <- .getPrm(arglist,name="annotation",default=NA_character_) # decor <- .getPrm(arglist,name="decor",default=TRUE) # scalebar <- .getPrm(arglist,name="scalebar",default=FALSE) verbose <- .getPrm(arglist,name="verb",kwd="plot",default=NA) ## FALSE? @@ -87,13 +88,15 @@ nl <- nb/np ## ??? not used after # print(img) # print(c(nb=nb,np=np,ng=ng,isRGB=as.integer(isRGB))) - annotation <- nb>1 & !isRGB #& !isList + if ((length(annotation)==1)&&(is.na(annotation))) { + annotation <- nb>1 & !isRGB #& !isList + } if (is.na(verbose)) verbose <- nb>2 txt <- NULL if (is.character(annotation)) txt <- if (length(annotation)==nb) annotation else rep(annotation,nb) - else if ((is.logical(annotation))&&(annotation)) + else if ((is.logical(annotation))&&(isTRUE(annotation))) txt <- ln else txt <- "" diff --git a/R/conn.create_any.R b/R/conn.create_any.R index 6809c42..7b839e8 100644 --- a/R/conn.create_any.R +++ b/R/conn.create_any.R @@ -2,8 +2,11 @@ .prepare.con(x,implement="ENVI",...) } 'create_gdal' <- function(x,...) { - requireNamespace("rgdal",quietly=.isPackageInUse()) - .prepare.con(x,implement="GDAL",...) + if (!.isPackageInUse()) { + .rgdal_requireNamespace() + return(.prepare.con(x,implement="RGDAL",...)) + } + .prepare.con(x,implement="EGDAL",...) } #'create_ncdf' <- function(x,...) { # requireNamespace("ncdf4",quietly=.isPackageInUse()) diff --git a/R/conn.open_envi.R b/R/conn.open_envi.R index bc38483..0e538c3 100644 --- a/R/conn.open_envi.R +++ b/R/conn.open_envi.R @@ -711,10 +711,10 @@ } else if (!isSF) { if (lverbose) - message("rgdal::showP4") - .try(grid$crs <- rgdal::showP4(wkt)) - # .try(grid$crs <- attr(rgdal::GDALinfo(con$fname,returnStats=FALSE) - # ,"projection")) + message("showP4() in 'rgdal'") + .try(grid$crs <- .rgdal_showP4(wkt)) + # .try(grid$crs <- attr(GDALinfo(con$fname,returnStats=FALSE) + # ,"projection")) ## GDALinfo() from 'rgdal' } else { if (lverbose) @@ -743,8 +743,8 @@ grid$crs <- grid$crs[nchar(grid$crs)>0] } else { - message(" sf::st_crs -> rgdal::showP4") - .try(grid$crs <- rgdal::showP4(wkt)) + message(" sf::st_crs -> showP4() in 'rgdal'") + .try(grid$crs <- .rgdal_showP4(wkt)) } } # stop("This is ureacheable branch! TODO for `sf`>0.8") diff --git a/R/conn.open_gdal.R b/R/conn.open_gdal.R index 4a7741e..69beca4 100644 --- a/R/conn.open_gdal.R +++ b/R/conn.open_gdal.R @@ -1,129 +1,29 @@ 'ursa_open' <- function(fname,verbose=FALSE) open_gdal(fname=fname,verbose=verbose) -'open_gdal' <- function(fname,verbose=FALSE) { - ## 20170116 removed '...' argument - if (!is.character(fname)) - return(NULL) - requireNamespace("rgdal",quietly=.isPackageInUse()) - # if (verbose) - # .elapsedTime("rgdal has been loaded") - opW <- options(warn=0-!verbose,show.error.messages=TRUE) ## to prevent 'GeoTransform values not available' - on.exit(options(opW)) - if (devel <- F) { - # a <- vapour:::gdalinfo_internal(fname,json=TRUE,stats=FALSE) - # a <- jsonlite::fromJSON(a) - } - a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE - ,returnColorTable=TRUE,returnCategoryNames=TRUE),silent=TRUE) - if (inherits(a,"try-error")) { - fname <- normalizePath(fname) - a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE - ,returnColorTable=TRUE,returnCategoryNames=TRUE),silent=TRUE) - if (inherits(a,"try-error")) { - if ((TRUE)||(!.isPackageInUse())) - cat(geterrmessage()) - # * using R version 3.4.0 Patched (2017-05-16 r72684) - # * using platform: x86_64-pc-linux-gnu (64-bit) - # > ### Name: open_gdal - # > ### Title: Open GDAL file - # > ### Aliases: open_gdal - # > ### Keywords: connection - # > - # > ### ** Examples - # > - # > session_grid(NULL) - # > fname1 <- system.file("pictures/cea.tif",package="rgdal") - # > message(fname1) - # /tmp/RtmpdrKt9J/RLIBS_310d3548ed74/rgdal/pictures/cea.tif - # > a1 <- open_gdal(fname1) - # > print(a1) - # NULL - # > print(a1[]) - # NULL - # > close(a1) - # Error in UseMethod("close") : - # no applicable method for 'close' applied to an object of class "NULL" - # Calls: close - ## 20170529 patch for failure with 'rgdal' at r-forge - if (.Platform$OS.type=="unix"){ - message(paste("Unable to open GDAL file. Failure for" - ,"R-forge buildig machine (Unix OS) since May 2017")) - if ((!.lgrep("\\.(rds)$",fname))&&(file.exists(fname))) {## 20170529 - return(ursa_new()) - } - } - return(NULL) +'open_gdal' <- function(fname,engine=c("native","sf","gdalraster","vapour") + ,verbose=FALSE) { + engList <- as.character(as.list(match.fun("open_gdal"))[["engine"]])[-1] + if (length(engine)0) { + nodata <- gsub("^.*=(\\s*(\\S+))$","\\1",gi) + if (typeof(ursa_value(res))=="integer") + ignorevalue(res) <- as.integer(unique(nodata)) + else + ignorevalue(res) <- as.numeric(unique(nodata)) + } + } if (!is.null(band)) res <- res[band] } else { - obj <- open_gdal(fname,verbose=verbose) + obj <- open_gdal(fname,engine=engine,verbose=verbose) if (is.null(obj)) return(NULL) res <- if (!is.null(band)) obj[band] else obj[] @@ -113,94 +143,3 @@ session_grid(res) res } -'.read_gdal' <- function(fname,fileout=NULL,verbose=!FALSE,...) { - if (!is.character(fname)) - return(NULL) - # suppressMessages(require("rgdal")) - requireNamespace("rgdal",quietly=.isPackageInUse()) - if (verbose) - .elapsedTime("rgdal has been loaded") - # print(geterrmessage()) - op <- options(warn=0-!verbose) - a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE - ,returnColorTable=TRUE,returnCategoryNames=TRUE)) - options(op) - if (inherits(a,"try-error")) { - fname <- normalizePath(fname) - op <- options(warn=0-!verbose) - a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE - ,returnColorTable=TRUE,returnCategoryNames=TRUE)) - options(op) - if (verbose) - str(a) - if (inherits(a,"try-error")) { - if (verbose) { - message("It looks like file ",.dQuote(fname) - ," is not found or not GDAL-recognized") - } - return(NULL) - } - } - a1 <- as.numeric(a) - g1 <- regrid() - g1$rows <- as.integer(a1[1]) - g1$columns <- as.integer(a1[2]) - nl <- as.integer(a1[3]) - g1$minx <- a1[4] - g1$miny <- a1[5] - g1$resx <- a1[6] - g1$resy <- a1[7] - g1$maxx <- with(g1,minx+resx*columns) - g1$maxy <- with(g1,miny+resy*rows) - g1$crs <- attr(a,"projection") - if (is.na(g1$crs)) - g1$crs <- "" - b1 <- attr(a,"mdata") - ln <- .gsub("^Band_\\d+=\\t*(.+)$","\\1",.grep("band",b1,value=TRUE)) - c1 <- attr(a,"df") - hasndv <- unique(c1$hasNoDataValue) - nodata <- unique(c1$NoDataValue) - nodata <- if ((length(hasndv)==1)&&(length(nodata)==1)&&(hasndv)) nodata - else NA - # print(length(attr(a,"ColorTable"))) - ct <- attr(a,"ColorTable") - if ((length(ct))&&(!is.null(ct[[1]]))) { - ct <- ct[[1]] - ca <- attr(a,"CATlist") - if ((length(ca))&&(!is.null(ca[[1]]))) { - nval <- ca[[1]] - ct <- ct[seq(length(nval))] - } - else - nval <- NULL #seq(length(ct)) - names(ct) <- nval - } - else - ct <- character() - class(ct) <- "ursaColorTable" - session_grid(g1) - dset <- methods::new("GDALReadOnlyDataset",fname) - if (!length(ln)) { - dima <- dim(dset) - ln <- paste("Band",if (length(dima)==3) seq(dima[3]) else 1L) - } - if (!is.character(fileout)) { - val <- rgdal::getRasterData(dset) - dima <- dim(val) - if (length(dima)==2) - dim(val) <- c(dima,1L) - val <- val[,rev(seq(dim(val)[2])),,drop=FALSE] ## added 20160330 - res <- as.ursa(value=val,bandname=ln,ignorevalue=nodata) - } - else { - res <- create_envi(fileout,bandname=ln,ignorevalue=nodata,...) - for (i in seq_along(ln)) - { - res[i]$value[] <- rgdal::getRasterData(dset,band=i) - } - } - rgdal::closeDataset(dset) - res$colortable <- ct - class(res$value) <- ifelse(length(ct),"ursaCategory","ursaNumeric") - res -} diff --git a/R/conn.write_gdal.R b/R/conn.write_gdal.R index 20296fe..6d3369e 100644 --- a/R/conn.write_gdal.R +++ b/R/conn.write_gdal.R @@ -1,5 +1,5 @@ # 'ursa_write' <- function(...) .syn('.write_gdal',2,...) -'ursa_write' <- function(obj,fname) { +'ursa_write' <- function(obj,fname) { ## proposed: compress=TRUE for DEFLATE, ZSTD, etc if (!.lgrep("\\..+$",basename(fname))) { return(write_envi(obj,fname)) } @@ -9,8 +9,10 @@ td <- file.path(tempdir(),basename(.maketmp())) dir.create(td) wd <- setwd(td) - for (i in seq(obj)) - write_gdal(obj[i],aname[i]) + for (i in seq(obj)) { + ursa_write(obj[i],aname[i]) ## RECURSIVE!!! + # write_gdal(obj[i],aname[i]) + } if (!.is.colortable(obj)) file.remove(dir(pattern="\\.aux\\.xml$")) zname <- file.path(wd,fname) @@ -20,7 +22,7 @@ setwd(wd) return(invisible(integer())) } - if ((TRUE)&&(.lgrep("\\.(tif|img)$",basename(fname)))&&(nchar(Sys.which("gdal_translate")))) { + if ((FALSE)&&(.lgrep("\\.(tif|img)$",basename(fname)))&&(nchar(Sys.which("gdal_translate")))) { # print("interim ENVI, then system GDAL") ftmp <- .maketmp() ret <- write_envi(obj,paste0(ftmp,".")) @@ -39,7 +41,7 @@ ,"-co",.dQuote("ZLEVEL=9") ,"-co",.dQuote("TILED=NO") ,"-co",.dQuote(paste0("INTERLEAVE=" - ,ifelse(length(obj)>=2,"PIXEL","BAND"))) + ,ifelse(length(obj)<2,"PIXEL","BAND"))) ,.dQuote(ftmp),.dQuote(fname))) else if (.lgrep("\\.(img)$",basename(fname))) system2("gdal_translate",c("-q","-of","HFA" @@ -49,12 +51,68 @@ envi_remove(ftmp) return(invisible(ret)) } + ##~ if (("sf" %in% loadedNamespaces())&& + ##~ (requireNamespace("stars",quietly=.isPackageInUse()))) { + ##~ ret <- .write_sfgdal(obj,fname) + ##~ } + if ((!"sf" %in% loadedNamespaces())&&(isTRUE(getOption("ursaForceSF")))) + requireNamespace("sf",quietly=.isPackageInUse()) + ftmp <- .maketmp() + ret <- write_envi(obj,paste0(ftmp,".")) + ret2 <- .envi2gdal(src=ftmp,dst=fname,datatype=ret,bands=length(obj)) + envi_remove(ftmp) + if (ret==ret2) + return(invisible(ret)) + # stop("Failed to write raster file ",dQuote(fname)) return(write_gdal(obj=obj,fname=fname)) } +'.envi2gdal' <- function(src,dst,datatype,bands) { + fpath <- dirname(dst) + if (!dir.exists(fpath)) + dir.create(fpath,recursive=TRUE) + if (file.exists(dst)) + file.remove(dst) + op <- character() + if (.lgrep("\\.(tif(f)*)$",basename(dst))) { + pr <- ifelse(datatype %in% c(4L,5L),3L,2L) + op <- c("-of","GTiff" + ,"-co",paste0("COMPRESS=",c("DEFLATE","ZSTD")[1]) + ,"-co",paste0("PREDICTOR=",pr) + ,"-co",paste0("ZSTD_LEVEL=9") + ,"-co",paste0("ZLEVEL=9") + ,"-co",paste0("TILED=NO") + ,"-co",paste0("INTERLEAVE=" + ,ifelse(bands<2,"PIXEL","BAND")) + ) + } + else if (.lgrep("\\.(img|hfa)$",basename(dst))) { + op <- c("-of","HFA" + ,"-co",paste("COMPRESSED=YES") + ) + } + else { + return(invisible(-98L)) + } + # print(paste(op,collapse=" ")) + gd <- sf::gdal_utils(util="translate" + ,source=src + ,destination=dst + ,quiet=TRUE + ,options=op + ) + if (file.exists(dst)) + return(invisible(datatype)) + invisible(-97L) +} 'write_gdal' <- function (obj,...) { - requireNamespace("rgdal",quietly=.isPackageInUse()) - if (!length(obj$colortable)) { - rgdal::setCPLConfigOption("GDAL_PAM_ENABLED","FALSE") ## doesnt work 20180327 + if (.isPackageInUse()) { + res <- try(.write_sfgdal(obj,...)) + # ret <- .try(res <- .write_sfgdal(obj,...)) + if (!inherits(res,"try-error")) + return(invisible(res)) + message(as.character(res)) + warning("File creation is failed; writting is failed") + return(invisible(NULL)) } res <- create_gdal(obj,...) if (is.null(res)) @@ -63,3 +121,47 @@ close(res) return(invisible(res$con$datatype)) } +'.write_sfgdal' <- function(obj,fname,driver) { + if ((!"sf" %in% loadedNamespaces())&&(T | isTRUE(getOption("ursaForceSF")))) + requireNamespace("sf",quietly=.isPackageInUse()) + if (!requireNamespace("stars",quietly=.isPackageInUse())) + warning("Package `stars` is required for raster writting") + datatype <- .optimal.datatype(obj) + nodata <- ignorevalue(obj) + dtName <- switch(as.character(datatype) + ,'1'="Byte",'2'="Int16",'4'="Float32" + ,'11'="Int8",'12'="UInt16",'13'="UInt32",'3'="Int32" + ,'5'="Float64",stop("cannot recognize datatype")) + if (missing(driver)) { + driver <- NULL + bname <- basename(fname) + if (.lgrep("\\.tif(f)*$",bname)) + driver <- "GTiff" + else if (.lgrep("\\.img$",bname)) + driver <- "HFA" # https://gdal.org/frmt_hfa.html + else if (.lgrep("\\.png$",bname)) + driver <- "PNG" + else if (.lgrep("\\.jp(e)*g$",bname)) + driver <- "JPEG" + else if (.lgrep("\\.bmp$",bname)) + driver <- "BMP" + # else if (.lgrep("\\.sdat$",fname)) + # driver <- "SAGA" + if (is.null(driver)) + driver <- "ENVI" + } + if (driver=="GTiff") { + opt <- c("COMPRESS=DEFLATE" + ,paste0("PREDICTOR=",ifelse(datatype %in% c(4,5),"3","2")) + ,paste0("INTERLEAVE=",ifelse(length(obj)==1,"PIXEL","BAND")) + ,"TILED=NO" + ) + } + else + opt <- character() + ret <- sf::gdal_write(as_stars(obj),driver=driver + ,file=fname,type=dtName,NA_value=nodata,options=opt + ,geotransform=with(ursa_grid(obj),c(minx,resx,0,maxy,0,-resy)) + ) + return(invisible(datatype)) +} diff --git a/R/get_earthdata.R b/R/get_earthdata.R index beb00c2..52fbbd5 100644 --- a/R/get_earthdata.R +++ b/R/get_earthdata.R @@ -198,7 +198,11 @@ epsg <- match.arg(epsg) matrixSet <- switch(epsg,'3413'="250m",'3857'="GoogleMapsCompatible_Level9") isPNG <- length(grep("png",ext))>0 - isJPG <- length(grep("jpg",ext))>0 + isJPEG <- length(grep("jpg",ext))>0 + if (isJPEG) { + if (!requireNamespace("jpeg",quietly=.isPackageInUse())) + stop("Suggested package 'jpeg' is missed, but is required here.") + } src <- file.path("https://gibs.earthdata.nasa.gov/wmts",paste0("epsg",epsg) ,"best",product,"default",time,matrixSet,paste0(z,"/",y,"/",x,ext)) # dst <- paste0("tmp-",z,"-",y,"-",x,ext) @@ -232,7 +236,7 @@ if (isPNG) { a[[i]] <- aperm(png::readPNG(dst),c(2,1,3)) } - else if (isJPG) + else if (isJPEG) a[[i]] <- aperm(jpeg::readJPEG(dst),c(2,1,3)) } # file.remove(dst) diff --git a/R/package_gdalraster.R b/R/package_gdalraster.R new file mode 100644 index 0000000..caf37bc --- /dev/null +++ b/R/package_gdalraster.R @@ -0,0 +1,159 @@ +'.open_gdalraster' <- function(fname,engine="gdalraster",verbose=FALSE) { + if (!is.character(fname)) + return(NULL) + engine <- match.arg(engine) + requireNamespace("gdalraster",quietly=.isPackageInUse()) + opW <- options(warn=0-!verbose,show.error.messages=TRUE) + on.exit(options(opW)) + ds <- methods::new(gdalraster::GDALRaster,filename=fname,read_only=TRUE) + # str(ds) + if (verbose) { + md <- list(ncols=ds$getRasterXSize() + ,nrows=ds$getRasterYSize() + ,bbox=ds$bbox() + ,nodata=ds$getNoDataValue(band=1) + ,dim=ds$dim() + ,res=ds$res() + # ,md=ds$getMetadata(band=1) + ,transform=ds$getGeoTransform() + ,crs=ds$getProjectionRef() + ,datatype=ds$getDataTypeName(band=1) + # ,info=ds$info() + # ,jinfo=ds$infoAsJSON() |> jsonlite::fromJSON() + ,md0=ds$getMetadata(band=0,domain="") + # ,md1=ds$getMetadata(band=1,domain="") + # ,mdi0=ds$getMetadataItem(band=0,domain="",mdi_name="") + ,ct=ds$getColorTable(band=1) ## ver 1.4.1 + ) + str(md) + } + dima <- ds$dim() + datatype <- ds$getDataTypeName(band=1) + nodata <- ds$getNoDataValue(band=1) + md0 <- ds$getMetadata(band=0,domain="") + bbox <- ds$bbox() + res <- ds$res() + if (TRUE) { + g1 <- regrid(bbox=bbox,res=res + ,crs=sf::st_crs(ds$getProjectionRef())$proj4string + # ,crs=ds$getProjectionRef() + ) + } + else { + g1 <- .grid.skeleton() + g1$minx <- bbox[1] + g1$maxx <- bbox[3] + g1$miny <- bbox[2] + g1$maxy <- bbox[4] + g1$columns <- dima[1] + g1$rows <- dima[2] + g1$resx <- res[1] + g1$resy <- res[2] + # g1$crs=sf::st_crs(ds$getProjectionRef())$proj4string + g1$crs=ds$getProjectionRef() + } + # session_grid(g1) + res <- .raster.skeleton() + res$dim <- c(prod(dima[1:2]),dima[3]) + con <- .con.skeleton() + con$driver <- "GDALRASTER" + con$samples <- g1$columns + con$lines <- g1$rows + con$bands <- dima[3] + con$indexC <- seq(g1$columns) + con$indexR <- seq(g1$rows) + con$indexZ <- seq_len(dima[3]) + con$seek <- FALSE + con$fname <- fname + con$handle <- ds + con$datatype <- switch(datatype,byte=1L,integer=2L,real=4L,float=4L + ,Byte=1L,UInt8=1L,Int8=11 + ,Int16=2L,UInt16=12,UInt32=13,Int32=3 + ,Float32=4L,Float64=5L + ,NA_integer_) + res$con <- con + ursa_grid(res) <- g1 + if (!is.null(datatype)) + ignorevalue(res) <- ifelse(con$datatype %in% c(1L,11L,2L,12L,3L,13L) + ,as.integer(nodata),nodata) + ct <- NULL ## CURRENTLY UNEMPLEMENTED + ursa_grid(res) <- g1 + patt <- "^Band_(\\d+)=(.+)$" + j <- grep(patt,md0) + bname <- gsub(patt,"\\2",md0[j]) + # bname <- gsub("^Band_\\d+=","",grep("^Band",md$md0,value=TRUE)) + if (!length(bname)) + names(res) <- paste("Band",seq_along(con$bands)) + else { + ind <- as.integer(gsub(patt,"\\1",md0[j])) + names(res)[ind] <- bname + } + # names(res) <- bname + ursa_colortable(res) <- ct + # if (!is.null(a$nodata_value)) + # ignorevalue(res) <- a$nodata_value + class(res$value) <- ifelse(length(ct),"ursaCategory","ursaNumeric") + res +} +'.read_gdalraster' <- function(fname,resetGrid=TRUE,band=NULL + ,engine=c("gdalraster"),verbose=FALSE,...) { ## ,... + engine <- match.arg(engine) + requireNamespace("gdalraster",quietly=.isPackageInUse()) + a <- .open_gdalraster(fname,engine=engine,verbose=verbose) + ds <- methods::new(gdalraster::GDALRaster,filename=fname,read_only=TRUE) + if (verbose) { + md <- list(ncols=ds$getRasterXSize() + ,nrows=ds$getRasterYSize() + ,bbox=ds$bbox() + ,nodata=ds$getNoDataValue(band=1) + ,dim=ds$dim() + ,res=ds$res() + # ,md=ds$getMetadata(band=1) + ,transform=ds$getGeoTransform() + ,crs=ds$getProjectionRef() + # ,info=ds$info() + # ,jinfo=ds$infoAsJSON() |> jsonlite::fromJSON() + ,md0=ds$getMetadata(band=0,domain="") + # ,md1=ds$getMetadata(band=1,domain="") + # ,mdi0=ds$getMetadataItem(band=0,domain="",mdi_name="") + ,ct=ds$getColorTable(band=1) ## ver 1.4.1 + ) + str(md) + } + dima <- ds$dim() + nodata <- ds$getNoDataValue(band=1) + md0 <- ds$getMetadata(band=0,domain="") + g1 <- regrid(bbox=ds$bbox(),res=ds$res() + ,crs=sf::st_crs(ds$getProjectionRef())$proj4string + # ,crs=ds$getProjectionRef() + ) + session_grid(g1) + patt <- "^Band_(\\d+)=(.+)$" + j <- grep(patt,md0) + bname <- gsub(patt,"\\2",md0[j]) + # bname <- gsub("^Band_\\d+=","",grep("^Band",md$md0,value=TRUE)) + if (!length(bname)) + bname <- paste("Band",seq_along(dima[3])) + else { + ind <- as.integer(gsub(patt,"\\1",md0[j])) + bname[ind] <- bname + } + out <- ursa_new(bandname=bname,nodata=nodata) + if (verbose) + cat("read") + for (i in seq(out)) { + if (verbose) + cat(".") + # print(i) + # ursa_value(out)[,i] <- + a <- ds$read(band=i + ,xoff=0,yoff=0 + ,xsize=dima[1],ysize=dima[2] + ,out_xsize=dima[1],out_ysize=dima[2] + ) + out$value[,i] <- a + } + if (verbose) + cat(" done!\n") + out +} diff --git a/R/package_sf.R b/R/package_sf.R index 2f0c371..f0e69ce 100644 --- a/R/package_sf.R +++ b/R/package_sf.R @@ -1,3 +1,126 @@ +'.open_sfgdal' <- function(fname,engine="sf",verbose=FALSE) { + if (!requireNamespace("sf",quietly=.isPackageInUse())) + stop("Package 'sf' is required for this operation") + obj <- sf::gdal_read(fname,read_data=FALSE) + columns <- obj$cols[2] + rows <- obj$rows[2] + bands <- length(obj$bands) + # patt <- "^Band_(\\d+)=(.+)$" + patt <- "^Band_(\\d+)=\\t*(.+)$" + bname <- grep(patt,obj$meta,value=TRUE) + b1 <- .grep(patt,obj$meta,value=TRUE) + bname <- .gsub(patt,"\\2",b1) + bname[as.integer(.gsub(patt,"\\1",b1))] <- bname + if (all(is.na(obj$geotransform))) { + resx <- 1 + resy <- 1 + minx <- 0 + miny <- 0 + maxx <- columns + maxy <- rows + } + else { + resx <- obj$geotransform[2] + resy <- -obj$geotransform[6] + minx <- obj$geotransform[1] + maxy <- obj$geotransform[4] + maxx <- minx+columns*resx + miny <- maxy-rows*resy + } + g1 <- regrid(minx=minx,maxx=maxx,miny=miny,maxy=maxy,columns=columns,rows=rows + ,crs=sf::st_crs(obj$crs)$proj4string + ) + res <- .raster.skeleton() + res$grid <- g1 + con <- .con.skeleton() + con$samples <- columns + con$lines <- rows + con$bands <- bands + con$driver <- "SF" + con$indexC <- seq(columns) + con$indexR <- seq(rows) + con$indexZ <- seq_along(bands) + con$seek <- FALSE + con$fname <- fname + con$datatype <- switch(obj$datatype,byte=1L,integer=2L,real=4L,float=4L + ,Byte=1L,UInt8=1L,Int8=11 + ,Int16=2L,UInt16=12,UInt32=13,Int32=3 + ,Float32=4L,Float64=5L + ,NULL) + con$handle <- obj + res$con <- con + isClass <- length(obj$attribute_tables[[1]])>0 + isColor <- length(obj$color_tables[[1]])>0 + isCat <- (isClass)||(isColor) + if (isCat) { + if (isClass) { + ctName <- obj$attribute_tables[[1]][["category"]] + if (is.null(ctName)) + isCat <- FALSE + } + } + if (isCat) { + if (isColor) { + ctCol <- obj$color_tables[[1]] + ct <- rgb(ctCol[,1],ctCol[,2],ctCol[,3],ctCol[,4],maxColorValue=255) + if (all(substr(ct,8,9)=="FF")) + ct <- substr(ct,1,7) + if (isClass) + if (length(ct)>length(ctName)) + ct <- ct[seq_len(length(ctName))] + } + else + ct <- rep(NA,length(ctName)) + if (isClass) + names(ct) <- ctName + class(ct) <- "ursaColorTable" + } + if ((isCat)||((T & !.lgrep("float",obj$datatype)))) { + # .elapsedTime("F") + # v <- as.integer(v) + # dim(v) <- dimv + # storage.mode(v) <- "integer" + mode(res$value) <- "integer" + # .elapsedTime("G") + } + # .elapsedTime("as.ursa -- before") + # res <- as.ursa(v) ## RECURSIVE + # res <- ursa_new(v) + # .elapsedTime("as.ursa -- after") + if (isCat) { + ursa_colortable(res) <- ct + class(res$value) <- "ursaCategory" + } + bname <- obj$description + if (any(nchar(bname)>0)) { + names(res) <- gsub("\\t","",bname) ## patch for ENVI 'band name' + } + else { + patt <- "^Band_(\\d+)=(.+)$" + j <- grep(patt,obj$meta) + ind <- as.integer(gsub(patt,"\\1",obj$meta[j])) + bname <- gsub(patt,"\\2",obj$meta[j]) + names(res)[ind] <- bname + } + res$dim <- as.integer(c(columns*rows,bands)) + gi <- sf::gdal_utils("info",fname,quiet=!FALSE) + gi <- strsplit(gi,split="\\n")[[1]] + if (tryToUseOnlyInfoForGridAndMetadata <- FALSE) { + cat("---------------\n") + print(gi) + cat("---------------\n") + q() + } + gi <- grep("NoData Value",gi,value=TRUE) + if (length(gi)>0) { + nodata <- gsub("^.*=(\\s*(\\S+))$","\\1",gi) + if (typeof(ursa_value(res))=="integer") + ignorevalue(res) <- as.integer(unique(nodata)) + else + ignorevalue(res) <- as.numeric(unique(nodata)) + } + res +} '.read_stars' <- function(fname) { if (!requireNamespace("sf",quietly=.isPackageInUse())) stop("Package 'sf' is required for this operation") @@ -5,7 +128,7 @@ columns <- a$cols[2] rows <- a$rows[2] bands <- a$bands[2] - patt <- "^Band_(\\d+)=(.+)$" + # patt <- "^Band_(\\d+)=(.+)$" patt <- "^Band_(\\d+)=\\t*(.+)$" bname <- grep(patt,a$meta,value=TRUE) b1 <- .grep(patt,a$meta,value=TRUE) @@ -79,7 +202,16 @@ attr(md,"raster") <- band class(md) <- "dimensions" ret <- list(imported=as.array(obj,flip=TRUE,permute=FALSE)) + if (T & length(ct <- ursa_colortable(obj))>0) { + dima <- dim(ret[[1]])[-3] + ret[[1]] <- factor(ret[[1]],levels=seq_along(ct)-0L,labels=names(ct)) + dim(ret[[1]]) <- dima + attr(ret[[1]],"colors") <- unclass(unname(ct)) + attr(ret[[1]],"exclude") <- rep(FALSE,length(ct)) + md$band <- NULL + } attr(ret,"dimensions") <- md + # attr(ret,"geotransform") <- c(g$minx,g$resx,0,g$maxy,-g$resy,0) class(ret) <- "stars" ret } diff --git a/R/package_vapour.R b/R/package_vapour.R new file mode 100644 index 0000000..9f9d0a4 --- /dev/null +++ b/R/package_vapour.R @@ -0,0 +1,131 @@ +'.open_vapour' <- function(fname,engine="vapour",verbose=FALSE) { + if (!is.character(fname)) + return(NULL) + engine <- match.arg(engine) + requireNamespace("vapour",quietly=.isPackageInUse()) + opW <- options(warn=0-!verbose,show.error.messages=TRUE) ## to prevent 'GeoTransform values not available' + on.exit(options(opW)) + a <- vapour::vapour_raster_info(fname) + g1 <- regrid() + g1$rows <- a$dimension[2] + g1$columns <- a$dimension[1] + ##~ nl <- as.integer(a1[3]) + g1$minx <- a$extent[1] + g1$maxx <- a$extent[2] + g1$miny <- a$extent[3] + g1$maxy <- a$extent[4] + # g1$resx <- a$geotransform[2] + # g1$resy <- -a$geotransform[4] + g1$resx <- with(g1,(maxx-minx)/columns) + g1$resy <- with(g1,(maxy-miny)/rows) + g1$crs <- a$projstring + # comment(g1$crs) <- a$projection + # if (is.na(g1$crs)) + # g1$crs <- "" + # str(g1) + # session_grid(g1) + res <- .raster.skeleton() + # res$dim <- as.integer(c(prod(a$dimension),a$bands)) + res$dim <- c(prod(a$dimension),a$bands) |> as.integer() + con <- .con.skeleton() + con$driver <- "VAPOUR" + con$samples <- g1$columns + con$lines <- g1$rows + con$bands <- a$bands + con$indexC <- seq(g1$columns) + con$indexR <- seq(g1$rows) + con$indexZ <- seq_len(a$bands) + con$seek <- FALSE + con$fname <- fname + con$handle <- fname ## methods::new("GDALReadOnlyDataset",fname) + con$datatype <- switch(a$datatype,byte=1L,integer=2L,real=4L,float=4L + ,Byte=1L,UInt8=1L,Int8=11 + ,Int16=2L,UInt16=12,UInt32=13,Int32=3 + ,Float32=4L,Float64=5L + ,NA_integer_) + res$con <- con + if (!is.null(a$nodata_value)) + ignorevalue(res) <- ifelse(con$datatype %in% c(1L,11L,2L,12L,3L,13L) + ,as.integer(a$nodata_value),a$nodata_value) + vrt <- vapour::vapour_vrt(fname) + vrt <- strsplit(vrt,split="\n")[[1]] + if (length(ind <- grep("CategoryName",vrt))) { + patt <- "\\s*(.+)$" + ca <- grep(patt,vrt[seq(ind[1],ind[2])],value=TRUE) + ca <- gsub(patt,"\\1",ca) + } + else + ca <- NULL + if (length(ind <- grep("ColorTable",vrt))) { + patt <- "\\s*" + ct <- vrt[seq(ind[1]+1L,ind[2]-1L)] + ct <- data.frame(c1=as.integer(gsub(patt,"\\1",ct)) + ,c2=as.integer(gsub(patt,"\\2",ct)) + ,c3=as.integer(gsub(patt,"\\3",ct)) + ,c4=as.integer(gsub(patt,"\\4",ct)) + ) + ct <- apply(ct,1,function(x) { + rgb(x[1],x[2],x[3],x[4],maxColorValue=255) + }) + } + else + ct <- NULL + if (!is.null(ct)) { + if (!is.null(ca)) { + ct <- ct[seq(length(ca))] + } + names(ct) <- ca + } + else if (!is.null(ca)) { + ct <- rep(NA,length(ca)) + names(ct) <- ca + } + else + ct <- character() + class(ct) <- "ursaColorTable" + patt <- "^\\s*(.+)$" + b <- vrt[grep(patt,vrt)] + if (!length(b)) + bname <- paste("Band",seq_along(con$bands)) + else + bname <- gsub(patt,"\\2",b)[as.integer(gsub(patt,"\\1",b))] + ursa_grid(res) <- g1 + names(res) <- bname + ursa_colortable(res) <- ct + # if (!is.null(a$nodata_value)) + # ignorevalue(res) <- a$nodata_value + class(res$value) <- ifelse(length(ct),"ursaCategory","ursaNumeric") + res +} +'.read_vapour' <- function(fname,resetGrid=TRUE,band=NULL + ,engine=c("vapour"),verbose=FALSE,...) { ## ,... + if (engine=="vapour") { + # .elapsedTime("vapour -- step1") + if (F) { + ri <- vapour::vapour_raster_info(fname) + str(ri) + # .elapsedTime("vapour -- step5") + q() + } + a <- .open_vapour(fname,engine=engine,verbose=verbose) + # .elapsedTime("vapour -- step2") + if (inDetail <- TRUE) { + # .elapsedTime("vapour -- step3") + b <- vapour::gdal_raster_data(fname,bands=seq(a)) + # print(is.raw(b[[1]])) + # .elapsedTime("vapour -- step4") + # if (ri$datatype %in% c("Byte","Int32","UInt32","Int64")) + if (a$con$datatype %in% c(1L,2L,3L,11L,12L,13L)) + ursa_value(a) <- as.integer(do.call(cbind,b)) + else + ursa_value(a) <- do.call(cbind,b) + # .elapsedTime("vapour -- step5") + } + else + ursa_value(a) <- vapour::gdal_raster_data(fname,bands=seq(a)) |> do.call(cbind,args=_) + if (resetGrid) + session_grid(a) + return(a) + } + NULL +} diff --git a/R/panel_coastline.R b/R/panel_coastline.R index 5ea2079..2e22c62 100644 --- a/R/panel_coastline.R +++ b/R/panel_coastline.R @@ -38,7 +38,7 @@ lwd <- .getPrm(arglist,name="lwd",kwd=kwd,default=0.5) lty <- .getPrm(arglist,name="lty",kwd=kwd,default=1L) fail180 <- .getPrm(arglist,name="fail180",kwd=kwd,default=NA) - obj <- .getPrm(arglist,name=paste0("(^$|",kwd,")") ## name="^$" + obj <- .getPrm(arglist,name=paste0("(^$|",kwd,"$)") ## name="^$" ,class=list("character","matrix","SpatialPolygonsDataFrame","sf")#[-3] ,default=NULL) verbose <- .getPrm(arglist,name="verbose",kwd=kwd,default=FALSE) @@ -181,12 +181,14 @@ if (!nchar(proj4)) { if (!isLoaded) - requireNamespace("rgdal",quietly=.isPackageInUse()) - proj4 <- rgdal::CRSargs(sp::CRS(sprintf("+init=epsg:%s",proj[ind]))) + requireNamespace(ifelse(.isPackageInUse(),"sf","rgdal") + ,quietly=.isPackageInUse()) + proj4 <- .rgdal_CRSargs(sp::CRS(sprintf("+init=epsg:%s",proj[ind]))) } else if (!isLoaded) { if (!requireNamespace("proj4",quietly=.isPackageInUse())) - requireNamespace("rgdal",quietly=.isPackageInUse()) + requireNamespace(ifelse(.isPackageInUse(),"sf","rgdal") + ,quietly=.isPackageInUse()) } } else @@ -194,7 +196,8 @@ if (!isLoaded) { if (!("sf" %in% loadedNamespaces())) { if (!requireNamespace("proj4",quietly=.isPackageInUse())) - requireNamespace("rgdal",quietly=.isPackageInUse()) + requireNamespace(ifelse(.isPackageInUse(),"sf","rgdal") + ,quietly=.isPackageInUse()) } } proj4 <- paste(proj,collapse=" ") diff --git a/R/panel_graticule.R b/R/panel_graticule.R index 8a0f765..a837987 100644 --- a/R/panel_graticule.R +++ b/R/panel_graticule.R @@ -163,7 +163,7 @@ ##~ ,KEEP.OUT.ATTRS=FALSE,stringsAsFactors=FALSE) ##~ g2 <- cbind(g2$x,g2$y)[c(1,4),] ##~ g2a <- proj4::project(g2,g1$crs,inv=TRUE) - ##~ g2b <- rgdal::project(g2,g1$crs,inv=TRUE) + ##~ g2b <- project(g2,g1$crs,inv=TRUE) ## project() from 'rgdal' ##~ print(g2) ##~ print(g2a) ##~ print(g2b) diff --git a/R/panel_plot.R b/R/panel_plot.R index 95871f6..f3969b6 100644 --- a/R/panel_plot.R +++ b/R/panel_plot.R @@ -22,7 +22,7 @@ if (.lgrep("\\.(shp(\\.zip)*|(geojson|sqlite|gpkg)(\\.(gz|bz2))*)$",obj)) { if (FALSE) { ## 20171216 deprecated op <- options(warn=0) - requireNamespace("rgdal",quietly=.isPackageInUse()) + # requireNamespace("rgdal",quietly=.isPackageInUse()) a <- .shp.read(obj) # a <- spTransform(a,session_grid()$crs) # ret <- .panel_plot(a,add=TRUE,...) diff --git a/R/progressBar.R b/R/progressBar.R index 50ddcbe..af8fcbb 100644 --- a/R/progressBar.R +++ b/R/progressBar.R @@ -3,6 +3,8 @@ ,title=.argv0(),label="" ,min=0,max=1,initial=min,width=NA,style=1 ,tail=FALSE,silent=FALSE) { + if (isPackageTest <- isTRUE(Sys.getenv("_R_CHECK_PACKAGE_NAME_")=="ursa")) + silent <- TRUE if (silent) { pb <- logical() class(pb) <- "ursaProgressBar" diff --git a/R/spatial_engine.R b/R/spatial_engine.R index 638ed33..dac54be 100644 --- a/R/spatial_engine.R +++ b/R/spatial_engine.R @@ -691,11 +691,11 @@ } if (isSP) { if (!("LINESTRING" %in% spatial_geotype(obj))) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (.rgeos_requireNamespace()) stop("suggested package is required for this operation") - res <- try(rgeos::gLength(obj,byid=TRUE)) + res <- try(.rgeos_gLength(obj,byid=TRUE)) if (inherits(res,"try-error")) - res <- try(rgeos::gLength(spatial_buffer(obj),byid=TRUE)) + res <- try(.rgeos_gLength(spatial_buffer(obj),byid=TRUE)) return(unname(res)) } if (FALSE) { ## thesame @@ -1092,8 +1092,8 @@ } else if (implement_by_rgeos <- FALSE) { # stop("unimplemented for 'sp' objects") - requireNamespace("rgeos",quietly=.isPackageInUse()) - res <- rgeos::gIntersection(x,y,byid=TRUE,drop_lower_td=TRUE + .rgeos_requireNamespace() + res <- .rgeos_gIntersection(x,y,byid=TRUE,drop_lower_td=TRUE ,unaryUnion_if_byid_false=FALSE) res2 <- names(sp::over(spatial_geometry(x),spatial_geometry(y),returnList=TRUE)) res2 <- grep("NA",res2,invert=TRUE,value=TRUE) @@ -1125,13 +1125,13 @@ return(res) } else if (isSP) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (!.rgeos_requireNamespace()) stop("suggested package is required for this operation") # opW <- options(warn=-1) - res <- try(rgeos::gDifference(x,y,byid=TRUE)) + res <- try(.rgeos_gDifference(x,y,byid=TRUE)) # options(opW) if (inherits(res,"try-error")) - res <- try(rgeos::gDifference(spatial_buffer(x),spatial_buffer(y),byid=TRUE)) + res <- try(.rgeos_gDifference(spatial_buffer(x),spatial_buffer(y),byid=TRUE)) return(res) } else if (dev <- FALSE) { @@ -1157,13 +1157,13 @@ return(res) } else if (isSP) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (!.rgeos_requireNamespace()) stop("suggested package is required for this operation") # opW <- options(warn=-1) - res <- try(rgeos::gSymdifference(x,y,byid=TRUE)) + res <- try(.rgeos_gSymdifference(x,y,byid=TRUE)) # options(opW) if (inherits(res,"try-error")) - res <- try(rgeos::gSymdifference(spatial_buffer(x),spatial_buffer(y),byid=TRUE)) + res <- try(.rgeos_gSymdifference(spatial_buffer(x),spatial_buffer(y),byid=TRUE)) return(res) } else if (dev <- FALSE) { @@ -1202,10 +1202,10 @@ return(res) } else if (isSP) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (!.rgeos_requireNamespace()) stop("suggested package is required for this operation") # opW <- options(warn=-1) - res <- rgeos::gBuffer(obj,byid=TRUE,width=dist,quadsegs=quadsegs) + res <- .rgeos_gBuffer(obj,byid=TRUE,width=dist,quadsegs=quadsegs) # options(opW) return(res) } @@ -1236,16 +1236,16 @@ return(res) } else if (isSP) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (!.rgeos_requireNamespace()) stop("suggested package is required for this operation") if (missing(y)) { - res <- try(rgeos::gUnaryUnion(x,id=NULL)) + res <- try(.rgeos_gUnaryUnion(x,id=NULL)) if (inherits(res,"try-error")) { - res <- rgeos::gUnaryUnion(.spatial_repair(x),id=NULL) + res <- .rgeos_gUnaryUnion(.spatial_repair(x),id=NULL) } return(res) } - res <- rgeos::gUnion(x,y,byid=byid) + res <- .rgeos_gUnion(x,y,byid=byid) return(res) } else if (dev <- FALSE) { @@ -1262,10 +1262,10 @@ return(res) } else if (isSP) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (!.rgeos_requireNamespace()) stop("suggested package is required for this operation") # opW <- options(warn=-1) - res <- rgeos::gSimplify(obj,tol=tol,topologyPreserve=topologyPreserve) + res <- .rgeos_gSimplify(obj,tol=tol,topologyPreserve=topologyPreserve) # options(opW) return(res) } @@ -1283,9 +1283,9 @@ valid <- try(sf::st_is_valid(obj,NA_on_exception=TRUE,reason=verbose)) } else if (isSP) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (!.rgeos_requireNamespace()) stop("suggested package is required for this operation") - valid <- try(rgeos::gIsValid(obj,reason=verbose)) + valid <- try(.rgeos_gIsValid(obj,reason=verbose)) } else return(NULL) @@ -1316,7 +1316,15 @@ if (!is.null(spatial_data(res))) { if (isSP) { # res <- lapply(seq_along(arglist),function(i) sp::spChFIDs(arglist[[i]],as.character(i))) - return(do.call("rbind",arglist)) + da <- do.call(rbind,lapply(arglist,spatial_data)) + geom <- lapply(arglist,spatial_geometry) + geom$makeUniqueIDs <- TRUE + geom <- do.call(rbind,geom) + # da <- data.frame(foo=seq(spatial_count(geom))) + if (!ncol(da)) + return(geom) + spatial_data(geom) <- da + return(geom) } if (isSF) { geom <- unique(sapply(arglist,function(x) attr(x,"sf_column"))) @@ -1398,9 +1406,9 @@ if (verbose) print(data.frame(sf=isSF,sp=isSP,row.names="engine")) if (isSP) { - if (!requireNamespace("rgeos",quietly=.isPackageInUse())) + if (!.rgeos_requireNamespace()) stop("suggested package is required for this operation") - res <- rgeos::gIsValid(obj,byid=TRUE,reason=TRUE) + res <- .rgeos_gIsValid(obj,byid=TRUE,reason=TRUE) if (reason) return(unname(res)) if (each) diff --git a/R/spatial_levelsplit.R b/R/spatial_levelsplit.R index 65a3995..4d1773c 100644 --- a/R/spatial_levelsplit.R +++ b/R/spatial_levelsplit.R @@ -1,5 +1,35 @@ 'spatial_levelsplit' <- function(obj,sep=" - ") { ind <- order(spatial_area(obj),decreasing=TRUE) + n <- length(ind) + obj <- obj[ind,] + res <- vector("list",length(ind-1)) + aname <- spatial_colnames(obj) + res[[1]] <- tail(obj,1) + da <- spatial_data(obj) + if (length(dtype <- which(sapply(da,inherits,c("integer","numeric"))))) { + for (i in dtype) { + spatial_data(res[[1]])[,i] <- paste("0",spatial_data(res[[1]])[,i],sep=sep) + } + } + for (i in rev(tail(seq(spatial_count(obj)),-1))) { + res2 <- spatial_difference(spatial_geometry(obj[i-1,]),spatial_geometry(obj[i,])) + da2 <- apply(da[c(i,i-1),,drop=FALSE],2,function(x) { + y <- unique(x) + if (length(y)==1) + return(y) + paste(unique(x),collapse=sep) + }) + if (!is.list(da2)) + da2 <- lapply(da2,function(x) x) + spatial_data(res2) <- as.data.frame(da2) + res[[n-i+2L]] <- res2 + } + ret <- do.call(spatial_bind,res) + ret +} +'.spatial_levelsplit_prev' <- function(obj,sep=" - ") { + ind <- order(spatial_area(obj),decreasing=TRUE) + obj <- obj[rev(ind),] res <- vector("list",length(ind-1)) n1 <- ncol(spatial_data(obj)) indCol1 <- seq(1L,n1) diff --git a/R/spatial_read.R b/R/spatial_read.R index c78825b..2ea104f 100644 --- a/R/spatial_read.R +++ b/R/spatial_read.R @@ -1,4 +1,4 @@ -'spatial_read' <- function(dsn,engine=c("native","sp","sf","geojsonsf")) { +'spatial_read' <- function(dsn,engine=c("native","sf","geojsonsf")) { if (.lgrep("\\.(tif|tiff|tif\\.zip|img|png|bmp|dat)$",dsn)) return(ursa_read(dsn)) g0 <- getOption("ursaSessionGrid") diff --git a/R/spatial_write.R b/R/spatial_write.R index 5feabdd..9f36154 100644 --- a/R/spatial_write.R +++ b/R/spatial_write.R @@ -343,7 +343,7 @@ if (!inherits(obj,c("SpatialPointsDataFrame","SpatialLinesDataFrame" ,"SpatialPolygonsDataFrame"))) spatial_data(obj) <- data.frame(dummy=seq_len(spatial_count(obj))) - rgdal::writeOGR(obj + .rgdal_writeOGR(obj ,dsn=fname # iconv(fname,to="UTF-8") ,layer=lname,driver=driver ,dataset_options=dopt,layer_options=lopt @@ -352,8 +352,8 @@ ,verbose=verbose) if ((FALSE)&&(driver=="ESRI Shapefile")) { ## replace "OGC ESRI" by "OGC WKT" prj <- sp::proj4string(obj) - prj1 <- rgdal::showWKT(prj,morphToESRI=TRUE) - prj2 <- rgdal::showWKT(prj,morphToESRI=FALSE) + prj1 <- .rgdal_showWKT(prj,morphToESRI=TRUE) + prj2 <- .rgdal_showWKT(prj,morphToESRI=FALSE) if (!identical(prj1,prj2)) { writeLines(prj2,gsub("\\.shp$",".prj",fname)) } @@ -370,7 +370,7 @@ if (driver %in% c("GeoJSON","KML","GPX")) { if (!identical(spatial_crs(obj),spatial_crs(4326))) { if ((devel <- FALSE)&&(!.isPackageInUse())) { - ## ?rgdal::make_EPSG + ## see ?make_EPSG for 'rgdal' print(spatial_crs(obj)) # epsg <- sf::st_crs(spatial_crs(obj))$epsg # print(c(epsg=epsg)) diff --git a/R/ursa_as.R b/R/ursa_as.R index d6fe411..5d96f0a 100644 --- a/R/ursa_as.R +++ b/R/ursa_as.R @@ -233,6 +233,8 @@ if (isColor) { ctCol <- obj$color_tables[[1]] ct <- rgb(ctCol[,1],ctCol[,2],ctCol[,3],ctCol[,4],maxColorValue=255) + if (all(substr(ct,8,9)=="FF")) + ct <- substr(ct,1,7) if (isClass) if (length(ct)>length(ctName)) ct <- ct[seq_len(length(ctName))] @@ -265,6 +267,13 @@ if (any(nchar(bname)>0)) { names(res) <- gsub("\\t","",bname) ## patch for ENVI 'band name' } + else { + patt <- "^Band_(\\d+)=(.+)$" + j <- grep(patt,obj$meta) + ind <- as.integer(gsub(patt,"\\1",obj$meta[j])) + bname <- gsub(patt,"\\2",obj$meta[j]) + names(res)[ind] <- bname + } } else { if (length(dimv)==2) diff --git a/R/xxx.geocode.R b/R/xxx.geocode.R index d52c9c9..df65a0e 100644 --- a/R/xxx.geocode.R +++ b/R/xxx.geocode.R @@ -52,7 +52,8 @@ # ,"&polygon_text=1" ,"&format=xml","&bounded=0","&accept-language=en-US,ru") # dst <- tempfile() # "nominatim.xml" # tempfile() - # print(src) + if (F & verbose) + message(src) dst <- .ursaCacheDownload(src,quiet=!verbose) xmlstring <- scan(dst,character(),quiet=!verbose) # Encoding(xmlstring) <- "UTF-8" @@ -134,6 +135,8 @@ ,"&polygon_text=1" ,"&format=xml" ,"&bounded=0","&accept-language=en-US,ru") + if (verbose) + message(src) dst <- .ursaCacheDownload(src,cache=cache,quiet=!verbose) if (verbose) .elapsedTime("shape|180 -- parsing") @@ -180,8 +183,10 @@ isSF <- "sf" %in% loaded || requireNamespace("sf",quietly=.isPackageInUse()) if (!isSF) { - isSP <- "rgeos" %in% loaded || - requireNamespace("rgeos",quietly=.isPackageInUse()) + if (.isPackageInUse()) + isSP <- FALSE + else + isSP <- "rgeos" %in% loaded || .rgeos_requireNamespace() } else isSP <- FALSE @@ -192,24 +197,25 @@ ,"&polygon_",ifelse(isWKT,"text=1","geojson=1") ,"&format=xml" ,"&bounded=0","&accept-language=en-US,ru") + if (verbose) + message(src) dst <- .ursaCacheDownload(src,cache=cache,quiet=!verbose) if (verbose) .elapsedTime("shape|180 -- parsing") - # str(dst) - b <- readLines(dst,encoding="UTF-8",warn=FALSE)[3] + b <- readLines(dst,encoding="UTF-8",warn=FALSE)[2] # ind1 <- unlist(gregexpr("geojson)=\\'\\{",b)) # ind2 <- unlist(gregexpr("\\}\\'",b)) ##~ ind1 <- gregexpr("geo(text|json)=\\'",b) ##~ ind2 <- gregexpr("(\\)|\\})\\'",b) - ind1 <- unlist(gregexpr("geo(text|json)=\\'",b)) - ind2 <- unlist(gregexpr("(\\)|\\})\\'",b)) + ind1 <- unlist(gregexpr("geo(text|json)=(\\'|\")",b)) + ind2 <- unlist(gregexpr("(\\)|\\})(\\'|\")",b)) ind3 <- which(ind1>0) ind4 <- which(ind2>0) if ((identical(ind3,ind4))&&(length(ind3)>0)) { ## ind3[1]==ind4[1] ind1 <- ind1[ind3] ind2 <- ind2[ind4] shape <- lapply(seq_along(ind3),function(i) { - n1 <- nchar(.gsub2("(geo(text|json)=\\')","\\1",b)) + n1 <- nchar(.gsub2("(geo(text|json)=(\\'|\"))","\\1",b)) b2 <- substr(b,ind1[i]+n1,ind2[i]) if (F) return(b2) @@ -228,7 +234,7 @@ d2 <- spatial_geometry(sf::st_as_sf(d2,wkt="geom")) } else if (isSP) { - d2 <- rgeos::readWKT(b2) + d2 <- .rgeos_readWKT(b2) } spatial_crs(d2) <- 4326 if (("top" %in% select)&&(is_spatial_points(d2))) diff --git a/R/xxx.panel_WMS.R b/R/xxx.panel_WMS.R index e99451e..621cab9 100644 --- a/R/xxx.panel_WMS.R +++ b/R/xxx.panel_WMS.R @@ -838,6 +838,9 @@ src <- srclist[[k]] isPNG <- .lgrep("\\&format=image.+png",src)>0 isJPEG <- .lgrep("\\&format=image.+(jpg|jpeg)",src)>0 + if (isJPEG) + if (!requireNamespace("jpeg",quietly=.isPackageInUse())) + stop("Suggested package 'jpeg' is missed, but is required here.") if (verbose) print(c(png=isPNG,jpg=isJPEG,GDAL=(!isPNG & !isJPEG))) i0 <- 0 diff --git a/R/xxx.panel_cluster.R.curr b/R/xxx.panel_cluster.R.curr new file mode 100644 index 0000000..5207ca3 --- /dev/null +++ b/R/xxx.panel_cluster.R.curr @@ -0,0 +1,511 @@ +'panel_cluster' <- function(obj,overlap=1,cex=1,ratio=0.2,col=NULL + ,method=c("complete","centroid","single") + ,fun=c("count","sum","mean","label"),label=fun %in% "count" + ,ngroup=NA,separate=FALSE,repel=20L,legend="bottomright" + ,title=NULL,silent=FALSE,verbose=FALSE,...) { + if (.skipPlot(TRUE)) + return(NULL) + ##~ method <- c('1'="ward.D",'2'="ward.D2",'3'="single",'4'="complete" + ##~ ,'5'="average",'6'="mcquitty",'7'="median" + ##~ ,'8'="centroid")[4] ## 3 4! 8 + method <- match.arg(method) + fun <- match.arg(fun) + if (isFALSE(legend)) + legend <- NULL + cutted <- 1.05 + da <- spatial_data(obj) + # str(colnames(da)) + # str(da[,colnames(da),drop=TRUE]) + if (!is.null(da)) { + indCat <- which(sapply(colnames(da),function(x) + inherits(da[,x,drop=TRUE],c("character","factor"))))[1] + isCat <- !is.na(indCat) + if (fun %in% c("count")) { + indNum <- which(sapply(colnames(da),function(x) + inherits(da[,x,drop=TRUE],c("integer"))))[1] + isNum <- !is.na(indNum) + } + else + isNum <- FALSE + } + else { + isCat <- FALSE + isNum <- FALSE + } + if ((isCat)&&(isNum)) { + if (length(ind <- which(is.na(da[[indNum]])))) { + obj <- obj[-ind,] + da <- da[-ind,] + } + } + if (isCat) { + aname <- obj[[indCat]] + nameCat <- colnames(da)[indCat] + } + else { + if (separate) + separate <- F + legend <- NULL + } + if (verbose) { + print(c('Category'=indCat)) + print(c('Count'=indNum)) + } + g1 <- getOption("ursaPngPanelGrid") + xy <- spatial_coordinates(spatial_transform(spatial_geometry(obj),ursa_crs(g1))) + xy <- cbind(xy,da) + n <- if (!isNum) rep(1L,spatial_count(obj)) else obj[[indNum]] + xy4 <- xy[do.call(c,lapply(seq_along(n),function(i) rep(i,n[i]))),,drop=FALSE] + rownames(xy4) <- NULL + # xy4[[colnames(da)[indNum]]] <- 1L + # print(table(as.integer(rownames(xy4)))) + cell <- ursa(g1,"cellsize") + # .ursaOptions() + scale <- getOption("ursaPngScale") + dpi <- getOption("ursaPngDpi") + ps <- getOption("ursaPngPointsize") + retina <- getOption("ursaPngRetina") + s <- unname((cex*c(annotation=1.5))*overlap*ps/scale*cell*dpi/96*sqrt(2)) + if (!label) + s <- s*0.5 + if (verbose) + print(data.frame(cell=cell,retina=retina,scale=scale + ,overlap=overlap,dpi=dpi,ps=ps,cex=cex,s=s)) + if (isCat) + bname <- if (is.factor(aname)) levels(aname) else unique(aname) + else { + indFun <- which(sapply(colnames(da),function(x) + inherits(da[,x],c("integer","numeric"))))[1] + if (!is.na(indFun)) + bname <- names(indFun) + else + bname <- ".undefined" + } + if ((separate)&&(isCat)&&(!is.na(ngroup))&&(length(ngroup)!=length(bname))&&(ngroup[1]>2)) { + tg <- table(xy4[[nameCat]]) + # print(tg) + # mul <- ngroup/max(tg) + # ngroup <- ceiling(as.numeric(tg)*mul) + # print(length(tg)) + # print(ngroup) + if (any(nchar(names(ngroup)))) { + ng <- ngroup + ngroup <- rep(NA,length(tg)) + names(ngroup) <- names(tg) + if (length(ind <- match(names(ng),names(ngroup)))) + ngroup[ind] <- ng + } + else { + ngroup <- rep(ngroup,length(tg)) + names(ngroup) <- names(tg) + } + # print(ngroup) + } + # print(ngroup) + lutList <- lapply(if (separate) bname else ".+",function(sep) { + # message(sQuote(sep),":") + # print(ngroup[sep]) + # return(NULL) + # str(xy4) + # str(grep(paste0("^",sep,"$"),xy4[[nameCat]])) + if (isCat) { + # xy5 <- xy4[grep(paste0("^",sep,"$"),xy4[[nameCat]]),] + xy5 <- if (separate) xy4[xy4[[nameCat]] %in% sep,] else xy4 + } + else + xy5 <- xy4 + if (nrow(xy5)<2) { + chcD <- 1L + } + else { + len <- dist(xy5[,c("x","y")]) + # str(xy5) + # print(summary(len)) + chc <- hclust(len,method=method) + if ((length(ngroup)>1)&&(!is.null(names(ngroup)))) + ng <- ngroup[sep] + else + ng <- ngroup + if (min(len[len>0])>s*0.75) + ng <- NA + # print(data.frame(ng=ng,len=min(len[len>0]))) + if (!is.na(ng)) { + chcD <- cutree(chc,k=min(c(ng,nrow(xy5)))) + } + else { + chcD <- cutree(chc,h=s) + } + } + ta <- table(chcD) + ##~ print(ta) + ##~ print(table(cutree(chc,h=s))) + ##~ print(nrow(xy5)) + ##~ print(sum(ta)) + # pal <- paste0(cubehelix(length(bname),dark=127,light=127,rotate="circle"),"A0") + lut <- array(0L,dim=c(length(ta),length(bname)),dimnames=list(names(ta),bname)) + lut <- cbind(.x=NA,.y=NA,.r=NA,.n=NA,data.frame(lut,check.names=FALSE)) + xy5 <- data.frame(xy5,.cluster=chcD) + for (i in seq(nrow(lut))) { + da2 <- xy5[xy5$.cluster==i,]#c("x","y")] + # print(da2) + if (isCat) { + ta2 <- table(da2[[nameCat]]) + lut[i,match(names(ta2),colnames(lut))] <- as.integer(ta2) + } + else { + if ((bname!=".undefined")&&(fun %in% c("mean"))) { + lut[i,bname] <- mean(da2[[bname]],na.rm=TRUE) + } + else if ((bname!=".undefined")&&(fun %in% c("sum"))) { + lut[i,bname] <- sum(da2[[bname]],na.rm=TRUE) + } + else + lut[i,bname] <- nrow(da2) + } + lut$.n[i] <- nrow(da2) + lut$.x[i] <- mean(da2$x) + lut$.y[i] <- mean(da2$y) + } + lut <- aggregate(lut[,-grep("^\\.[xy]",colnames(lut))] + ,by=list(.x=lut$.x,.y=lut$.y),sum) + lut + }) + lut <- do.call(rbind,lutList) + rownames(lut) <- NULL + if (is.character("ratio") & "log" %in% ratio) + lut$.r <- log(lut$.n+1) + else + lut$.r <- lut$.n^ratio # rowSums(lut[,bname,drop=FALSE])^ratio + lut$.r <- lut$.r/min(lut$.r) + if (repel) { + if (isTRUE(repel)) + repel <- 20L + else + repel <- as.integer(repel) + # S <- 1+dist(lut$.r) + # print(lut) + # gr <- expand.grid(i=seq(nrow(lut)),j=seq(nrow(lut)),KEEP.OUT.ATTRS=FALSE) + S <- 0.5*rowSums(expand.grid(a=lut$.r,b=lut$.r,KEEP.OUT.ATTRS=FALSE)) + S <- as.dist(matrix(S,nrow=nrow(lut),byrow=T)) + S <- as.dist(S) + xy <- as.matrix(lut[,c(".x",".y")]) + dimnames(xy) <- NULL + # xy <- cbind(xy,S) + d <- s/20 + iter <- 100 + R2 <- 0.5*s*cutted + k <- 0L + isProgress <- FALSE + repeat({ + D <- dist(xy)/S + ind1 <- which(D<2*R2) + ind1 <- ind1[!.is.eq(D[ind1],2*R2)] + if (!length(ind1)) + break + if (!k) { + # str(ind1) + iter <- repel*length(ind1) + pb <- ursaProgressBar(iter,title="Repel clusters",silent=silent) + isProgress <- TRUE + } + if (isProgress) + setUrsaProgressBar(pb) + ind2 <- .sample(ind1,1) + D1 <- as.matrix(D) + ind3 <- match(D[ind2],c(D1)) + j <- c(col(D1))[ind3] + i <- c(row(D1))[ind3] + xy2 <- xy[c(i,j),] + dxy <- c(diff(xy2[,1]),diff(xy2[,2])) + L <- sqrt(sum(dxy^2)) + d2 <- if (T | L/2+d/2iter) + break + k <- k+1L + }) + if (isProgress) + close(pb) + # print(c(convergent=k,niter=iter)) + lut[,c(".x",".y")] <- xy + } + lut <- lut[order(lut$.r,decreasing=TRUE),] + d <- dist(lut[,c(".x",".y")]) + indCrd <- grep("^\\.[xy]$",colnames(lut)) + if (F) { + p <- spatial_buffer(spatialize(lut[,indCrd],coords=c(".x",".y") + ,crs=ursa_crs(g1)),s/2) + spatial_write(p,"C:/platt/R/ursa-package/run/panel_cluster/mammal.geojson") + q() + } + if (F) { + ct <- NULL + if (T & .is.colortable(col)) { + print(bname) + print(col) + ind <- na.omit(match(bname,names(col))) + if (length(ind)!=length(bname)) + col <- as.character(col) + else { + print(is.character(col)) + } + } + q() + print(col) + print(bname) + } + if (F & is.character(col)) { + ct <- ursa_colortable(colorize(bname + ,pal=rep(col,length.out=length(bname)),alpha="A0")) + ctInd <- ct + } + else if (F & is.list(col)) { + # do.call("colorize",c(list(body),col)) + ct <- colorize(bname,pal=rep(col,length.out=length(bname)),alpha="A0") + } + else if (fun %in% c("count","label")) { + hasCT <- FALSE + if (T & .is.colortable(col)) { + ind <- na.omit(match(bname,names(col))) + if (length(ind)==length(bname)) { + hasCT <- TRUE + ct <- col[ind] + } + } + if (!hasCT) + ct <- colorize(bname,alpha="A0" + ,pal.dark=127,pal.light=127,pal.rotate="circle" + ) + rm(hasCT) + ctInd <- ursa_colortable(ct) + } + else { + if (is.list(col)) { + if (!length(grep("stretch",names(col)))) + col$stretch <- "linear" + ct <- do.call("colorize",c(list(lut[[bname]]),col)) + } + else if (is.character(col)) { + ct <- colorize(lut[[bname]],stretch="linear",alpha="A0",pal=col) + } + else { + # ct <- colorize(lut[[bname]],stretch="linear",alpha="A0") ## -- 20210909 + ct <- colorize(bname,stretch="linear",alpha="A0") ## ++ 20210909 + } + ctInd <- ursa_colortable(ct)[ursa_colorindex(ct)] + } + bg <- if (separate) "white" else ctInd + if (length(bg)==1) + bg <- rep(bg,length(ctInd)) + bg <- col2rgb(bg)/255 + bg <- rgb(bg[1,],bg[2,],bg[3,],alpha=ifelse(separate,0.6,0.2)) + s2 <- s/ifelse(label,2,1.5)/overlap + for (i in seq(nrow(lut))) { + x <- lut$.x[i] # <- mean(da2$x) + y <- lut$.y[i] # <- mean(da2$y) + r <- lut$.r[i] + if (fun %in% c("count","label")) { + v <- as.integer(lut[i,bname]) + .panel_pie(v,x=x,y=y,radius=lut$.r[i]*s2,col=ctInd,bg=bg,ball=!label + ,verbose=verbose) # lwd=0.5 + } + else { + .panel_pie(1,x=x,y=y,radius=lut$.r[i]*s2,col=ctInd[i],ball=!label + ,verbose=verbose) + } + p <- sf::st_as_sf(lut[i,],coords=c(".x",".y"),crs=ursa_crs(g1)) + if (F) + panel_plot(spatial_buffer(p,s/2),col="transparent",border="grey40",lwd=0.5) + # panel_plot(spatial_buffer(p,s/2),col="transparent",border="white",lwd=0.5) + if (F) ## donut/bagel + panel_plot(spatial_buffer(p,(c(s-10*cell*cex,0.75*s*r)[2])/2) + ,col="#FFFFFFAF",border="transparent") + if (T & label) { + if (fun %in% "count") + lab <- sum(v) + else + lab <- lut[i,bname,drop=FALSE] + if (fun %in% c("label")) { + lname <- names(lab) + lab <- lname[which(lab>0)] + } + panel_annotation(x=x,y=y,label=as.character(lab),cex=cex^0.25,adj=c(0.5,0.53) + # ,fg="#FFFFFFA0",bg="#000000AF" + ,buffer=2/scale ## commment it + # ,buffer=2 + ) + } + if (F) { + da2 <- xy4[xy4$.cluster==i,] + for (j in seq(nrow(da2))) + segments(x,y,da2$x[j],da2$y[j],col="#00000030",lwd=0.5) + } + } + if (!is.null(legend)) { + if (isTRUE(legend)) + legend <- eval(as.list(args(panel_cluster))$legend) + sc <- 96*getOption("ursaPngRetina")/getOption("ursaPngDpi") + if (T) + str(list('par(cex)'=par("cex"),cex=cex,scale=getOption("ursaPngScale") + ,retina=getOption("ursaPngRetina"),ps=getOption("ursaPngPointsize") + ,dpi=getOption("ursaPngDpi"),sc=sc)) + legend(legend,legend=bname,title=title + ,col=ctInd + ,cex=c(1,cex)[1]/par("cex") + ,pch=21 + ,pt.lwd=ifelse(label,1,0)*2.4/par("cex")*sc + ,pt.cex=1.8/par("cex") + ,box.lwd=0.1,bg="#FFFFFFAF" + # ,pt.bg=ursa_colortable(colorize(seq_along(ctInd),pal=ctInd,alpha="30")) + ,pt.bg=if (label) bg else ctInd + ,... + ) + # return(invisible(ct)) ## colortable of obj[[indCat]] + return(invisible(ursa_colortable(ct))) + } + ct <- ursa_colortable(ct) + if (F) + ret <- list(name=names(ct) + ,type="POLYGON" + ,fill=as.character(ct) + ) + else { + ret <- .legend.skeleton() + ret$name=names(ct) + ret$col <- "white" + ret$border <- "transparent" + ret$pch <- 21 + ret$pt.lwd <- ifelse(label,1,0)*2.4/par("cex") + ret$pt.cex <- 1.8/par("cex") + ret$pt.bg <- as.character(ct) + } + if (T) { + opR <- getOption("ursaPngLegend") + options(ursaPngLegend=if (is.null(opR)) list(ret) else c(opR,list(ret))) + } + # return(invisible(list(ret))) + return(invisible(ret)) + ##~ ret <- list(name=oname,type="default" + ##~ ,col="transparent",border="transparent",lty=1,lwd=1,pch=0,cex=NA + ##~ ,fill="transparent",bg="transparent",density=NA,angle=45) +} +'.panel_pie' <- function(z,x=0,y=0,radius=1,edges=200,clockwise=TRUE,init.angle=90 + ,col=NULL,bg="white" + ,border="white",lty=NULL,lwd=NULL,ball=FALSE + ,verbose=FALSE) { + if (!is.numeric(z) || any(is.na(z) | z < 0)) + stop("'z' values must be positive.") + if (verbose) + cat("--------\nPIE\n----------\n") + g0 <- getOption("ursaPngPanelGrid") + if (verbose) { + print(session_grid()) + print(g0) + print(getOption("ursaPngComposeGrid")) + print(getOption("ursaSessionGrid")) + } + cell <- ursa(g0,"cellsize") + z <- z/sum(z) + ind <- which(z>0) + mul <- cell/radius + # print(c(pie.cell=cell,pie.radius=radius,pie.mul=radius/cell)) + if (any(z[ind]160)) + border2[] <- "#00000080" + } + if (!is.null(lty)) + lty <- rep_len(lty, nz) + if (!is.null(lwd)) + lwd <- rep_len(lwd, nz) + twopi <- if (clockwise) -2*pi else 2*pi + # print(c(pie.asp=asp,pie.scale=c(1,0.7))) + 't2xy' <- function(t,scale=c(1,0.7)) { + t2p <- twopi*t+init.angle*pi/180 + if (max(dz)==1) { + if (T & verbose) + print("MAX(DZ)==1") + xp <- c(asp[1]*radius*scale[1]*cos(t2p)+x) + yp <- c(asp[2]*radius*scale[1]*sin(t2p)+y) + } + else { + if (T & verbose) + print("MAX(DZ)!=1") + xp <- c(0+x,asp[1]*radius*scale[1]*cos(t2p)+x,0+x) + yp <- c(0+y,asp[2]*radius*scale[1]*sin(t2p)+y,0+y) + } + if (length(scale)>1) { + if (max(dz)==1) { + if (T & verbose) + print("TWO SCALES: MAX(DZ)==1") + xp <- c(xp,NA,asp[1]*radius*scale[2]*cos(t2p)+x) + yp <- c(yp,NA,asp[2]*radius*scale[2]*sin(t2p)+y) + } + else { + if (T & verbose) + print("TWO SCALES: MAX(DZ)!=1") + xp <- c(xp,NA,0+x,asp[1]*radius*scale[2]*cos(t2p)+x,0+x) + yp <- c(yp,NA,0+y,asp[2]*radius*scale[2]*sin(t2p)+y,0+y) + } + } + list(x=xp,y=yp) + } + col1 <- col # ursa_colortable(colorize(seq_along(col),pal=col,alpha="A0")) + if (!is.character(bg)) + col2 <- ursa_colortable(colorize(seq_along(col),pal=col,alpha="30")) + else { + col2 <- bg + } + for (i in seq_len(nz)) { + n <- max(2,floor(edges*dz[i])) + if (!ball) { ## external circle + P <- t2xy(seq.int(z[i],z[i+1],length.out=n),scale=c(1,0.65)) + ##~ polygon(c(P$x,0+x),c(P$y,0+y),border=border[i],col=col[i] + ##~ ,lty=lty[i],lwd=lwd[i] + ##~ ) + polypath(P$x,P$y,border=border2[i],col=col1[i] + ,lty=lty[i],lwd=lwd[i] + ,rule=c("winding","evenodd")[2] + ) + } + P <- t2xy(seq.int(z[i],z[i+1],length.out=n),scale=ifelse(ball,0.75,0.65)) + polypath(P$x,P$y,border=border1[i],col=if (ball) col1[i] else col2[i] + ,lty=lty[i],lwd=lwd[i] + ,rule=c("winding","evenodd")[2] + ) + } + col +} diff --git a/R/xxx.panel_legend.R b/R/xxx.panel_legend.R index 5eda023..ebe618e 100644 --- a/R/xxx.panel_legend.R +++ b/R/xxx.panel_legend.R @@ -100,6 +100,13 @@ }) # detach("arglist") } + if ((all(arglist$col=="transparent"))&&(all(arglist$fill=="transparent"))) { + arglist$col <- arglist$border + arglist$angle <- NULL + arglist$density <- NULL + arglist$fill <- NULL + arglist$pch <- NA + } if (verbose) str(arglist) ret <- do.call("legend",arglist) diff --git a/R/xxx.spatialize.R b/R/xxx.spatialize.R index c31e5bc..cc02dfd 100644 --- a/R/xxx.spatialize.R +++ b/R/xxx.spatialize.R @@ -1,4 +1,4 @@ -'spatialize' <- function(dsn,engine=c("native","sp","sf","geojsonsf") +'spatialize' <- function(dsn,engine=c("native","sf","geojsonsf") ,layer=".*",field=".+",coords=c("x","y"),crs=character() ,geocode="",place="",area=c("bounding","point","shape") ,grid=NULL,size=NA,cell=NA,expand=1,border=NA @@ -6,7 +6,13 @@ ,style="auto" ## auto none internal keep # ,zoom=NA ,subset="",verbose=FALSE,...) { - engine <- match.arg(engine) + engList <- as.character(as.list(match.fun("spatialize"))[["engine"]])[-1] + if (length(engine)0) - hasColor <- (isCT)&&(all(!is.na(ct))) - hasNames <- (isCT)&&(all(!is.na(names(ct)))) - # print(c(has_nodata=!is.na(nodata),isCT=isCT,hasColor=hasColor,hasNames=hasNames)) - if (any(!is.na(nodata),isCT,hasColor,hasNames)) { - for (i in seq(nband(x))) { - bset <- methods::new("GDALRasterBand",x$con$handle,i) - if (!is.na(nodata)) - rgdal::GDALcall(bset,"SetNoDataValue",nodata) - if (hasColor) - rgdal::GDALcall(bset,"SetRasterColorTable",as.character(ct)) - if (hasNames) - rgdal::GDALcall(bset,"SetCategoryNames",names(ct)) - # if (isCT) - # rgdal::putRasterData(dset,as.array(colorize(obj[i]),flip=TRUE,drop=TRUE),band=i) - # else - # rgdal::putRasterData(dset,as.array(obj[i],flip=TRUE,drop=TRUE),band=i) - } - } + else if (x$con$driver=="RGDAL") { + .rgdal_prepare_con(x) } x$value <- NA # class(x$value) <- ifelse(isCT,"ursaCategory","ursaNumeric") @@ -193,7 +168,7 @@ connection <- NULL interleaveName <- c("bsq","bil","bip") interleave <- NULL - implementName <- c("ENVI","GDAL") + implementName <- c("ENVI",ifelse(.isPackageInUse(),"EGDAL","RGDAL")) implement <- NULL driver <- NULL proj <- NULL @@ -375,7 +350,7 @@ byteorder <- 0L if (is.na(con$byteorder)) con$byteorder <- byteorder - if ((con$driver=="ENVI")&&(TRUE)) ## forced to compress + if ((con$driver %in% c("ENVI","EGDAL"))&&(TRUE)) ## forced to compress { if (!(is.null(compressed))) { if (!is.na(compressed)) @@ -438,7 +413,7 @@ con$connection <- "bzfile" else if (length(.grep("\\.xz$",con$fname))) con$connection <- "xzfile" - else if (length(.grep("\\.(envi|bin|img|dat)$",con$fname))) + else if (length(.grep("\\.(envi|bin|img|dat|tif|tiff|hfa)$",con$fname))) { con$connection <- "file" con$compress <- 0L @@ -487,8 +462,14 @@ con$bands <- obj$dim[2] con$interleave <- with(con,switch(interleave,spatial="bsq",temporal="bil" ,interleave)) - if (con$driver=="ENVI") { - con$handle <- do.call(con$connection,list(con$fname,"w+b")) + if (con$driver %in% c("ENVI","EGDAL")) { + if (con$driver=="ENVI") + con$handle <- do.call(con$connection,list(con$fname,"w+b")) + else { + ftemp <- .maketmp(1) + con$fname <- c(con$fname,ftemp) + con$handle <- do.call(con$connection,list(ftemp,"w+b")) + } cl <- class(con$handle) if (("bzfile" %in% cl)||("xzfile" %in% cl)||("gzfile" %in% cl)) ## gz? con$seek <- FALSE @@ -496,7 +477,7 @@ con$seek <- TRUE rm(cl) } - else if (con$driver=="GDAL") { + else if (con$driver %in% c("EGDAL","RGDAL")) { if (.lgrep("\\.tif(f)*$",fname)) driver <- "GTiff" else if (.lgrep("\\.img$",fname)) @@ -516,25 +497,33 @@ ,'11'="Int8",'12'="UInt16",'13'="UInt32",'3'="Int32" ,'5'="Float64",stop("cannot recognize datatype")) nb <- if (is.na(con$posZ[1])) con$bands else length(con$posZ) - try(con$handle <- methods::new("GDALTransientDataset" - ,methods::new("GDALDriver",driver) - ,con$lines,con$samples,nb,dtName)) - if (!inherits(con$handle,"GDALTransientDataset")) - return(NA) - con$seek <- FALSE + if (con$driver %in% "RGDAL") { + try(con$handle <- methods::new("GDALTransientDataset" + ,methods::new("GDALDriver",driver) + ,con$lines,con$samples,nb,dtName)) + if (!inherits(con$handle,"GDALTransientDataset")) + return(NA) + con$seek <- FALSE + } + else { ## via ENVI -> GDAL after closing + ftemp <- .maketmp(1) + con$fname <- c(con$fname,ftemp) + con$handle <- do.call(con$connection,list(ftemp,"w+b")) + con$seek <- TRUE + } } if ("file" %in% class(con$handle)) { - if (file.exists(oldpack <- paste0(con$fname,".gz"))) + if (file.exists(oldpack <- paste0(con$fname[1],".gz"))) file.remove(oldpack) - if (file.exists(oldpack <- paste0(con$fname,".bz2"))) + if (file.exists(oldpack <- paste0(con$fname[1],".bz2"))) file.remove(oldpack) - if (file.exists(oldpack <- paste0(con$fname,".xz"))) + if (file.exists(oldpack <- paste0(con$fname[1],".xz"))) file.remove(oldpack) } - if (file.exists(aux <- paste0(con$fname,".aux.xml"))) + if (file.exists(aux <- paste0(con$fname[1],".aux.xml"))) file.remove(aux) - if (con$driver=="ENVI") { + if (con$driver %in% c("ENVI","EGDAL")) { if (((con$interleave %in% c("bil","bsq"))&&(con$seek))|| (con$connection %in% c("gzfile"))) #&&(!is.matrix(obj$value))) { @@ -639,7 +628,9 @@ con$byteorder <- 0L if (is.na(con$datatype)) con$datatype <- 1L - fname <- .gsub("\\.(bin|bingz|envi|envigz|img|dat|gz|bz2|xz|unpacked(.*)~)$","",con$fname) + indF <- ifelse(length(con$fname)>1,2L,1L) + fname <- .gsub("\\.(bin|bingz|envi|envigz|img|dat|gz|bz2|xz|unpacked(.*)~)$","" + ,con$fname[indF]) if (is.na(fname)) { fname <- x$name[1] @@ -651,13 +642,13 @@ list1 <- .dir(path=dirname(fname) ,pattern=sprintf("^%s($|\\.(envi|envigz|bin|bingz|dat|img|gz|bz2|xz|.*aux\\.xml)$)" ,basename(fname)),full.names=TRUE) - if (length(ind <- .grep(sprintf("^%s$",basename(con$fname)),basename(list1)))) + if (length(ind <- .grep(sprintf("^%s$",basename(con$fname[indF])),basename(list1)))) list1 <- list1[-ind] file.remove(list1[which(!file.info(list1)$isdir)]) } Fout <- file(myname,"wt") writeLines(sprintf("%s","ENVI"),Fout) - writeLines(sprintf("description = {%s}",con$fname),Fout) + writeLines(sprintf("description = {%s}",con$fname[indF]),Fout) writeLines(sprintf("samples = %d",con$samples),Fout) writeLines(sprintf("lines = %d",con$lines),Fout) if (is.na(con$posZ[1])) @@ -892,28 +883,37 @@ file.remove(wktout) } } - else if (!("sf" %in% loadedNamespaces())) { - if (lverbose) - message("'rgdal' engine") - if (!.try(wkt <- rgdal::showWKT(proj4,morphToESRI=TRUE))) - wkt <- NULL - } - else { ## 'sf' in namespace; 'OGC_WKT' ONLY. - if (lverbose) - message("'sf' engine") - if (!.try(wkt <- { - if (utils::packageVersion("sf")<"0.9") - ret <- sf::st_as_text(sf::st_crs(proj4),EWKT=TRUE) - else - ret <- sf::st_crs(proj4)$Wkt - ret - })) - # if (!.try(wkt <- sf::st_as_text(sf::st_crs(proj4),EWKT=TRUE))) - # wkt <- NULL - # print(proj4) - # message(wkt) - if (!TRUE) { ## 20191216 patch for EXTENSION["PROJ4","+proj=......."] - wkt <- gsub(",EXTENSION\\[\"PROJ4\".+\\]","]",wkt) + else { + if (!("sf" %in% loadedNamespaces())) { + if (.isPackageInUse()) { + if (lverbose) + message("forced 'sf' loading") + requireNamespace("sf") ## rgdal retired + } + } + if (!("sf" %in% loadedNamespaces())) { + if (lverbose) + message("'rgdal' engine") + if (!.try(wkt <- .rgdal_showWKT(proj4,morphToESRI=TRUE))) + wkt <- NULL + } + else { ## 'sf' in namespace; 'OGC_WKT' ONLY. + if (lverbose) + message("'sf' engine") + if (!.try(wkt <- { + if (utils::packageVersion("sf")<"0.9") + ret <- sf::st_as_text(sf::st_crs(proj4),EWKT=TRUE) + else + ret <- sf::st_crs(proj4)$Wkt + ret + })) + # if (!.try(wkt <- sf::st_as_text(sf::st_crs(proj4),EWKT=TRUE))) + # wkt <- NULL + # print(proj4) + # message(wkt) + if (!TRUE) { ## 20191216 patch for EXTENSION["PROJ4","+proj=......."] + wkt <- gsub(",EXTENSION\\[\"PROJ4\".+\\]","]",wkt) + } } } if (lverbose) @@ -927,7 +927,7 @@ if ((is.character(x$name))&&(sum(nchar(x$name))>0)) { if (.lgrep(",",x$name)) { - metaname <- paste0(.gsub("\\.(gz|bz2|xz)$","",x$con$fname),".aux.xml") + metaname <- paste0(.gsub("\\.(gz|bz2|xz)$","",x$con$fname[indF]),".aux.xml") Fmeta <- file(metaname,"wt") writeLines("",Fmeta) writeLines(" ",Fmeta) diff --git a/R/yyy.crop.R b/R/yyy.crop.R index 242e82f..ff9eb2f 100644 --- a/R/yyy.crop.R +++ b/R/yyy.crop.R @@ -8,8 +8,11 @@ requireNamespace("png",quietly=.isPackageInUse()) if (isPNG) NULL - else if (isJPEG) + else if (isJPEG) { + # if (!requireNamespace("jpeg",quietly=.isPackageInUse())) + # stop("Suggested package 'jpeg' missed, but is required here.") isJPEG <- requireNamespace("jpeg",quietly=.isPackageInUse()) + } else if (isWEBP) isWEBP <- requireNamespace("webp",quietly=.isPackageInUse()) else if (isSVG) { diff --git a/R/yyy.project.R b/R/yyy.project.R index 48e12ed..2ba15a8 100644 --- a/R/yyy.project.R +++ b/R/yyy.project.R @@ -16,7 +16,7 @@ opW <- options(warn=-11,show.error.messages=verbose);on.exit(options(opW)) # if (("package:rgdal" %in% search())|| # (!requireNamespace("proj4",quietly=.isPackageInUse()))) - # res <- rgdal::project(xy=xy,proj=proj,inv=inv) + # res <- project(xy=xy,proj=proj,inv=inv) ## project() from 'rgdal' # else # res <- proj4::project(xy=t(xy),proj=proj,inverse=inv) a <- FALSE @@ -35,17 +35,17 @@ is_proj4 <- (("proj4" %in% loaded)|| (!isTRUE(getOption("ursaForceSF")))&& (requireNamespace("proj4",quietly=.isPackageInUse()))) ## `proj4` faster `sf`20220216 - is_rgdal <- "rgdal" %in% loaded + is_rgdal <- !.isPackageInUse() & "rgdal" %in% loaded is_sf <- "sf" %in% loaded if ((!is_sf)&&(!is_rgdal)&&(!is_proj4)) { - requireNamespace("proj4",quietly=.isPackageInUse()) - loaded <- loadedNamespaces() - is_proj4 <- "proj4" %in% loaded + is_pro4 <- requireNamespace("proj4",quietly=.isPackageInUse()) + if ((!is_proj4)&&(T | .isPackageInUse())) + is_sf <- requireNamespace("sf",quietly=.isPackageInUse()) } if (verbose) print(c(proj4=is_proj4,rgdal=is_rgdal,sf=is_sf)) # if ((!FALSE)&&(!("package:rgdal" %in% search()))&& - if ((!a)&&(("proj4" %in% loaded)|| + if ((!a)&&((is_proj4)|| ((FALSE)&&(requireNamespace("proj4",quietly=.isPackageInUse()))))) { if (verbose) message("'proj4' is used") @@ -76,7 +76,7 @@ proj4version <- utils::packageVersion("proj4") if ((proj4version>="1.0.12")&&(!nchar(Sys.getenv("PROJ_LIB")))) { Sys.setenv(PROJ_LIB=system.file("proj",package="sf")) - if (!nchar(Sys.getenv("PROJ_LIB"))) + if ((!.isPackageInUse())&&(!nchar(Sys.getenv("PROJ_LIB")))) Sys.setenv(PROJ_LIB=system.file("proj",package="rgdal")) } if (proj4version>="1.0.10") { @@ -97,7 +97,7 @@ },silent=TRUE) } } - if ((!a)&&(T & "sf" %in% loaded)) { + if ((!a)&&(is_sf)) { if (verbose) message("'sf' is used") if (inv) { @@ -115,6 +115,19 @@ # ind <- which((is.na(xy[,1]))|(is.na(xy[,2]))) hasNA <- anyNA(xy[,1]) tryMatrix <- TRUE + if (omitOutside <- FALSE) { + # if (length(ind180 <- which(xy[,1]>180))) + # xy[ind180,1] <- xy[ind180,1]-180 + lim <- c(-18000,10,180000,80) + if (length(ind180 <- which(xy[,1]<=lim[1]))) + xy[ind180,1] <- lim[1] + if (length(ind180 <- which(xy[,1]>=lim[3]))) + xy[ind180,1] <- lim[3] + if (length(ind180 <- which(xy[,2]<=lim[2]))) + xy[ind180,2] <- lim[2] + if (length(ind180 <- which(xy[,2]>=lim[4]))) + xy[ind180,4] <- lim[4] + } if (hasNA) { ind <- which(is.na(xy[,1])) ## less conditions res <- matrix(NA,ncol=2,nrow=nrow(xy)) @@ -122,7 +135,8 @@ a <- .try(res[-ind,] <- unclass(sf::st_transform(sf::st_sfc( sf::st_multipoint(xy[-ind,]),crs=crs_s),crs_t)[[1]])) else { - a <- .try(res[-ind,] <- sf::sf_project(from=crs_s,to=crs_t,pts=xy[-ind,])) + a <- .try(res[-ind,] <- sf::sf_project(from=crs_s,to=crs_t,pts=xy[-ind,] + ,keep=TRUE)) } } else { @@ -138,19 +152,22 @@ print(crs_t) print(sf::st_crs(crs_t)$proj4string) } - a <- .try(res <- sf::sf_project(from=crs_s,to=crs_t,pts=xy)) + a <- .try(res <- sf::sf_project(from=crs_s,to=crs_t,pts=xy + ,keep=TRUE)) } } } if (!a) { - if (verbose) { - print("WWW") - q() - } if (verbose) message("'rgdal' is used") - if (!("rgdal" %in% loadedNamespaces())) - requireNamespace("rgdal",quietly=.isPackageInUse()) + if (.isPackageInUse()) { + opWG <- options(warn=1) + warning("Unable to reproject without `rgdal` package") + options(opWG) + } + if (!("rgdal" %in% loadedNamespaces())) { + .rgdal_requireNamespace() + } if (!is.character(proj)) proj <- .epsg2proj4(proj) if (is.list(xy)) @@ -161,10 +178,10 @@ ind <- which(is.na(xy[,1])) ## less conditions if (length(ind)) { res <- matrix(NA,ncol=2,nrow=nrow(xy)) - a <- .try(res[-ind,] <- rgdal::project(xy=xy[-ind,],proj=proj,inv=inv)) + a <- .try(res[-ind,] <- .rgdal_project(xy=xy[-ind,],proj=proj,inv=inv)) } else { - a <- .try(res <- rgdal::project(xy=xy,proj=proj,inv=inv)) + a <- .try(res <- .rgdal_project(xy=xy,proj=proj,inv=inv)) } if (!a) { if (verbose) diff --git a/R/yyy.shp.R b/R/yyy.shp.R index dd7155b..fbbbae4 100644 --- a/R/yyy.shp.R +++ b/R/yyy.shp.R @@ -11,111 +11,6 @@ return(fname) paste0(fname,".shp") } -'.shp.read' <- function(fname,reproject=TRUE,encoding="1251",resetGrid=FALSE - ,verbose=0L,...) -{ - ## b <- sf::st_read("gde-1-1-15.shp",quiet=TRUE) - ## b <- sf::st_transform(b,ursa_proj(a)) - # print(fname) - requireNamespace("rgdal",quietly=.isPackageInUse()) - if (resetGrid) - reproject <- FALSE - # require(methods) - if (.lgrep("\\.zip$",basename(fname))) - fname <- .gsub("\\.zip$","",fname) - fpath <- dirname(fname) - z <- file.path(fpath,paste0(.shp.layer(fname),".zip")) # ,. - if (!file.exists(z)) - z <- file.path(fpath,paste0(.shp.layer(fname),".shp.zip")) - if (file.exists(z)) - { - a <- utils::unzip(z,exdir=fpath,junkpaths=TRUE) - on.exit(file.remove(a)) - } - if (verbose>1) - .elapsedTime("readOGR:start") - cpgname <- file.path(fpath,paste0(.shp.layer(fname),".cpg")) - e_opt <- if (file.exists(cpgname)) readLines(cpgname,warn=FALSE) else "" - i_opt <- if (grepl("UTF(-)*8",e_opt)) TRUE else FALSE - # print(data.frame(e_opt=e_opt,i_opt=i_opt)) - opW <- options(warn=0) - res <- rgdal::readOGR(.shp.file(fname),.shp.layer(fname),pointDropZ=TRUE - ,encoding=e_opt,use_iconv=i_opt - ,verbose=as.logical(verbose),...) - options(opW) - if (verbose>1) - .elapsedTime("readOGR:finish") - proj4 <- session_grid()$crs - if ((reproject)&&(nchar(proj4))&&(!is.na(sp::proj4string(res)))) { - if (verbose>1) - .elapsedTime("spTransform:start") - res <- sp::spTransform(res,proj4) - if (verbose>1) - .elapsedTime("spTransform:finish") - } - if (resetGrid) - session_grid(NULL) - res -} -'.shp.write' <- function(obj,fname,compress=FALSE,zip=NULL) -{ - requireNamespace("methods",quietly=.isPackageInUse()) - ## Error: inherits(obj, "Spatial") is not TRUE - # require("methods") - requireNamespace("rgdal",quietly=.isPackageInUse()) - # suppressMessages(require(rgdal)) ## should be already loaded - if (!is.null(zip)) - compress <- zip - fpath <- dirname(fname) - layer <- .shp.layer(fname) - suppressWarnings({ - first <- TRUE - op <- options(warn=2) - repeat({ - if (!file.exists(.shp.file(fname))) - break - if (file.remove(.shp.file(fname))) - break - if (first) { - cat(paste("Waiting for permitted writting",.sQuote(basename(fname)))) - first <- FALSE - } - cat(".") - Sys.sleep(1) - }) - if (!first) - cat(" ok!\n") - options(op) - }) - opW <- options(warn=0) - rgdal::writeOGR(obj,fpath,layer,driver="ESRI Shapefile" - # ,encoding=encoding - ,overwrite=TRUE) - options(opW) - writeLines("1251",file.path(fpath,paste0(layer,".cpg"))) - if (!compress) - return(NULL) - f <- .dir(path=dirname(fname) - ,pattern=paste0("^",.shp.layer(fname),"\\.(cpg|dbf|prj|qpj|shp|shx)$") - ,full.names=TRUE) - z <- paste0(.shp.file(fname),".zip") - opW <- options(warn=-1) - first <- TRUE - while(file.exists(z)) { - if (file.remove(z)) - break - if (first) { - cat(paste("Waiting for deleting",.sQuote(z))) - first <- FALSE - } - cat(".") - Sys.sleep(1) - } - if (!first) - cat(" ok!\n") - options(opW) - utils::zip(z,f,flags="-qm9j") ## verbose output ## 'myzip(z,f,keys="-m -9 -j")' -} '.shp.geometry' <- function(fname,verbose=FALSE) { if (.lgrep("\\.zip$",basename(fname))) fname <- .gsub("\\.zip$","",fname) diff --git a/R/yyy.tile.R b/R/yyy.tile.R index b426700..934dadb 100644 --- a/R/yyy.tile.R +++ b/R/yyy.tile.R @@ -389,8 +389,11 @@ isGIF <- FALSE if (isPNG <- fileext %in% c("png")) a <- try(255*png::readPNG(fname),silent=!verbose) - else if (isJPEG <- fileext %in% c("jpg","jpeg")) + else if (isJPEG <- fileext %in% c("jpg","jpeg")) { + if (!requireNamespace("jpeg",quietly=.isPackageInUse())) + stop("Suggested package 'jpeg' missed, but is required here.") a <- try(255*jpeg::readJPEG(fname),silent=!verbose) + } else { a <- try(255*png::readPNG(fname),silent=!verbose) if (inherits(a,"try-error")) { diff --git a/R/yyy.util.R b/R/yyy.util.R index 9dab362..eb8610b 100644 --- a/R/yyy.util.R +++ b/R/yyy.util.R @@ -443,7 +443,8 @@ '.isRscript' <- function() .lgrep("^(--file=|-f$|-e$|--hiddenslave$)",commandArgs(FALSE))>=1 #'.isPackageInUse.deprecated' <- function() "ursa" %in% loadedNamespaces() '.isPackageInUse' <- function(verbose=FALSE) { - cond1 <- "package:ursa" %in% search() + if (is.logical(piu <- getOption("ursaPackageInUse"))) + return(piu) cond2 <- "ursa" %in% loadedNamespaces() cond3 <- !("plEnviron" %in% search()) # ret <- (cond1)&&(cond2) @@ -451,6 +452,7 @@ if (verbose) { print(search()) print(loadedNamespaces()) + cond1 <- "package:ursa" %in% search() print(c(cond1=cond1,cond2=cond2,cond3=cond3,ret=ret)) } ret diff --git a/inst/requisite/coast-l.rds b/inst/requisite/coast-l.rds index c1c85f6..7d31c92 100644 Binary files a/inst/requisite/coast-l.rds and b/inst/requisite/coast-l.rds differ diff --git a/man/conn.create_any.Rd b/man/conn.create_any.Rd index 3295242..20684d2 100644 --- a/man/conn.create_any.Rd +++ b/man/conn.create_any.Rd @@ -8,7 +8,8 @@ Create ENVI or GDAL files on disk %% ~~ A concise (1-5 lines) description of what the function does. ~~ \code{create_envi} creates ENVI binary and header files on disk. ENVI binary file is filled by blank (zero) values. \cr -\code{create_gdal} is a wrapper for creating new object of class \code{\link[rgdal:GDALTransientDataset-class]{GDALTransientDataset}}. +%%~ \code{create_gdal} is a wrapper for creating new object of class \code{\link[rgdal:GDALTransientDataset-class]{GDALTransientDataset}}. +\code{create_gdal} is just an entry for GDAL wrapper; currently via internal ENVI implementation. } \usage{ create_gdal(x, ...) @@ -27,6 +28,9 @@ Use \code{name = value} sequence. Properties of new ENVI file are extracted from } } \details{ + +Prior \pkg{ursa} version < 3.10, \code{create_gdal()} used classes and methods from package \pkg{rgdal}. Currenty, alternatives are not found for complete replacement of \pkg{rgdal}. At the present, ENVI binary and header are created, firstly, and \code{\link[ursa:classRaster_close]{close()}} transforms to desired GDAL format, finally. + \code{create_envi} and \code{create_gdal} use parameters of grid (boundary box, cell size, projection) from reference object of class \code{ursaRaster} in argument \code{x} or calls \code{\link[ursa:session]{session_grid}}. You may specify values of GDAL or ENVI binary file later using \code{\link[ursa:classRaster.Replace]{[<-}}. If \code{x} is object of class \code{ursaRaster} then metadata parameters (interleave, data type, ignore value, etc) are inherited. Keywords: diff --git a/man/conn.open_gdal.Rd b/man/conn.open_gdal.Rd index e31bc6d..4122be0 100644 --- a/man/conn.open_gdal.Rd +++ b/man/conn.open_gdal.Rd @@ -8,7 +8,7 @@ Open GDAL file \code{open_gdal} creates object of \code{ursaRaster} class, and prepares \code{\link[base]{connections}} for data reading. } \usage{ -open_gdal(fname, verbose = FALSE) +open_gdal(fname, engine=c("native", "sf", "gdalraster", "vapour"), verbose = FALSE) ursa_open(fname, verbose = FALSE) @@ -17,6 +17,10 @@ ursa_open(fname, verbose = FALSE) \arguments{ \item{fname}{ Character. Filename; full-name or short-name. +} + \item{engine}{ +Character. Functionality of which package is used for reading data. This is experimental list, which future depends on evolution of reviewed packages and their availability for partial reading of multiband rasters. + } \item{verbose}{ Logical. \code{verbose=TRUE} provides some additional information on console. Default is \code{FALSE}. @@ -56,13 +60,18 @@ Nikita Platonov \email{platonov@sevin.ru} \examples{ session_grid(NULL) -fname1 <- system.file("pictures/cea.tif",package="rgdal") +# fname1 <- system.file("pictures/cea.tif",package="rgdal") +fname1 <- system.file("tif/geomatrix.tif",package="sf") message(fname1) a1 <- open_gdal(fname1) print(a1) print(a1[]) close(a1) -fname2 <- system.file("pictures/test_envi_class.envi",package="rgdal") +# fname2 <- system.file("pictures/test_envi_class.envi",package="rgdal") +fname2 <- tempfile(fileext=".") +a <- ursa_dummy(1,resetGrid=TRUE) +b <- colorize(a[a>91],stretch="equal",name=format(Sys.Date()+seq(0,6),"\%A \%d")) +write_envi(b,fname2) message(fname2) b1 <- open_gdal(fname2) b2 <- open_envi(fname2) @@ -71,6 +80,7 @@ print(b2) print(c('The same grid?'=identical(ursa_grid(b1),ursa_grid(b2)) ,'The same data?'=identical(ursa_value(b1[]),ursa_value(b2[])))) close(b1,b2) +envi_remove(fname2) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. diff --git a/man/conn.read_gdal.Rd b/man/conn.read_gdal.Rd index 9d3b83c..6074874 100644 --- a/man/conn.read_gdal.Rd +++ b/man/conn.read_gdal.Rd @@ -5,10 +5,11 @@ Read GDAL supported raster files. } \description{ -\code{read_gdal} creates \code{ursaRaster} object from GDAL supported raster files using functions from \pkg{rgdal} packages. +\code{read_gdal} creates \code{ursaRaster} object from GDAL supported raster files using functions from packages with low-level raster reading. } \usage{ -read_gdal(fname, resetGrid = TRUE, band = NULL, engine = c("native", "rgdal", "sf"), +read_gdal(fname, resetGrid = TRUE, band = NULL, + engine = c("native", "sf", "gdalraster", "vapour"), verbose = FALSE, ...) ursa_read(fname, verbose = FALSE) @@ -25,7 +26,8 @@ Logical. If \code{TRUE} then new sessional grid is based on opened raster image. Character (\link[base:regex]{regular expression}) or integer. } \item{engine}{ -Character. Functionality of which package is used for reading data. If partial data (\code{band} is not \code{NULL}), then \code{engine} is \code{"rgdal"}. If value is \code{"sf"} and no partial data reading then \code{sf::gdal_read()} is used before importing. If value is \code{"rgdal"} or partial data reading, then interaction with \pkg{rgdal} is used. Currently, \code{"native"} is similar to \code{"rgdal"}, but in next versions behaviour can be changed to engine selection depends on which namespace has already loaded or has suggested package \pkg{sf} been installed. +Character. Functionality of which package is used for reading data. This is experimental list, which future depends on evolution of reviewed packages and their availability for partial reading of multiband rasters. +%%~ Character. Functionality of which package is used for reading data. If partial data (\code{band} is not \code{NULL}), then \code{engine} is \code{"rgdal"}. If value is \code{"sf"} and no partial data reading then \code{sf::gdal_read()} is used before importing. If value is \code{"rgdal"} or partial data reading, then interaction with \pkg{rgdal} is used. Currently, \code{"native"} is similar to \code{"rgdal"}, but in next versions behaviour can be changed to engine selection depends on which namespace has already loaded or has suggested package \pkg{sf} been installed. } \item{verbose}{ Logical. Value \code{TRUE} may provide some additional information on console. Default is \code{FALSE}. @@ -39,11 +41,11 @@ Ignored. The composite GDAL formats (e.g., \href{https://gdal.org/drivers/raster/netcdf.html}{NetCDF: Network Common Data Format}, \href{https://gdal.org/drivers/raster/hdf5.html}{HDF5: Hierarchical Data Format Release 5}) are likely unsupported. -\code{read_gdal} uses functions from \pkg{rgdal}: -\itemize{ - \item\code{\link[rgdal:readGDAL]{GDALinfo}} - to get raster metadata. - \item\code{\link[rgdal:GDALRasterBand-class]{getRasterData}} - to get raster data. -} +\code{read_gdal} uses functions from other other packages. It's a wrapper. +%%~ \itemize{ +%%~ \item\code{\link[rgdal:readGDAL]{GDALinfo}} - to get raster metadata. +%%~ \item\code{\link[rgdal:GDALRasterBand-class]{getRasterData}} - to get raster data. +%%~ } Category names and color tables are supported. } @@ -62,22 +64,30 @@ Nikita Platonov \email{platonov@sevin.ru} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ -\code{\link[rgdal:readGDAL]{rgdal::GDALinfo()}} for supported GDAL raster formats +%%~ \code{\link[rgdal:readGDAL]{rgdal::GDALinfo()}} for supported GDAL raster formats \code{\link[ursa:ursa_as]{as.ursa}} is an alternative call for GDAL raster files import. } \examples{ session_grid(NULL) -rgdal::gdalDrivers() -Fin1 <- system.file("pictures/Rlogo.jpg",package="rgdal") +# rgdal::gdalDrivers() +if (requireNamespace("sf")) + print(sf::st_drivers()) +# Fin1 <- system.file("pictures/Rlogo.jpg",package="rgdal") +Fin1 <- system.file("img/Rlogo.png",package="png") a1 <- read_gdal(Fin1) print(a1) display(a1) -Fin2 <- system.file("pictures/test_envi_class.envi",package="rgdal") +# Fin2 <- system.file("pictures/test_envi_class.envi",package="rgdal") +Fin2 <- tempfile(fileext=".") +a <- ursa_dummy(1,resetGrid=TRUE) +b <- colorize(a[a>91],stretch="equal",name=format(Sys.Date()+seq(0,6),"\%A \%d")) +write_envi(b,Fin2) b1 <- read_gdal(Fin2) b2 <- read_envi(Fin2,resetGrid=TRUE) +envi_remove(Fin2) print(identical(ursa_grid(b1),ursa_grid(b2))) print(identical(ursa_value(b1),ursa_value(b2))) print(identical(ursa_colortable(b1),ursa_colortable(b2))) diff --git a/man/glance.Rd b/man/glance.Rd index 12aef33..cae7a3c 100644 --- a/man/glance.Rd +++ b/man/glance.Rd @@ -158,8 +158,8 @@ Package \pkg{sf} is 'Suggested' for package \pkg{ursa}. %%~ } \examples{ session_grid(NULL) -f <- system.file("vectors","scot_BNG.shp",package="rgdal") -glance(f,style="merc",field="(NAME|COUNT)") +f <- system.file("shape/nc.shp",package="sf") +glance(f,style="merc",field="(NAME|AREA|COUNT)") cmd <- paste("Rscript --vanilla -e ursa::glance()",paste0("\"",f,"\"") ,"style=\"merc\"","field=\"(lon|lat)\"") cat(" --------- Try in command line: -----------\n") diff --git a/man/panel_plot.Rd b/man/panel_plot.Rd index e476bcc..4da05b7 100644 --- a/man/panel_plot.Rd +++ b/man/panel_plot.Rd @@ -80,7 +80,7 @@ Package \pkg{graphics} (\code{help(package="graphics")}) and functions \code{\li } \examples{ session_grid(NULL) -require(rgdal) +# require(rgdal) ## 'rgdal is retired' a <- pixelsize() g1 <- session_grid() n <- 12L diff --git a/man/spatial_engine.Rd b/man/spatial_engine.Rd index 9ce9db7..fe4443d 100644 --- a/man/spatial_engine.Rd +++ b/man/spatial_engine.Rd @@ -162,10 +162,14 @@ See description of argument \code{recirsive} in function \code{\link[base:list.f See description of argument \code{ignore.case} in function \code{\link[base:list.files]{dir}}. } \item{quadsegs}{ -Integer. Number of segments per quadrant (fourth of a circle), for all or per-feature. See description for \code{quadsegs} argument of \code{\link[rgeos:rgeos-deprecated]{gBuffer}} (NOTE: deprecated after \pkg{rgeos} v.0.6-1) and for \code{nQuadSegs} argument of \code{\link[sf:geos_unary]{st_buffer}}. +Integer. Number of segments per quadrant (fourth of a circle), for all or per-feature. See description +%%~ for \code{quadsegs} argument of \code{\link[rgeos:rgeos-deprecated]{gBuffer}} (NOTE: deprecated after \pkg{rgeos} v.0.6-1) and +for \code{nQuadSegs} argument of \code{\link[sf:geos_unary]{st_buffer}}. } \item{dist}{ -Numeric. Buffer distance for all, or for each of the elements. See description for \code{width} argument of \code{\link[rgeos:rgeos-deprecated]{gBuffer}} (NOTE: deprecated after \pkg{rgeos} v.0.6-1) and for \code{dist} argument of \code{\link[sf:geos_unary]{st_buffer}}. +Numeric. Buffer distance for all, or for each of the elements. See description +%%~ for \code{width} argument of \code{\link[rgeos:rgeos-deprecated]{gBuffer}} (NOTE: deprecated after \pkg{rgeos} v.0.6-1) and +for \code{dist} argument of \code{\link[sf:geos_unary]{st_buffer}}. } \item{byid}{ Logical. For \code{spatial_union} function, \code{TRUE} does unite of each feature; \code{FALSE} returns a single feature that is the geometric union of the set of features; default \code{NA} is coerced to \code{FALSE} for unary operation (missing \code{y}) and to \code{TRUE} for binary operation. diff --git a/man/spatial_levelsplit.Rd b/man/spatial_levelsplit.Rd index d9eacad..64384b8 100644 --- a/man/spatial_levelsplit.Rd +++ b/man/spatial_levelsplit.Rd @@ -31,9 +31,7 @@ Nikita Platonov \email{platonov@sevin.ru} palette("Set3") radius <- seq(1,length.out=5,by=1)*200 ct <- ursa_colortable(colorize(radius,alpha=0.5,pal=sample(palette(),length(radius)))) -origin <- data.frame(lon=139.2,lat=36.6) -sp::coordinates(origin) <- ~lon+lat -sp::proj4string(origin) <- "EPSG:4326" +origin <- sf::st_sfc(sf::st_point(c(lon=139.2,lat=36.6)),crs=4326) origin <- spatial_transform(origin,"EPSG:6671") isopoly <- do.call(spatial_bind,lapply(radius*1e3,function(r) spatial_buffer(origin,r))) spatial_data(isopoly) <- data.frame(radius=radius) diff --git a/man/spatial_read.Rd b/man/spatial_read.Rd index 6d98d83..82cf94f 100644 --- a/man/spatial_read.Rd +++ b/man/spatial_read.Rd @@ -4,24 +4,30 @@ Wrapper functions for reading spatial objects. } \description{ -Read either simple features (package \pkg{sf}) and abstract of class Spatial (package \pkg{sp}) from disk using appropriate functionality (\emph{\dQuote{engine}}) of respective packages is used. +Read either simple features (package \pkg{sf}) +%%~ and abstract of class Spatial (package \pkg{sp}) +from disk using appropriate functionality (\emph{\dQuote{engine}}) of respective packages is used. } \usage{ -spatial_read(dsn, engine = c("native", "sp", "sf", "geojsonsf")) +spatial_read(dsn, engine = c("native", "sf", "geojsonsf")) } \arguments{ \item{dsn}{ Character. File name of spatial object (vector GIS). } \item{engine}{ -Character. Functionality of which package is used for reading data. If value is \code{"sf"}, then package \pkg{sf} is used and simple features are returned. If value is \code{"geojsonsf"}, GDAL driver is GeoJSON and package \pkg{geojsonsf} can be loaded, then package \pkg{geojsonsf} is used and simple features are returned. If value is \code{"sp"}, then package \pkg{rgdal} is used and Spatial abstracts (package \pkg{sp}) are returned. If value is \code{"native"} then engine selection depends on has suggested package \pkg{sf} been installed and is there possibility to use \pkg{geosonjf} for GeoJSON driver. If these checks are failed then package \pkg{rgdal} is used and Spatial abstracts (package \pkg{sp}) are returned. +Character. Functionality of which package is used for reading data. If value is \code{"sf"}, then package \pkg{sf} is used and simple features are returned. If value is \code{"geojsonsf"}, GDAL driver is GeoJSON and package \pkg{geojsonsf} can be loaded, then package \pkg{geojsonsf} is used and simple features are returned. +%%~ If value is \code{"sp"}, then package \pkg{rgdal} is used and Spatial abstracts (package \pkg{sp}) are returned. +If value is \code{"native"} then engine selection depends on has suggested package \pkg{sf} been installed and is there possibility to use \pkg{geosonjf} for GeoJSON driver. +%%~ If these checks are failed then package \pkg{rgdal} is used and Spatial abstracts (package \pkg{sp}) are returned. } } \details{ Currently, list of arguments of this funtion is simplified and can be expanded. } \value{ -Depending of used engine, either simple features (package \pkg{sf}) or Spatial abstracts (\pkg{sp}). +%%~ Depending of used engine, either simple features (package \pkg{sf}) or Spatial abstracts (\pkg{sp}). +Object of Simple Features (package \pkg{sf}). } \author{ Nikita Platonov \email{platonov@sevin.ru} @@ -31,9 +37,10 @@ Nikita Platonov \email{platonov@sevin.ru} } \seealso{ -\code{\link[sf:st_read]{read_sf}} (valid if package \pkg{sf} is installed) +\code{\link[sf:st_read]{read_sf}} +%%~ (valid if package \pkg{sf} is installed) -\code{\link[rgdal:readOGR]{readOGR}} (package \pkg{rgdal}) +%%~ \code{\link[rgdal:readOGR]{readOGR}} (package \pkg{rgdal}) \code{\link[ursa:spatial_write]{spatial_write}} } @@ -53,18 +60,6 @@ if (requireNamespace("sf",quietly=TRUE)) { res1 <- spatial_read(fname1,engine="sf") print(series(res1)) } -if (requireNamespace("sp")) { - obj2 <- da - sp::coordinates(obj2) <- c("x","y") - sp::proj4string(obj2) <- sp::CRS("+init=epsg:4326") - print(series(obj2)) - print(spatial_crs(obj2)) - fname2 <- file.path(tempdir(),"res2.shp") - print(fname2) - spatial_write(obj2,fname2) - res2 <- spatial_read(fname2,engine="sp") - print(series(obj2)) -} print(spatial_dir(tempdir())) } \keyword{attribute} diff --git a/man/spatial_write.Rd b/man/spatial_write.Rd index 4551df3..252db15 100644 --- a/man/spatial_write.Rd +++ b/man/spatial_write.Rd @@ -4,7 +4,8 @@ Wrapper functions for writing spatial objects. } \description{ -Write spatial object to disk. If spatial object is Simple Features, then appropriate functions from package \pkg{sf} are used. If spatial objest are abstract of class Spatial then appropriate functions from packages \pkg{sp} and \pkg{rgdal} are used. +Write spatial object to disk. If spatial object is Simple Features, then appropriate functions from package \pkg{sf} are used. +%%~ If spatial objest are abstract of class Spatial then appropriate functions from packages \pkg{sp} and \pkg{rgdal} are used. } \usage{ @@ -14,7 +15,11 @@ spatial_write(obj, fname, layer, driver = NA, compress = "", %- maybe also 'usage' for other objects documented here. \arguments{ \item{obj}{ -Spatial object: either Simple Features (\pkg{sf}) or Spatial Abstract (\pkg{sp}). \link[base:list]{List} of spatial objects can be used. +Spatial object: +%%~ either +Simple Features (\pkg{sf}). +%%~ or Spatial Abstract (\pkg{sp}). +\link[base:list]{List} of spatial objects can be used. } \item{fname}{ Character. File name with or without extension. If extension is missed, then argument \code{driver} must be specified. @@ -36,7 +41,9 @@ Logical. Value \code{TRUE} provides information on console. Default is \code{FAL } } \details{ -Based on \code{\link[sf:st_write]{sf::st_write}} and \code{\link[rgdal:writeOGR]{rgdal::writeOGR}} functions with additonal options: compressing of output file(s), coordinates trasforming (to longitudes and latitudes for \code{driver="GeoJSON"}), creating multi-layer destination (for \code{driver="SQLite"}). +Based on \code{\link[sf:st_write]{sf::st_write}} +%~ and \code{\link[rgdal:writeOGR]{rgdal::writeOGR}} +function with additonal options: compressing of output file(s), coordinates trasforming (to longitudes and latitudes for \code{driver="GeoJSON"}), creating multi-layer destination (for \code{driver="SQLite"}). } \value{ invisible \code{NULL}. @@ -46,9 +53,10 @@ Nikita Platonov \email{platonov@sevin.ru} } \seealso{ -\code{\link[sf:st_write]{write_sf}} (valid if package \pkg{sf} is installed) +\code{\link[sf:st_write]{write_sf}} +%%~ (valid if package \pkg{sf} is installed) -\code{\link[rgdal:writeOGR]{writeOGR}} (package \pkg{rgdal}) +%%~ \code{\link[rgdal:writeOGR]{writeOGR}} (package \pkg{rgdal}) \code{\link[ursa:spatial_read]{spatial_read}} } @@ -68,18 +76,6 @@ if (requireNamespace("sf",quietly=TRUE)) { res1 <- spatial_read(fname1,engine="sf") print(series(res1)) } -if (requireNamespace("sp")) { - obj2 <- da - sp::coordinates(obj2) <- c("x","y") - sp::proj4string(obj2) <- sp::CRS("+init=epsg:4326") - print(series(obj2)) - print(spatial_crs(obj2)) - fname2 <- file.path(tempdir(),"res2.shp") - print(fname2) - spatial_write(obj2,fname2) - res2 <- spatial_read(fname2,engine="sp") - print(series(obj2)) -} print(spatial_dir(tempdir())) } \keyword{attribute} diff --git a/man/ursa_as.Rd b/man/ursa_as.Rd index b8f14e2..7cf9c64 100644 --- a/man/ursa_as.Rd +++ b/man/ursa_as.Rd @@ -143,9 +143,10 @@ print(b5b) display(b5b) } ## to avoid over-timing during tests -- end -b6 <- as.ursa(system.file("pictures/erdas_spnad83.tif",package="rgdal")) +# b6 <- as.ursa(system.file("pictures/erdas_spnad83.tif",package="rgdal")) +b6 <- as.ursa(system.file("tif/geomatrix.tif",package="sf")) print(b6) -display(b6,coast=FALSE,col="orange") +display(b6,pal=c("black","white"),coast=FALSE,col="orange") \donttest{ ## package 'raster' is required -- begin if (requireNamespace("raster")) { diff --git a/man/ursa_proj.Rd b/man/ursa_proj.Rd index 05712d1..447cb31 100644 --- a/man/ursa_proj.Rd +++ b/man/ursa_proj.Rd @@ -62,7 +62,7 @@ fname <- tempfile() write_envi(a,fname) a2 <- read_envi(fname,resetGrid=TRUE) print(ursa_crs(a2)) -try(print(rgdal::CRSargs(sp::CRS(p4s)))) +# try(print(rgdal::CRSargs(sp::CRS(p4s)))) ## 'rgdal' is retired envi_remove(fname) } % Add one or more standard keywords, see file 'KEYWORDS' in the diff --git a/src/symbols.rds b/src/symbols.rds new file mode 100644 index 0000000..ebbb935 Binary files /dev/null and b/src/symbols.rds differ