From 2381e8b39b370074bc32bca7d36d271fdbd9f069 Mon Sep 17 00:00:00 2001 From: nplatonov Date: Sun, 5 May 2024 19:13:18 +0300 Subject: [PATCH] 3.11.0-1093 --- .Rbuildignore | 2 + .counter | 1 + DESCRIPTION | 6 +- NAMESPACE | 5 +- NEWS.md | 40 ++- R/Ops.local_group.R | 6 +- R/_RogerBivand.R | 16 +- R/_rename20a660d5.R | 25 +- R/_ursa_install.R | 35 ++- R/allocate.R | 8 +- R/classCRS.R | 427 ++++++++++++++++++++++++++++ R/classColorTable.R | 6 + R/classConnection.R | 2 +- R/classGrid.R | 4 +- R/classRaster.Extract.R | 1 + R/classRaster.Replace.R | 42 ++- R/classRaster_as.data.frame.R | 2 +- R/classRaster_close.R | 5 +- R/colorize.R | 11 +- R/compose_close.R | 18 +- R/compose_design.R | 35 ++- R/compose_open.R | 63 ++-- R/compose_panel.R | 2 +- R/conn.open_envi.R | 29 +- R/conn.open_gdal.R | 4 +- R/conn.read_gdal.R | 43 ++- R/conn.read_stars.R | 0 R/conn.write_gdal.R | 101 +++++-- R/display.R | 8 +- R/envi_files.R | 25 +- R/get_earthdata.R | 45 ++- R/glance.R | 25 +- R/identify.R | 5 + R/package_gdalraster.R | 19 +- R/package_proj4.R | 13 + R/package_sf.R | 82 ++++-- R/package_vapour.R | 23 +- R/panel_annotation.R | 14 +- R/panel_coastline.R | 100 ++++--- R/panel_graticule.R | 305 ++++++++++++-------- R/panel_new.R | 82 ++++-- R/panel_plot.R | 25 +- R/panel_raster.R | 23 +- R/panel_scalebar.R | 10 +- R/pixelsize.R | 7 +- R/polygonize.R | 10 +- R/progressBar.R | 1 + R/reclass.R | 32 ++- R/regrid.R | 82 ++++-- R/session.R | 19 +- R/spatial_engine.R | 115 ++++++-- R/spatial_read.R | 2 +- R/spatial_write.R | 98 +++++-- R/{segmentize.R => trackline.R} | 8 +- R/ursa_as.R | 48 ++-- R/{ursa_proj.R => ursa_crs.R} | 7 +- R/ursa_grid.R | 35 ++- R/ursa_new.R | 2 +- R/whiteboxing.R | 2 +- R/xxx.gdal_rasterize.R | 17 +- R/xxx.gdalwarp.R | 27 +- R/xxx.geomap.R | 34 ++- R/xxx.ncdf.R | 2 +- R/xxx.panel_WMS.R | 22 +- R/xxx.panel_cluster.R | 29 +- R/xxx.polarmap.R | 10 +- R/xxx.spatialize.R | 232 +++++++++++---- R/yyy.RogerBivand.R | 15 +- R/yyy.cache.R | 15 +- R/yyy.connection.R | 16 +- R/yyy.crop.R | 22 +- R/yyy.getPrm.R | 24 +- R/yyy.plot.R | 2 +- R/yyy.project.R | 137 +++++++-- R/yyy.tile.R | 88 ++++-- R/yyy.util.R | 50 +--- R/zzz.R | 13 +- inst/requisite/template.hdr | 4 +- man/___prompt.R | 2 +- man/classCRS.Rd | 52 ++++ man/classRaster.Replace.Rd | 2 +- man/colorize.Rd | 4 +- man/compose_design.Rd | 7 +- man/conn.read_gdal.Rd | 28 +- man/conn.write_gdal.Rd | 11 +- man/glance.Rd | 25 +- man/panel_new.Rd | 15 +- man/panel_plot.Rd | 57 ++-- man/panel_scalebar.Rd | 2 +- man/polygonize.Rd | 13 +- man/spatial_engine.Rd | 12 +- man/spatial_read.Rd | 8 +- man/spatial_write.Rd | 18 +- man/{segmentize.Rd => trackline.Rd} | 19 +- man/{ursa_proj.Rd => ursa_crs.Rd} | 0 man/ursa_new.Rd | 2 +- man/whiteboxing.Rd | 3 +- 97 files changed, 2405 insertions(+), 845 deletions(-) create mode 100644 .counter create mode 100644 R/classCRS.R delete mode 100644 R/conn.read_stars.R create mode 100644 R/package_proj4.R rename R/{segmentize.R => trackline.R} (94%) rename R/{ursa_proj.R => ursa_crs.R} (88%) create mode 100644 man/classCRS.Rd rename man/{segmentize.Rd => trackline.Rd} (79%) rename man/{ursa_proj.Rd => ursa_crs.Rd} (100%) diff --git a/.Rbuildignore b/.Rbuildignore index ef831c9..3a181b3 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,5 @@ ^\.github$ +^\.git$ ^src/ursa.dll$ +^src/ursa.o$ ^.git.*$ diff --git a/.counter b/.counter new file mode 100644 index 0000000..cf23797 --- /dev/null +++ b/.counter @@ -0,0 +1 @@ +1094 diff --git a/DESCRIPTION b/DESCRIPTION index 70235a3..4c198ed 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: ursa Type: Package Title: Non-Interactive Spatial Tools for Raster Processing and Visualization -Version: 3.10.5 +Version: 3.11.0-1093 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 @@ -10,8 +10,8 @@ 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, sf (>= 0.6-1), png -Suggests: jsonlite, 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, whitebox +Imports: utils, graphics, grDevices, stats, sf (>= 0.6-1) +Suggests: jsonlite, proj4, raster, ncdf4, locfit, knitr, rmarkdown, tcltk, sp, methods, fasterize, IRdisplay, caTools, shiny, tools, png, jpeg, webp, htmlwidgets, htmltools, leaflet, leafem, leafpop, RColorBrewer, ragg, widgetframe, geojsonsf (>= 2.0.0), leaflet.providers, magick, terra, stars, vapour, gdalraster, sys, RSQLite, whitebox NeedsCompilation: yes ByteCompile: no diff --git a/NAMESPACE b/NAMESPACE index 9a12c25..11f342f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -132,7 +132,6 @@ export("read_envi") export("read_gdal") export("reclass") export("regrid") -export("segmentize") export("series") export("session_bbox") export("session_cellsize") @@ -156,6 +155,7 @@ export("spatial_colnames") export("spatial_colnames<-") export("spatial_coordinates") export("spatial_count") +export("spatial_crop") export("spatial_crs") export("spatial_crs<-") export("spatial_data") @@ -191,6 +191,7 @@ export("spatial_valid") export("spatial_write") export("temporal_interpolate") export("temporal_mean") +export("trackline") export("update_coastline") export("ursa") export("ursa_apply") @@ -293,6 +294,7 @@ S3method("plot",ursaRaster) S3method("print",ursaCategory) S3method("print",ursaColorTable) S3method("print",ursaConnection) +S3method("print",ursaCRS) S3method("print",ursaGrid) S3method("print",ursaNumeric) S3method("print",ursaRaster) @@ -302,6 +304,7 @@ S3method("seek",ursaConnection) S3method("seq",ursaGrid) S3method("seq",ursaRaster) S3method("sort",ursaRaster) +S3method("str",ursaCRS) S3method("str",ursaGrid) S3method("str",ursaRaster) S3method("summary",ursaCategory) diff --git a/NEWS.md b/NEWS.md index d443099..ade4156 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,16 +1,36 @@ -2024-01-12 +2024-02-13 -### Version 3.10.5 +### Version 3.11.1 - ongoing… -- Package **`proj4`** is removed from ‘Suggests’. +- In function `colorize()` default value of argument `lazyload` is + changed from `FALSE` to `TRUE` to speed-up rendering large rasters. + +- Plotting doesn’t affect sessional grid. + +- Layout matrix can be specified directly (argument `layout` in + `compose_design()` and superior functions). + +- Package start-up initializes `options(ursaProj4Legacy=TRUE)` to keep + using PROJ4, primarely, for printing. This initialization is skipped + if `ursaProj4Legacy` option was assigned before package loading. + +- Package **`png`** is added to ‘Suggests’ (from ‘Imports’). + + + +### Version 3.11 (interim) + +- MAJOR: WKT as well as PROJ4 is used for coordinate reference + systems. ### Version 3.10.4 @@ -65,7 +85,7 @@ - Package **`RSQLite`** is added as suggested for using map tiles from specified directory of SAS Planet cache -- In `segmentize()` 1) improved response of `by` argument, 2) order of +- In `trackline()` 1) improved response of `by` argument, 2) order of `type` argument is reversed to `c("united","conseqwent")` - Coastline is updated to version 2023-08-24T03:31. @@ -110,7 +130,7 @@ - New argunent `expand` in function `ursa_crop()` for spatial expansion using relative value. -- New argument `by` in function `segmentize()` to split segments by +- New argument `by` in function `trackline()` to split segments by specified field name. - New function `spatial_levelsplit()` trasforms nested polygons (e.g., @@ -158,13 +178,13 @@ ### Version 3.9.4 -- Fixed example of `segmentize()` for non-Windows systems. +- Fixed example of `trackline()` for non-Windows systems. ### Version 3.9.3 - Test building for R 4.1.0. -- New function `segmentize()` to connect sequence of spatial points to +- New function `trackline()` to connect sequence of spatial points to line segments. - New return value `ursaLegend` in function `panel_plot()` for spatial @@ -174,8 +194,8 @@ - New arguments `...` in function `session_grid()` for preliminary passing to `regrid()`. -- New argument `connect` in function `segmentize()` for creating - either solid multi-segment or multiple consequent segments. +- New argument `connect` in function `trackline()` for creating either + solid multi-segment or multiple consequent segments. - Patterned argument `vertical` in function `panel_annnotation()` can be numeric (degrees on label inclination). diff --git a/R/Ops.local_group.R b/R/Ops.local_group.R index c696e16..e67e203 100644 --- a/R/Ops.local_group.R +++ b/R/Ops.local_group.R @@ -90,17 +90,17 @@ ,x=as.numeric(x$value),bg=as.numeric(nodata) ,dim=as.integer(dimx),cover=as.numeric(cover) ,weight=weight,sum=as.integer(sum) - ,res=numeric(dimx[1]*1L),NAOK=FALSE) + ,res=numeric(dimx[1]*1L),NAOK=FALSE)$res if (verbose) .elapsedTime(paste(fun,"stop",sep=":")) if (is.na(x$con$posR[1])) { - obj$value[] <- a$res + obj$value[] <- a class(obj$value) <- "ursaNumeric" } else { obj$con$posR <- x$con$posR - obj$value <- a$res + obj$value <- a dim(obj$value) <- c(dimx[1],1) } if (abs(nodata)<1) diff --git a/R/_RogerBivand.R b/R/_RogerBivand.R index c505cea..6375b5a 100644 --- a/R/_RogerBivand.R +++ b/R/_RogerBivand.R @@ -65,6 +65,7 @@ g1$crs <- attr(a,"projection") if (is.na(g1$crs)) g1$crs <- "" + g1$crs <- .ursaCRS(g1$crs) b1 <- .grep("band",attr(a,"mdata"),value=TRUE) patt <- "^Band_(\\d+)=\\t*(.+)$" bname <- .gsub(patt,"\\2",b1) @@ -555,18 +556,3 @@ .DeadEnd() rgeos::gIsValid(...) } -'.proj4_requireNamespace' <- function(...) { - if (isTRUE(getOption("ursaPackageInUse"))) - .Retired() - requireNamespace("proj4",quietly=.isPackageInUse()) -} -'.proj4_project' <- function(...) { - if (isTRUE(getOption("ursaPackageInUse"))) - .Retired() - proj4::project(...) -} -'.proj4_ptransform' <- function(...) { - if (isTRUE(getOption("ursaPackageInUse"))) - .Retired() - proj4::ptransform(...) -} diff --git a/R/_rename20a660d5.R b/R/_rename20a660d5.R index 9cb17bc..e38d31b 100644 --- a/R/_rename20a660d5.R +++ b/R/_rename20a660d5.R @@ -17,9 +17,9 @@ src <- "\\$proj(4)*" dst <- "$crs" } - else if (stage2 <- F) { - src <- "crsstring" - dst <- "proj4string" + else if (stage2 <- T) { + src <- "sleeping\\(" + dst <- "verbosing\\(" } else if (stage3 <- F) { src <- "proj4=" @@ -33,15 +33,21 @@ src <- "crs==" dst <- "ZZZ==" } - else if (stage6 <- T) { - src <- ".DeadRoad" - dst <- ".DeadEnd" + else if (stage6 <- F) { + if (step1 <- T) { + src <- "segmentize" + dst <- "trackline" + } + else { + src <- "st_trackline" + dst <- "st_segmentize" + } } else { stop("please select stage") } toWrite <- FALSE - ind <- "1" # as.character(c(1,2,3,4,5,6,7,8,9,10,11,12)) + ind <- 11 # as.character(c(1,2,3,4,5,6,7,8,9,10,11,12)) dpath1 <- c('1'="C:/platt/R/ursa-package/ursa/R" ,'2'="C:/platt/R/ursa-package/ursa/man" ,'3'="C:/platt/R/ursa-package/example" @@ -53,8 +59,8 @@ ,'8'="D:/DATA" ,'9'="D:/NRT" ,'10'="D:/update" - ,'11'="D:/RAS/2020" - ,'12'="D:/RAS/2019" + ,'11'="D:/RAS/2024" + ,'12'="D:/RAS/2023" ) ind1 <- which(names(dpath1) %in% ind) ind2 <- which(names(dpath2) %in% ind) @@ -101,3 +107,4 @@ invisible({ rm(.a) NULL }) +warnings() diff --git a/R/_ursa_install.R b/R/_ursa_install.R index 97fa057..8e7ae44 100644 --- a/R/_ursa_install.R +++ b/R/_ursa_install.R @@ -8,7 +8,7 @@ list2 <- ls(envir=ns) unloadNamespace(ns) list2 <- grep("^[A-Za-z]",list2,value=TRUE) - list2 <- grep("\\.(ursa(Raster|Grid|ColorTable|Connection|Numeric|Category|Stack|ProgressBar))" + list2 <- grep("\\.(ursa(Raster|Grid|CRS|ColorTable|Connection|Numeric|Category|Stack|ProgressBar))" ,list2,value=TRUE,invert=TRUE) list2 <- grep("^(as\\.Raster|djqwotrhfndh)\\.",list2,value=TRUE,invert=TRUE) if (length(list3 <- grep("^C_.+",list2,value=TRUE,invert=FALSE))) { @@ -115,6 +115,12 @@ } '.buildAndInstall' <- function() { wd <- setwd("C:/platt/R/ursa-package");on.exit(setwd(wd)) + src <- "ursa/DESCRIPTION" + dst <- tempfile() + file.copy(src,dst) + wd2 <- setwd("news") + source("versionConsistence.R") + setwd(wd2) if (requireNamespace("tools")) { toWrite <- TRUE md5fname <- "ursa/R/_md5" @@ -132,17 +138,37 @@ if (toWrite) write.table(new,md5fname,quote=FALSE ,col.names=FALSE,row.names=FALSE) - else + else { + cat("`ursa` is up-to-date\n") + file.rename(dst,src) return(NULL) + } } if (requireNamespace("ursa")) stopifnot(!.generate_namespace(verbose=FALSE)) patt <- "^ursa_.*(\\.tar\\.gz|\\.zip)$" nul <- file.remove(dir(pattern=patt)) + desc <- readLines(src) + pattV <- "^(Version:\\s*)(\\S+)\\s*$" + if (subVersion <- length(indC <- grep(pattV,desc))>0) { + cfile <- "ursa/.counter" + ver <- unlist(package_version(gsub(pattV,"\\2",desc[indC]))) + if (length(ver)==3) + ver[3] <- ver[3]-1 + ver <- paste(ver[1:3],collapse=".") + counter <- as.integer(readLines(cfile)) + desc[indC] <- gsub(pattV,sprintf("\\1%s-%04d",ver,counter),desc[indC]) + print(desc[indC],quote=FALSE) + writeLines(desc,src) + } system("R --vanilla CMD build ursa") + # if (file.exists(dst)) + # file.rename(dst,src) pkg <- tail(dir(pattern=patt)) if (length(pkg)!=1) return(NULL) + # if (length(indC)) + # writeLines(sprintf("%04d",counter+1L),cfile) opt1 <- "--fake" ## --no-multiarch opt2 <- "--no-html" opt3 <- "--no-html --build" @@ -169,8 +195,11 @@ else { Sys.setenv(R_LIBS_USER=.libPaths()[1]) # Sys.setenv(BINPREF=Sys.getenv("R_BINPREF")) - system2("R",c("--vanilla","CMD","INSTALL",opt3,pkg)[-1]) + ret <- system2("R",c("--vanilla","CMD","INSTALL",opt3,pkg)[-1]) # system(paste("R","--vanilla","CMD","INSTALL",opt2,pkg)) + if ((!ret)&&(subVersion)) { + writeLines(sprintf("%04d",counter+1L),cfile) + } } # file.remove(pkg) NULL diff --git a/R/allocate.R b/R/allocate.R index 21d870e..de16235 100644 --- a/R/allocate.R +++ b/R/allocate.R @@ -102,7 +102,7 @@ colnames(vec) <- c("x","y") ind <- .grep("^(lon|lat)",mname) if ((length(ind)==2)&&(is.null(proj4))) - proj4 <- paste("+proj=longlat +datum=WGS84 +no_defs") + proj4 <- paste(.crsWGS84()) } if (is.null(proj4)) proj4 <- "" @@ -121,8 +121,6 @@ z[,i] <- as.numeric(val)-1 } } - if (is.na(nodata)) - nodata <- .optimal.nodata(z) if (!.is.grid((getOption("ursaSessionGrid")))) { x <- sort(unique(vec$x)) y <- sort(unique(vec$y)) @@ -203,7 +201,7 @@ } if (onlyGrid) return(session_grid()) - res <- ursa_new(bandname=lname,ignorevalue=nodata) + res <- ursa_new(bandname=lname) ## --20240217, skip ignorevalue<- z <- as.matrix(z) z[is.na(z)] <- nodata g1 <- res$grid @@ -212,6 +210,8 @@ dimy <- with(res$grid,c(columns,rows,nb)) if (verbose) .elapsedTime(paste0(fun,":start")) + if (is.na(nodata)) + nodata <- .optimal.nodata(z) res$value <- .Cursa(C_rasterize,dat=numeric(prod(dimy)),dim=as.integer(dimy) ,bbox=as.numeric(with(g1,c(minx,miny,maxx,maxy))) ,x=as.numeric(vec$x),y=as.numeric(vec$y),value=as.numeric(z) diff --git a/R/classCRS.R b/R/classCRS.R new file mode 100644 index 0000000..b63e37a --- /dev/null +++ b/R/classCRS.R @@ -0,0 +1,427 @@ +'print.ursaCRS' <- function(x,...) { + # if (!.crsForceProj4()) + # cat("'ursaCRS' ") + # x <- unclass(.crsBeauty(x)) + class(x) <- "character" + if (.crsForceProj4()) { + x <- .proj4string(x) + } + if (.isWKT(x)) { + return(cat(x,...,"\n")) + } + print(x,...) +} +'str.ursaCRS' <- function(object,...) { + if (isP4 <- .isProj4(object)) + comment(object) <- NULL + if ((!.crsForceProj4())&&(!isP4)&&(!.isPackageInUse())) + cat(" 'ursaCRS'") + str(unclass(.crsBeauty(object))) #.crsBeauty(object,...) +} +'.ursaCRS' <- function(crs) { + if (T & .crsForceProj4()) { + crs <- .proj4string(crs) + } + if (F & .crsForceWKT()) + crs <- .WKT(crs) + class(crs) <- c("ursaCRS","character") + crs +} +'.isUrsaCRS' <- function(crs) inherits(crs,"ursaCRS") +'.crsSemiMajor' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + if (.isWKT(crs)) { + # .elapsedTime("B1") + B <- NA + a <- strsplit(crs,split="(\\]|\\[|,)")[[1]] + if (length(ind <- grep("^SPHEROID",a))==1) { + opW <- options(warn=-1) + B <- as.numeric(a[ind+2]) + options(opW) + # if (is.na(B)) + # B <- 6378137 + } + if ((is.na(B))&&(isNamespaceLoaded("sf"))) { + B <- as.numeric(sf::st_crs(crs)$SemiMajor,units="m") + } + if (is.na(B)) { + opW <- options(warn=-1) + warning("SemiMajor was not determed. Used from `WGS84`") + options(opW) + B <- 6378137 + } + # .elapsedTime("B2") + return(B) + } + ell <- .gsub(".*\\+ellps=(\\S+)\\s.*","\\1",crs) + if (ell=="WGS84") + B <- 6378137 + else if (ell==crs) { + B <- .gsub(".*\\+a=(\\S+)\\s.*","\\1",crs) + if (B!=crs) + B <- as.numeric(B) + else { + opW <- options(warn=-1) + warning("Supposed that this projection is not supported yet") + options(opW) + B <- 6378137 + } + } + else { + opW <- options(warn=-1) + warning("Supposed that this projection is not supported yet") + options(opW) + B <- 6378137 + } + B +} +'.isCRS' <- function(crs) { + if (is.na(crs)) + return(FALSE) + if (!nchar(crs)) + return(FALSE) + if (grepl("^(ENGCRS)\\[",crs)) + return(FALSE) + if (grepl("^(EPSG:\\d+|ESRI:\\d+|WGS84)$",crs)) + return(TRUE) + TRUE # .isProj4(crs) | .isWKT(crs) +} +'.isWKT' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + isTRUE(grepl("(^|\\[\n\\s+)(BOUNDCRS|PROJCS|PROJCRS|GEOGCS|GEOGCRS|ENGCRS)\\[",crs)) +} +'.isWKT2' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + isTRUE(grepl("(^|\\[\n\\s+)(PROJCRS|GEOGCRS)\\[",crs)) +} +'.isLongLat' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + if (.isWKT(crs)) { + if (ret <- grepl("^(PROJCS|PROJCRS)\\[",crs,)) + return(!ret) + if (ret <- grepl("^(GEOGCS|GEOGCRS)\\[",crs)) + return(ret) + a1 <- strsplit(crs,split="(\\n\\s+|,|\\[|\\])")[[1]] + ret <- grepl("^(GEOGCS|GEOGCRS)$",head(a1,7)) + return(any(ret)) + } + .lgrep("(\\+proj=longlat|epsg:4326)",crs)>0 +} +'.isMerc' <- function(crs) { + # if (missing(crs)) + # crs <- session_crs() + "merc" %in% .crsProj(crs) +} +'.isProj4' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + (!.isWKT(crs))&&(grepl("\\+proj=",crs)) +} +'.isEPSG' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + grepl("EPSG:\\d+",crs) +} +'.crsProj' <- function(crs) { + unknown <- "" + if (missing(crs)) + crs <- session_crs() + if (inherits(crs,"crs")) { + crs <- .WKT(crs) + } + else if (.isProj4(crs)) { + return(.gsub(".+proj=(\\S+)\\s.+","\\1",crs)) + } + else if (!.isWKT(crs)) { + return(unknown) + } + if (.isLongLat(crs)) + return("longlat") + a1 <- strsplit(crs,split="(\\n\\s+|,|\\[|\\])")[[1]] + if (length(ind <- grep("(PROJECTION|METHOD)",a1))>0) { + a2 <- a1[ind[1]+1L] + if (.lgrep("stereographic",a2)) + res <- "stere" + else if (.lgrep("transverse.*mercator",a2)) + res <- c("tmerc","utm")[1] + else if (.lgrep("mercator",a2)) ## after tmerc + res <- "merc" + else if (.lgrep("Cylindrical.*Equal.*Area",a2)) + res <- "cea" + else if (.lgrep("Equirectangular",a2)) + res <- "eqc" + else if (.lgrep("Equidistant.*Cylindric",a2)) + res <- "eqc" + else if (.lgrep("Equidistant.*Conic",a2)) + res <- "eqdc" + else if (.lgrep("Lambert.*(Conformal.*Conic|Conic.*Conformal)",a2)) + res <- "lcc" + else if (.lgrep("Lambert.*Azimuthal.*Equal.*Area",a2)) + res <- "laea" + else { + if (!.isPackageInUse()) { + opW <- options(warn=1) + warning(paste("Need to recognize Projection class from:",a2)) + options(opW) + } + res <- "undefined" + } + } + else + res <- unknown + res +} +'.crsLon0' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + if (!.isWKT(crs)) + return(as.numeric(.gsub2("\\+lon_0=(\\S+)\\s","\\1",crs))) + if (.isLongLat(crs)) + return(NA) + a1 <- strsplit(crs,split="(\\n\\s+|,|\\[|\\])")[[1]] + patt <- c("Longitude\\sof\\s(natural\\s|false\\s)*origin" + ,"[Cc]entral_[Mm]eridian" + ,"longitude_of_center") + if (length(ind <- grep(paste0("(",paste(patt,collapse="|"),")"),a1))>0) { + opW <- options(warn=1) + a2 <- as.numeric(a1[ind+1L]) + options(opW) + } + else { + a2 <- NA + } + # if ((is.na(a2))&&(isNamespaceLoaded("sf"))) + # return(.crsLon0(sf::st_crs(crs)$proj4string)) ## RECURSIVE + a2 +} +'.crsLat0' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + if (!.isWKT(crs)) { + patt <- "\\+lat_0=(\\S+)\\s" + if (!grepl(patt,crs)) + return(NA) + return(as.numeric(.gsub2(patt,"\\1",crs))) + } + if (.isLongLat(crs)) + return(NA) + a1 <- strsplit(crs,split="(,|\\[|\\])")[[1]] + projClass <- .crsProj(crs) + patt <- c("Latitude\\sof\\s(natural|false)\\sorigin" + ,"latitude_of_center" + ,"latitude_of_origin" + ,"Latitude_Of_Origin" + ) + if (projClass %in% "stere") + patt <- c(patt,c("Latitude\\sof\\sstandard\\sparallel" + ,"[Ss]tandard_[Pp]arallel")) + if (length(ind <- grep(paste0("(",paste(patt,collapse="|"),")"),a1))==1) { + opW <- options(warn=1) + a2 <- as.numeric(a1[ind+1L]) + options(opW) + if (projClass %in% c("stere")) + a2 <- 90*sign(a2) + } + else { + if (projClass %in% "tmerc") { + a2 <- NA + } + else if (projClass %in% "merc") { + a2 <- 0 + } + else { + a2 <- NA + } + } + # if ((is.na(a2))&&(isNamespaceLoaded("sf"))) + # return(.crsLat0(sf::st_crs(crs)$proj4string)) ## RECURSIVE + a2 +} +'.crsLatTS' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + if (!.isWKT(crs)) { + a2 <- .gsub2("\\+lat_(ts|1|2)=(\\S+)\\s","\\2",crs) + a2 <- ifelse(a2==crs,0,as.numeric(a2)) + return(a2) + } + if (.isLongLat(crs)) + return(NA) + a1 <- strsplit(crs,split="(\\n\\s+|,|\\[|\\])")[[1]] + projClass <- .crsProj(crs) + patt <- c("Latitude\\sof\\s(1st\\s|2nd\\s)*standard\\sparallel" + ,"[Ss]tandard_[Pp]arallel_[12]") + if (projClass %in% c("stere")) + patt <- c(patt,"latitude_of_origin") + if (length(ind <- grep(paste0("(",paste(patt,collapse="|"),")"),a1))>0) { + opW <- options(warn=1) + a2 <- as.numeric(a1[ind+1L]) + options(opW) + } + else { + lat0 <- .crsLat0(crs) + if (isTRUE(abs(lat0)==90)) + a2 <- lat0 + else if (.crsProj(crs) %in% c("tmerc")) # "laea" "merc" + a2 <- lat0 + else + a2 <- NA + } + if ((is.na(a2))&&(projClass %in% c("merc"))) + a2 <- .crsLat0(crs) + # if ((is.na(a2))&&(isNamespaceLoaded("sf"))) + # return(.crsLatTS(sf::st_crs(crs)$proj4string)) ## RECURSIVE + a2 +} +'.crsName' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + else if (!.isWKT(crs)) { + if ((!.isProj4(crs))&&(nchar(crs)>64)) + return("unknown") + crs <- .WKT(crs) + } + a1 <- strsplit(crs,split="(\\n\\s+|,|\\[|\\])")[[1]] + # print(head(a1,288)) + if (length(ind <- grep("^(PROJCS|PROJCRS|GEOGCS|GEOGCRS)$",a1))>0) { + a2 <- a1[ind[1]+1L] + return(gsub("(^\"|\"$)","",a2)) + } + "notfound" +} +'.crsBeauty' <- function(crs,extended=FALSE) { + digits <- ifelse(extended,6,2) + if (missing(crs)) + crs <- session_crs() + else if (is_spatial(crs)) + crs <- spatial_crs(crs) + else if (is_ursa(crs)) + crs <- ursa_crs(crs) + if (!.isCRS(crs)) + return("") + if (!inherits(crs,"ursaCRS")) + crs <- .ursaCRS(crs) + if (!nchar(crs)) + return(crs) + if (.isProj4(crs)) { + if (!extended) + return(crs) + } + if (.crsForceProj4()) + return(.proj4string(crs)) + if (!.isWKT(crs)) { + crs <- .WKT(crs) + } + # if (.isLongLat(crs)) + # return("WGS 84") + pname <- .crsName(crs) + if ((!extended)&&(pname!="unknown")) + return(pname) + a1 <- strsplit(crs,split="(\\n\\s+|,|\\[|\\])")[[1]] + # print(a1,quote=FALSE) + if (length(ind <- grep("(ELLIPSOID|SPHEROID)",a1))>0) { + ellps <- gsub("^\"|\"$","",a1[ind[1]+1L]) + rf <- sprintf(paste0("%.",digits,"f"),as.numeric(gsub("^\"|\"$","",a1[ind[1]+3L]))) + } + else { + ellps <- "" + rf <- paste0("0.",paste0(rep("0",digits),collapse="")) + } + if (length(ind <- grep("DATUM",a1))>0) { + datum <- gsub("^\"|\"$","",a1[ind[1]+1L]) + } + else + datum <- "" + ellps[ellps=="WGS_1984"] <- "WGS 84" + if (F) + res <- data.frame(foo="bar" + ,proj=.crsProj(crs) + ,datum=datum + ,ellps=ellps + # ,name=.pname + ,a=.crsSemiMajor(crs) + ,rf=rf + ,lon_0=.crsLon0(crs) + ,lat_0=.crsLat0(crs) + ,lat_ts=.crsLatTS(crs) + ) + ret <- projClass <- .crsProj(crs) + if (projClass=="longlat") { + if (extended) + return(ret) + return(.ursaCRS(ret)) + } + ret <- paste(ret,paste0("lon_0=",round(.crsLon0(crs),digits)) + ,paste0("lat_0=",round(.crsLat0(crs),digits))) + if (all(!is.na(lat_ts <- .crsLatTS(crs)))) { + ret <- paste(ret,paste0("lat_ts=",paste(round(lat_ts,digits),collapse=","))) + } + if (ellps=="unknown") + ret <- paste(ret,paste0("a=",.crsSemiMajor(crs),"+",rf)) + else + ret <- paste(ret,sQuote(ellps)) + if (extended) + return(ret) + .ursaCRS(ret) +} +'.proj4string' <- function(crs) { + if (missing(crs)) + crs <- session_crs() + if (inherits(crs,"crs")) { + if (.isProj4(crs$input)) + return(crs$input) + crs <- crs$wkt + } + if (isTRUE(crs=="")) + return("") + if (.isProj4(crs)) + return(crs) + ret <- sf::st_crs(unclass(crs))$proj4string + if (is.na(ret)) + return("") + ret +} +'.WKT' <- function(crs,WKT2=TRUE) { + # isWKT2 <- !FALSE ## failed for writting + if (missing(crs)) + crs <- session_crs() + if (inherits(crs,"crs")) {## sf:: + if (WKT2) + return(crs$wkt) + return(crs$Wkt) + } + if (WKT2) + return(sf::st_crs(crs)$wkt) + return(sf::st_crs(crs)$Wkt) +} +'.crsWGS84' <- function() { + if ((!.crsForceWKT())||(.crsForceProj4())) + return("+proj=longlat +datum=WGS84 +no_defs") + ret <- paste0('GEOGCS["WGS 84",DATUM["WGS_1984",SPHEROID["WGS 84",6378137,298.257223563]],' + ,'PRIMEM["Greenwich",0],UNIT["degree",0.0174532925199433,AUTHORITY["EPSG","9122"]],' + ,'AXIS["Latitude",NORTH],AXIS["Longitude",EAST],AUTHORITY["EPSG","4326"]]') + .ursaCRS(ret) +} +'.crsWGS84simple' <- function() "+proj=longlat +datum=WGS84 +no_defs" +# '.crsForceProj4' <- function() isTRUE(getOption("ursaProj4Legacy")) +'.crsForceProj4' <- function(value) { + if (missing(value)) + return(isTRUE(getOption("ursaProj4Legacy"))) + options(ursaProj4Legacy=value) + invisible(value) +} +# '.crsWeakWKT' <- function() isFALSE(getOption("ursaForceWKT")) +'.crsForceWKT' <- function(value) { + if (missing(value)) { + return(!isFALSE(getOption("ursaForceWKT"))) + } + options(ursaForceWKT=value) + invisible(value) +} +'.identicalCRS' <- function(src,dst) { + identical(.crsBeauty(src,extended=TRUE),.crsBeauty(dst,extended=TRUE)) +} diff --git a/R/classColorTable.R b/R/classColorTable.R index 2fae3a5..b43b469 100644 --- a/R/classColorTable.R +++ b/R/classColorTable.R @@ -139,6 +139,12 @@ '.be.category' <- function(obj) { (.is.colortable(obj))&&(!.is.category(obj)) } +'.postponed.category' <- function(obj) { + # (.is.colortable(obj))&&(!.is.category(obj)) ## -- 20240213 + if (!.is.colortable(obj)) + return(FALSE) + inherits(obj$value,c("ursaSymbol","ursaCategory","ursaNumeric")[c(1,2)]) +} 'names.ursaColorTable' <- function(x) NextMethod("names",x) 'names<-.ursaColorTable' <- function(x,value) { ##~ print("HERE") diff --git a/R/classConnection.R b/R/classConnection.R index e5d4fdc..af3b650 100644 --- a/R/classConnection.R +++ b/R/classConnection.R @@ -3,7 +3,7 @@ obj <- list(driver=NA_character_ ,samples=NA_integer_,lines=NA_integer_,bands=NA_integer_ ,datatype=NA_integer_,interleave=NA_character_,byteorder=NA_integer_ - ,endian=NA_character_,swap=NA_integer_,signed=NA + ,endian=NA_character_,swap=NA_integer_,signed=NA,scale=NA_real_ ,offset=NA_integer_,wkt=FALSE,nodata=NA_real_,mode="raw" ,sizeof=NA_integer_,indexC=NA_integer_,indexR=NA_integer_,indexZ=NA_integer_ ,posC=NA_integer_,posR=NA_integer_,posZ=NA_integer_ diff --git a/R/classGrid.R b/R/classGrid.R index 1082bc3..c3233ef 100644 --- a/R/classGrid.R +++ b/R/classGrid.R @@ -4,7 +4,7 @@ ,minx=NA_real_,maxx=NA_real_,miny=NA_real_,maxy=NA_real_ ,seqx=numeric(0),seqy=numeric(0) ,crs="",retina=NA) - # class(g1$crs) <- c("character","ursaProjection") + class(g1$crs) <- c("ursaCRS","character")[1] class(g1) <- "ursaGrid" g1 } @@ -17,6 +17,7 @@ x$seqy <- NULL if (is.na(x$retina)) x$retina <- NULL + # x$crs <- .crsBeauty(x$crs) str(x,formatNum=function(x) format(x,scientific=FALSE),...) } 'str.ursaGrid' <- function(object,...) { @@ -38,6 +39,7 @@ object$seqy <- NULL if ((!is.null(object$retina))&&(is.na(object$retina))) object$retina <- NULL + # object$crs <- .crsBeauty(object$crs) str(object,...)#,formatNum=function(x) format(x,scientific=FALSE),...) # do.call("str",lx,...)#,formatNum=function(x) format(x,scientific=FALSE),...) } diff --git a/R/classRaster.Extract.R b/R/classRaster.Extract.R index fb2ccf2..581c846 100644 --- a/R/classRaster.Extract.R +++ b/R/classRaster.Extract.R @@ -208,6 +208,7 @@ dim(res$value) <- with(con,c(samples,lines,bands)) } else { + seek(con,where=0L,origin="start",rw="r") res$value <- with(con,.readline(handle,datatype,n,endian)) if (con$interleave=="bil") ##bil[col,band,row] -> R[col,row,band] { diff --git a/R/classRaster.Replace.R b/R/classRaster.Replace.R index 3d05b18..e9bcb9a 100644 --- a/R/classRaster.Replace.R +++ b/R/classRaster.Replace.R @@ -125,10 +125,11 @@ # print(range(j2)) # print(i) # str(value) - for (m in seq(along=i)) - { + dimv <- rep(seq(dim(value)[2]),length.out=length(i)) + for (m in seq(along=i)) { # obj$data[j,i[m]] <- value[,m] - val <- value[,m,drop=FALSE] + # val <- value[,m,drop=FALSE] ## -- 20240225 + val <- value[,dimv[m],drop=FALSE] ## ++ 20240225 # val[val==con$nodata] <- NA if (FALSE) { @@ -205,8 +206,10 @@ j <- seq(dimy[1]) else if (toSeek) toSeek <- toSeek+1 - if (missing(i)) - i <- seq(dimy[2]) + if (missing(i)) { + # i <- seq(dimy[2]) ## -- + i <- seq(dimx[2]) ## ++ 20240225 + } else if (toSeek) toSeek <- toSeek+2 if (is.list(j)) @@ -458,13 +461,16 @@ listJ[[j3]] <- i[j1:j2] j1 <- j2+1 } + dimV <- dim(value$value)[3] for (j0 in seq_along(listJ)) { j1 <- listJ[[j0]] minJ <- min(j1)-1 j2 <- match(j1,i) + j2 <- rep(seq(dimV),length.out=length(j2)) ## ++ 20240225 for (r in seq(dimz[2])) { + # str(value$value[,]) if (toSeek) { pos <- with(con,((r-1)*nb+minJ)*samples*sizeof+offset) @@ -502,16 +508,17 @@ else if (con$interleave=="bsq") { toSeek <- con$seek ## introdiced 2012-08-27 + r2 <- rep(seq(dim(value$value)[3]),length.out=length(i)) ## ++ 20240225: r -> r2[r] for (r in seq(along=i)) { if (toSeek) seek(con$handle,origin="start" ,with(con,(i[r]-1)*lines*samples*sizeof+offset),rw="w") if (toRound) - writeBin(as.vector(.round(value$value[,,r],0),con$mode) + writeBin(as.vector(.round(value$value[,,r2[r]],0),con$mode) ,size=con$sizeof,endian=con$endian,con$handle) else - writeBin(as.vector(value$value[,,r],con$mode) + writeBin(as.vector(value$value[,,r2[r]],con$mode) ,size=con$sizeof,endian=con$endian,con$handle) # if ((!toSeek)&&(r bil [col,band,row] { - for (r in seq(dim(value$value)[2])) - writeBin(as.vector(value$value[,r,],con$mode) + for (r in seq(dim(value$value)[2])) { + writeBin(as.vector(value$value[,r,rv],con$mode) ,size=con$sizeof,endian=con$endian,Fout) + } } else if (con$interleave=="bip") ## R's [col,row,band] -> bip [band,col,row] { for (r in seq(dim(value$value)[2])) - writeBin(as.vector(t(value$value[,r,]),con$mode) + writeBin(as.vector(t(value$value[,r,rv]),con$mode) ,size=con$sizeof,endian=con$endian,Fout) } else if (con$interleave=="bsq") ## R's [col,row,band] -> bsq [col,row,band] { - for (r in seq(dim(value$value)[3])) - writeBin(as.vector(value$value[,,r],con$mode) + for (r in seq(con$bands)) + writeBin(as.vector(value$value[,,rv[r]],con$mode) ,size=con$sizeof,endian=con$endian,Fout) } } diff --git a/R/classRaster_as.data.frame.R b/R/classRaster_as.data.frame.R index 2621651..98fb39f 100644 --- a/R/classRaster_as.data.frame.R +++ b/R/classRaster_as.data.frame.R @@ -105,7 +105,7 @@ } if (is.character(col.names)) colnames(res) <- rep(col.names,length=ncol(res)) - attr(res,"crs") <- g1$crs[which.max(nchar(g1$crs))] + attr(res,"crs") <- .ursaCRS(g1$crs[which.max(nchar(g1$crs))]) # attr(res,"colortable") <- ursa_colortable(obj) res } diff --git a/R/classRaster_close.R b/R/classRaster_close.R index 32fe09d..e297b2e 100644 --- a/R/classRaster_close.R +++ b/R/classRaster_close.R @@ -25,7 +25,10 @@ file.remove(con$fname) else if (con$compress==-2L) { - fname <- .gsub("\\.unpacked(.*)~$",".envi",con$fname) + if (is.null(fname <- attr(con$fname,"source"))) + fname <- .gsub("\\.unpacked(.*)~$",".envi",con$fname) + else + fname <- gsub("gz$","",fname) file.rename(con$fname,fname) if (file.exists(ftmp <- paste0(fname,".gz"))) file.remove(ftmp) diff --git a/R/colorize.R b/R/colorize.R index 46ad848..e7438f9 100644 --- a/R/colorize.R +++ b/R/colorize.R @@ -12,7 +12,7 @@ ,"bathy","grayscale","greyscale",".onetoone") ,minvalue=NA,maxvalue=NA,byvalue=NA,ltail=NA,rtail=NA ,tail=NA,ncolor=NA,nbreak=NA,interval=0L,ramp=TRUE - ,byte=FALSE,lazyload=FALSE,reset=FALSE + ,byte=FALSE,lazyload=TRUE,reset=FALSE ,origin="1970-01-01",format="",alpha="" ,colortable=NULL ,verbose=FALSE,...) @@ -239,8 +239,9 @@ if (.is.colortable(obj$colortable)) { ct <- obj$colortable if (all(!is.na(ct))) { - if (.is.category(obj)) ## attr(obj$value,"category") + if (.is.category(obj)) {## attr(obj$value,"category") return(obj) + } else { rel$pal <- unclass(unname(ct)) } @@ -323,7 +324,9 @@ } return(res) } - stretch <- match.arg(stretch) + stretchList <- as.character(as.list(match.fun("colorize"))[["stretch"]])[-1] + stretchList <- c(stretchList,".onetoone") + stretch <- match.arg(stretch[1],stretchList) if (length(name)) { ncolor <- length(name) ramp <- FALSE @@ -1302,7 +1305,7 @@ col <- rev(col) } obj <- .as.colortable(obj,col=col,name=name,alpha=alpha) - class(obj$value) <- ifelse(lazyload,"ursaNumeric","ursaCategory") + class(obj$value) <- ifelse(lazyload,c("ursaNumeric","ursaSymbol")[2],"ursaCategory") if (!lazyload) ignorevalue(obj) <- n else if (is.na(ignorevalue(obj))) diff --git a/R/compose_close.R b/R/compose_close.R index 77416e5..f3491b6 100644 --- a/R/compose_close.R +++ b/R/compose_close.R @@ -4,8 +4,12 @@ arglist <- list(...) kind <- .getPrm(arglist,name="(^$|crop|kind)",valid=c("crop","crop2","nocrop")) border <- .getPrm(arglist,name="(border|frame)",default=5L) - bpp <- .getPrm(arglist,name="bpp",valid=c(8L,24L) - ,default=switch(getOption("ursaPngDevice"),windows=8L,cairo=24L,24L)) + if (.lgrep("bpp",names(arglist))) + bpp <- .getPrm(arglist,name="bpp",valid=c(8L,24L) + ,default=switch(getOption("ursaPngDevice") + ,windows=8L,cairo=24L,24L)) + else + bpp <- getOption("ursaPngBpp",default=24L) execute <- .getPrm(arglist,name="(execute|view|open|render)",default=!.isShiny()) # if (isTRUE(Sys.getenv("_R_CHECK_PACKAGE_NAME_")=="ursa")) # execute <- FALSE @@ -105,11 +109,11 @@ if (execute) { if (!toOpen) { op <- par(mar=c(0,0,0,0)) - plot(grDevices::as.raster(png::readPNG(fileout))) + plot(grDevices::as.raster(.readPNG(fileout))) if (TRUE) { fann <- .dir(path=system.file("optional/sponsorship",package="ursa") ,pattern="\\.png$",full.names=TRUE) - ann <- png::readPNG(sample(fann,1)) + ann <- .readPNG(sample(fann,1)) plot(grDevices::as.raster(ann),add=TRUE) } par(op) @@ -165,7 +169,7 @@ n <- 999L if (!(bpp %in% c(8,24))) { requireNamespace("png",quietly=.isPackageInUse()) - x <- png::readPNG(fileout,native=TRUE,info=FALSE) + x <- .readPNG(fileout,native=TRUE,info=FALSE) if (verbose) .elapsedTime("uniqueColor:start") n <- length(unique(c(x))) @@ -260,9 +264,9 @@ if (!toOpen) { op <- par(mar=c(0,0,0,0)) if (TRUE) - plot(grDevices::as.raster(png::readPNG(fileout))) + plot(grDevices::as.raster(.readPNG(fileout))) else { ## failed asp=1 - img <- png::readPNG(fileout,native=TRUE) + img <- .readPNG(fileout,native=TRUE) dima <- dim(img) plot(0,0,type="n",axes=FALSE,xlim=c(0,dima[1]),ylim=c(0,dima[2]),asp=1,xlab="",ylab="") rasterImage(img,0,0,dima[1],dima[2]) diff --git a/R/compose_design.R b/R/compose_design.R index 28a1c1e..9421872 100644 --- a/R/compose_design.R +++ b/R/compose_design.R @@ -2,8 +2,10 @@ arglist <- list(...) # str(lapply(arglist,function(x) list(class=class(x),names=names(x)))) obj <- .getPrm(arglist,name="^$",default=NULL - ,class=list(c("list","ursaRaster"),"ursaRaster","integer")) - layout <- .getPrm(arglist,name="layout",default=NA_integer_) + ,class=list(c("list","ursaRaster"),"ursaRaster","integer","matrix")) + # layout <- .getPrm(arglist,name="layout",default=NA_integer_) + layout <- .getPrm(arglist,name="layout",class=list(c("matrix","integer"),"integer") + ,default=NA_integer_) # if (identical(obj,layout)) # obj <- NULL byrow <- .getPrm(arglist,name="byrow",default=TRUE) @@ -24,7 +26,11 @@ str(list(obj=if (is.list(obj)) sapply(obj,class) else class(obj) ,layout=layout,byrow=byrow,skip=skip,legend=legend ,side=side,ratio=ratio,fixed=fixed)) - if (is.null(legend)) { + if ((is.matrix(layout))&&(is.na(legend))) { + forcedLegend <- FALSE + legend <- NA + } + else if (is.null(legend)) { forcedLegend <- FALSE legend <- NA } @@ -48,8 +54,15 @@ # stop("NULL") if (any(is.na(layout))) layout <- c(1L,1L) - panelr <- layout[1] - panelc <- layout[2] + if (is.matrix(layout)) { + dima <- dim(layout) + panelr <- dima[1] + panelc <- dima[2] + } + else { + panelr <- layout[1] + panelc <- layout[2] + } isList <- FALSE } else @@ -187,10 +200,10 @@ } } } - mosaic <- matrix(0,ncol=panelc*2+3,nrow=panelr*2+3) + mosaic <- matrix(0L,ncol=panelc*2+3,nrow=panelr*2+3) k <- 0L m <- k - if (byrow) + if ((byrow)&&(!is.matrix(layout))) { for (ir in 1:panelr) { @@ -218,7 +231,11 @@ } } } - k <- m+1 + if (is.matrix(layout)) { + m <- length(unique(c(layout))) + mosaic[mosaic>0] <- layout + } + k <- m+1L if (length(legend)==1) { if ((isList)&&(forcedLegend)&&((panelc>1)||(panelr>1))) { ## 20160112 added &&(forcedLegend) nl <- length(unique(fld[fld>0])) @@ -372,7 +389,7 @@ else if ((length(leg2)>1)&&((length(leg1)==1))) posc <- posc[posc>1 & posc1)) { @@ -48,8 +57,7 @@ scale <- 1 } } - else if ((.lgrep("\\+proj=merc",session_crs()))&& - (!is.na(.is.near(session_cellsize(),2*6378137*pi/(2^(1:21+8)))))) { + else if ((.isMerc())&&(!is.na(.is.near(session_cellsize(),2*6378137*pi/(2^(1:21+8)))))) { # print("WEB #2") arglist <- as.list(match.call()) ## try mget(names(match.call())[-1]) if (!("scale" %in% names(arglist))) { @@ -66,6 +74,9 @@ retina <- 2 } } + if ((is.character(mosaic))&&(grepl("\\.(png|jpeg|svg|webp|pdf)",mosaic)>0)) { + fileout <- mosaic + } if ((is.character(mosaic))&&(mosaic=="rgb")) mosaic <- compose_design(layout=c(1,1),legend=NULL) else if (!inherits(mosaic,"ursaLayout")) @@ -76,7 +87,7 @@ ,scale=scale,width=width,height=height ,indent=indent,frame=frame,box=box,delafter=delafter,wait=wait ,device=device,antialias=antialias,font=font - ,background=background,retina=retina,dev=dev,verbose=verbose) + ,background=background,retina=retina,bpp=bpp,dev=dev,verbose=verbose) if (dev) { options(ursaPngPlot=TRUE) compose_close(...) @@ -87,7 +98,7 @@ ,width=NA,height=NA ,indent=NA,frame=NA,box=TRUE,delafter=NA,wait=5 ,device=NA,antialias=NA,font=NA,background="white" - ,retina=NA,dev=FALSE,verbose=FALSE) { + ,retina=NA,bpp=NA,dev=FALSE,verbose=FALSE) { if (is.na(retina)) { retina <- getOption("ursaRetina") if (!is.numeric(retina)) @@ -99,7 +110,7 @@ ,fileout=fileout,dpi=dpi,pointsize=pointsize,scale=scale ,width=width,height=height,indent=indent,frame=frame ,box=box,delafter=delafter,wait=wait,device=device - ,antialias=antialias,font=font,background=background,dev=dev + ,antialias=antialias,font=font,background=background,bpp=bpp,dev=dev ,verbose=verbose)) } patt <- "^\\.(png|svg|png|webp|jpeg|jpg)$" @@ -154,7 +165,7 @@ fileout <- paste0(fileout,".png") else if ((isSVG)&&(!.lgrep("\\.svg$",fileout))) fileout <- paste0(fileout,".svg") - g1 <- session_grid() + g1 <- .compose_grid() # session_grid() # scale1 <- (18.5*96)/(g1$rows*2.54) # scale2 <- (23.7*96)/(g1$columns*2.54) paperScale <- 0 @@ -166,8 +177,8 @@ if (nchar(.s0)) .s <- .s/100000 .s0 <- ifelse(nchar(.s0),as.numeric(.s0),1) - if (.lgrep("\\+proj=merc",g1$crs)) { - lat <- with(session_grid(),.project(cbind(0.5*(maxx+minx),0.5*(maxy+miny)) + if (.isMerc()) { + lat <- with(g1,.project(cbind(0.5*(maxx+minx),0.5*(maxy+miny)) ,crs,inv=TRUE))[1,2] sc <- 1/cos(lat*pi/180) } @@ -210,8 +221,8 @@ mainc <- g1$columns*dpiscale mainr <- g1$rows*dpiscale if (verbose) - print(c(v=scale1,h=scale2,autoscale=autoscale,scale=scale,c=g1$columns,r=g1$rows - ,retina=retina,digits=3)) + print(data.frame(width=width,height=height,v=scale1,h=scale2,autoscale=autoscale + ,scale=scale,c=g1$columns,r=g1$rows,retina=retina),digits=3) pointsize0 <- ifelse(.isKnitr(),round(12*retina,1),round(12*retina,1)) if (is.na(pointsize)) { # print(c(pointsize0=pointsize0,dpi=dpi,scale=scale,scale0=autoscale)) @@ -255,8 +266,9 @@ sizec[apply(panel,2,indmatch,"all",slegend)] <- frame sizer[apply(panel,1,indmatch,"any",simage)] <- mainr sizec[apply(panel,2,indmatch,"any",simage)] <- mainc - if ((TRUE)||(box)) - { + # mosaic$panel <- c(mainr,mainc)*dpi/2.54 + mosaic$size <- list(r=sizer*dpi/2.54/scale,c=sizec*dpi/2.54/scale) + if ((TRUE)||(box)) { ## -- 20240130 sizec <- sizec+1*2.54/dpi sizer <- sizer+1*2.54/dpi } @@ -266,8 +278,9 @@ if ((dname!=".")&&(!dir.exists(dname))) dir.create(dname,recursive=TRUE) if (verbose) - print(c(png_width=png_width,png_height=png_height - ,scale=scale,autoscale=autoscale,pointsize=pointsize,dpi=dpi)) + print(data.frame(png_width=png_width,png_height=png_height + ,sizec=max(sizec),sizer=max(sizer) + ,scale=scale,autoscale=autoscale,pointsize=pointsize,dpi=dpi)) if (.isJupyter()) options(jupyter.plot_mimetypes=ifelse(isJPEG,'image/jpeg','image/png')) if (isSVG) { @@ -321,6 +334,20 @@ # ,family=c("Tahoma","Verdana","Georgia","Calibri","sans")[1] nf <- layout(panel,widths=lcm(sizec) ,heights=lcm(sizer),respect=TRUE) + if (F) { + g2 <- .compose_grid() + if (is.null(g2)) { + if (FALSE) { + mul <- 1 + g2 <- regrid(session_grid(),mul=scale*mul) + attr(g2,"smoothing") <- mul + } + else + g2 <- session_grid() + options(ursaPngComposeGrid=g2) + } + print(getOption("ursaPngComposeGrid")) + } options(ursaPngScale=scale,ursaPngDpi=dpi,ursaPngLayout=mosaic ,ursaPngFileout=fileout,ursaPngBox=box ## ,ursaPngLegend=mosaic$legend ,ursaPngFigure=0L,ursaPngDelafter=delafter ## ,ursaPngBar=frame @@ -328,8 +355,10 @@ ,ursaPngFamily=font,ursaPngWaitBeforeRemove=wait ,ursaPngDevice=device,ursaPngShadow="" ,ursaPngBackground=background,ursaPngPanel="",ursaPngSkip=FALSE - ,ursaPngRetina=retina - ,ursaPngPointsize=pointsize,ursaPngComposeGrid=session_grid()) + ,ursaPngRetina=retina,ursaPngBpp=bpp,ursaPngPointsize=pointsize + ,ursaPngPanelGrid=g1 ## to use by default + ,ursaPngComposeGrid=g1 + ) # if (.isKnitr()) { # # if (knitr::opts_knit$get("")) # fileout <- paste0("file:///",fileout) diff --git a/R/compose_panel.R b/R/compose_panel.R index d963da0..0c29410 100644 --- a/R/compose_panel.R +++ b/R/compose_panel.R @@ -16,7 +16,7 @@ } else { aname <- names(arglist) - indB <- .grep("^blank",aname) + indB <- .grep("(^blank|^(ref|dim)$)",aname) do.call("panel_new",arglist[indB]) # indSP <- which(sapply(arglist,inherits,"Spatial")) # indSF <- which(sapply(arglist,inherits,c("sfc","sf"))) diff --git a/R/conn.open_envi.R b/R/conn.open_envi.R index c625a55..e4e6c9e 100644 --- a/R/conn.open_envi.R +++ b/R/conn.open_envi.R @@ -12,6 +12,8 @@ fname <- gsub("\\.$","",fname) wname <- fname fname <- envi_list(wname,exact=TRUE) + if (!length(fname)) + return(NULL) dname <- unique(dirname(fname)) if (identical(wname,dname)) ## 20220130 fname <- envi_list(file.path(dirname(wname),paste0("^",basename(wname),"$")) @@ -106,7 +108,7 @@ { map <- unlist(strsplit(f5,",")) if (map[1]=="Geographic Lat/Lon") - grid$crs <- c("4326","+proj=longlat +datum=WGS84 +no_defs")[-1] + grid$crs <- c("4326",.crsWGS84())[-1] else if (map[1]=="UTM") grid$crs <- paste("+proj=utm",paste0("+zone=",map[8]) ,paste0("+datum=" @@ -163,7 +165,7 @@ ,basename(fname)) if (con$mode=="integer") con$nodata <- as.integer(con$nodata) - if (length(p)) + if (((.crsForceProj4())||(!nchar(wkt)))&&(length(p))) { proj4 <- NULL pr <- NULL @@ -283,7 +285,8 @@ grid2 <- getOption("ursaSessionGrid") if (!.is.grid(grid2)) { - session_grid(grid) + if (nchar(grid$crs)) + session_grid(grid) con$indexC <- seq(grid$columns) con$indexR <- seq(grid$rows) } @@ -399,7 +402,7 @@ } else if ((file.exists(fname.gz))&&(!file.info(fname.gz)$isdir)) { - verbose <- Sys.Date()<=as.Date("2020-04-20") & !.isPackageInUse() + verbose <- Sys.Date()<=as.Date("2024-04-20") & !.isPackageInUse() solved <- FALSE if (nchar(Sys.which("gzip"))) { if (cache) { @@ -461,8 +464,7 @@ con$fname <- file.path(dirname(fbase) ,paste0(basename(fname) ,".unpacked",basename(fbase),"~")) - # print(con$fname) - # q() + attr(con$fname,"source") <- fname.envigz system2("gzip",c("-f -d -c",.dQuote(fname.envigz)),stdout=con$fname,stderr=FALSE) solved <- !is.null(con$fname) } @@ -684,15 +686,19 @@ } if (is.null(grid$crs)) grid$crs <- "" + if ((forceWKT <- TRUE)&&(!nchar(grid$crs))&&(nchar(wkt))) { + grid$crs <- .ursaCRS(wkt) + session_grid(grid) + } if ((!nchar(grid$crs))&&(nchar(wkt))) { - lverbose <- FALSE + lverbose <- !FALSE if (lverbose) .elapsedTime("wkt -> proj4 start") # (!("package:rgdal" %in% search()))) { isSF <- ("sf" %in% loadedNamespaces())&&(utils::packageVersion("sf")<"99990.9") isSP <- "sp" %in% loadedNamespaces() - if ((nchar(Sys.which("gdalsrsinfo")))&&(!isSF)&&(!isSP)) { + if ((FALSE)&&(nchar(Sys.which("gdalsrsinfo")))&&(!isSF)&&(!isSP)) { if (lverbose) message("'gdalsrsinfo' engine (read)") if (FALSE) ## slow @@ -710,7 +716,7 @@ grid$crs <- grid$crs[nchar(grid$crs)>0] } } - else if (!isSF) { + else if ((!isSF)&&(isSP)) { if (lverbose) message("showP4() in 'rgdal'") .try(grid$crs <- .rgdal_showP4(wkt)) @@ -755,7 +761,7 @@ session_grid(grid) } con$driver <- "ENVI" - # class(grid$crs) <- c("character","ursaProjection") + grid$crs <- .ursaCRS(grid$crs) obj$grid <- grid obj$con <- con arglist <- list(...) @@ -763,8 +769,9 @@ ,class=c("integer","numeric"),default=NA,verbose=FALSE) if (!is.na(nodata)) obj$con$nodata <- nodata - if (!.lgrep("(layer|band)*name",names(arglist))) + if (!.lgrep("(layer|band)*name",names(arglist))) { return(obj) + } ln1 <- obj$name ln2 <- arglist[[.grep("(layer|band)*name",names(arglist))]] if (identical(ln1,ln2)) diff --git a/R/conn.open_gdal.R b/R/conn.open_gdal.R index d9f1260..929c2db 100644 --- a/R/conn.open_gdal.R +++ b/R/conn.open_gdal.R @@ -10,8 +10,8 @@ engine <- match.arg(engine,engList) # if (engine=="native") # engine <- "sf" ## replace to 'sf' - if (verbose) - print(c(engine=engine),quote=FALSE) + # if (verbose) + # print(c(engine=engine),quote=FALSE) fname <- gsub("\\.$","",fname) if ((engine=="vapour")&&(requireNamespace("vapour",quietly=.isPackageInUse()))) { return(.open_vapour(fname,engine=engine,verbose=verbose)) diff --git a/R/conn.read_gdal.R b/R/conn.read_gdal.R index 6b7e00c..436f72b 100644 --- a/R/conn.read_gdal.R +++ b/R/conn.read_gdal.R @@ -1,4 +1,13 @@ 'ursa_read' <- function(fname,verbose=FALSE) { ## ,resetGrid=TRUE + if (length(fname)>1) { + ret <- lapply(fname,ursa_read,verbose=verbose) + len <- sapply(ret,nband) + if (all(len==1)) { + ret <- as_ursa(ret) + names(ret) <- basename(fname) + } + return(ret) + } if (envi_exists(fname)) { return(read_envi(fname)) # ,resetGrid=resetGrid } @@ -31,18 +40,25 @@ NULL } 'read_gdal' <- function(fname,resetGrid=TRUE,band=NULL - ,engine=c("native","sf","gdalraster","vapour") + ,engine=c("native","sf") ,verbose=FALSE,...) { ## ,... # if (resetGrid) # session_grid(NULL) engList <- as.character(as.list(match.fun("read_gdal"))[["engine"]])[-1] if (length(engine)0) + engList <- c(engList,"gdalraster") + if (nchar(system.file(package="vapour"))>0) + engList <- c(engList,"vapour") if (!.isPackageInUse()) { - engList <- c(engList,"rgdal") + if (nchar(system.file(package="rgdal"))>0) + engList <- c(engList,"rgdal") } } engine <- match.arg(engine,engList) fname <- gsub("\\.$","",fname) + if (isURL <- grepl("^(http|ftp)(s)*",dirname(fname))) + fname <- .ursaCacheDownload(fname,mode="wb",quiet=!verbose) if (!file.exists(fname)) { list1 <- dir(path=dirname(fname),pattern=paste0("^",basename(fname)),full.names=TRUE) list1 <- list1[.grep("\\.(tif|tiff|img|hfa)$",basename(list1))] @@ -64,7 +80,7 @@ if ((engine=="native")&&(.forceRGDAL())) engine <- "rgdal" loaded <- loadedNamespaces() #.loaded() - forceSF <- .forceSF() + forceSF <- .forceSFpackage() if (accepted_changes <- TRUE) { if ((is.null(band))&&(engine %in% "native")) { if ((!forceSF)&&(("sp" %in% loaded)||("rgdal" %in% loaded))) @@ -97,24 +113,35 @@ if ((isSF)&&(!("sf" %in% loaded))) isSF <- requireNamespace("sf",quietly=.isPackageInUse()) if (verbose) - print(data.frame(isSF=isSF,engine=engine)) + print(data.frame('isSF (alt: open_gdal)'=isSF,engine=engine,check.names=FALSE)) if (isSF) { # str(md <- sf::gdal_metadata(fname,parse=!FALSE)) # str(ds <- sf::gdal_subdatasets(fname,name=TRUE)) opW <- options(warn=ifelse(.isPackageInUse(),-1,1)) res <- as_ursa(sf::gdal_read(fname)) options(opW) - if (forcedNoData <- TRUE) { + if (forcedNoData <- FALSE) { ## see code `as_ursa` gi <- sf::gdal_utils("info",fname,quiet=TRUE) gi <- strsplit(gi,split="\\n")[[1]] - gi <- grep("NoData Value",gi,value=TRUE) - if (length(gi)>0) { - nodata <- gsub("^.*=(\\s*(\\S+))$","\\1",gi) + nd <- grep("NoData Value",gi,value=TRUE) + if (length(nd)>0) { + nodata <- gsub("^.*=(\\s*(\\S+))$","\\1",nd) if (typeof(ursa_value(res))=="integer") ignorevalue(res) <- as.integer(unique(nodata)) else ignorevalue(res) <- as.numeric(unique(nodata)) } + str(ignorevalue(res)) + q() + sc <- grep("(Offset:|Scale:)",gi,value=TRUE) + if (length(sc)>0) { + str(sc) + scB <- as.numeric(gsub(".*Offset:\\s*((-)*\\d(\\.\\d+)*)(\\D.*|$)","\\1",sc)) + scK <- as.numeric(gsub(".*Scale:\\s*((-)*\\d(\\.\\d+)*)(\\D.*|$)","\\1",sc)) + sc <- c(scale=scK,offset=scB) + str(sc) + q() + } } if (!is.null(band)) res <- res[band] diff --git a/R/conn.read_stars.R b/R/conn.read_stars.R deleted file mode 100644 index e69de29..0000000 diff --git a/R/conn.write_gdal.R b/R/conn.write_gdal.R index 60cfefd..bf48c66 100644 --- a/R/conn.write_gdal.R +++ b/R/conn.write_gdal.R @@ -1,7 +1,8 @@ # 'ursa_write' <- function(...) .syn('.write_gdal',2,...) -'ursa_write' <- function(obj,fname) { ## proposed: compress=TRUE for DEFLATE, ZSTD, etc +'ursa_write' <- function(obj,fname,...) { ## proposed: compress=TRUE for DEFLATE, ZSTD, etc if (!.lgrep("\\..+$",basename(fname))) { - return(write_envi(obj,fname)) + if (!length(list(...))) + return(write_envi(obj,fname,...)) } # stop("B") if (.lgrep("\\.zip$",basename(fname))) { @@ -10,7 +11,7 @@ dir.create(td) wd <- setwd(td) for (i in seq(obj)) { - ursa_write(obj[i],aname[i]) ## RECURSIVE!!! + ursa_write(obj[i],aname[i],...) ## RECURSIVE!!! # write_gdal(obj[i],aname[i]) } if (!.is.colortable(obj)) @@ -26,7 +27,7 @@ # print("interim ENVI, then system GDAL") ftmp <- .maketmp() ret <- write_envi(obj,paste0(ftmp,".")) - pr <- ifelse(ret %in% c(1L,2L,3L,11L,12L,13L),2L,3L) + pr <- 1L # ifelse(ret %in% c(1L,2L,3L,11L,12L,13L),2L,3L) fpath <- dirname(fname) if (!dir.exists(fpath)) dir.create(fpath,recursive=TRUE) @@ -55,27 +56,41 @@ ##~ (requireNamespace("stars",quietly=.isPackageInUse()))) { ##~ ret <- .write_sfgdal(obj,fname) ##~ } - if ((!"sf" %in% loadedNamespaces())&&(.forceSF())) + if ((!"sf" %in% loadedNamespaces())&&(.forceSFpackage())) requireNamespace("sf",quietly=.isPackageInUse()) ftmp <- .maketmp() ret <- write_envi(obj,paste0(ftmp,".")) - ret2 <- .envi2gdal(src=ftmp,dst=fname,datatype=ret,bands=length(obj)) + 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)) + return(write_gdal(obj=obj,fname=fname,...)) } -'.envi2gdal' <- function(src,dst,datatype,bands) { +'.envi2gdal' <- function(src,dst,datatype,bands,...) { + arglist <- list(...) + # opts <- .getPrm(arglist,name="opt",class=c("list","character")) + opts <- arglist[[grep("^opt(ion)*s",names(arglist))[1]]] + driver <- arglist[[grep("^driver",names(arglist))[1]]] + if (is.null(opts)) + opts <- arglist + # str(list(driver=driver,opts=opts)) 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" + if (!is.null(driver)) + op <- c("-of",driver) + else if (!.lgrep("\\..+$",basename(dst))) { + op <- c("-of","ENVI") + } + else if (.lgrep("\\.(tif(f)*)$",basename(dst))) { + pr <- 1L # ifelse(datatype %in% c(4L,5L),3L,2L) + op <- c("-of","GTiff") + if (!length(opts)) + op <- c(op ,"-co",paste0("COMPRESS=",c("DEFLATE","ZSTD")[1]) ,"-co",paste0("PREDICTOR=",pr) ,"-co",paste0("ZSTD_LEVEL=9") @@ -86,14 +101,36 @@ ) } else if (.lgrep("\\.(img|hfa)$",basename(dst))) { - op <- c("-of","HFA" - ,"-co",paste("COMPRESSED=YES") - ) + op <- c("-of","HFA") + if (is.null(opts)) + op <- c(op,"-co",paste("COMPRESSED=YES")) + } + else if (.lgrep("\\.(png)$",basename(dst))) { + op <- c("-of","PNG") + } + else if (.lgrep("\\.(jpg|jpeg)$",basename(dst))) { + op <- c("-of","JPEG") } else { + # op <- character() + warning("unimplemented") return(invisible(-98L)) } - # print(paste(op,collapse=" ")) + if (length(opts)) { + if (is.character(opts)) { + oname <- names(opts) + if (is.null(oname)) + op2 <- do.call(c,strsplit(opts,split="\\s+")) + else + op2 <- paste0(oname,"=",opts) + } + else if (is.list(opts)) + op2 <- paste0(names(opts),"=",sapply(opts,\(x) x)) + else + op2 <- character() + op <- c(op,do.call("c",lapply(op2,function(x) c("-co",x)))) + } + # print(paste(op,collapse=" ")) gd <- sf::gdal_utils(util="translate" ,source=src ,destination=dst @@ -109,7 +146,22 @@ engine <- .getPrm(arglist,name="engine",default="native") # if ((.isPackageInUse())||(!.rgdal_requireNamespace())) { ## .rgdal_loadedNamespaces if ((.isPackageInUse())||(engine!="rgdal")) { - res <- try(.write_sfgdal(obj,...)) + if (!requireNamespace("stars",quietly=.isPackageInUse())) { + # opW <- options(warn=1) + # warning("Package `stars` is required for raster writting") + # options(opW) + if (!is.null(aname <- names(arglist))) { + if (!nchar(aname)[1]) { + aname[1] <- "fname" + names(arglist) <- aname + } + } + # res <- try(ursa_write(obj=obj,fname=arglist[[1]],arglist[-1])) + res <- try(do.call("ursa_write",c(list(obj=obj),arglist))) + } + else { + res <- try(.write_sfgdal(obj,...)) + } # ret <- .try(res <- .write_sfgdal(obj,...)) if (!inherits(res,"try-error")) return(invisible(res)) @@ -128,10 +180,8 @@ return(invisible(res$con$datatype)) } '.write_sfgdal' <- function(obj,fname,driver,options,...) { - if ((!"sf" %in% loadedNamespaces())&&(T | .forceSF())) + if ((!"sf" %in% loadedNamespaces())&&(T | .forceSFpackage())) 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) @@ -156,10 +206,16 @@ if (is.null(driver)) driver <- "ENVI" } + if (length(arglist <- list(...))>0) { + if (missing(options)) + options <- arglist + else + options <- c(options,arglist) + } if (missing(options)) { if (driver=="GTiff") { opt <- c("COMPRESS=DEFLATE" - ,paste0("PREDICTOR=",ifelse(datatype %in% c(4,5),"3","2")) + ,paste0("PREDICTOR=",ifelse(datatype %in% c(4,5),c("3","1")[2],c("2","1")[2])) ,paste0("INTERLEAVE=",ifelse(length(obj)==1,"PIXEL","BAND")) ,"TILED=NO" ) @@ -181,7 +237,10 @@ opt <- character() # opt <- paste(opt,collapse=" ") } - ret <- sf::gdal_write(as_stars(obj),driver=driver + if (grepl("\\.$",basename(fname))) + fname <- gsub("\\.$","",fname) + .obj <- as_stars(obj) + 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)) ) diff --git a/R/display.R b/R/display.R index a329739..e1447a0 100644 --- a/R/display.R +++ b/R/display.R @@ -71,7 +71,7 @@ if (TRUE) { #(.isPackageInUse()) fann <- .dir(path=system.file("optional/sponsorship",package="ursa") ,pattern="\\.png$",full.names=TRUE) - ann <- png::readPNG(sample(fann,1)) + ann <- .readPNG(sample(fann,1)) panel_annotation(ann,alpha=0.5,pos="bottomright",cex=0.5) } if (.isKnitr()) @@ -115,11 +115,13 @@ print(all(p<500)) ## return } e.avg <- na.omit(e$mean) + if (!length(e.avg)) + return(TRUE) e.sd <- na.omit(e$sd) + if (!length(e.sd)) + return(TRUE) e.min <- na.omit(e$min) e.max <- na.omit(e$max) - if (!length(e.avg)) - return(TRUE) ##~ sd.avg <- sd(e.avg) ##~ sd.sd <- sd(e.sd) ##~ sd.min <- sd(e.min) diff --git a/R/envi_files.R b/R/envi_files.R index 336672b..407fbbe 100644 --- a/R/envi_files.R +++ b/R/envi_files.R @@ -142,8 +142,8 @@ if (!(grepl("(^\\^|\\$$|\\\\[dDwWsS](\\{|\\+|\\*))",pattern))) pattern <- gsub("\\\\","/",pattern) ## failed for sia\\d{4} } - if (.lgrep("(/|\\\\)",pattern)) - { + # print(c(path=path,pattern=pattern)) + if (.lgrep("(/|\\\\)",pattern)) { isDir <- file.info(pattern)$isdir if ((!is.na(isDir))&&(isDir)) { path <- pattern @@ -156,11 +156,30 @@ } else if (file.exists(dirname(pattern))) { path <- dirname(pattern) - pattern <- gsub(paste0(path,"(/+|\\\\)"),"",pattern) + # pattern <- gsub(paste0(path,"(/+|\\\\)"),"",pattern) + pattern <- gsub(paste0(path,c("/+","(/+|\\\\)")[1]),"",pattern) # pattern <- basename(pattern) recursive <- FALSE full.names <- TRUE } + else if (path==".") { ## ++ 20240303 + if (F) + path <- dirname(pattern) + else { + p <- strsplit(pattern,split="/")[[1]] + if (length(p)>1) { + path <- head(p,-1) + # print(c(path=path,pattern=pattern)) + if (!dir.exists(path)) { + return(character()) + } + if (F) + patterm <- basename(pattern) + else + pattern <- tail(p,1) + } + } + } } # print(c(path=path,pattern=pattern)) } diff --git a/R/get_earthdata.R b/R/get_earthdata.R index f2c0108..7903cd3 100644 --- a/R/get_earthdata.R +++ b/R/get_earthdata.R @@ -10,7 +10,7 @@ ,'3'="MODIS_Aqua_CorrectedReflectance_TrueColor" ,'4'="MODIS_Terra_CorrectedReflectance_TrueColor" ,'5'="VIIRS_SNPP_CorrectedReflectance_TrueColor" - ,'6'="Coastlines") + ,'6'="Coastlines_15m") epsg3413 <- paste("+proj=stere +lat_0=90 +lat_ts=70 +lon_0=-45 +k=1" ,"+x_0=0 +y_0=0 +datum=WGS84 +units=m +no_defs") epsg3857 <- paste("+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0" @@ -18,7 +18,8 @@ ,"+wktext +no_defs") if ((length(bbox)==1)&&(is.na(bbox))) { g0 <- session_grid() - if (.lgrep("\\+proj=merc",g0$crs)) { + # g0$crs <- .proj4string(g0$crs) + if (.isMerc(g0$crs)) { ll <- with(g0,.project(cbind(c(minx,maxx),c(miny,maxy)),crs,inv=TRUE)) # bbox <- c(min(ll[,1]),min(ll[,2]),max(ll[,1]),max(ll[,2])) bbox <- c(ll[1,1],ll[1,2],ll[2,1],ll[2,2]) @@ -170,7 +171,7 @@ if ((nband(b)==4)&&(global_min(b[4])==255)&&(global_max(b[4])==255)) b <- b[-4] attr(b,"copyright") <- "Global Imagery Browse Services, NASA/GSFC/ESDIS" - cond1 <- .lgrep("\\+proj=merc\\s",g1$crs) & .lgrep("\\+proj=merc\\s",g4$crs) + cond1 <- .isMerc(g1$crs) & .isMerc(g4$crs) cond2 <- g1$columns==g4$columns & g1$rows==g4$rows & .is.near(g1$miny,g4$miny) & .is.near(g1$maxy,g4$maxy) & .is.near(g1$resx,g4$resx) & .is.near(g1$resy,g4$resy) & @@ -192,20 +193,46 @@ if (inherits(time,c("Date","POSIXct","POSIXlt"))) time <- format(time,"%Y-%m-%d") # product <- c("Coastlines","arctic_coastlines")[1] - isDecor <- product %in% c("Coastlines","arctic_coastline") + isDecor <- product %in% c("Coastlines","Coastlines_15m","arctic_coastline") if (isDecor) time <- "" - ext <- ifelse(product %in% c("Coastlines","arctic_coastline"),".png",".jpg") + ext <- ifelse(product %in% c("Coastlines","Coastlines_15m","arctic_coastline") + ,".png",".jpg") epsg <- match.arg(epsg) - matrixSet <- switch(epsg,'3413'="250m",'3857'="GoogleMapsCompatible_Level9") + matrixSet <- switch(epsg,'3413'="250m" + ,'3857'=ifelse(isDecor,"GoogleMapsCompatible_Level13" + ,"GoogleMapsCompatible_Level9")) isPNG <- length(grep("png",ext))>0 + if (isPNG) { + if (!requireNamespace("png",quietly=.isPackageInUse())) + stop("Suggested package 'png' is missed, but is required here.") + } 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)) + if (T) { + src <- file.path("https://gibs.earthdata.nasa.gov/wmts",paste0("epsg",epsg) + ,"best",product,"default",time,matrixSet,paste0(z,"/",y,"/",x,ext)) + } + else { + # https://gibs-a.earthdata.nasa.gov/wmts/epsg3857/best/wmts.cgi?Request=GetCapabilities + src <- file.path("https://gibs-a.earthdata.nasa.gov/wmts",paste0("epsg",epsg),"best/wmts.cgi") + prm <- paste(paste0("Request=GetTile") + ,paste0("format=image/",gsub("\\.","",ext)) + ,paste0("Version=1.0.0") + ,paste0("Service=WMTS") + ,paste0("layer=Coastlines_15m")#,product) + ,paste0("tilematrixset=",matrixSet) + ,paste0("TileMatrix=",z) + ,paste0("TileCol=",x) + ,paste0("TileRow=",y) + ,sep="&" + ) + src <- paste(src,prm,sep="?") + + } # dst <- paste0("tmp-",z,"-",y,"-",x,ext) # dst <- sapply(seq_along(src),function(x) tempfile()) method <- getOption("download.file.method") @@ -236,7 +263,7 @@ } } if (isPNG) { - a[[i]] <- aperm(png::readPNG(dst),c(2,1,3)) + a[[i]] <- aperm(.readPNG(dst),c(2,1,3)) } else if (isJPEG) a[[i]] <- aperm(jpeg::readJPEG(dst),c(2,1,3)) diff --git a/R/glance.R b/R/glance.R index 14f2a2c..ea175da 100644 --- a/R/glance.R +++ b/R/glance.R @@ -186,7 +186,7 @@ # print(c(dsn=class(dsn))) # obj <- spatialize(dsn) if (missing(dsn)) { - dsn <- if (style!="auto") .geomap(style=style) else .geomap() + dsn <- if (style!="auto") .geomap(style=style,verbose=verbose) else .geomap(verbose=verbose) return(display(dsn,...)) ## ++20180617 } toUnloadMethods <- !("methods" %in% .loaded()) @@ -195,6 +195,10 @@ .require("methods",quietly=.isPackageInUse()) # requireNamespace("methods",quietly=.isPackageInUse()) } + if (!is.null(getOption("ursaSessionGrid"))) { + g5 <- session_grid() + on.exit(session_grid(g5)) + } obj <- spatialize(dsn=dsn,engine=engine,layer=layer,field=field,geocode=geocode ,place=place,area=area,grid=grid,size=size # ,expand=expand,border=border @@ -209,7 +213,7 @@ isSP <- !isSF g0 <- attr(obj,"grid") if (is.null(g0)) - g0 <- session_grid() + g0 <- .compose_grid() # g1 <- getOption("ursaSessionGrid") # if (identical(g0,g1)) # border <- 0 @@ -225,7 +229,8 @@ toUnloadMethods <- FALSE # dname <- attr(obj,"colnames") dname <- spatial_fields(obj) - style <- attr(obj,"style") + if (!is.null(attr(obj,"style"))) + style <- attr(obj,"style") geocodeStatus <- attr(obj,"geocodeStatus") if (is.null(geocodeStatus)) geocodeStatus <- FALSE @@ -289,6 +294,11 @@ proj <- "merc" } isWeb <- .lgrep(tilePatt,art)>0 | art %in% providers | isUrl + if (F & isWeb) { + if (!.isWeb(g0)) { + stop("Grid is inconsistent for tiling") + } + } if (verbose) str(list(style=style,art=art,proj=proj,isUrl=isUrl,isWeb=isWeb)) # proj <- match.arg(proj) @@ -299,7 +309,7 @@ basemapRetina <- FALSE if (isWeb) { bbox <- with(g0,c(minx,miny,maxx,maxy)) - if (grepl("\\+proj=longlat",g0$crs)) + if (.isLongLat(g0$crs)) lim <- bbox else lim <- c(.project(matrix(bbox,ncol=2,byrow=TRUE),g0$crs @@ -406,8 +416,8 @@ if ((is.null(basemap))&&(border>0)) { g0 <- regrid(g0,border=border) } - attr(obj,"grid") <- g0 - session_grid(g0) + .compose_grid(g0) + # session_grid(g0) # str(g0) # xy <- with(g0,.project(rbind(c(minx,miny),c(maxx,maxy)),crs,inv=TRUE)) # display(blank="white",col="black");q() @@ -529,8 +539,9 @@ retina <- ifelse(is.na(retina2),retina3,retina2) compose_open(res,scale=1,retina=retina,...) } - else + else { compose_open(res,...) + } gline <- compose_graticule(...) if (toCoast) cline <- compose_coastline(...) diff --git a/R/identify.R b/R/identify.R index cd52dd6..e448db0 100644 --- a/R/identify.R +++ b/R/identify.R @@ -158,6 +158,11 @@ y <- x[,2] x <- x[,1] } + else if (is_spatial(x)) { + x <- spatial_coordinates(x) + y <- x[,2] + x <- x[,1] + } else stop("specify 'y'") } diff --git a/R/package_gdalraster.R b/R/package_gdalraster.R index 214f90a..31f9aa2 100644 --- a/R/package_gdalraster.R +++ b/R/package_gdalraster.R @@ -23,6 +23,7 @@ ,md0=ds$getMetadata(band=0,domain="") # ,md1=ds$getMetadata(band=1,domain="") # ,mdi0=ds$getMetadataItem(band=0,domain="",mdi_name="") + ,desc=ds$getDescription(band=1) ,ct=ds$getColorTable(band=1) ## ver 1.4.1 ) str(md) @@ -36,7 +37,7 @@ if (TRUE) { g1 <- regrid(bbox=bbox,res=res # ,crs=sf::st_crs(ds$getProjectionRef())$proj4string - ,crs=ds$getProjectionRef() + ,crs=.ursaCRS(ds$getProjectionRef()) ) } else { @@ -52,6 +53,7 @@ # g1$crs=sf::st_crs(ds$getProjectionRef())$proj4string g1$crs=ds$getProjectionRef() } + ds$close() # session_grid(g1) res <- .raster.skeleton() res$dim <- c(prod(dima[1:2]),dima[3]) @@ -101,7 +103,7 @@ requireNamespace("gdalraster",quietly=.isPackageInUse()) a <- .open_gdalraster(fname,engine=engine,verbose=verbose) ds <- methods::new(gdalraster::GDALRaster,filename=fname,read_only=TRUE) - if (verbose) { + if (F & verbose) { ## repeatition of `open_gdalraster` md <- list(ncols=ds$getRasterXSize() ,nrows=ds$getRasterYSize() ,bbox=ds$bbox() @@ -125,15 +127,17 @@ md0 <- ds$getMetadata(band=0,domain="") g1 <- regrid(bbox=ds$bbox(),res=ds$res() # ,crs=sf::st_crs(ds$getProjectionRef())$proj4string - ,crs=ds$getProjectionRef() + ,crs=.ursaCRS(ds$getProjectionRef()) ) session_grid(g1) patt <- "^Band_(\\d+)=(.+)$" - j <- grep(patt,md0) - bname <- gsub(patt,"\\2",md0[j]) + bname <- NULL + if (length(j <- grep(patt,md0))>0) + 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])) + if (!length(bname)) { + bname <- paste("Band",seq_len(dima[3])) + } else { ind <- as.integer(gsub(patt,"\\1",md0[j])) bname[ind] <- bname @@ -162,5 +166,6 @@ ursa_colortable(out) <- ct class(out$value) <- "ursaCategory" } + ds$close() out } diff --git a/R/package_proj4.R b/R/package_proj4.R new file mode 100644 index 0000000..8b5c9cb --- /dev/null +++ b/R/package_proj4.R @@ -0,0 +1,13 @@ +'.proj4_requireNamespace' <- function(...) { + requireNamespace("proj4",quietly=.isPackageInUse()) +} +'.proj4_project' <- function(...) { + if (!.proj4_requireNamespace()) + .Missing("proj4") ## .Retired() + proj4::project(...) +} +'.proj4_ptransform' <- function(...) { + if (!.proj4_requireNamespace()) + .Missing("proj4") ## .Retired() + proj4::ptransform(...) +} diff --git a/R/package_sf.R b/R/package_sf.R index e34a8d2..4baf055 100644 --- a/R/package_sf.R +++ b/R/package_sf.R @@ -1,7 +1,34 @@ +'.gdal_sfinfo' <- function(fname) { + md <- list(nodata=NA,scale=NA,offset=NA) + if (forceInfo <- TRUE) { + gi <- sf::gdal_utils("info",fname,quiet=TRUE) + gi <- strsplit(gi,split="\\n")[[1]] + nd <- grep("NoData Value",gi,value=TRUE) + if (length(nd)>0) { + md$nodata <- as.numeric(gsub("^.*=(\\s*(\\S+))$","\\1",nd)) + # if (typeof(ursa_value(res))=="integer") + # ignorevalue(res) <- as.integer(unique(nodata)) + # else + # ignorevalue(res) <- as.numeric(unique(nodata)) + } + sc <- grep("(Offset:|Scale:)",gi,value=TRUE) + if (length(sc)>0) { + md$offset <- as.numeric(gsub(".*Offset:\\s*((-)*\\d(\\.\\d+)*)(\\D.*|$)","\\1",sc)) + md$scale <- as.numeric(gsub(".*Scale:\\s*((-)*\\d(\\.\\d+)*)(\\D.*|$)","\\1",sc)) + } + if ((!is.na(md$nodata[1]))&&(!is.na(md$scale))&&(!is.na(md$offset))) { + md$nodata <- md$nodata*md$scale+md$offset + } + } + md +} '.open_sfgdal' <- function(fname,engine="sf",verbose=FALSE) { if (!requireNamespace("sf",quietly=.isPackageInUse())) stop("Package 'sf' is required for this operation") + if (verbose) + print(c('open_gdal'="`sf::gdal_read()` without data")) obj <- sf::gdal_read(fname,read_data=FALSE) + md <- .gdal_sfinfo(fname) columns <- obj$cols[2] rows <- obj$rows[2] bands <- length(obj$bands) @@ -9,8 +36,10 @@ crs <- obj[[ind]] if (is.character(crs)) crs <- sf::st_crs(crs)$proj4string - if (inherits(crs,"crs")) - crs <- crs$proj4string + if (inherits(crs,"crs")) { + crs <- .WKT(crs) + # crs <- .proj4string(crs) + } if (is.na(crs)) crs <- "" if (all(is.na(obj$geotransform))) { @@ -29,8 +58,12 @@ maxx <- minx+columns*resx miny <- maxy-rows*resy } + ##~ a <- list(minx=minx,maxx=maxx,miny=miny,maxy=maxy,columns=columns,rows=rows + ##~ ,crs=crs # sf::st_crs(obj$crs)$proj4string + ##~ ) + ##~ str(a,digits=16) g1 <- regrid(minx=minx,maxx=maxx,miny=miny,maxy=maxy,columns=columns,rows=rows - ,crs=crs # sf::st_crs(obj$crs)$proj4string + ,crs=.ursaCRS(crs) # sf::st_crs(obj$crs)$proj4string ) res <- .raster.skeleton() res$grid <- g1 @@ -85,13 +118,20 @@ } } } - 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") + if (.lgrep("float",obj$datatype)) + vmode <- "numeric" + else + vmode <- "integer" + if ((isCat)||(vmode=="integer")) { + if ((!is.na(md$scale))&&(!is.na(md$offset))) { + # .elapsedTime("F") + # v <- as.integer(v) + # dim(v) <- dimv + # storage.mode(v) <- "integer" + vmode <- "numeric" + res$con$datatype <- 4L + # .elapsedTime("G") + } } # .elapsedTime("as.ursa -- before") # res <- as.ursa(v) ## RECURSIVE @@ -116,22 +156,12 @@ names(res) <- 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)) + if (!is.na(md$nodata[1])) { + if (vmode!=mode(md$nodata)) + mode(md$nodata) <- vmode + ignorevalue(res) <- unique(md$nodata) } + mode(res$value) <- vmode res } '.read_stars' <- function(fname) { @@ -172,6 +202,8 @@ res } 'as_stars' <- function(obj) { + if (inherits(obj,"stars")) + return(obj) if (!inherits(obj,"ursaRaster")) return(NULL) g <- ursa_grid(obj) diff --git a/R/package_vapour.R b/R/package_vapour.R index 9f9d0a4..8b72cc6 100644 --- a/R/package_vapour.R +++ b/R/package_vapour.R @@ -18,7 +18,7 @@ # g1$resy <- -a$geotransform[4] g1$resx <- with(g1,(maxx-minx)/columns) g1$resy <- with(g1,(maxy-miny)/rows) - g1$crs <- a$projstring + g1$crs[] <- if (T) a$projection else a$projstring # comment(g1$crs) <- a$projection # if (is.na(g1$crs)) # g1$crs <- "" @@ -64,9 +64,10 @@ ,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) - }) + if (all(ct$c4==255)) + ct <- apply(ct,1,function(x) rgb(x[1],x[2],x[3],maxColorValue=255)) + else + ct <- apply(ct,1,function(x) rgb(x[1],x[2],x[3],x[4],maxColorValue=255)) } else ct <- NULL @@ -85,16 +86,18 @@ class(ct) <- "ursaColorTable" patt <- "^\\s*(.+)$" b <- vrt[grep(patt,vrt)] - if (!length(b)) - bname <- paste("Band",seq_along(con$bands)) - else + if (!length(b)) { + bname <- paste("Band",seq_len(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") + class(res$value) <- ifelse(length(ct)>0,"ursaCategory","ursaNumeric") res } '.read_vapour' <- function(fname,resetGrid=TRUE,band=NULL @@ -115,10 +118,12 @@ # print(is.raw(b[[1]])) # .elapsedTime("vapour -- step4") # if (ri$datatype %in% c("Byte","Int32","UInt32","Int64")) + clval <- class(a$value) 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) + ursa_value(a)[] <- do.call(cbind,b) + class(a$value) <- clval # .elapsedTime("vapour -- step5") } else diff --git a/R/panel_annotation.R b/R/panel_annotation.R index 786e1f2..c7afaeb 100644 --- a/R/panel_annotation.R +++ b/R/panel_annotation.R @@ -5,8 +5,16 @@ return(invisible(NULL)) arglist <- list(...) if ((length(arglist))&&(is_spatial(arglist[[1]]))) { - obj <- spatial_transform(arglist[[1]],session_crs()) + bbox <- ursa_bbox(.panel_grid()) + obj <- spatial_transform(arglist[[1]],.panel_crs()) + if (F & is_spatial_polygons(obj)) { + obj <- spatial_intersection(obj,polygonize(bbox)) + } xy <- spatial_coordinates(spatial_centroid(obj)) + ind <- which(xy[,1]>=bbox["xmin"] & xy[,1]<=bbox["xmax"] & + xy[,2]>=bbox["ymin"] & xy[,2]<=bbox["ymax"]) + obj <- obj[ind,] + xy <- xy[ind,] da <- spatial_data(obj) noLabel <- !ncol(da) # if (noLabel) @@ -75,7 +83,7 @@ str(list(label=label,position=position,cex=cex,adjust=adjust,fg=fg,bg=bg ,fill=fill,buffer=buffer,vertical=vertical,verbose=verbose)) opt <- par(family=font) - g1 <- getOption("ursaPngPanelGrid") # session_grid() + g1 <- .panel_grid() # session_grid() minx <- g1$minx miny <- g1$miny maxx <- g1$maxx @@ -173,7 +181,7 @@ else width <- strwidth(paste(label,"|",sep=""),units="user",cex=mycex) } - if (vertical) { + if (abs(vertical)>45) { .w <- width width <- height height <- .w*1.05 diff --git a/R/panel_coastline.R b/R/panel_coastline.R index f47cfb3..de1cc3d 100644 --- a/R/panel_coastline.R +++ b/R/panel_coastline.R @@ -30,7 +30,7 @@ bg <- sum(c(col2rgb(getOption("ursaPngBackground")))*c(0.30,0.59,0.11)) defcol <- ifelse(bg<128,"#FFFFFF3F","#0000003F") # grey60 col <- .getPrm(arglist,name="(col|line)",kwd=kwd,default=defcol) - fill <- .getPrm(arglist,name="fill",kwd=kwd,default="transparent") + fill <- .getPrm(arglist,name="fill",kwd=kwd,default=c("#FFFF003F","transparent")[2]) detail <- .getPrm(arglist,name="detail",kwd=kwd,default=NA_character_) density <- .getPrm(arglist,name="density",kwd=kwd,default=NA_real_) angle <- .getPrm(arglist,name="angle",kwd=kwd,default=NA_real_) @@ -55,11 +55,15 @@ '.compose_coastline' <- function(obj=NULL,panel=0,col=NA,fill="transparent" ,detail=NA,density=NA,angle=NA,land=FALSE ,lwd=0.5,lty=1,fail180=NA,verbose=FALSE) { + # forceProj4string <- isTRUE(getOption("ursaTransformProj4sring")) if (verbose) str(list(obj=obj,panel=panel,col=col,fill=fill,detail=detail ,density=density,angle=angle - ,land=land,lwd=lwd,lty=lty,fail180=fail180)) - g1 <- session_grid() + ,land=land,lwd=lwd,lty=lty,fail180=fail180 + ,forceProj4string=isTRUE(getOption("ursaSFProjectProj4string")))) + g1 <- .panel_grid() # session_grid() + if (is.null(g1)) + g1 <- .compose_grid() if (!is.null(obj)) { isPoly <- inherits(obj,c("sf","SpatialPolygonsDataFrame")) if ((is.matrix(obj))&&(ncol(obj)==2)) @@ -101,9 +105,10 @@ } } else if (.lgrep("\\.rds$",obj)) { - g1 <- session_grid() + stop("COASLINE GRID AGAIN") + # g1 <- session_grid() ## earlier coast_xy <- readRDS(obj) - if (nchar(g1$crs)) { + if (.isCRS(g1$crs)) { # b <- attributes(coast_xy) coast_xy <- .project(coast_xy,g1$crs) # attributes(coast_xy) <- b @@ -124,16 +129,19 @@ return(res) } } - isLongLat <- .lgrep("(\\+proj=longlat|epsg:4326)",g1$crs)>0 - isMerc <- .lgrep("\\+proj=merc",g1$crs)>0 - isCea <- .lgrep("\\+proj=cea",g1$crs)>0 - isUTM <- .lgrep("\\+proj=utm",g1$crs)>0 + projClass <- .crsProj(g1$crs) + isLongLat <- "longlat" %in% projClass + isMerc <- "merc" %in% projClass + isCea <- "cea" %in% projClass + isUTM <- "utm" %in% projClass proj <- g1$crs if ((is.list(proj))&&("input" %in% names(proj))) proj <- proj[["input"]] - proj <- proj[nchar(proj)==max(nchar(proj))] - if ((any(is.na(proj)))||(nchar(proj)==0)) + if (length(proj)>1) + proj <- proj[nchar(proj)==max(nchar(proj))] + if (!.isCRS(proj)) { return(NULL) + } isDetail <- !is.na(detail) if (is.na(detail)) detail <- "l" @@ -184,43 +192,52 @@ proj4 <- sf::st_crs(proj[ind])$proj4string } } - else - { - proj4 <- paste(proj,collapse=" ") + else { + proj4 <- proj # paste(proj,collapse=" ") + if (!.crsForceWKT()) ## proj4sting is faster, if operated by 'sf' + proj4 <- .proj4string(proj4) } - if ((!isLongLat)&&(!isMerc)) { - lat0 <- .gsub("^.*\\+lat_[012]=(\\S+)\\s.*$","\\1",proj4) - if (lat0==proj4) { - # lat0 <- .gsub("^.*\\+lat_ts=(\\S+)\\s.*$","\\1",proj4) + # print(data.frame(isLongLat=isLongLat,isMerc=isMerc)) + if (FALSE) { ## deprecate + if ((!isLongLat)&&(!isMerc)) { + lat0 <- .gsub("^.*\\+lat_[012]=(\\S+)\\s.*$","\\1",proj4) + lat0 <- .crsLat0(proj4) if (lat0==proj4) { - epsg <- .gsub("^.+init=epsg:(\\d+).*$","\\1",proj4) - if ((epsg==proj4)) - lat0 <- NA - else { - epsg <- as.integer(epsg) - if (epsg %in% c(3411,3413,3408,3571:3576,6931,6973)) - lat0 <- 90 - else if (epsg %in% c(3409,6932,6974,3412,3976)) - lat0 <- -90 - else + # lat0 <- .gsub("^.*\\+lat_ts=(\\S+)\\s.*$","\\1",proj4) + if (lat0==proj4) { + epsg <- .gsub("^.+init=epsg:(\\d+).*$","\\1",proj4) + if ((epsg==proj4)) lat0 <- NA + else { + epsg <- as.integer(epsg) + if (epsg %in% c(3411,3413,3408,3571:3576,6931,6973)) + lat0 <- 90 + else if (epsg %in% c(3409,6932,6974,3412,3976)) + lat0 <- -90 + else + lat0 <- NA + } } + else + lat0 <- as.numeric(lat0) } else lat0 <- as.numeric(lat0) } else - lat0 <- as.numeric(lat0) + lat0 <- NA + } + else { + lat0 <- .crsLat0(proj4) } - else - lat0 <- NA ant_xy <- NULL ind <- attr(xy,"antarctic") if (!is.null(ind)) indS <- which(abs(coast_xy[ind,2])<(85.0-1e-3)) if (!isLongLat) { # indNA <- which(is.na(coast_xy[,1]) | is.na(coast_xy[,2])) - coast_xy <- .project(coast_xy,proj4) + # qs::qsave(coast_xy,"C:/tmp/interim.qs");q() + coast_xy <- .project(coast_xy,proj4,verbose=!.isPackageInUse()) isInf <- any(is.infinite(coast_xy)) if (isInf) { shadow <- unname(col2rgb(fill,alpha=TRUE)[4,1]) # if (shadow!=0) @@ -285,14 +302,14 @@ fail180 <- (isMerc || isLongLat) if ((fail180)||(isLongLat || isMerc)) { if (!isLongLat) { - lon0 <- as.numeric(.gsub(".*\\+lon_0=(\\S+)\\s*.*","\\1",proj4)) + lon0 <- .crsLon0(proj4) B <- mean(abs(.project(rbind(cbind(lon0-180+1e-9,-45),cbind(lon0+180-1e-9,+45)) ,proj4)[,1])) } else B <- 180 if (isMerc) { - # B <- .getMajorSemiAxis(proj4)*pi + # B <- .crsSemiMajor(proj4)*pi # B <- 7720000 '.shift' <- function(seg) { # if (all(seg[,2]>0)) ## debug Chukotka vs @@ -527,7 +544,7 @@ ##~ isFound <- FALSE if (!coastline) return(NULL) - g1 <- session_grid() + g1 <- .panel_grid() ## session_grid() # if (!isFound) obj <- .getPrm(arglist,class="ursaCoastLine",default=NULL) figure <- getOption("ursaPngFigure") @@ -550,9 +567,10 @@ } } if ((any(obj$panel))&&(!(figure %in% obj$panel))) - return(NULL) - if (is.null(obj$coast_xy)) - return(NULL) + return(invisible(NULL)) + if (is.null(obj$coast_xy)) { + return(invisible(NULL)) + } if (!FALSE) { obj$col <- .getPrm(arglist,name="col",kwd=kwd,default=obj$col) obj$fill <- .getPrm(arglist,name="fill",kwd=kwd,default=obj$fill) @@ -607,8 +625,10 @@ } ## ?polypath: Hatched shading (as implemented for polygon()) is not (currently) supported. ## if semi-opacity|trasparency them 'polygon' else fill is transparent - polypath(coast_xy[,1],coast_xy[,2],border=col,col=fill - ,rule=c("winding","evenodd")[2],lwd=lwd) ##,density=15?? + ret <- try(polypath(coast_xy[,1],coast_xy[,2],border=col,col=fill + ,rule=c("winding","evenodd")[2],lwd=lwd)) ##,density=15?? + if (inherits(ret,"try-error")) + cat("Plotting coastline...",ret) } } }) diff --git a/R/panel_graticule.R b/R/panel_graticule.R index b4cc0e9..a696491 100644 --- a/R/panel_graticule.R +++ b/R/panel_graticule.R @@ -57,18 +57,18 @@ if (verbose) str(list(col=col,lon=lon,lat=lat,col=col,lwd=lwd,lty=lty,panel=panel ,marginalia=marginalia,trim=trim,cex=cex)) - opStrangeWarn <- options(warn=-1) ## strings not representable in native encoding will be translated to UTF-8 + # opStrangeWarn <- options(warn=-1) ## strings not representable in native encoding will be translated to UTF-8 ret <- .compose_graticule(panel=panel,col=col,border=border ,lon=lon,lat=lat,lwd=lwd,lty=lty ,marginalia=marginalia,trim=trim ,language=language,cex=cex,verbose=verbose) - options(opStrangeWarn) + # options(opStrangeWarn) ret } '.compose_graticule' <- function(panel=0L,col="grey70",border="grey70",lon=NA,lat=NA ,lwd=0.5,lty=2,marginalia=rep(FALSE,4),trim=FALSE ,language=NA_character_,cex=0.75,verbose=FALSE) { -# verbose <- TRUE + # verbose <- TRUE if (is.na(language)) { if (TRUE) { ctype <- Sys.getlocale("LC_TIME") @@ -78,12 +78,28 @@ else language <- Sys.getenv("LANGUAGE") } - g1 <- session_grid() - proj4 <- g1$crs - isProj <- nchar(proj4)>0 - projClass <- if (isProj) .gsub(".*\\+proj=(\\S+)\\s.+","\\1",proj4) else "" - isLonLat <- .lgrep("(\\+proj=longlat|epsg:4326)",proj4)>0 - isMerc <- .lgrep("\\+proj=merc",proj4)>0 + g1 <- .panel_grid() # session_grid() + if (is.null(g1)) ## e.g. from `glance()` + g1 <- .compose_grid() + if (!.crsForceWKT()) + proj4 <- .proj4string(g1$crs) + else + proj4 <- g1$crs ## proj4sring is FASTER for 'sf' + isProj <- .isCRS(g1$crs) + # projClass <- if (isProj) .gsub(".*\\+proj=(\\S+)\\s.+","\\1",proj4) else "" + if (isProj) { + projClass <- .crsProj(proj4) + if (T & !nchar(projClass)) { + proj4 <- if (.crsForceProj4()) .proj4string(proj4) else .WKT(proj4) + projClass <- .crsProj(proj4) + } + } + else + projClass <- "" + isLonLat <- projClass=="longlat" # .isLongLat(proj4) # lgrep("(\\+proj=longlat|epsg:4326)",proj4)>0 + isMerc <- projClass=="merc" # .isMerc(proj4) # .lgrep("\\+proj=merc",proj4)>0 + if (verbose) + print(data.frame(isProj=isProj,projClass=projClass,isLonLat=isLonLat,isMerc=isMerc)) minx <- g1$minx maxx <- g1$maxx if (g1$minylat[1] & lat31) lat0 else lat1 + # if (length(lat)1) { @@ -463,8 +483,9 @@ } lonList <- list(unique(lon)) latList <- list(unique(lat)) - # print(lon) - # print(lat) + if (verbose) { + print(list(lon=lon,lat=lat)) + } } marginalia <- rep(marginalia,length=4) # north <- 89.5 @@ -477,7 +498,7 @@ } outframe <- NULL alim <- 15 ## critical anlge (degree) between border line and grid line - projclass <- .gsub(".+proj=(\\S+)\\s.+","\\1",g1$crs) + # projclass <- .crsProj(g1$crs) ## was assign earlier for (j in seq_along(lonList)) { lonSet <- unique(round(lonList[[j]],11)) @@ -495,105 +516,156 @@ llkind <- rep(0L,length(gridline)) llval <- rep(NA,length(gridline)) i <- 0L + if (isMerc) { + B <- .crsSemiMajor(g1$crs)*pi + ##~ lon_0 <- as.numeric(.gsub(".*\\+lon_0=(\\S+)\\s.*","\\1",g1$crs)) + ##~ lat_ts <- .gsub2("\\+lat_ts=(\\S+)\\s","\\1",g1$crs) + ##~ lat_ts <- ifelse(lat_ts==g1$crs,0,as.numeric(lat_ts)) + lon_0 <- .crsLon0(g1$crs) + lat_ts <- .crsLatTS(g1$crs) + lonS <- seq(-180,360,len=10) + } if (!isProj) { - lat <- seq(min(latSet),max(latSet),len=10) + latS <- seq(min(latSet),max(latSet),len=10) + lonS <- seq(min(lonSet),max(lonSet),len=10) } else { latSet <- na.omit(latSet) - if (projclass %in% c("stere","laea")[1]) - lat <- seq(min(latSet),max(latSet),len=2) - else if (projclass %in% c("merc")) - lat <- c(-1,1)*(90-1e-6) + if (projClass %in% c("stere","laea")[1]) + latS <- seq(min(latSet),max(latSet),len=2) + else if (projClass %in% c("merc")) + latS <- c(-1,1)*(90-1e-6) else { if (length(latSet)==1) - lat <- latSet + latS <- latSet else { - lat <- seq(min(latSet),max(latSet),by=mean(diff(latSet))/10) + latS <- seq(min(latSet),max(latSet),by=abs(mean(diff(latSet))/10)) } } + lonS <- seq(min(lonSet),max(lonSet),by=mean(abs(diff(lonSet)))/(j*10)) } - if (isMerc) { - B <- .getMajorSemiAxis(g1$crs)*pi - lon_0 <- as.numeric(.gsub(".*\\+lon_0=(\\S+)\\s.*","\\1",g1$crs)) - lat_ts <- .gsub2("\\+lat_ts=(\\S+)\\s","\\1",g1$crs) - lat_ts <- ifelse(lat_ts==g1$crs,0,as.numeric(lat_ts)) - } - for (lon in lonSet) - { - if (!((isLonLat)||(isMerc))) { - if ((lon==360)&&(0 %in% lonSet)) - next - if ((lon==-180)&&(+180 %in% lonSet)) + if (projectAtOnce <- TRUE) { + for (lon in lonSet) { + if (!((isLonLat)||(isMerc))) { + if ((lon==360)&&(0 %in% lonSet)) + next + if ((lon==-180)&&(+180 %in% lonSet)) + next + } + i <- i+1L + gridline[[i]] <- cbind(rep(lon,length(latS)),unname(latS)) + llkind[i] <- 1L + llval[i] <- lon + } + for (lat in latSet) { + if (abs(lat)==max(abs(latSet))) next + i <- i+1L + gridline[[i]] <- cbind(unname(lonS),rep(lat,length(lonS))) + llkind[i] <- 2L + llval[i] <- lat } - i <- i+1L - ll <- cbind(rep(lon,length(lat)),lat) - # proj4a <- "+proj=merc +lon_0=48 +x_0=0 +y_0=0 +datum=WGS84 +units=m +no_defs " - # gridline[[i]] <- if (isProj & !isLonLat) proj4::project(t(ll),g1$crs) else ll if (isProj & !isLonLat) { - gridline[[i]] <- .project(ll,g1$crs) - # gridline[[i]] <- .project(ll,proj4a) - if ((FALSE)&&(isMerc)) { - x <- gridline[[i]][1,1] - print(data.frame(lon=lon,x=x,y=(lon-lon_0)/180*B)) - ##~ if (((lon<0)&&(x>maxx))||(lon<=(-180))) - ##~ x <- x-2*20037508 - ##~ else if ((lon>360)&(x0)) - x <- x-2*B - else if ((lon>360)&(xmaxx) - # x <- x-2*20037508 - # else if (x0))) - # gridline[[i]][,1] <- -2*20037508+gridline[[i]][,1] } - else - gridline[[i]] <- ll - llkind[i] <- 1L - llval[i] <- lon } - if (projclass %in% c("merc")) - lon <- seq(-180,360,len=10) - else if (isProj) - lon <- seq(min(lonSet),max(lonSet),by=mean(abs(diff(lonSet)))/(j*10)) - else - lon <- seq(min(lonSet),max(lonSet),len=10) - for (lat in latSet) - { - i <- i+1L - if (abs(lat)==max(abs(latSet))) - gridline[[i]] <- cbind(NA,NA) - else { - ll <- cbind(lon,rep(lat,length(lon))) - # print(series(ll,3)) + else { ## deprecated + if (!.isPackageInUse()) + cat("Deprecated: multiple calling '.project()'\n") + for (lon in lonSet) + { + if (!((isLonLat)||(isMerc))) { + if ((lon==360)&&(0 %in% lonSet)) + next + if ((lon==-180)&&(+180 %in% lonSet)) + next + } + i <- i+1L + ll <- cbind(rep(lon,length(latS)),unname(latS)) + # proj4a <- "+proj=merc +lon_0=48 +x_0=0 +y_0=0 +datum=WGS84 +units=m +no_defs " # gridline[[i]] <- if (isProj & !isLonLat) proj4::project(t(ll),g1$crs) else ll if (isProj & !isLonLat) { - ll <- .project(ll,g1$crs) - if (projclass %in% "merc") { - ll <- ll[order(ll[,1]),] - ll[1,1] <- ll[1,1]-1e8 - ll[nrow(ll),1] <- ll[nrow(ll),1]+1e8 + gridline[[i]] <- .project(ll,proj4) + # gridline[[i]] <- .project(ll,proj4a) + if ((FALSE)&&(isMerc)) { + x <- gridline[[i]][1,1] + print(data.frame(lon=lon,x=x,y=(lon-lon_0)/180*B)) + ##~ if (((lon<0)&&(x>maxx))||(lon<=(-180))) + ##~ x <- x-2*20037508 + ##~ else if ((lon>360)&(x0)) + x <- x-2*B + else if ((lon>360)&(xmaxx) + # x <- x-2*20037508 + # else if (x0))) + # gridline[[i]][,1] <- -2*20037508+gridline[[i]][,1] + } + else + gridline[[i]] <- ll + llkind[i] <- 1L + llval[i] <- lon + } + for (lat in latSet) + { + i <- i+1L + if (abs(lat)==max(abs(latSet))) + gridline[[i]] <- cbind(NA,NA) + else { + ll <- cbind(unname(lonS),rep(lat,length(lonS))) + # print(series(ll,3)) + # gridline[[i]] <- if (isProj & !isLonLat) proj4::project(t(ll),g1$crs) else ll + if (isProj & !isLonLat) { + ll <- .project(ll,proj4) + if (projClass %in% "merc") { + ll <- ll[order(ll[,1]),] + ll[1,1] <- ll[1,1]-1e8 + ll[nrow(ll),1] <- ll[nrow(ll),1]+1e8 + } + ind <- which(diff(ll[,1])<0) + if ((length(ind)==2)&&(ind[1]+1!=ind[2])) { + ll <- ll[(ind[1]+1):ind[2],,drop=FALSE] + } } + gridline[[i]] <- ll } - gridline[[i]] <- ll + llkind[i] <- 2L + llval[i] <- lat } - llkind[i] <- 2L - llval[i] <- lat } for (i in seq(along=gridline)) { @@ -830,7 +902,7 @@ if ((length(gridline)==1)&&(!gridline)) return(NULL) obj <- .getPrm(arglist,class="ursaGridLine",default=NULL) - g1 <- session_grid() + g1 <- .panel_grid() # session_grid() # if ((!is.null(g1$labx))&&(!is.null(g1$laby))) { if ((length(g1$seqx))&&(length(g1$seqy))) { .repairForScatterPlot() @@ -875,10 +947,8 @@ .panel_graticule(obj,marginalia=marginalia,verbose=verbose) } '.panel_graticule' <- function(obj,marginalia=rep(TRUE,4),verbose=FALSE) { - g1 <- getOption("ursaPngComposeGrid") - g2 <- getOption("ursaPngPanelGrid") - # print(g1) - # print(g2) + g1 <- .compose_grid() + g2 <- .panel_grid() # internal <- isTRUE(comment(marginalia)=="internal") internal <- !identical(g1,g2) if (internal) { @@ -921,6 +991,8 @@ } else cond3 <- TRUE + if (!.isPackageInUse()) + cat("============ panel_graticule: try `.identicalCRS()`\n") ret <- cond1 & cond2 & cond3 } } @@ -932,8 +1004,7 @@ with(obj,{ if (verbose) str(list(col=col,lwd=lwd,lty=lty)) - for (i in seq(along=gridline)) - { + for (i in seq(along=gridline)) { xy <- gridline[[i]] # if (all(is.na(xy))) # next @@ -944,9 +1015,13 @@ pngOp <- options()[.grep("^ursaPng.+",names(options()))] layout <- pngOp[["ursaPngLayout"]][["layout"]] layout0 <- (layout==pngOp[["ursaPngFigure"]]) - indr <- which(rowSums(layout0)==1) - indc <- which(colSums(layout0)==1) - # print(c(row=indr,column=indc)) + indr <- which(rowSums(layout0)>0) + indc <- which(colSums(layout0)>0) + if (length(indr)>1) + indr <- seq(min(indr),max(indr)) + if (length(indc)>1) + indc <- seq(min(indc),max(indc)) + # str(list(row=indr,column=indc)) if (FALSE) { isTop <- all(layout[1L:(indr-1L),indc]==0) isBottom <- all(layout[(indr+1L):nrow(layout),indc]==0) @@ -954,10 +1029,10 @@ isRight <- all(layout[indr,(indc+1L):ncol(layout)]==0) } else { - isTop <- all(layout[(indr-2L):(indr-1L),indc]==0) - isBottom <- all(layout[(indr+1L):(indr+2L),indc]==0) - isLeft <- all(layout[indr,(indc-2L):(indc-1L)]==0) - isRight <- all(layout[indr,(indc+1L):(indc+2L)]==0) + isTop <- all(layout[(min(indr)-2L):(min(indr)-1L),indc]==0) + isBottom <- all(layout[(max(indr)+1L):(max(indr)+2L),indc]==0) + isLeft <- all(layout[indr,(min(indc)-2L):(min(indc)-1L)]==0) + isRight <- all(layout[indr,(max(indc)+1L):(max(indc)+2L)]==0) } marginalia0 <- marginalia marginalia <- as.integer(marginalia0 & c(isBottom,isLeft,isTop,isRight)) @@ -971,10 +1046,10 @@ # fig2 <- pngOp[["ursaPngFigure"]] layout2 <- layout layout2[layout2<=panel2] <- 0L - isTop2 <- all(layout2[(indr-2L):(indr-1L),indc]==0) - isBottom2 <- all(layout2[(indr+1L):(indr+2L),indc]==0) - isLeft2 <- all(layout2[indr,(indc-2L):(indc-1L)]==0) - isRight2 <- all(layout2[indr,(indc+1L):(indc+2L)]==0) + isTop2 <- all(layout2[(min(indr)-2L):(min(indr)-1L),indc]==0) + isBottom2 <- all(layout2[(max(indr)+1L):(max(indr)+2L),indc]==0) + isLeft2 <- all(layout2[indr,(min(indc)-2L):(min(indc)-1L)]==0) + isRight2 <- all(layout2[indr,(max(indc)+1L):(max(indc)+2L)]==0) marginalia2 <- as.integer(marginalia0 & c(isBottom2,isLeft2,isTop2,isRight2)) marginalia2 <- as.integer(!marginalia)*marginalia2 if ((marginalia[4])&&(marginalia2[2])) diff --git a/R/panel_new.R b/R/panel_new.R index 42a820c..71ed938 100644 --- a/R/panel_new.R +++ b/R/panel_new.R @@ -12,7 +12,6 @@ options(ursaPngSkip=TRUE) return(invisible(NULL)) } - g1 <- session_grid() if (figN>1) { .panel_attribution() if (getOption("ursaPngBox")) @@ -21,39 +20,81 @@ options(ursaPngFigure=figN) arglist <- list(...) kwd <- "blank" + g1 <- .getPrm(arglist,name="(grid|ref|dim)",kwd=kwd,class="ursaGrid",default=NULL) + if (is.null(g1)) + g1 <- .panel_grid() + else + .panel_grid(g1) + crs <- if (is.null(g1)) "" else g1$crs density <- .getPrm(arglist,name="density",kwd=kwd,default=NA_real_) angle <- .getPrm(arglist,name="angle",kwd=kwd,default=NA_real_) def.col <- if ((any(!is.na(density)))&&(any(!is.na(angle)))) "grey80" else "chessboard" + if (devel5 <- FALSE) { + col <- .getPrm(arglist,name="(^$|fill)",kwd=kwd,class="character" + ,default="brown",verbose=TRUE) + str(col) + q() + } col <- .getPrm(arglist,name="(^$|bg|blank|fill)",kwd=kwd - ,default=ifelse(nchar(g1$crs)>0,def.col,"white")) # grey90 + ,default=ifelse(nchar(crs)>0,def.col,"white") + ,class=c("character","ursaColorTable")) # grey90 + alpha <- .getPrm(arglist,name="alpha",kwd=kwd,default=1) lwd <- .getPrm(arglist,name="lwd",kwd=kwd,default=1) lty <- .getPrm(arglist,name="lty",class=c("character","integer") ,kwd=kwd,default=1) mar <- .getPrm(arglist,name="mar",kwd=kwd,default=rep(0,4)) asp <- .getPrm(arglist,name="asp",kwd=kwd,default=NA_real_) # default=1? verbose <- .getPrm(arglist,name="verb(ose)*",kwd=kwd,default=FALSE) - .panel_new(col=col,density=density,angle=angle,lwd=lwd,lty=lty,mar=mar - ,asp=asp,verbose=verbose) + .panel_new(grid=g1,col=col,alpha=alpha,density=density,angle=angle + ,lwd=lwd,lty=lty,mar=mar,asp=asp,verbose=verbose) } -'.panel_new' <- function(col="chessboard",density=NA,angle=NA,lwd=1,lty=1 - ,asp=NA,mar=rep(0,4),verbose=FALSE) { +'.panel_new' <- function(col="chessboard",alpha=NA,density=NA,angle=NA + ,lwd=1,lty=1,asp=NA,mar=rep(0,4),grid=NULL + ,verbose=FALSE) { if (.skipPlot()) return(invisible(NULL)) if (verbose) - str(list(col=col,density=density,angle=angle,lwd=lwd,lty=lty,mar=mar,asp=asp)) - g1 <- session_grid() - scale <- getOption("ursaPngScale") + str(list(col=col,alpha=alpha,density=density,angle=angle,lwd=lwd,lty=lty + ,mar=mar,asp=asp)) + g1 <- .compose_grid() + if (noGrid <- is.null(grid)) + grid <- session_grid() + sc <- getOption("ursaPngScale") + if (!is.numeric(sc)) + sc <- 1 + if (T) { + mul <- 1 + cl <- getOption("ursaPngLayout") + m <- cl$layout + m[m!=getOption("ursaPngFigure")] <- 0 + indC <- which(colSums(m)>0) + indR <- which(rowSums(m)>0) + if ((length(indC))&&(length(indR))) { + if (length(indC)>1) + indC <- seq(min(indC),max(indC)) + if (length(indR)>1) + indR <- seq(min(indR),max(indR)) + ref0 <- c(sum(cl$size$r[indR]),sum(cl$size$c[indC])) + if (!identical(as.integer(.round(ref0)),unname(dim(grid)))) { + # print(ref0) + grid <- consistent_grid(grid,ref=ref0,verbose=!TRUE) + options(ursaPngPanelGrid=grid) + } + else if (noGrid) + options(ursaPngPanelGrid=grid) + } + } par(mar=rep(mar,length=4),xaxs="i",yaxs="i")#,xaxt="n",yaxt="n") - xlim <- with(g1,c(minx,maxx)) - ylim <- with(g1,c(miny,maxy)) - xlim[1] <- xlim[1]-1*g1$resx/scale - ylim[2] <- ylim[2]+1*g1$resy/scale + xlim <- with(grid,c(minx,maxx)) + ylim <- with(grid,c(miny,maxy)) + xlim[1] <- xlim[1]-1*grid$resx/sc + ylim[2] <- ylim[2]+1*grid$resy/sc plot(0,0,type="n",xlim=xlim,ylim=ylim,axes=FALSE,asp=asp,xlab="",ylab="") if (col=="chessboard") { - sc <- getOption("ursaPngScale") - if (!is.numeric(sc)) - sc <- 1 - g2 <- regrid(mul=sc/8,resetGrid=TRUE,tolerance=0.999) ## let rough grid + # print(session_grid()) + # if (!is.numeric(sc)) + # sc <- 1 + g2 <- regrid(grid,mul=sc/8,resetGrid=!TRUE,tolerance=0.999) ## let rough grid dima <- dim(g2) if (isTRUE(getOption("ursaPngBackground") %in% c("black","#000000"))) { minc <- 21/255 @@ -72,17 +113,20 @@ m2 <- matrix(rep(s2,length(ind2)),byrow=TRUE,ncol=ncol(a)) a[ind1,] <- m1 a[ind2,] <- m2 + # a[] <- runif(prod(dim(a)),min=0.6,max=1) panel_plot(as.raster(a),interpolate=FALSE) - session_grid(g1) + # session_grid(g3) col <- "white" } else { + a <- col2rgb(col,alpha=TRUE) + col <- rgb(a[1,],a[2,],a[3,],.round(a[4,]*alpha),maxColorValue=255) opEnd <- par(lend="square") for (an in angle) rect(min(xlim),min(ylim),max(xlim),max(ylim) ,col=col,border="transparent",density=density,angle=an,lwd=lwd,lty=lty) par(opEnd) } - options(ursaPngPanel=col,ursaPngPanelGrid=session_grid()) + options(ursaPngPanel=col) # ,ursaPngPanelGrid=g3 invisible(NULL) } diff --git a/R/panel_plot.R b/R/panel_plot.R index f3969b6..4f6ba38 100644 --- a/R/panel_plot.R +++ b/R/panel_plot.R @@ -15,8 +15,7 @@ arglist2 <- list(...) ## remove dupe of 'add=TRUE' ct <- NULL if (inherits(obj,c("raster"))) { - ret <- with(session_grid() - ,rasterImage(as.raster(obj),minx,miny,maxx,maxy,...)) + ret <- with(.panel_grid(),rasterImage(as.raster(obj),minx,miny,maxx,maxy,...)) } else if (is.character(obj)) { if (.lgrep("\\.(shp(\\.zip)*|(geojson|sqlite|gpkg)(\\.(gz|bz2))*)$",obj)) { @@ -40,7 +39,7 @@ ret <- panel_raster(read_gdal(obj),...) } else if ((getOption("ursaPngScale")==1)&& - (.lgrep("\\+proj=merc",session_crs())>0)&& + (.isMerc()>0)&& ((TRUE)||(.lgrep(obj,.tileService())))) { ret <- panel_raster(obj,...) } @@ -52,8 +51,11 @@ } else if (is_spatial(obj)) { oprj <- spatial_crs(obj) - sprj <- session_crs() - if (!identical(oprj,sprj)) { + sprj <- .panel_crs() # session_crs() + if (!identical(.crsBeauty(oprj,extended=TRUE),.crsBeauty(sprj,extended=TRUE))) { + if (F & !.isPackageInUse()) { + cat("Please check comparison of WKT strings\n") + } if ((is.list(oprj))&&("input" %in% names(oprj))) oprj <- oprj[["input"]] if ((is.list(sprj))&&("input" %in% names(sprj))) @@ -230,8 +232,14 @@ if ((.lgrep("pch",names(arglist2)))&& (arglist2$pch %in% c(21,22,23,24,25))) { ## ?pch op <- median(col2rgb(arglist2$bg,alpha=T)["alpha",]) + if (!is.null(arglist2$border)) { + bg <- c(col2rgb(arglist2$border)) + arglist2$col <- rgb(bg[1],bg[2],bg[3],op,maxColorValue=255) + } + else { arglist2$col <- rgb(0,0,0,op,maxColorValue=255) - # arglist2$bg <- "transparent" + # arglist2$bg <- "transparent" + } } } if (!.lgrep("cex",names(arglist2))) { @@ -265,6 +273,7 @@ else mul <- 1 lwd <- mul*as.numeric(gsub("\\D","",lwd)) + print("LWD") cell <- session_cellsize() sc <- getOption("ursaPngScale") dpi <- getOption("ursaPngDpi")/96 @@ -368,7 +377,7 @@ if ((TRUE)&&(.lgrep("point",geoType))&&(!is.null(ct))) { ret$col <- ct$colortable } - if ((all(ret$bg!="transpareny"))&&(all(ret$border=="transparent"))) { + if ((isTRUE(all(ret$bg!="transpareny")))&&(isTRUE(all(ret$border=="transparent")))) { ret$fill <- ret$bg } if ((TRUE)&&(.lgrep("polygon",geoType))) { @@ -507,6 +516,8 @@ opW <- options(warn=-1) ## release 'warn=-1': no warnings } ##~ message("-----------------") + ##~ str(.panel_grid()) + ##~ str(par()) ##~ str(obj) ##~ str(arglist) ##~ message("-----------------") diff --git a/R/panel_raster.R b/R/panel_raster.R index b5e6799..764a5aa 100644 --- a/R/panel_raster.R +++ b/R/panel_raster.R @@ -82,16 +82,24 @@ # panel_new() # print(obj) # q() - # print(c(isCT=.is.colortable(obj),isC=obj$category)) - isCT <- .is.colortable(obj) & .is.category(obj) # & attr(obj$value,"category") + # print(c(isCT=.is.colortable(obj),isC=.is.category(obj))) + # isCT <- .is.colortable(obj) & .is.category(obj) # & attr(obj$value,"category") + isCT <- .postponed.category(obj) ## ++ 20240213 if (isCT) ct <- ursa_colortable(obj) scale <- getOption("ursaPngScale") e <- band_nNA(obj) isRGB <- nband(obj) %in% c(2,3,4) & all(band_nNA(obj)>=0) # '==0' is NA used for RGB? - g1 <- getOption("ursaPngPanelGrid") - if (ursa_crs(g1)!=ursa_crs(obj)) + g1 <- .panel_grid() + if (!.identicalCRS(ursa_crs(g1),ursa_crs(obj))) { ## if (ursa_crs(g1)!=ursa_crs(obj)) { + # print(ursa_crs(g1) |> unclass()) + # print(ursa_crs(obj) |> unclass()) + if (!.isPackageInUse()) { + str(ursa_crs(g1)) + str(ursa_crs(obj)) + } obj <- .gdalwarp(obj,grid=g1) + } toResample <- floor(1/scale)>1 & !isRGB if (is.na(useRaster)) { cond1 <- getOption("ursaPngDevice")!="windows" @@ -100,8 +108,7 @@ useRaster <- cond1 && cond2 } if (verbose) - str(list(isRGB=isRGB,isCT=isCT,toResample=toResample,isColorTable=isCT - ,useRasrer=useRaster)) + str(list(isRGB=isRGB,isCT=isCT,toResample=toResample,useRasrer=useRaster)) if (toResample) { # obj <- contract(obj,size=sc,verbose=TRUE) @@ -127,6 +134,8 @@ if (!isCT) { if (!.is.colortable(obj)) { arglist[[1]] <- quote(obj) + # if (!length(grep("^lazy(load)*",names(arglist)))) + # arglist$lazyload <- FALSE obj <- do.call("colorize",arglist) } else if (!.is.category(obj)) { # attr(obj$value,"category") @@ -172,6 +181,8 @@ names(obj$colortable) <- ctname } } + if (inherits(obj$value,"ursaSymbol")) + obj <- reclass(obj) img <- as.matrix(obj,coords=TRUE) g1 <- ursa_grid(obj) #session_grid() if (F) { diff --git a/R/panel_scalebar.R b/R/panel_scalebar.R index 4943fda..39f5cd4 100644 --- a/R/panel_scalebar.R +++ b/R/panel_scalebar.R @@ -15,8 +15,8 @@ } position <- .getPrm(arglist,name="pos(ition)*",kwd=kwd ,class=list("character","numeric"),default="---") - g0 <- session_grid() - canScale <- .lgrep("(epsg:3857|\\+proj=(merc|zzzzz)\\s)",g0$crs)>0 + g0 <- .panel_grid() # session_grid() + canScale <- .isMerc(g0$crs) # .lgrep("(epsg:3857|\\+proj=(merc|zzzzz)\\s)",g0$crs)>0 if ((all(position=="---"))&&(canScale)) { lat <- with(g0,.project(rbind(c(minx,miny),c(maxx,maxy)),crs,inv=TRUE))[,2] sc <- sort(1/cos(lat*pi/180)) @@ -56,7 +56,7 @@ indirect <- FALSE if (verbose) str(list(position=position,w=w,cex=cex,col=col,bg=bg,fill=fill,verbose=verbose)) - g1 <- session_grid() + g1 <- .panel_grid() # session_grid() paperScale <- getOption("ursaPngPaperScale") if (is.na(language)) { if (TRUE) { @@ -85,7 +85,7 @@ options(opW) return(invisible(NULL)) } - isLonLat <- .lgrep("(\\+proj=longlat|epsg:4326)",g1$crs)>0 + isLonLat <- .isLongLat(g1$crs) # .lgrep("(\\+proj=longlat|epsg:4326)",g1$crs)>0 if ((isLonLat)||((TRUE)&&(!nchar(g1$crs)))) return(invisible(NULL)) isGeo <- nchar(g1$crs)>0 @@ -93,7 +93,7 @@ return(invisible(NULL)) dx <- with(g1,maxx-minx) dy <- with(g1,maxy-miny) - isMerc <- .lgrep("(\\+proj=merc|epsg\\:3857)",g1$crs)>0 + isMerc <- .isMerc(g1$crs) # .lgrep("(\\+proj=merc|epsg\\:3857)",g1$crs)>0 if (isMerc) { x3 <- pos[1] if (pos[1]<0.1) diff --git a/R/pixelsize.R b/R/pixelsize.R index 23ad079..94479e3 100644 --- a/R/pixelsize.R +++ b/R/pixelsize.R @@ -9,9 +9,10 @@ session_grid(NULL) g1 <- session_grid() } - if (.lgrep("\\+proj=stere",g1$crs)) + projClass <- .crsProj(g1$crs) + if (projClass=="stere") return(.pxlsize.stere(g1,verbose=verbose)) - if (.lgrep("\\+proj=merc",g1$crs)) + if (projClass=="merc") return(.pxlsize.merc(g1,verbose=verbose)) mul <- if (with(g1,resx*resy)<1e5) c("sq.m"=1) else c("sq.km"=1e-6) ursa_new(value=with(g1,resx*resy*mul) @@ -29,7 +30,7 @@ '.pxlsize.stere' <- function(g,verbose=FALSE) { # https://en.wikibooks.org/wiki/PROJ.4 '.pow' <- function(x,y) x^y - proj4 <- g$crs + proj4 <- .proj4string(g$crs) ## 'sf' is loaded here if (FALSE) semi <- c("6378137","6356752.3") ## low-precision if (.lgrep("\\+datum=WGS84",proj4)) diff --git a/R/polygonize.R b/R/polygonize.R index 883bb93..94b7ad0 100644 --- a/R/polygonize.R +++ b/R/polygonize.R @@ -1,8 +1,11 @@ -'polygonize' <- function(obj,fname,engine=c("native","sp","sf") +'polygonize' <- function(obj,fname,engine=c("native","sf") ,verbose=NA,...) { # class(obj) missing(obj) ## keep`session_grid` from reset in `a <- polygonize(envi_read())` - engine <- match.arg(engine) + engList <- as.character(as.list(match.fun("polygonize"))[["engine"]])[-1] + if ((isNamespaceLoaded("sp"))||(nchar(system.file(package="sp"))>0)) + engList <- c(engList,"sp") + engine <- match.arg(engine[1],engList) if (engine=="sp") { isSF <- FALSE isSP <- TRUE @@ -29,7 +32,8 @@ if ((!missing(obj))&&(is.numeric(obj))&&(length(obj)==4)&& ((!anyNA(match(names(obj),c("minx","maxx","miny","maxy"))))|| (!anyNA(match(names(obj),c("xmin","xmax","ymin","ymax")))))) { - obj <- regrid(bbox=unname(obj),dim=c(1,1),crs=session_crs()) + crs <- if (is.null(attr(obj,"crs"))) session_crs() else attr(obj,"crs") + obj <- regrid(bbox=unname(obj),dim=c(1,1),crs=crs) } onlyGeometry <- missing(obj) || .is.grid(obj) isList <- !onlyGeometry && .is.ursa_stack(obj) diff --git a/R/progressBar.R b/R/progressBar.R index af8fcbb..7687f72 100644 --- a/R/progressBar.R +++ b/R/progressBar.R @@ -16,6 +16,7 @@ n <- length(kind) max <- if ((n==1)&&(is.numeric(kind))&&(.is.integer(kind))) kind else n kind <- head(eval(formals()$kind),1) + # print(data.frame(n=n,max=max,kind=kind)) } else kind <- kind0 diff --git a/R/reclass.R b/R/reclass.R index 58f3f58..988ce1f 100644 --- a/R/reclass.R +++ b/R/reclass.R @@ -22,19 +22,21 @@ if (.is.colortable(dst)) { ct <- ursa_colortable(dst) val <- .deintervale(ct) - if (is.character(val)) - { + if (is.character(val)) { if (length(val)==length(ct)) {## categoral cname <- val val <- seq_along(val)-1L # str(list(value=val,name=cname,pal=unclass(unname(ct)))) pal <- unclass(unname(ct)) if (anyNA(pal)) { - res <- colorize(obj,value=val,name=cname) + # print("COLORIZE LIMITED (value, name)") + res <- colorize(obj,value=val,name=cname,lazyload=FALSE) ursa_colortable(res) <- ct } - else - res <- colorize(obj,value=val,name=cname,pal=unclass(unname(ct))) + else { + # print("COLORIZE LIMITED (value, name, pal") + res <- colorize(obj,value=val,name=cname,pal=pal,lazyload=FALSE) + } } else { ## interval ## not-tested res <- obj @@ -44,12 +46,14 @@ } else { # print(c(val=length(val),ct=length(ct))) - if (length(val)==length(ct)) ## categoral - { - res <- colorize(obj,value=val,pal=unclass(unname(ct))) + if (length(val)==length(ct)) { ## categoral + # print("COLORIZE LIMITED (value, pal)") + res <- colorize(obj,value=val,pal=unclass(unname(ct)),lazyload=FALSE) + } + else { ## interval + # print("COLORIZE LIMITED (value, breakvalue)") + res <- colorize(obj,breakvalue=val,pal=unclass(unname(ct)),lazyload=FALSE) } - else ## interval - res <- colorize(obj,breakvalue=val,pal=unclass(unname(ct))) } return(res) } @@ -77,7 +81,8 @@ class(obj$value) <- "ursaCategory" } else { - class(obj$value) <- "ursaNumeric" + class(obj$value) <- ifelse(.is.colortable(obj) + ,c("ursaNumeric","ursaSymbol")[2],"ursaNumeric") } if (TRUE) { n1 <- length(na.omit(c(obj$value))) @@ -137,6 +142,8 @@ args$src <- seq_along(ct)-1 if (length(val)==length(ct)) { ## categoral args$dst <- as.numeric(val) + if (.is.integer(val)) + args$dst <- as.integer(args$dst) } else { ## interval v1 <- as.numeric(val) @@ -177,7 +184,7 @@ if (TRUE) { ## ++ 20180706 if (inherits(obj$value,"ursaCategory")) class(obj$value) <- "ursaNumeric" - else if (inherits(obj$value,"ursaNumeric")) + else if (inherits(obj$value,c("ursaNumeric"))) class(obj$value) <- "ursaCategory" } return(obj) @@ -201,6 +208,7 @@ arglist <- list(...) if (!.lgrep("tail",names(arglist))) arglist$tail <- 0 + # print("COLORIZE EXPANDED") res <- do.call("colorize",c(list(obj),arglist),quote=TRUE) } res$colortable[] <- rep(NA_character_,length(res$colortable)) diff --git a/R/regrid.R b/R/regrid.R index 8cc5fc5..30d88a9 100644 --- a/R/regrid.R +++ b/R/regrid.R @@ -6,7 +6,8 @@ arglist <- list(...) if (missing(x)) { result <- .regrid(...) - resetGrid <- .getPrm(arglist,name="^reset",default=TRUE) + isPlot <- .is.grid(.compose_grid()) + resetGrid <- .getPrm(arglist,name="^reset",default=!isPlot) if (resetGrid) session_grid(result) return(result) @@ -30,7 +31,7 @@ session_grid(x) ## added 20160619 resetGrid <- TRUE cover <- NA - resample <- 1 + resample <- resample0 <- 1 verbose <- 0L cascade <- FALSE myname <- names(arglist) @@ -41,8 +42,13 @@ g2 <- ursa_grid(a) else if (.lgrep("^reset",n)) resetGrid <- as.logical(a) - else if (.lgrep("resample",n)) + else if (.lgrep("resample",n)) { + opW <- options(warn=-1) resample <- as.numeric(a) + options(opW) + if (is.na(resample)) + resample <- a + } else if (.lgrep("cover",n)) cover <- as.numeric(a) else if (.lgrep("cascade",n)) @@ -53,6 +59,18 @@ if (is.na(cover)) cover <- 0.5-1e-3 g1 <- x$grid + if (!.identicalCRS(spatial_crs(x),spatial_crs(g2))) { + if ((verbose)||(!.isPackageInUse())) { + cat("'gdalwarp' is used due to CRS iconsistence\n") + } + arglist[[1]] <- g2 + names(arglist)[1] <- "grid" + arglist <- c(list(src=x),arglist) + res <- do.call(".gdalwarp",arglist) + return(res) + } + if (is.character(resample)) + resample <- resample0 # isCT <- x$category # .is.category(x) ct <- x$colortable isCT <- length(ct)>0 @@ -175,7 +193,7 @@ ,proj4=NA,crs=NA,border=0 ,zero=c("keep","node","center") ,raster=FALSE,tolerance=NA #1e-10 - ,zoom=NA + ,zoom=NA,adjust=c(0.5,0.5) ,verbose=FALSE,...) { if (is.character(border)) ## cuttof 'border' in 'plot' functions @@ -206,6 +224,12 @@ message("grid from raster") g <- ursa_grid(grid) } + else if (is_spatial(grid)) { + checkZero <- TRUE + if (verbose) + message("grid from vector") + g <- spatial_grid(grid) + } else if ((is.character(grid))&&(envi_exists(grid,exact=TRUE))) { checkZero <- TRUE if (verbose) @@ -281,26 +305,49 @@ if (!anyNA(expand)) { x0 <- (g$minx+g$maxx)/2 y0 <- (g$miny+g$maxy)/2 - sx <- (g$maxx-g$minx)/2 - sy <- (g$maxy-g$miny)/2 + if (T) { + sx <- (g$maxx-g$minx)/2 + sy <- (g$maxy-g$miny)/2 + } else { + sx <- (g$maxx-g$minx)*c(adjust[1],1-adjust[1]) + sy <- (g$maxy-g$miny)*c(adjust[2],1-adjust[2]) + } if (length(expand)==1) { - expand <- rep(expand,length.out=2) - s <- sqrt(sx*sy) + if (expand>=1) + dx <- dy <- sqrt(sx*sy)*(expand-1) + else { + asp <- (sy/sx)^expand + v <- (sx+sy)*expand/(1+asp)*c(1,asp)-c(sx,sy) + dx <- v[1] + dy <- v[2] + } if (T) { - dx <- sx+round(s*(expand[1]-1)/g$resx*2)*g$resx/2 - dy <- sy+round(s*(expand[2]-1)/g$resy*2)*g$resy/2 + dx <- sx+round(dx/g$resx*2)*g$resx/2 + dy <- sy+round(dy/g$resy*2)*g$resy/2 } else { ## deprecated - dx <- sx+s*(expand[1]-1) - dy <- sy+s*(expand[2]-1) + s <- sqrt(sx*sy) + dx <- sx+s*(expand-1) + dy <- sy+s*(expand-1) } + bbox <- c(x0-dx*(0.5+adjust[1]) + ,y0-dy*(0.5+adjust[2]) + ,x0+dx*(0.5+(1-adjust[1])) + ,y0+dy*(0.5+(1-adjust[2])) + ) } else { - dx <- (expand[1])*sx - dy <- (expand[2])*sy + expand <- rep(expand,length.out=4) + # names(expand) <- c("miny","minx","maxy","maxx") + names(expand) <- c("minx","miny","maxx","maxy") + # expand <- expand[c(2,1,4,3)] + dx1 <- expand["minx"]*sx + dy1 <- expand["miny"]*sy + dx2 <- expand["maxx"]*sx + dy2 <- expand["maxy"]*sy + bbox <- unname(c(x0-dx1,y0-dy1,x0+dx2,y0+dy2)) } # print(with(g,c(minx,miny,maxx,maxy))) - bbox <- c(x0-dx,y0-dy,x0+dx,y0+dy) # print(bbox) } if ((anyNA(res))&&(!is.na(resx))&&(!is.na(resy))) @@ -333,6 +380,8 @@ g$maxy <- maxy minx <- miny <- maxx <- maxy <- NA } + if (is.na(tolerance)) + tolerance <- getOption("ursaTolerance",NA) if (is.na(tolerance)) { tolx <- .Machine$double.eps*max(abs(c(g$minx,g$maxx)))*mtol toly <- .Machine$double.eps*max(abs(c(g$miny,g$maxy)))*mtol @@ -539,9 +588,9 @@ print(seq(g,"y")) } } - # str(list(crs=crs,crs=proj4,'g$crs'=g$crs)) if ((is.na(proj4))&&(!is.na(crs))) proj4 <- crs + # str(list(crs=crs,proj4=proj4,'g$crs'=g$crs)) if (FALSE) { if (is.character(proj4)) g$crs <- proj4 @@ -594,6 +643,7 @@ } g$seqx <- numeric() g$seqy <- numeric() + g$crs <- .ursaCRS(g$crs) if (!raster) return(invisible(g)) session_grid(g) diff --git a/R/session.R b/R/session.R index 67c03bc..cc7cd8b 100644 --- a/R/session.R +++ b/R/session.R @@ -5,13 +5,12 @@ if ((is.null(ref))||(!.is.grid(ref))) { # fname <- system.file("template","default.hdr",package="ursa") fname <- file.path(getOption("ursaRequisite"),"template.hdr") - if (file.exists(fname)) { + if (!file.exists(fname)) fname <- system.file("requisite/template.hdr",package="ursa") - if (file.exists(fname)) - ref <- .read.hdr(fname)$grid - else - ref <- .read.hdr("default")$grid ## read.idr - } + if (file.exists(fname)) + ref <- .read.hdr(fname)$grid + else + ref <- .read.hdr("default")$grid ## read.idr options(ursaSessionGrid=ref) } if (!length(arglist)) { @@ -23,8 +22,11 @@ arglist <- NULL } } + # cat("`session_grid()` is called..............................\n") # above - 'Extract' (visible), below - 'Replace' (invisible) - options(ursaSessionGrid_prev=ref) + # options(ursaSessionGrid_prev=ref) + # if (is.null(getOption("ursaPngPanelGrid"))) + # options(ursaPngComposeGrid=NULL) if (is.null(obj)) return(options(ursaSessionGrid=NULL)) if (length(arglist)) { @@ -57,8 +59,7 @@ # print(spatial_dir(pattern=obj,recursive=FALSE)) opW <- options(warn=2) a <- try(open_envi(obj,resetGrid=TRUE,decompress=FALSE)) - options(opW) - if (inherits(a,"try-error")) { + if ((is.null(a))||(inherits(a,"try-error"))) { if (file.exists(obj)) { a <- open_gdal(obj) } diff --git a/R/spatial_engine.R b/R/spatial_engine.R index 271d84e..7339bc7 100644 --- a/R/spatial_engine.R +++ b/R/spatial_engine.R @@ -1,15 +1,23 @@ # wrappers to spatial (not raster) objects #.syn('spatial_crs',0,...) -'spatial_proj4' <- 'spatial_proj' <- 'spatial_crs' <- function(obj,verbose=FALSE) { +'spatial_proj4' <- 'spatial_proj' <- 'spatial_crs' <- function(obj + # ,beauty=FALSE + ,verbose=FALSE) { + beauty <- FALSE + if (.isUrsaCRS(obj)) + return(obj) if (!is.null(attr(obj,"crs",exact=TRUE))) { res <- attr(obj,"crs") if (inherits(res,"crs")) { if ((is.list(res))&&(!is.null(res$wkt))&&("sf" %in% loadedNamespaces())) { - return(sf::st_crs(res$wkt)$proj4string) + if (.crsForceProj4()) + return(.ursaCRS(.proj4string(res))) + else + return(.ursaCRS(.WKT(res))) } - return(res$proj4string) + return(.ursaCRS(res$proj4string)) } - return(res) + return(.ursaCRS(res)) } if ((TRUE)&&(is.character(obj))&&(nchar(obj)>0)&&(length(spatial_dir(obj))==1)) { obj <- spatial_read(obj) @@ -21,7 +29,12 @@ if (verbose) print(data.frame(ursa=isUrsa,sf=isSF,sp=isSP,prm=isPrm,row.names="engine")) if ((isSF)||(inherits(obj,"crs"))) { - return(sf::st_crs(obj)$proj4string) + if (.crsForceProj4()) + return(.ursaCRS(sf::st_crs(obj)$proj4string)) + if (beauty) + return(.ursaCRS(.crsBeauty(.WKT(sf::st_crs(obj))))) + # return(gsub("\\n\\s+","",.WKT(sf::st_crs(obj)))) + return(.ursaCRS(.WKT(sf::st_crs(obj)))) } if (isSP) { if (FALSE) ## `sp`<1.4-2 @@ -30,16 +43,25 @@ if (methods::is(spCRS,"CRS")) { wkt <- comment(spCRS) ret <- methods::slot(spCRS,"projargs") - if (FALSE) ## possible for future use - comment(ret) <- wkt - return(ret) + if (.crsForceProj4()) + return(.ursaCRS(ret)) + if (is.null(wkt)) + return(.ursaCRS("")) ## return(.ursaCRS(ret)) + if (beauty) + return(.ursaCRS(.crsBeauty(wkt))) + return(.ursaCRS(wkt)) } - return(NA_character_) + return(.ursaCRS(NA_character_)) } - if (isUrsa) + if (isUrsa) { + if (beauty) + return(.crsBeauty(ursa_crs(obj))) return(ursa_crs(obj)) + } if (isPrm) { - return(.epsg2proj4(obj,verbose=verbose,force=TRUE)) + if (!is.null(dim(obj))) + return(NULL) + return(.ursaCRS(.epsg2proj4(obj,verbose=verbose,force=TRUE))) } if (isTRUE(all(sapply(obj,.isSF)))) return(lapply(obj,spatial_crs,verbose=verbose)) @@ -134,6 +156,11 @@ 'spatial_bbox' <- function(obj,verbose=FALSE) { isSF <- .isSF(obj) isSP <- .isSP(obj) + if (is_ursa(obj)) + return(ursa_bbox(obj)) + if (.is.ursa_stack(obj)) { + return(lapply(obj,spatial_bbox,verbose=verbose)) + } if ((!isSF)&&(!isSP)&&(is.list(obj))) { if (isTRUE(all(sapply(obj,function(o) isTRUE(.isSF(o)) | isTRUE(.isSP(o)))))) { return(lapply(obj,spatial_bbox,verbose=verbose)) @@ -142,7 +169,7 @@ if (verbose) print(data.frame(sf=isSF,sp=isSP,row.names="engine")) res <- NULL - isLongLat <- .lgrep("\\+proj=longlat",spatial_crs(obj))>0 + isLongLat <- .isLongLat(spatial_crs(obj)) if (F & isLongLat) { xy <- spatial_coordinates(obj) if (F & isSF) { @@ -407,6 +434,8 @@ crs <- session_crs() else if ((is.ursa(crs))||(is.ursa(crs,"grid"))) crs <- ursa(crs,"crs") + else if (inherits(crs,"ursaCRS")) + crs <- unclass(crs) if (verbose) print(data.frame(sf=isSF,sp=isSP,row.names="engine")) if (isSF) { @@ -424,6 +453,8 @@ spatial_crs(obj) <- methods::slot(sp::CRS(crs0,doCheckCRSArgs=TRUE),"projargs") } ret <- sp::spTransform(obj,crs,...) + if (!length(spatial_fields(ret))) + spatial_data(ret) <- NULL options(opW) return(ret) # return(sp::spTransform(obj,crs,...)) ## sp::CRS(crs) ? @@ -711,8 +742,7 @@ ) } else { - res <- sp::SpatialLinesLengths(obj - ,longlat=.lgrep("\\+proj=longlat",spatial_crs(obj))>0) + res <- sp::SpatialLinesLengths(obj,longlat=.isLongLat(spatial_crs(obj))>0) } return(res) } @@ -826,8 +856,15 @@ path <- file.path(dirname(path),dpath[ind]) } } - res <- dir(path=path,pattern=patt0,full.names=full.names - ,recursive=recursive,ignore.case=ignore.case) + if ((TRUE)&&(file.exists(path))&&(grepl("\\.zip",basename(path)))) { + res <- unzip(path,list=TRUE)$Name + res <- res[grep(patt0,basename(res))] + # if (full.names) + # res + } + else + res <- dir(path=path,pattern=patt0,full.names=full.names + ,recursive=recursive,ignore.case=ignore.case) if ((!length(res))&&(is.na(pattern))) { if ((path==basename(path))&&(!dir.exists(path))) { # print("A") @@ -957,11 +994,11 @@ sf::st_agr(y) <- "constant" if (missedAttrTable <- is.null(spatial_data(x))) { xname <- basename(tempfile(pattern="field",tmpdir="")) - spatial_data(x) <- data.frame(array(0,dim=c(spatial_length(x),1) + spatial_data(x) <- data.frame(array(0,dim=c(spatial_count(x),1) ,dimnames=list(NULL,xname))) sf::st_agr(x) <- "constant" } - res <- try(sf::st_intersection(x,y)) + res <- try(sf::st_intersection(x,y),silent=TRUE) if (inherits(res,"try-error")) { if (length(grep("st_crs\\(x\\) == st_crs\\(y\\) is not TRUE" ,as.character(res)))) @@ -1312,8 +1349,11 @@ return(NULL) if ((length(arglist)==1)&& (any(sapply(arglist[[1]],is_spatial)))&& - (!is_spatial(arglist[[1]]))) + (!is_spatial(arglist[[1]]))) { arglist <- arglist[[1]] + if (length(ind <- which(sapply(arglist,is.null)))) + arglist <- arglist[-ind] + } res <- arglist[[1]] isSF <- .isSF(res) isSP <- .isSP(res) @@ -1440,6 +1480,8 @@ obj } 'spatial_grid' <- function(obj) { + if (missing(obj)) + return(session_grid()) if (!is_spatial(obj)) return(ursa_grid(obj)) if ((is.numeric(obj))&&(length(obj)==4)) { @@ -1455,12 +1497,33 @@ bbox <- bbox+100*c(-1,-1,1,1) crs <- spatial_crs(obj) } - if ((.lgrep("\\+proj=longlat",crs))&&(bbox["xmax"]<0)&&(bbox["xmin"]>0)) + if ((.isLongLat(crs))&&(bbox["xmax"]<0)&&(bbox["xmin"]>0)) bbox["xmax"] <- bbox["xmax"]+360 - nc <- (bbox["xmax"]-bbox["xmin"]) - nr <- (bbox["ymax"]-bbox["ymin"]) - res <- max(nc,nr)/640 - p <- as.numeric(pretty(res)) - res <- p[which.min(abs(res-p))] - regrid(setbound=unname(bbox),crs=crs,res=res) + if (isWeb <- .isWeb(session_grid())) { + res <- session_cellsize() + } + else { + nc <- (bbox["xmax"]-bbox["xmin"]) + nr <- (bbox["ymax"]-bbox["ymin"]) + res <- max(nc,nr)/640 + p <- as.numeric(pretty(res)) + res <- p[which.min(abs(res-p))] + } + ret <- regrid(setbound=unname(bbox),crs=crs,res=res) + ret +} +'spatial_crop' <- function(x,y) { + if (!.isSF(x)) + return(NULL) + # if (!.isSF(y)) + # return(NULL) + if (anyNA(sf::st_agr(x))) + sf::st_agr(x) <- "constant" + if (is_spatial_points(y)) + y <- spatialize(spatial_bbox(y)) + else if (length(match(na.omit(names(y)),c("minx","miny","maxx","maxy")))==4) + y <- spatialize(y) + else if (.is.grid(y)) + y <- spatialize(spatial_bbox(y)) + sf::st_crop(x,y) } diff --git a/R/spatial_read.R b/R/spatial_read.R index 2ea104f..7cfdabc 100644 --- a/R/spatial_read.R +++ b/R/spatial_read.R @@ -1,4 +1,4 @@ -'spatial_read' <- function(dsn,engine=c("native","sf","geojsonsf")) { +'spatial_read' <- function(dsn,engine=c("native","sf")) { 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 9f71289..b3ba7bb 100644 --- a/R/spatial_write.R +++ b/R/spatial_write.R @@ -1,7 +1,9 @@ 'spatial_write' <- function(obj,fname,layer,driver=NA,compress="" - ,ogr2ogr=nchar(Sys.which("ogr2ogr"))>0 + # ,ogr2ogr=nchar(Sys.which("ogr2ogr"))>0 ,verbose=FALSE) { # obj <- head(obj,100) + ogr2ogr <- TRUE + gdalUtils <- TRUE bname <- basename(fname) dname <- dirname(fname) if ((dname!=".")&&(!dir.exists(dname))) @@ -181,13 +183,16 @@ for (i in seq_along(fname1)) { if (!allSF) setUrsaProgressBar(pb) - b <- paste(fname,fname1[i],"-nln",lname[i]) + if (gdalUtils) + b <- c("-nln",lname[i]) + else + b <- c(fname,fname1[i],"-nln",lname[i]) if (length(dopt)) - b <- paste(paste("-dco",dopt),b) + b <- c("-dco",dopt,b) if (length(lopt)) - b <- paste(paste("-lco",lopt),b) + b <- c("-lco",lopt,b) if ((i==1)&&(keepCRS)) - b <- paste(b,"-t_srs",.dQuote(p4s[1])) + b <- c(b,"-t_srs",p4s[1]) if ((interimExt=="shp")&&(!is.null(iname[[i]]))) { aname <- sprintf("fld%03d",seq_along(iname[[i]])) s <- paste("select",paste(aname,"as",paste0("\\\"",iname[[i]],"\\\"") @@ -195,20 +200,40 @@ ,"from",paste0("\\\"" ,.gsub("\\.shp$","",basename(fname1[i])) ,"\\\"")) - s <- paste("-sql",.dQuote(s)) + s <- c("-sql",s) ##~ cat(s) ##~ cat("\n") ##~ s <- "" } else s <- "" - if (i==1) - cmd <- paste("ogr2ogr",s,"-f",.dQuote(driver),b) - else - cmd <- paste("ogr2ogr",s,"-update -append",b) - if (verbose) - message(cmd) - if (!system(cmd)) { + if (!gdalUtils) { + if (i==1) { + cmd <- paste("ogr2ogr",s,"-f",.dQuote(driver),b) + } + else { + cmd <- paste("ogr2ogr",s,"-update -append",b) + } + if (verbose) + message(cmd) + ret <- system(cmd)==0 + } + else { + if (i==1) { + opt <- c(s,"-f",driver,b) + } + else { + opt <- c(s,"-update","-append",b) + } + opt <- opt[nchar(opt)>0] + ret <- sf::gdal_utils("vectortranslate" + ,source=fname1[i] + ,destination=fname + ,options=opt + ,quiet=!verbose + ) + } + if (ret) { if (.lgrep("\\.shp$",basename(fname1[i]))) .shp.remove(fname1[i]) else if (file.exists(fname1[i])) @@ -299,7 +324,11 @@ } } isSF <- inherits(obj,c("sf","sfc")) - isSP <- !isSF + isSP <- (!isSF)&&(.forceRGDAL()) ## .forceRGDAL(TRUE) + if ((!isSP)&&(!isSF)) { + obj <- sf::st_as_sf(obj) + isSF <- TRUE + } if (verbose) print(data.frame(sf=isSF,sp=isSP,row.names="engine")) if (isSF) @@ -329,7 +358,7 @@ } if (isSP) { if (driver %in% c("GeoJSON","KML","GPX")) { - obj <- sp::spTransform(obj,sp::CRS("+init=epsg:4326")) + obj <- sp::spTransform(obj,sp::CRS("EPSG:4326")) } opW <- options(warn=1) # dsn <- if (driver %in% c("zzzESRI Shapefile")) dname else fname @@ -438,9 +467,8 @@ obj[,i] <- format(c(obj[,i,drop=TRUE]),tz="UTC","%Y-%m-%dT%H:%M:%SZ") } } - a <- geojsonsf::sf_geojson(obj,atomise=F,simplify=F,digits=6) + a <- geojsonsf::sf_geojson(obj,atomise=T,simplify=F,digits=6) # a <- iconv(a,to="UTF-8") - # writeLines(a,Fout) writeLines(a,Fout) } close(Fout) @@ -480,11 +508,11 @@ } b <- character() if (length(dopt)) - b <- c(b,paste("-dco",.dQuote(dopt))) + b <- c(b,c("-dco",dopt)) if (length(lopt)) - b <- c(b,paste("-lco",.dQuote(lopt))) + b <- c(b,c("-lco",lopt)) lnameF <- ifelse(interimExt=="shp",.gsub("\\.shp$","",basename(fname)),lname) - if (length(aname)) { + if ((exists("iname"))&&(length(aname))) { s <- paste("select" ,paste(iname,"as",paste0("\\\"",aname,"\\\""),collapse=",") ,"from",paste0("\\\"",lnameF,"\\\"")) @@ -492,21 +520,33 @@ } else s <- "" - cmd <- paste("ogr2ogr" - ,ifelse(verbose,"-progress",""),s - ,"-f",.dQuote(driver0) - ,ifelse(interimExt=="shp","",paste("-t_srs",.dQuote(p4s))) - ,b - ,.dQuote(fname0),.dQuote(fname),"-nln",lname) - if (verbose) - message(cmd) keepHDR <- length(envi_list(lname)) if (keepHDR) { fhdr2 <- tempfile() fhdr1 <-paste0(lname,".hdr") file.rename(fhdr1,fhdr2) } - system(cmd) ## this ov + if (!gdalUtils) { + cmd <- paste("ogr2ogr" + ,ifelse(verbose,"-progress",""),s + ,"-f",.dQuote(driver0) + ,ifelse(interimExt=="shp","",paste("-t_srs",.dQuote(p4s))) + ,b + ,.dQuote(fname0),.dQuote(fname),"-nln",lname) + if (verbose) + message(cmd) + system(cmd) ## this ov + } + else { + opt <- c(if (verbose) "-progress",if (nchar(s)) s,"-f",driver0 + ,if (interimExt!="shp") c("-t_srs",p4s),b) + ret <- sf::gdal_utils("vectortranslate" + ,source=fname + ,destination=fname0 + ,options=opt + ,quiet=!verbose + ) + } if (keepHDR) { file.rename(fhdr2,fhdr1) } diff --git a/R/segmentize.R b/R/trackline.R similarity index 94% rename from R/segmentize.R rename to R/trackline.R index 08dc86c..05d2959 100644 --- a/R/segmentize.R +++ b/R/trackline.R @@ -1,9 +1,9 @@ -'segmentize' <- function(obj,by=NULL,connect=c("united","consequent")) { +'trackline' <- function(obj,by=NULL,connect=c("united","consequent")) { connect <- match.arg(connect) # if (!is.null(by)) # connect <- "united" if ((!is.null(by))&&(connect=="consequent")) { - ret <- do.call(spatial_bind,by(obj,by,segmentize,connect=connect)) ## RECURSIVE + ret <- do.call(spatial_bind,by(obj,by,trackline,connect=connect)) ## RECURSIVE ##~ for (a in spatial_fields(obj)) { ##~ byvalue <- obj[[a]] ##~ str(a) @@ -20,7 +20,7 @@ if ((TRUE)&&(T & is.null(by))&&(spatial_geotype(obj) %in% c("MULTIPOINT"))&& (spatial_count(obj)>1)) { ret <- lapply(seq_len(spatial_count(obj)),\(j) { - res <- segmentize(obj[j,],by=spatial_data(obj[j,]),connect=connect) ## RECURSIVE + res <- trackline(obj[j,],by=spatial_data(obj[j,]),connect=connect) ## RECURSIVE }) ret <- do.call(spatial_bind,ret) return(ret) @@ -87,7 +87,7 @@ # sp::coordinates(x) <- c("coords.x1","coords.x2") sp::coordinates(x) <- crd } - ret <- segmentize(x,connect=connect) ## RECURSIVE + ret <- trackline(x,connect=connect) ## RECURSIVE ret }) ind <- which(!sapply(res,is.null)) diff --git a/R/ursa_as.R b/R/ursa_as.R index d9357af..63165c1 100644 --- a/R/ursa_as.R +++ b/R/ursa_as.R @@ -7,8 +7,9 @@ return(obj) return(ursa_new(obj,...)) } - if (.is.ursa_stack(obj)) + if (.is.ursa_stack(obj)) { return(ursa_brick(obj)) ## 20170122 removed 'return(obj)' + } if (is.data.frame(obj)) { return(allocate(obj,...)) } @@ -158,7 +159,6 @@ if ((is.list(obj))&&(!anyNA(match(c("filename","cols","rows","bands","driver" ,"geotransform","datatype","meta") ,names(obj))))) { ## from 'sf::gdal_read' - # .elapsedTime("A") columns <- obj$cols[2] rows <- obj$rows[2] bands <- obj$bands[2] @@ -168,8 +168,10 @@ # crs <- crs$proj4string if (is.character(crs)) crs <- sf::st_crs(crs)$proj4string - else if (inherits(crs,"crs")) - crs <- crs$proj4string + else if (inherits(crs,"crs")) { + crs <- .WKT(crs) + # crs <- .proj4string(crs) + } if (is.na(crs)) crs <- "" # patt <- "^Band_(\\d+)=\\t*(.+)$" @@ -184,7 +186,7 @@ maxx <- minx+columns*resx miny <- maxy-rows*resy # print(c(minx=minx,miny=miny,maxx=maxx,maxy=maxy)) - if (dontFlip <- miny>maxy) { + if (dontFlip <- ((miny>maxy))&&(nchar(crs)>0)) { interim <- maxy maxy <- miny miny <- interim @@ -211,8 +213,10 @@ } if (is.na(g1$crs)) g1$crs <- "" + g1$crs <- .ursaCRS(g1$crs) # .elapsedTime("J") session_grid(g1) + md <- .gdal_sfinfo(obj$filename) # hasData <- inherits("NULL",class(attr(obj,"data"))) hasData <- !inherits(attr(obj,"data"),"NULL") # .elapsedTime("sf::gdal_read -- start") @@ -227,7 +231,6 @@ attr(v,"units") <- NULL dimv <- dim(v) if (R.Version()$arch %in% c("i386","x86_64","dummy")[1:2]) { - # print("U") if (devel2 <- TRUE) { if (length(dimv)==2) dimv <- c(dimv,band=1L) @@ -269,16 +272,25 @@ } } if ((isCat)||((T & !.lgrep("float",obj$datatype)))) { - # .elapsedTime("F") - # v <- as.integer(v) - # dim(v) <- dimv - # storage.mode(v) <- "integer" - mode(v) <- "integer" + if ((is.na(md$scale))||(is.na(md$offset))) { + # .elapsedTime("F") + # v <- as.integer(v) + # dim(v) <- dimv + # storage.mode(v) <- "integer" + mode(v) <- "integer" + } # .elapsedTime("G") } # .elapsedTime("as.ursa -- before") # res <- as.ursa(v) ## RECURSIVE + names(attr(v,"dim")) <- NULL res <- ursa_new(v,flip=!dontFlip) + if (!is.na(md$nodata[1])) { + vmode <- mode(v) + if (vmode!=mode(md$nodata)) + mode(md$nodata) <- vmode + ignorevalue(res) <- unique(md$nodata) + } # .elapsedTime("as.ursa -- after") if (isCat) { ursa_colortable(res) <- ct @@ -417,6 +429,7 @@ return(res) } if (inherits(obj,"SpatRaster")) { ## package `terra` + g0 <- getOption("ursaSessionGrid") if (devel <- FALSE) { # a1 <- obj@ptr$getCategories() # a1 <- obj@ptr$getCatIndex() @@ -435,20 +448,21 @@ # crs <- obj@ptr$get_crs("proj4") # aname <- obj@ptr$names bbox <- as.vector(terra::ext(obj))[c(1,3,2,4)] - res <- terra::res(obj) + cell <- terra::res(obj) crs <- terra::crs(obj,proj=TRUE) # sn <- methods::slotNames(obj) # aname <- methods::slot(obj,sn)$names aname <- names(obj) ## wrong, TODO - g1 <- regrid(bbox=bbox,res=res,crs=crs) + g1 <- regrid(bbox=bbox,res=cell,crs=crs) if (identical(bbox,c(0,0,1,1))) g1 <- regrid(bbox=c(0,0,rev(dim(g1))),res=1,crs=crs) - # g0 <- getOption("ursaSessionGrid") # session_grid(g1) if (approved <- TRUE) { - opW <- options(warn=-1) + session_grid(g1) + # opW <- options(warn=-1) res <- ursa(obj[]) ## as.matrix() - options(opW) + # options(opW) + session_grid(g0) } else { .elapsedTime("rast -- 1") @@ -620,7 +634,7 @@ g1$crs <- p } else if (.lgrep("(lon|lat)",aname)==2) - g1$crs <- "+proj=longlat +datum=WGS84 +no_defs" + g1$crs <- .crsWGS84() session_grid(g1) } if (length(indz)==1) diff --git a/R/ursa_proj.R b/R/ursa_crs.R similarity index 88% rename from R/ursa_proj.R rename to R/ursa_crs.R index 71fbfdd..5427eb4 100644 --- a/R/ursa_proj.R +++ b/R/ursa_crs.R @@ -26,7 +26,7 @@ } 'ursa_crs<-' <- function(obj,keepGrid=FALSE,value) { if ((is.numeric(value))&&(.is.integer(value))) - value <- paste0("+init=epsg:",round(value)) + value <- paste0("EPSG:",round(value)) else if (inherits(value,"CRS")) value <- methods::slot(value,"projargs") else if (!is.character(value)) @@ -37,10 +37,11 @@ if (!is.ursa(obj)) { if (!.is.grid(obj)) return(NULL) - obj$crs <- ursa_crs(value) + obj$crs <- .ursaCRS(ursa_crs(value)) + # obj$crs <- ursa_crs(value) return(obj) } - obj$grid$crs <- ursa_crs(value) + obj$grid$crs <- .ursaCRS(ursa_crs(value)) if (!keepGrid) session_grid(obj) obj diff --git a/R/ursa_grid.R b/R/ursa_grid.R index d539a79..f50b8e6 100644 --- a/R/ursa_grid.R +++ b/R/ursa_grid.R @@ -99,7 +99,7 @@ ref$resx <- ref$resy <- 1 } } - g0 <- getOption("ursaPngComposeGrid") + g0 <- .compose_grid() isPlot <- isFALSE(is.null(g0)) if (!isPlot) g0 <- getOption("ursaSessionGrid") @@ -116,7 +116,7 @@ obj <- g0 if (identical(obj,ref)) return(obj) - isWeb <- ((.lgrep("\\+proj=merc",session_crs()))&& + isWeb <- ((.isMerc())&& (!is.na(.is.near(ursa(obj,"cellsize"),2*6378137*pi/(2^(1:21+8)))))) if (is_spatial(ref)) ref <- spatial_grid(ref) @@ -185,9 +185,38 @@ } ##~ d4 <- c(ursa(g3,"nrow"),ursa(g3,"ncol")) ##~ print(d4) - if (isPlot) { + if ((FALSE)&&(isPlot)) { # options(ursaPngPanelGrid=g3) session_grid(g3) } g3 } +'.compose_grid' <- function(obj) { + if (missing(obj)) { + g <- getOption("ursaPngComposeGrid") + if (is.null(g)) { + g <- getOption("ursaSessionGrid") + # options(ursaPngComposeGrid=g) + } + if (is.null(g)) + return(invisible(NULL)) + return(g) + } + options(ursaPngComposeGrid=ursa_grid(obj)) + invisible(NULL) +} +'.panel_grid' <- function(obj) { + if (.skipPlot(TRUE)) { + options(ursaPngComposeGrid=NULL) + return(invisible(NULL)) + } + if (missing(obj)) + return(getOption("ursaPngPanelGrid")) + g1 <- .compose_grid() + g2 <- spatial_grid(obj) + g3 <- consistent_grid(g2,ref=g1) + options(ursaPngPanelGrid=g3) + invisible(NULL) +} +'.panel_crs' <- function() .panel_grid()$crs +'.panel_cellsize' <- function() ursa(.panel_grid(),"cellsize") diff --git a/R/ursa_new.R b/R/ursa_new.R index c79ff52..3055935 100644 --- a/R/ursa_new.R +++ b/R/ursa_new.R @@ -50,7 +50,7 @@ sp <- with(grid,columns*rows) if (is.array(value)) ## # if ((is.null(grid))&&(is.array(value))) { - dimb <- dima <- dim(value) + dimb <- dima <- unname(dim(value)) if (length(dima)==2) { if ((TRUE)&&(dima[1]!=with(grid,columns*rows))) {## added 20160201 value <- value[,rev(seq(dima[2])),drop=FALSE] diff --git a/R/whiteboxing.R b/R/whiteboxing.R index 6c121bc..406ef84 100644 --- a/R/whiteboxing.R +++ b/R/whiteboxing.R @@ -44,7 +44,7 @@ for (i in seq_along(prm)) { if (is_ursa(prm[[i]])) { fname <- tempfile(fileext=".tif") - write_gdal(prm[[i]],fname,options="COMPRESS=LZW") + write_gdal(prm[[i]],fname,COMPRESS="LZW",TILED="NO") prm[[i]] <- fname } if (!nchar(pname[i])) { diff --git a/R/xxx.gdal_rasterize.R b/R/xxx.gdal_rasterize.R index ea98be3..4d3d2d5 100644 --- a/R/xxx.gdal_rasterize.R +++ b/R/xxx.gdal_rasterize.R @@ -43,7 +43,14 @@ dsn <- attr(obj,"dsn") # print(c(dsn=dsn,dsnE=dsnE)) g0 <- attr(obj,"grid") + if (is.null(g0)) { + g0 <- getOption("ursaSessionGrid") + if (is.null(g0)) + g0 <- spatial_grid(obj) + } dname <- attr(obj,"colnames") + if (is.null(dname)) + dname <- spatial_fields(obj) dmask <- .getPrm(arglist,name="(attr|field)",default=".+") feature <- .getPrm(arglist,name="feature",valid=c("field","geometry","FID")) where <- .getPrm(arglist,name="subset",default="") @@ -129,7 +136,7 @@ proj4 <- .gsub("(^\\s|\\s$)","",proj4) proj4 <- proj4[nchar(proj4)>0] if (noProj <- !length(proj4)) - proj4 <- "+proj=longlat +datum=WGS84 +no_defs" + proj4 <- .crsWGS84() ftemp <- .maketmp() # .maketmp() #tempfile(pattern="") # ".\\tmp1" cmd <- paste("ogrinfo","-q",.dQuote(dsn)) if (verbose) @@ -177,14 +184,14 @@ bb2 <- bb2[c(1,2,4,5)] } # print(proj4) - if (.lgrep("\\+proj=longlat",proj4)) { + if (.isLongLat(proj4)) { bb2[1][bb2[1]<(-179)] <- -180 bb2[3][bb2[3]>(179)] <- 180 } ## https://gdal.org/ogr2ogr.html https://gis-lab.info/qa/ogr2ogr-examples.html g1 <- regrid(g0,border=5) - cmd <- paste("ogr2ogr","-t_srs",.dQuote(g0$crs) - ,ifelse(noProj,paste("-s_srs",.dQuote(proj4)),"") + cmd <- paste("ogr2ogr","-t_srs",.dQuote(.proj4string(g0$crs)) + ,ifelse(noProj,paste("-s_srs",.dQuote(.proj4string(proj4))),"") ,"-sql",.dQuote(paste("select FID,* from",.dQuote(.dQuote(lname)))) ,"-dialect",c("SQLITE","OGRSQL")[2] ,"-select FID" @@ -234,7 +241,7 @@ ,"-sql",.dQuote(paste("select FID,* from",.dQuote(.dQuote(lname)))) ,"-dialect",c("SQLITE","OGRSQL")[2] ,"-init -1 -a_nodata -1" - ,"-a_srs",.dQuote(proj4) + ,"-a_srs",.dQuote(.proj4string(proj4)) ,"-tr",resx,resy # ,"-where",dQuote(subset) ,"-te",minx,miny,maxx,maxy diff --git a/R/xxx.gdalwarp.R b/R/xxx.gdalwarp.R index 9fb28f2..eef0e08 100644 --- a/R/xxx.gdalwarp.R +++ b/R/xxx.gdalwarp.R @@ -18,6 +18,8 @@ else grid <- ursa_grid(grid) isSF <- isTRUE(sf) & requireNamespace("sf",quietly=.isPackageInUse()) + if (F & !isSF) + isSF <- requireNamespace("sf",quietly=.isPackageInUse()) if (!isSF & !nchar(Sys.which("gdalwarp"))) { withRaster <- requireNamespace("raster",quietly=.isPackageInUse()) if (withRaster) { @@ -42,6 +44,7 @@ ct <- NULL if (is.ursa(src)) { ct <- ursa_colortable(src) + ursa_colortable(src) <- character() removeSrc <- TRUE .src <- src nodata <- ignorevalue(src) @@ -77,7 +80,7 @@ } if (!("co" %in% names(opt))) { if (driver=="GTiff") { - pr <- ifelse(((removeSrc)&&(inherits(.src$value,"ursaNumeric"))),3,2) + pr <- ifelse(((removeSrc)&&(inherits(.src$value,"ursaNumeric"))),c(3,1)[2],c(2,1)[2]) opt <- c(opt,co=paste0("COMPRESS=",c("DEFLATE","ZSTD")[1]) ,co=paste0("PREDICTOR=",pr) ,co="TILED=NO") @@ -90,7 +93,6 @@ optF <- "" } else if (!is.null(names(opt))) { - str(opt) if (T) ## 20230228++ optF <- paste(lapply(names(opt),\(x) { val <- opt[[x]] @@ -119,6 +121,11 @@ if (!("r" %in% names(opt))) { optF <- paste(optF,"-r",resample) } + proj4 <- gsub("\\n\\s+","",unclass(proj4)) + if (!isSF) + proj4 <- gsub("\"","\\\\\"",proj4) + # if (.isWKT(proj4)) + # proj4 <- .proj4string(proj4) if (is.null(grid)) cmd <- paste("-overwrite -of",driver ,ifelse(is.na(nodata),"",paste("-srcnodata",nodata,"-dstnodata",nodata)) @@ -128,7 +135,7 @@ cmd <- with(grid,c(NULL ,"-overwrite" ,"-of",driver - ,if (nchar(proj4)) c("-t_srs",.dQuote(proj4)) + ,if (nchar(proj4)) c("-t_srs",ifelse(isSF,proj4,.dQuote(proj4))) # ,if (nchar(proj4)) c("-t_srs",proj4) ,"-nosrcalpha" ,"-tr",resx,resy,"-te",minx,miny,maxx,maxy @@ -150,14 +157,20 @@ # Sys.setenv(PROJ_LIB=proj_lib) } else { - sf::gdal_utils("warp",src,dst,options=gsub("\"","",cmd),quiet=verbose==0L) + cmd <- gsub("(^\"|\"$)","",cmd) + sf::gdal_utils("warp",src,dst,options=cmd,quiet=verbose==0L) } session_grid(NULL) if (inMemory) { ret <- if (driver=="ENVI") read_envi(dst) else read_gdal(dst) - if (!is.null(ct)) - ursa_colortable(ret) <- ct - attr(ret,"copyright") <- credits + # hdr <- readLines(paste0(dst,".hdr")) + # print(hdr) + if (!is.null(ct)) { + ret <- colorize(ret,colorable=ct,lazyload=TRUE) ## ++ 20240304 + # ursa_colortable(ret) <- ct ## -- 20240304 + } + if (is.ursa(src)) + attr(ret,"copyright") <- credits } else if (!close) ret <- if (driver=="ENVI") open_envi(dst) else open_gdal(dst) diff --git a/R/xxx.geomap.R b/R/xxx.geomap.R index ae2b5a2..5edc81e 100644 --- a/R/xxx.geomap.R +++ b/R/xxx.geomap.R @@ -275,7 +275,7 @@ geocodeStatus <- FALSE if (.isSP(loc)) { proj4 <- sp::proj4string(loc) - if (!.lgrep("\\+proj=longlat",proj4)) { + if (!.isLongLat(proj4)) { loc <- sp::bbox(loc) if (length(loc)==6) loc <- loc[c(1,2,4,5)] @@ -287,8 +287,8 @@ if (inherits(loc,"sf")) loc <- sf::st_bbox(loc) proj4 <- attr(loc,"crs")$proj4string - # if (proj4!="+proj=longlat +datum=WGS84 +no_defs") - if (!.lgrep("\\+proj=longlat",proj4)) + # if (proj4!=.crsWGS84()) + if (!.isLongLat(proj4)) loc <- c(.project(matrix(loc,ncol=2,byrow=TRUE),proj4 ,inv=TRUE))[c(1,3,2,4)] } @@ -298,8 +298,11 @@ if ((TRUE)||(isWMS)) { if (is.null(loc)) { border <- 0 - g3 <- g0 <- getOption("ursaSessionGrid")#session_grid() + g0 <- getOption("ursaPngPanelGrid") + if (is.null(g0)) ## not after 'panel_new()' + g0 <- getOption("ursaSessionGrid")#session_grid() notYetGrid <- is.null(g0) + g3 <- g0 if (notYetGrid) loc <- c(-179,-82,179,82) else { @@ -347,8 +350,8 @@ x[1] <- x[1]-2*B lon_0 <- round(180*mean(x)/B,6) } - else if ((TRUE)&&(!is.null(g3))&&(.lgrep("\\+proj=(merc|laea)",g0$crs))) ## ++20180325 - lon_0 <- as.numeric(.gsub(".*\\+lon_0=(\\S+)\\s.*","\\1",g0$crs)) + else if ((TRUE)&&(!is.null(g3))&&(.lgrep("^(merc|laea)$",.crsProj(g0$crs)))) ## ++20180325 + lon_0 <- .crsLon0(g0$crs) # as.numeric(.gsub(".*\\+lon_0=(\\S+)\\s.*","\\1",g0$crs)) else lon_0 <- round(180*mean(x)/B,6) if (isPolar) { @@ -443,9 +446,14 @@ else if ((g0$columns<=size[1])&&(g0$rows<=size[2])) break } + if ((!notYetGrid)&&(!fixRes)&&(i==1)) { + spatialize(polygonize(ursa_bbox(g3)),style="web") + g0 <- session_grid() + i <- which.min(abs(s-ursa(g0,"cellsize"))) + } if ((isPolar)&&(!notYetGrid)) { ## more accurate checking is required - m1 <- gsub(".*\\+proj=laea\\s.+\\+lon_0=(\\S+)\\s.*","\\1",g0$crs) - m2 <- gsub(".*\\+proj=laea\\s.+\\+lon_0=(\\S+)\\s.*","\\1",g3$crs) + m1 <- .crsLon0(g0$crs) # gsub(".*\\+proj=laea\\s.+\\+lon_0=(\\S+)\\s.*","\\1",g0$crs) + m2 <- .crsLon0(g3$crs) # gsub(".*\\+proj=laea\\s.+\\+lon_0=(\\S+)\\s.*","\\1",g3$crs) m3 <- !is.na(.is.near(g0$resx,g3$resx)) m4 <- !is.na(.is.near(g0$resy,g3$resy)) m <- m1==m2 & m3 & m4 @@ -592,8 +600,8 @@ B0 <- 6378137 B <- B0*pi dz <- 2^zoom - res <- 2*pi*B0/dz - dx0 <- lon_0*pi/180*B0 + res <- 2*B/dz + dx0 <- lon_0*B/180 # lon_0*pi/180*B0 minx <- g0$minx+dx0 maxx <- g0$maxx+dx0 if (isWGS84) @@ -613,7 +621,7 @@ } else { g1 <- regrid(g0,setbound=c(minx,g0$miny,maxx,g0$maxy),proj=epsgWeb) - g1 <- regrid(g1,res=2*pi*B0/dz) + g1 <- regrid(g1,res=2*B/dz) g1 <- regrid(g1,res=c(g0$resx,g0$resy),crs=g0$crs) g1$minx <- g1$minx-dx0 g1$maxx <- g1$maxx-dx0 @@ -944,7 +952,7 @@ ,quiet=!verbose ) j <- if (i==1) 0 else sum(col2[seq(i-1)]) - img[,j+seq(col2[i]),] <- png::readPNG(fname) + img[,j+seq(col2[i]),] <- .readPNG(fname) # file.remove(fname) } basemap <- as.integer(255*as.ursa(img,aperm=TRUE,flip=TRUE)) @@ -982,7 +990,7 @@ download.file(src,fname,mode="wb" ,quiet=!verbose) } - basemap <- as.integer(255L*as.ursa(png::readPNG(fname) + basemap <- as.integer(255L*as.ursa(.readPNG(fname) ,aperm=TRUE,flip=TRUE)) if (!cache) file.remove(fname) diff --git a/R/xxx.ncdf.R b/R/xxx.ncdf.R index 3002815..705fa00 100644 --- a/R/xxx.ncdf.R +++ b/R/xxx.ncdf.R @@ -475,7 +475,7 @@ g1$crs <- b[[proj4]] # code lost: 'g1$crs <- p' } else if (.lgrep("(lon|lat)",aname)==2) - g1$crs <- "+proj=longlat +datum=WGS84 +no_defs" + g1$crs <- .crsWGS84() if (TRUE) g1 <- with(g1,regrid(g1,setbound=c(minx,miny,maxx,maxy) ,dim=c(rows,columns))) diff --git a/R/xxx.panel_WMS.R b/R/xxx.panel_WMS.R index 621cab9..e703fff 100644 --- a/R/xxx.panel_WMS.R +++ b/R/xxx.panel_WMS.R @@ -705,10 +705,11 @@ if (!nchar(Sys.which("gdalwarp"))) message("'gdalwarp' is required to be in search paths") } - proj4s <- unlist(strsplit(g0$crs,split="\\s+")) - ind <- .grep("\\+(proj=merc|[ab]=6378137|[xy]_0=0|k=1|units=m|lat_ts=0)",proj4s) - isMerc <- ((length(ind)==8)&&(!gdalwarp)) - isLonLat <- .lgrep("\\+proj=longlat",g0$crs)>0 + # proj4s <- unlist(strsplit(g0$crs,split="\\s+")) + # ind <- .grep("\\+(proj=merc|[ab]=6378137|[xy]_0=0|k=1|units=m|lat_ts=0)",proj4s) + # isMerc <- ((length(ind)==8)&&(!gdalwarp)) + isMerc <- (.isMerc(g0$crs))&&(.crsSemiMajor==6378137) + isLonLat <- .isLongLat(g0$crs) # .lgrep("\\+proj=longlat",g0$crs)>0 sc <- getOption("ursaPngScale") g3 <- g0 if ((is.numeric(sc))&&(sc<1e11+0.75)) { @@ -722,8 +723,9 @@ # print(g3,digits=15) } if (isMerc) { - ind <- .grep("\\+lon_0",proj4s) - lon0 <- as.numeric(.gsub(".+=(.+)","\\1",proj4s[ind])) + # ind <- .grep("\\+lon_0",proj4s) + # lon0 <- as.numeric(.gsub(".+=(.+)","\\1",proj4s[ind])) + lon0 <- .crsLon0(g0$crs) if (lon0==0) isMerc <- FALSE else { @@ -871,7 +873,7 @@ download.file(src2,dst,mode="wb",quiet=!verbose) } if (isPNG) - a <- try(png::readPNG(dst)) + a <- try(.readPNG(dst)) else if (isJPEG) a <- try(jpeg::readJPEG(dst)) else { @@ -882,7 +884,7 @@ if (isPNG) a <- try(jpeg::readJPEG(dst)) else if (isJPEG) - a <- try(png::readPNG(dst)) + a <- try(.readPNG(dst)) } if (inherits(a,"try-error")) { error <- paste(readLines(dst),collapse="\n") @@ -945,7 +947,7 @@ } if (!inherits(dst,"try-error")) { if (isPNG) - logo2 <- try(png::readPNG(dst)) + logo2 <- try(.readPNG(dst)) else if (isJPEG) logo2 <- try(jpeg::readJPEG(dst)) else { @@ -995,7 +997,7 @@ } if (!inherits(dst,"try-error")) { if (isPNG) - logo[[i]] <- try(png::readPNG(dst)) + logo[[i]] <- try(.readPNG(dst)) else if (isJPEG) logo[[i]] <- try(jpeg::readJPEG(dst)) else { diff --git a/R/xxx.panel_cluster.R b/R/xxx.panel_cluster.R index b433a9e..20a20bc 100644 --- a/R/xxx.panel_cluster.R +++ b/R/xxx.panel_cluster.R @@ -6,9 +6,18 @@ ##~ method <- c('1'="ward.D",'2'="ward.D2",'3'="single",'4'="complete" ##~ ,'5'="average",'6'="mcquitty",'7'="median" ##~ ,'8'="centroid")[4] ## 3 4! 8 + if (.skipPlot(TRUE)) + return(NULL) method <- match.arg(method) fun <- match.arg(fun) cutted <- 1.05 + bbox <- polygonize(ursa_bbox(getOption("ursaPngPanelGrid"))) + if (.isSF(obj)) { + sf::st_agr(obj) <- "constant" + obj <- sf::st_crop(spatial_transform(obj,spatial_crs(bbox)),bbox) + if (!spatial_count(obj)) + return(NULL) + } da <- spatial_data(obj) # str(colnames(da)) # str(da[,colnames(da),drop=TRUE]) @@ -47,7 +56,7 @@ print(c('Category'=indCat)) print(c('Count'=indNum)) } - g1 <- getOption("ursaPngPanelGrid") + g1 <- .panel_grid() 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]] @@ -99,13 +108,17 @@ # print(ngroup) } # print(ngroup) - print(series(xy4)) - str(bname) + if (verbose) { + print(series(xy4)) + str(bname) + } if ((!fun %in% c("mean","sum"))&&(ncol(xy4)>3)) bname <- bname[bname %in% xy4[[4]]] lutSep <- if (separate | length(bname)>1e6) sample(bname) else ".+" - str(bname) - print(lutSep) + if (verbose) { + str(bname) + print(lutSep) + } lutList <- lapply(lutSep,function(sep) { if (verbose) message(sQuote(sep),":") @@ -191,7 +204,7 @@ 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) + # lut$.r <- lut$.r/min(lut$.r) if (repel) { if (isTRUE(repel)) repel <- 20L @@ -405,11 +418,11 @@ stop("'z' values must be positive.") if (verbose) cat("--------\nPIE\n----------\n") - g0 <- getOption("ursaPngPanelGrid") + g0 <- .panel_grid() if (verbose) { print(session_grid()) print(g0) - print(getOption("ursaPngComposeGrid")) + print(.compose_grid()) print(getOption("ursaSessionGrid")) } cell <- ursa(g0,"cellsize") diff --git a/R/xxx.polarmap.R b/R/xxx.polarmap.R index 97d7192..ca2aa46 100644 --- a/R/xxx.polarmap.R +++ b/R/xxx.polarmap.R @@ -28,7 +28,7 @@ ,addFeature=TRUE,addHomeButton=TRUE ,addMouseCoordinates=TRUE,addScaleBar=TRUE ,addMeasure=FALSE - ,style=c("Arctic Connect","Arctic SDI")) { + ,style=c("Arctic SDI","Arctic Connect")) { isSDI <- isTRUE(.lgrep("sdi",style[1])>0) isConnect <- !isSDI if (onlyBasemap <- missing(obj)) { @@ -67,11 +67,11 @@ } else { layer <- as.character(as.list(match.call())[["obj"]]) ## try mget(names(match.call())[-1]) - if (!length(grep("\\+proj=laea",spatial_crs(obj)))) + if (.crsProj(spatial_crs(obj))!="laea") ## if (!length(grep("\\+proj=laea",spatial_crs(obj)))) obj <- spatialize(obj,resetProj=TRUE,resetGrid=TRUE,style=style) } if (is.na(epsg)) { - lon_0 <- as.numeric(gsub(".*\\+lon_0=(\\S+)\\s*.*$","\\1",spatial_crs(obj))) + lon_0 <- .crsLon0(spatial_crs(obj)) # as.numeric(gsub(".*\\+lon_0=(\\S+)\\s*.*$","\\1",spatial_crs(obj))) epsg[lon_0<(-165) || lon_0>=(+135)] <- 3571 ## -180 epsg[lon_0>=(-165) && lon_0<(-125)] <- 3572 ## -150 epsg[lon_0>=(-125) && lon_0<(-70)] <- 3573 ## -100 @@ -98,7 +98,7 @@ bounds <- list(c(-extent,extent),c(extent,-extent)) resolutions <- sapply(0:18,function(x) maxResolution/(2^x)) crsArctic <- leaflet::leafletCRS(crsClass="L.Proj.CRS",code=paste0("EPSG:",epsg) - ,proj4def=ursa::spatial_crs(epsg) + ,proj4def=.proj4string(epsg) ,resolutions=resolutions,origin=origin,bounds=bounds) m <- leaflet::leaflet(options=leaflet::leafletOptions(crs=crsArctic,minZoom=3,maxZoom=12)) m <- leaflet::addTiles(m @@ -124,7 +124,7 @@ maxZoom <- 10 crsASDI <- leaflet::leafletCRS(crsClass="L.Proj.CRS" ,code=paste0("EPSG:",epsg) - ,proj4def=spatial_crs(epsg) + ,proj4def=.proj4string(epsg) ,resolutions=resolutions ,origin=c(-extentASDI,extentASDI) ,bounds=list(c(-extentASDI,extentASDI) diff --git a/R/xxx.spatialize.R b/R/xxx.spatialize.R index 3773a8f..1082456 100644 --- a/R/xxx.spatialize.R +++ b/R/xxx.spatialize.R @@ -1,4 +1,4 @@ -'spatialize' <- function(dsn,engine=c("native","sf","geojsonsf") +'spatialize' <- function(dsn,engine=c("native","sf")# ,"sp","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,16 +6,26 @@ ,style="auto" ## auto none internal keep # ,zoom=NA ,subset="",verbose=FALSE,...) { - if (.isPackageInUse()) { - engine <- match.arg(engine) - } - else { - engList <- as.character(as.list(match.fun("spatialize"))[["engine"]])[-1] - if (length(engine)36 ## need more accurate detecton of proj4 - isPROJ4 <- .lgrep("(\\+init=epsg\\:|\\+proj=\\w+|\\+(ellps|datum=))",style)>0 + isPROJ4 <- (.isProj4(style))||(.isWKT(style))|| + (grepl("(^WGS84$|^EPSG|^ESRI|\\s\\+\\S+=)",style)) + if (FALSE) + print(data.frame(proj4=.isProj4(style),wkt=.isWKT(style) + ,name=grepl("(^WGS84$|^EPSG|^ESRI|\\s)",style) + ,style=substr(style,1,16))) if (length(style)) { if (is.numeric(style)) isEPSG <- TRUE @@ -81,10 +102,11 @@ } } proj4 <- NULL - if ((!(style %in% c("auto","keep")))&& - (isFALSE(resetProj))) { ## ++20230612 - if (!((is.character(dsn))&&(style %in% .tileService()))) + if ((!cond1)&&(T | is.character(dsn))&&(isFALSE(resetProj))) { ## ++20230612 + # if (T | !(style %in% .tileService(providers=TRUE))) { ## 20240216 + if (!.isWeb() | !(style %in% .tileService(providers=TRUE))) { ## 20240221 resetProj <- TRUE + } } if (!((is.character(dsn))&&(length(dsn)==1))) { nextCheck <- TRUE @@ -128,6 +150,8 @@ } else if (isSP) { ## cross-classes dsn <- sf::as_Spatial(dsn) + if (isSF) + isSF <- FALSE } obj <- dsn rm(dsn) @@ -136,6 +160,10 @@ if ((nextCheck)&&(is.array(dsn))) { return(display(dsn,...)) } + if ((nextCheck)&&(is.ursa(dsn,"grid"))) { + print(dsn) + stop("TODO") + } if ((nextCheck)&&(is.ursa(dsn))) { if ((isSF)||(isSP)) { obj <- as.data.frame(dsn) @@ -151,8 +179,9 @@ colnames(obj)[1:2] <- coords } if (isSF) { - if (isCRS) + if (isCRS) { obj <- sf::st_as_sf(obj,coords=coords,crs=crsNow) + } else obj <- sf::st_as_sf(obj,coords=coords) } @@ -218,7 +247,7 @@ crsNow <- NA if (is.na(crsNow)) { if ((.lgrep("^(lon|lng$)",coords[1])==1)&&(.lgrep("^lat",coords[2])==1)) - crsNow <- "+proj=longlat +datum=WGS84 +no_defs" + crsNow <- .crsWGS84() else if (is.data.frame(dsn)) { if (is.character(attr(dsn,"crs"))) crsNow <- attr(dsn,"crs") @@ -230,8 +259,9 @@ ind <- unique(c(which(is.na(xy[,1])),which(is.na(xy[,2])))) if (length(ind)) dsn <- dsn[-ind,] - if (inherits(try(sf::st_crs(crsNow)),"try-error")) + if (inherits(try(sf::st_crs(crsNow),silent=TRUE),"try-error")) { obj <- sf::st_as_sf(dsn,coords=coords,crs=4326) + } else if (isCRS) obj <- sf::st_as_sf(dsn,coords=coords,crs=crsNow) else @@ -241,7 +271,7 @@ obj <- dsn sp::coordinates(obj) <- coords if (isCRS) { - if (!.try(sp::proj4string(obj) <- crsNow)) + if (!.try(sp::proj4string(obj) <- crsNow)) ## sp::CRS() loads 'sf' sp::proj4string(obj) <- "EPSG:4326" } } @@ -492,10 +522,10 @@ arglist[[1]] <- tail(as.character(arglist[[1]]),1) if ((TRUE)&&("auto" %in% style)) { arglist$style <- switch(geocode - ,nominatim="CartoDB" + ,nominatim="Positron" ,pickpoint="mapnik" ,google="google terrain color" - ,"CartoDB") + ,"Positron") } return(do.call(arglist[[1]],arglist[-1])) ## RECURSIVE!!! } @@ -536,7 +566,16 @@ NULL else if (isZip <- .lgrep("\\.zip$",dsn)>0) { opW <- options(warn=1) - ziplist <- unzip(dsn,exdir=tempdir()) + layer <- gsub("^\\./","",layer) + ziplist <- unzip(dsn,list=TRUE)$Name + fname <- grep(layer,ziplist,value=TRUE) + if (!identical(ziplist,fname)) { + if (grepl("\\.shp$",fname)) { + fname <- paste0("^",gsub("\\.shp$","",layer),"\\.(cpg|dbf|prj|shp|shx)$") + ziplist <- ziplist[grep(fname,ziplist)] + } + } + ziplist <- unzip(dsn,files=ziplist,exdir=tempdir()) options(opW) if ((FALSE)&&(!length(ziplist))&&(nchar(Sys.which("7z")))) { ziplist <- system(paste("7z","l","-scsUTF-8",dsn),intern=TRUE) @@ -579,6 +618,42 @@ # file.remove(rarlist) stop("RAR") } + if (length(dsn)>1) { + rel <- as.list(match.call()) ## try mget(names(match.call())[-1]) + rname <- names(rel) + j <- NULL + for (i in seq_along(rel)[-1]) { + if (is.language(rel[[i]])) { + if (isTRUE(getOption("ursaNoticeMatchCall"))) + message('spatialize: try `mget(names(match.call())[-1])` instead of `as.list(match.call())`') + res <- eval.parent(rel[[i]]) + if (is.null(res)) + j <- c(j,i) + else if (is.language(res)) { + res <- eval.parent(res) + if (!is.language(res)) { + assign(rname[i],res) + rel[[i]] <- res + } + else + stop("unable to evaluate agrument ",.sQuote(rname[i])) + } + else + rel[[i]] <- res + } + } + if (length(j)) + rel <- rel[-j] + arglist <- c(rel,list(...)) + fun <- tail(as.character(arglist[[1]]),1) + ret <- lapply(dsn,function(d) { + arglist$dsn <- paste0(d) + # str(arglist) + spatial_trim(do.call(fun,arglist[-1])) + }) + names(ret) <- spatial_basename(dsn) + return(ret) + } if (isCDF <- .lgrep("\\.(nc|hdf)$",dsn)>0) { obj <- .read_nc(dsn,".+") if (!inherits(obj,"data.frame")) @@ -666,6 +741,9 @@ } } else { + if ((isSF)&&(isSP)) { + isSF <- !.forceRGDAL() ## .forceRGDAL(TRUE) + } opW <- options(warn=ifelse(isSP,-1,0)) if (isSF) { lname <- try(sf::st_layers(dsn)$name) @@ -677,10 +755,12 @@ cat("Cannot get layers\n") return(NULL) } - if (!is.character(layer)) + if (!is.character(layer)) { layer <- lname[layer[1]] - else + } + else { layer <- .grep(layer,lname,value=TRUE) + } if (length(layer)>1) { if (prevBehaviour <- FALSE) { print(paste("Select only one layer:",paste(paste0(seq(layer),")") @@ -715,7 +795,8 @@ rel <- rel[-j] arglist <- c(rel,list(...)) ret <- lapply(layer,function(l) { - arglist$layer <- l + arglist$layer <- paste0("^",l,"$") + # str(arglist) spatial_trim(do.call(as.character(arglist[[1]]),arglist[-1])) }) names(ret) <- layer @@ -726,8 +807,16 @@ # opW2 <- options(warn=0) obj <- sf::st_read(dsn,layer=layer,quiet=TRUE) # options(opW2) - if (!spatial_count(obj)) - return(obj) + if (!spatial_count(obj)) { + if (isTRUE(getOption("ursaNoticeMatchCall"))) + message('spatialize: try `mget(names(match.call())[-1])` instead of `as.list(match.call())`') + # res <- eval.parent(rel[[i]]) + rel <- as.list(match.call()) ## try mget(names(match.call())[-1]) + rel[["dsn"]] <- quote(obj) + obj <- do.call(as.character(rel[[1]]),rel[-1]) + if (!spatial_count(obj)) + return(obj) + } if (TRUE) { .o <- obj obj <- try(sf::st_zm(.o,drop=TRUE)) @@ -735,6 +824,10 @@ obj <- .o rm(.o) } + if (isSP) { + obj <- sf::as_Spatial(obj) + isSF <- FALSE + } } else { if (isSHP <- .lgrep("\\.shp$",dsn)>0) { @@ -781,7 +874,7 @@ obj <- do.call("subset",list(obj,parse(text=subset))) } if ((geocodeStatus)&&("auto" %in% style)) { - style <- switch(geocode,nominatim=c("CartoDB","mapnik","openstreetmap color")[1] + style <- switch(geocode,nominatim=c("Positron","mapnik","openstreetmap color")[1] ,pickpoint="mapnik" ,google="google terrain color") } @@ -818,6 +911,8 @@ # str(asf) # return(invisible(20L)) } + isSP <- .isSP(obj) + isSF <- .isSF(obj) if ((!identical(dname0,dname))&&(length(dname))) { if (isSF) obj <- obj[,dname] @@ -839,7 +934,7 @@ # da <- obj[,dname[i],drop=TRUE][,,drop=TRUE] ## sf>=0.4 # str(da) } - if (isSP) { + else if (isSP) { da <- methods::slot(obj,"data")[,dname[i],drop=TRUE] } if (is.character(da)) { @@ -935,7 +1030,7 @@ ## if inherits(da,"POSIXlt") then 'da' is a list with 9 items if (isSF) obj[,dname[i]] <- da - if (isSP) { + else if (isSP) { if (!inherits(da,c("Date","POSIXct"))) { opW <- options(warn=-1) da2 <- as.numeric(da) @@ -956,7 +1051,7 @@ da <- as.integer(round(da)) if (isSF) obj[,dname[i]] <- da - if (isSP) + else if (isSP) methods::slot(obj,"data")[,dname[i]] <- da } } @@ -977,8 +1072,12 @@ Encoding(cname) <- "UTF-8" spatial_colnames(obj) <- cname } - if ((isSF)&&(!sum(sapply(spatial_geometry(obj),length)))) - return(spatial_data(obj)) + if (isSF) { + if ((is.data.frame(obj))&&(!nrow(obj))) + return(obj) # return(spatial_data(obj)) + if (!sum(sapply(spatial_geometry(obj),length))) + return(spatial_data(obj)) + } ##~ if ((isSP)&&(!length(methods::slot(spatial_geometry(obj),"coords")))) { ##~ stop("NULL geometry for Spatial class") ##~ return(spatial_data(obj)) @@ -1070,12 +1169,18 @@ len[len>mlen] <- mlen } # canTile <- .lgrep(art,eval(as.list(args(".tileService"))$server))>0 - if (proj %in% c("onemorekwd?",projClass)) + if (style=="web") { + canTile <- TRUE + } + else if (proj %in% c("onemorekwd?",projClass)) { canTile <- FALSE + } else { canTile <- .lgrep(art,.tileService())>0 - if (!canTile) { - canTile <- style %in% .tileService(providers=TRUE) + if ((!canTile)&&(!.isCRS(style))) { + if ((!style %in% c("auto","none","keep"))&&(!isPROJ4)) { + canTile <- style %in% .tileService(providers=TRUE) + } # if (canTile) # art <- style } @@ -1098,9 +1203,11 @@ (tpat==3) # isColor <- .lgrep("colo(u)*r",style)>0 isWeb <- .lgrep(tilePatt,art) - if (verbose) + if (verbose) { print(data.frame(proj=proj,art=art,static=isStatic ,canTile=canTile,tile=isTile,web=isWeb,row.names="spatialize:")) + # str(as.list(match.call())) + } # isOSM <- proj %in% "osm" # isGoogle <- proj %in% "google" # http://static-api.maps.sputnik.ru/v1/?width=400&height=400&z=6&clng=179&clat=70 @@ -1110,16 +1217,21 @@ # if ((resetProj)||(is.ursa(g0,"grid"))||(is.numeric(lon0))||(is.numeric(lat0))) { proj4 <- spatial_crs(obj) if (verbose) - str(list(proj4=proj4,proj=proj,style=style,resetProj=resetProj)) - if ((is.na(proj4))&&(nchar(style))&&(.lgrep("\\+proj=.+",style))) { ## ++ 20180530 - proj4 <- style - # isPROJ4 <- FALSE + str(list(proj4=proj4,proj=proj,style=style,resetProj=resetProj + ,isPROJ4=isPROJ4)) + if ((is.na(proj4))&&(nchar(style))) { + hasProj <- if (.isProj4(style)) .lgrep("\\+proj=.+",style)>0 + else nchar(.crsProj(style))>0 + if (hasProj) { ## ++ 20180530 + proj4 <- style + # isPROJ4 <- FALSE + } } if ((proj4=="")&&(!(proj %in% c("auto","internal","keep")))) { resetProj <- TRUE proj4 <- "auto" } - isLonLat <- .lgrep("(\\+proj=longlat|epsg:4326)",proj4)>0 + isLonLat <- .isLongLat(proj4) if ((proj %in% c("auto"))&&(isLonLat)&&(!isEPSG)&&(style!="keep")) { ## added 2016-08-09 resetProj <- TRUE proj4 <- "auto" @@ -1128,11 +1240,11 @@ resetProj <- TRUE proj4 <- "auto" } - isMerc <- .lgrep("\\+proj=merc",proj4)>0 + isMerc <- .isMerc(proj4) if (isMerc) { - major <- .gsub(".+\\+a=(\\S+)\\s.+","\\1",proj4) ## 20037508 + major <- .crsSemiMajor(proj4) #.gsub(".+\\+a=(\\S+)\\s.+","\\1",proj4) ## 20037508 if (identical(major,proj4)) { - if (.lgrep("\\+(datum|ellps)=WGS84",proj4)) + if (.lgrep("\\+(datum|ellps)=WGS84",proj4)) ## TODO for WKT B <- 20037508 else ## yandex? B <- 20037508 @@ -1326,7 +1438,7 @@ # ,"+nadgrids=@null" ,"+wktext +no_defs") else if ((proj %in% c("longlat"))||(isLonLat)) { - t_srs <- "+proj=longlat +datum=WGS84 +no_defs" + t_srs <- .crsWGS84() } else if (proj %in% c("zzzgoogle")) { if (FALSE)#(selection %in% c(1000L,3L)) @@ -1335,7 +1447,7 @@ ,"+units=m +nadgrids=@null +wktext +no_defs") else t_srs <- paste("+proj=merc +a=6378137 +b=6378137" - ,"+lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0" + ,"+lat_ts=0.0 +lon_0=0.0 +x_0=0 +y_0=0 +k=1.0" ,"+units=m +nadgrids=@null +wktext +no_defs") } else @@ -1451,11 +1563,14 @@ if (isSF) { # opE <- options(show.error.messages=TRUE) # print(sf::st_bbox(obj)) - src0 <- sf::st_crs(obj)$proj4string + src0 <- spatial_crs(obj) # sf::st_crs(obj)$proj4string if (!is.na(src0)) { + # if (!.isPackageInUse()) + # cat("Please devel comparison of two WKTs\n") t_srs <- spatial_crs(t_srs) g0$crs <- t_srs - if ((!identical(src0,t_srs))&&(nchar(t_srs)>0)) + if ((!identical(.crsBeauty(src0,extend=TRUE) + ,.crsBeauty(t_srs,extend=TRUE)))&&(nchar(t_srs)>0)) obj <- sf::st_transform(obj,t_srs) } # print(sf::st_crs(obj)$proj4string) @@ -1552,7 +1667,7 @@ res <- p[which.min(abs(res-p))] g1 <- ursa_grid() g1$resx <- g1$resy <- as.numeric(res) - g1$crs <- proj4 + g1$crs[] <- proj4 g0 <- regrid(g1,bbox=unname(bbox[c("xmin","ymin","xmax","ymax")]) ,border=0) ## border=border } @@ -1589,8 +1704,9 @@ g0 <- ursa(basemap,"grid") attr(obj,"basemap") <- basemap } - if (is.null(g2)) + if (is.null(g2)) { session_grid(g0) + } geoMix <- (.lgrep("point",geoType)>0)+ (.lgrep("line",geoType)>0)+ (.lgrep("polygon",geoType)>0)>1 @@ -1612,7 +1728,11 @@ # print("WORK FOR SPATIAL TRIM") # str(list(style=style,proj=proj)) cond1 <- ((proj!=style[1])&&(!style %in% c("none","keep","web"))) - if (i_am_not_ready_to_cancel_it <- cond1) { + cond2 <- (isPROJ4)||(!geocodeStatus) + ##~ print(isPROJ4) + ##~ print(geocodeStatus) + ##~ print(c(cond1=cond1,cond2=cond2)) + if (i_am_not_ready_to_cancel_it <- ((cond1)&&(!cond2))) { if (!inherits(obj,"SpatialPixels")) attr(obj,"grid") <- g0 else diff --git a/R/yyy.RogerBivand.R b/R/yyy.RogerBivand.R index 7fdfb99..487d114 100644 --- a/R/yyy.RogerBivand.R +++ b/R/yyy.RogerBivand.R @@ -1,5 +1,8 @@ '.DeadEnd' <- function() stop("Dead End after {rgdal}/{rgeos}/{maptools} retiring") '.Retired' <- function() stop("This function is retired") +'.Missing' <- function(p) { + stop(paste0("Required package ",ifelse(missing(p),"",dQuote(p))," is missing")) +} '.open_rgdal' <- function(...) .DeadEnd() '.rgdal_getRasterData' <- function(...) .DeadEnd() '.rgdal_putRasterData' <- function(...) .DeadEnd() @@ -30,15 +33,3 @@ '.rgeos_gUnion' <- function(...) .DeadEnd() '.rgeos_gSimplify' <- function(...) .DeadEnd() '.rgeos_gIsValid' <- function(...) .DeadEnd() -'.proj4_requireNamespace' <- function(...) { - # requireNamespace("proj4",quietly=.isPackageInUse()) - .Retired() -} -'.proj4_project' <- function(...) { - # proj4::project(...) - .Retired() -} -'.proj4_ptransform' <- function(...) { - # proj4::ptransform(...) - .Retired() -} diff --git a/R/yyy.cache.R b/R/yyy.cache.R index 9f42773..37c5559 100644 --- a/R/yyy.cache.R +++ b/R/yyy.cache.R @@ -37,6 +37,7 @@ dhw <- file.path(fpath,"htmlwidgets") if (dir.exists(dhw)) unlink(dhw) + file.remove(.dir(path=fpath,pattern="^___ursa\\d+.+$",full.names=TRUE)) ## '.*png' etc } unlink(fpath) return(invisible(NULL)) @@ -116,8 +117,8 @@ } 0L } -'.ursaCacheDownload' <- function(src,dst,method,quiet=FALSE,cache=TRUE - ,mode="w",headers=NULL) { +'.ursaCacheDownload' <- function(src,dst,method,quiet=FALSE,cache=TRUE,mode="w" + ,extra=getOption("download.file.extra"),headers=NULL) { enc <- "UTF-8" inventory <- .ursaCacheInventory() src0 <- src @@ -160,10 +161,10 @@ } } src1 <- src - patt <- "(^http(s)*://)\\{(.+)\\}(.+$)" ## \\1 \\3 \\4 + patt <- "(^http(s)*://(tile|mt)*)\\{(.+)\\}(.+$)" ## \\1 \\4 \\5 if (.lgrep(patt,src)) { - dom <- unlist(strsplit(gsub(patt,"\\3",src),"")) - src <- unname(sapply(sample(dom),function(x) gsub(patt,paste0("\\1",x,"\\4"),src1))) + dom <- unlist(strsplit(gsub(patt,"\\4",src),"")) + src <- unname(sapply(sample(dom),function(x) gsub(patt,paste0("\\1",x,"\\5"),src1))) # dom <- unlist(strsplit(.gsub2("\\{(.+)\\}","\\1",gsub("\\{.\\}","",src)),"")) # src <- .gsub("{.+}",sample(dom,1),src0) # src <- unname(sapply(sample(dom),function(x) .gsub("{.+}",x,src0))) @@ -191,7 +192,7 @@ # message("check inventory") was <- utils::read.table(inventory,sep=",",encoding=enc) colnames(was) <- c("time","stamp","visits","size","src","dst") - if (is.character(dst)) { + if (F & is.character(dst)) { stop("dst") } ind <- tail(which(!is.na(match(was$src,src0))),1) ## match(src0,was$src) @@ -216,7 +217,7 @@ for (i in seq_along(src)) { ret <- try(download.file(url=URLencode(iconv(src[i],to="UTF-8")) ,destfile=dst,method=method,quiet=quiet,mode=mode - ,headers=headers)) + ,extra=extra,headers=headers)) if (!inherits(ret,"try-error")) break } diff --git a/R/yyy.connection.R b/R/yyy.connection.R index bbb3586..41be10b 100644 --- a/R/yyy.connection.R +++ b/R/yyy.connection.R @@ -529,7 +529,7 @@ { nb <- ifelse(is.na(con$posZ[1]),con$bands,length(con$posZ)) seek(con,origin="start" - ,where=with(con,(lines*samples*nb-1)*sizeof+offset),rw="w") + ,where=with(con,(lines*samples*as.numeric(nb)-1)*sizeof+offset),rw="w") val <- 0L storage.mode(val) <- con$mode with(con,writeBin(val,size=sizeof,endian=endian,handle)) @@ -670,8 +670,8 @@ projection_info <- "" proj4 <- grid$crs[1] p <- NULL - if (nchar(proj4)) - { + isWKT <- .isWKT(proj4) + if ((FALSE)&&(!isWKT)&&(nchar(proj4))) { pr <- unlist(strsplit(proj4,"\\s+")) projection_ellipse <- "unknown" projection_units <- "units=meters" @@ -859,7 +859,13 @@ # print(.epsg) rm(.epsg) } - if ((is.null(wkt))&&(projection_info=="")&&(nchar(proj4))) + if (isWKT) { + if (.isWKT2(proj4)) + wkt <- gsub("\\n\\s+","",.WKT(proj4,WKT2=FALSE)) + else + wkt <- gsub("\\n\\s+","",proj4) + } + else if ((is.null(wkt))&&(projection_info=="")&&(nchar(proj4))) { lverbose <- FALSE if (lverbose) @@ -904,7 +910,7 @@ 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 <- sf::st_crs(proj4)$Wkt ## don't use `.WKT(proj4)` ret })) # if (!.try(wkt <- sf::st_as_text(sf::st_crs(proj4),EWKT=TRUE))) diff --git a/R/yyy.crop.R b/R/yyy.crop.R index ff9eb2f..51be703 100644 --- a/R/yyy.crop.R +++ b/R/yyy.crop.R @@ -4,8 +4,8 @@ isSVG <- .lgrep("(svg)",gsub(".*\\.(.+$)","\\1",fileout))>0 isPNG <- .lgrep("(png)",gsub(".*\\.(.+$)","\\1",fileout))>0 frame <- as.integer(round(border)) - if (!isSVG) - requireNamespace("png",quietly=.isPackageInUse()) + # if (!isSVG) + # isPNG <- requireNamespace("png",quietly=.isPackageInUse()) if (isPNG) NULL else if (isJPEG) { @@ -34,8 +34,9 @@ x <- aperm(x,c(3,2,1)) rm(a) } - if (!isSVG) - x <- png::readPNG(fileout,native=FALSE,info=TRUE) + if (!isSVG) { + x <- .readPNG(fileout,native=FALSE,info=TRUE) + } dimx <- dim(x) isBlack <- isTRUE(getOption("ursaPngBackground") %in% (c("black","#000000"))) if (isBlack) @@ -99,11 +100,12 @@ } } else if (isJPEG) - jpeg::writeJPEG(x[indr,indc,],fileout) + .writeJPEG(x[indr,indc,],fileout) else if (isWEBP) webp::write_webp(x[indr,indc,],fileout) - else - png::writePNG(x[indr,indc,],fileout,dpi=att$dpi,text=c(source=R.version.string)) + else if (isPNG) { + .writePNG(x[indr,indc,],fileout,dpi=att$dpi,text=c(source=R.version.string)) + } 0L } '.crop2' <- function(fileout,border=5,verbose=FALSE) { @@ -117,7 +119,7 @@ isJPEG <- requireNamespace("jpeg",quietly=.isPackageInUse()) if (isWEBP) isWEBP <- requireNamespace("webp",quietly=.isPackageInUse()) - x <- png::readPNG(fileout,native=FALSE,info=TRUE) + x <- .readPNG(fileout,native=FALSE,info=TRUE) dimx <- dim(x) b <- .Cursa(C_internalMargin,x=as.numeric(x),dim=as.integer(dimx) ,indr=integer(dimx[1]),indc=integer(dimx[2]),NAOK=TRUE) @@ -157,7 +159,7 @@ else if (isWEBP) webp::write_webp(x[indr,indc,],fileout) else - png::writePNG(x[indr,indc,],fileout,dpi=att$dpi,text=c(source=R.version.string)) + .writePNG(x[indr,indc,],fileout,dpi=att$dpi,text=c(source=R.version.string)) if (verbose) .elapsedTime("crop2:finish") 0L @@ -170,6 +172,6 @@ if (!isJPEG) return(NULL) requireNamespace("png",quietly=.isPackageInUse()) - jpeg::writeJPEG(png::readPNG(fileout,native=FALSE,info=TRUE),fileout) + jpeg::writeJPEG(.readPNG(fileout,native=FALSE,info=TRUE),fileout) NULL } diff --git a/R/yyy.getPrm.R b/R/yyy.getPrm.R index a254805..766b462 100644 --- a/R/yyy.getPrm.R +++ b/R/yyy.getPrm.R @@ -44,10 +44,26 @@ } if (verbose) print(xName[ind[1],]) - i <- match(xName[ind[1],"where"],myname) + if (verbose) { + print(myname) + } + if (F & length(ind2 <- which(!nchar(myname)))>1) { + print("DEV") + print(ind2) + print(grepl("\\^\\$",xName[ind,"what"])) + str(link[ind2]) + i <- ind2 + } + else + i <- match(xName[ind[1],"where"],myname) cl <- class(link[[i]]) + # cl <- do.call(c,lapply(link[i],"class")) if ("ursaStack" %in% cl) cl <- "list" + else if ("array" %in% cl) { + if (is.numeric(link[[i]])) + cl <- c(cl,"numeric") + } isList <- is.list(link[[i]]) if (!is.list(class)) class <- list(class) @@ -101,7 +117,7 @@ m2 <- length(na.omit(match(cl2,cl)))>0 ##cl2 %in% cl } if (verbose) - print(m2) + print(c(m2=m2)) if (!m2) { if (length(valid)) { if (!any(cl %in% cl2)) @@ -162,6 +178,10 @@ if (!coerce) return(link[[i]]) if (toInteger) { + if (is.array(link[[i]])) { + storage.mode(link[[i]]) <- "integer" + return(link[[i]]) + } return(as.integer(link[[i]])) } else if (toLogical) { diff --git a/R/yyy.plot.R b/R/yyy.plot.R index 9986782..2575cab 100644 --- a/R/yyy.plot.R +++ b/R/yyy.plot.R @@ -205,7 +205,7 @@ } '.panel_attribution' <- function(pos=ifelse(vertical,"bottomright","bottomright") ,vertical=TRUE) { - g0 <- getOption("ursaPngPanelGrid") # getOption("ursaSessionGrid_prev") + g0 <- .panel_grid() # getOption("ursaSessionGrid_prev") g1 <- getOption("ursaSessionGrid") prev <- !identical(g0,g1) if (prev) diff --git a/R/yyy.project.R b/R/yyy.project.R index e32345a..75442d1 100644 --- a/R/yyy.project.R +++ b/R/yyy.project.R @@ -1,6 +1,7 @@ '.project' <- function(xy,proj,inv=FALSE,verbose=FALSE) { on.exit(NULL) - # verbose <- TRUE; print("ENTERED IN"); on.exit(print("ENTERED OUT"),add=TRUE) + # print("ENTERED IN"); on.exit(print("ENTERED OUT"),add=TRUE) + # verbose <- TRUE ## because of quicker load of 'proj4' package # show.error.messages=verbose if (isSF <- .isSF(xy)) { @@ -33,20 +34,31 @@ ## CHECK LATER (currently not quick): # dst <- with(PROJ::proj_trans_generic(src,source="EPSG:4326",target=crs),cbind(x_,y_)) loaded <- loadedNamespaces() - is_rgdal <- if (F) .forceRGDAL() else "rgdal" %in% loaded - is_sf <- "sf" %in% loaded + is_rgdal <- if (F) .forceRGDAL() else ("rgdal" %in% loaded)&&(.forceRGDAL(TRUE)) + is_sf <- TRUE # "sf" %in% loaded ## if F then trying to use `proj4` is_gdalraster <- "gdalraster" %in% loaded - if ((!is_sf)&&(!is_gdalraster)&&(grepl("^PROJCS",proj))) - is_sf <- .forceSF(TRUE) - if (.forceProj4()) ## `proj4` faster `sf` 20220216 + if ((!is_sf)&&(!is_gdalraster)&&(.isWKT(proj))) + is_sf <- .forceSFpackage(TRUE) + if (.isWKT(proj)) { + is_proj4 <- FALSE + } + else if (.forceProj4package()) { ## `proj4` faster `sf` 20220216 + # print("B1") is_proj4 <- TRUE - else if ((!is_sf)&&(!is_rgdal)&&(!is_gdalraster)&&(.forceProj4(TRUE))) + # if (is_sf) + # is_sf <- FALSE + } + else if ((!is_sf)&&(!is_rgdal)&&(!is_gdalraster)&&(.forceProj4package(TRUE))) { + # print("B2") is_proj4 <- TRUE - else + } + else { + # print("B3") is_proj4 <- FALSE + } if ((!is_sf)&&(!is_rgdal)&&(!is_proj4)&&(!is_gdalraster)) { # if (!"rgdal" %in% loadedNamespaces()) - is_sf <- .forceSF(TRUE) + is_sf <- .forceSFpackage(TRUE) } if (verbose) print(c(proj4=is_proj4,rgdal=is_rgdal,sf=is_sf,gdalraster=is_gdalraster)) @@ -87,8 +99,9 @@ if (proj4version>="1.0.10") { res <- .proj4_project(xy=xy,proj=proj,inverse=inv) } - else + else { res <- .proj4_project(xy=t(xy),proj=proj,inverse=inv) + } # res <- proj4::project(xy=list(xy[,1],xy[,2]),proj=proj,inverse=inv) },silent=TRUE) if ((!FALSE)&&(!a)&&(nrow(xy)==2)) { @@ -111,6 +124,9 @@ is_sf <- TRUE } } + if ((!a)&&(is_proj4)) { + is_sf <- TRUE + } if ((!a)&&(is_rgdal)) { if (verbose) message("'rgdal' is used") @@ -169,12 +185,12 @@ if (verbose) message("'sf' is used") if (inv) { - crs_t <- "+proj=longlat +datum=WGS84 +no_defs" - crs_s <- proj + crs_t <- .crsWGS84() + crs_s <- proj # unclass(proj) } else { - crs_s <- "+proj=longlat +datum=WGS84 +no_defs" - crs_t <- proj + crs_s <- .crsWGS84() + crs_t <- proj # unclass(proj) } if (is.list(xy)) xy <- cbind(xy[[1]],xy[[2]]) @@ -182,7 +198,21 @@ xy <- matrix(xy,ncol=2) # ind <- which((is.na(xy[,1]))|(is.na(xy[,2]))) hasNA <- anyNA(xy[,1]) - tryMatrix <- TRUE + tryMatrix <- T # (.isProj4(crs_s))&&(.isProj4(crs_t)) + if ((FALSE)&&(!.crsForceProj4())&&(.crsForceWKT())) { + crs_s <- list(input=NULL,wkt=crs_s) + class(crs_s) <- "crs" + crs_t <- list(input=NULL,wkt=crs_t) + class(crs_t) <- "crs" + } + if (F) { + # dimnames(xy) <- NULL + str(crs_s) + str(crs_t) + } + if (verbose) + .elapsedTime(paste(ifelse(tryMatrix,"sf_project","st_transform") + ,ifelse(.isWKT(crs_s),"(wkt)","(proj4string)")," -- start")) if (omitOutside <- FALSE) { # if (length(ind180 <- which(xy[,1]>180))) # xy[ind180,1] <- xy[ind180,1]-180 @@ -199,24 +229,28 @@ if (hasNA) { ind <- which(is.na(xy[,1])) ## less conditions res <- matrix(NA,ncol=2,nrow=nrow(xy)) - if (!tryMatrix) + if (!tryMatrix) { a <- .try(res[-ind,] <- unclass(sf::st_transform(sf::st_sfc( sf::st_multipoint(xy[-ind,]),crs=crs_s),crs_t)[[1]])) + } else { if (is_gdalraster) { a <- .try(res[-ind,] <- gdalraster::transform_xy(pts=xy[-ind,] ,srs_from=gdalraster::srs_to_wkt(crs_s) ,srs_to=gdalraster::srs_to_wkt(crs_t))) } - if (!a) + if (!a) { + # qs::qsave(list(from=crs_s,to=crs_t,pts=xy[-ind,],keep=TRUE),"C:/tmp/interim.qs") a <- .try(res[-ind,] <- sf::sf_project(from=crs_s,to=crs_t,pts=xy[-ind,] ,keep=TRUE)) + } } } else { - if (!tryMatrix) + if (!tryMatrix) { a <- .try(res <- unclass(sf::st_transform(sf::st_sfc( sf::st_multipoint(xy),crs=crs_s),crs_t)[[1]])) + } else { if (is_gdalraster) { a <- .try(res <- gdalraster::transform_xy(pts=xy @@ -228,15 +262,21 @@ try(sf::sf_proj_network(url="",TRUE)) if (F & verbose) { print(xy) + print(class(crs_s)) + print(class(crs_t)) + print(.isProj4(crs_s)) + print(.isProj4(crs_t)) print(crs_s) print(crs_t) print(sf::st_crs(crs_t)$proj4string) - } + } ## slow for WKT a <- .try(res <- sf::sf_project(from=crs_s,to=crs_t,pts=xy ,keep=TRUE)) } } } + if (verbose) + .elapsedTime(paste(ifelse(tryMatrix,"sf_project","st_transform")," -- finish")) } if ((FALSE)&&(!inv)&&(.lgrep("\\+proj=merc",g1$crs))) { g1 <- session_grid() @@ -259,10 +299,13 @@ # dismissEPSG: ## dev - FALSE, release and next versions - TRUE ## 'proj4::project' doesnot understand pure EPSG # a <- try(as.integer(code),silent=TRUE) + if (.isUrsaCRS(code)) + return(code) if ((is.character(code))&&(!nchar(code))) return(code) if (is.matrix(code)) return(NULL) + shortNames <- c("WGS84","NAD27") if (!.lgrep("\\D",code)) p4epsg <- paste0(c("+init=epsg:","EPSG:")[2],code) else if (.lgrep("^epsg:\\d+",code)) @@ -272,10 +315,25 @@ ,toupper(.gsub("\\+init=","",code))))[2] else if ((force)&&(.lgrep("^ESRI\\:",code,ignore.case=FALSE))) p4epsg <- code - else if (is.character(code)) - return(code) + else if (is.character(code)) { + if ((code %in% shortNames)||(grepl("\\s",code))) { + if (!force) + p4epsg <- code + else + return(code) + } + else if (nchar(code)<16) + return("") + else if (.isWKT(code)) { + return(code) + } + else { + p4epsg <- code + } + } else stop(code) + # print(c(input=code,p4=p4epsg)) loaded <- loadedNamespaces() if (dismissEPSG) force <- TRUE @@ -283,7 +341,10 @@ if ("sf" %in% loaded) { if (verbose) message("force to use 'sf'") - p4s <- sf::st_crs(code)$proj4string + if (.crsForceProj4()) + p4s <- .proj4string(code) + else + p4s <- .WKT(code) } else { if (verbose) @@ -298,7 +359,12 @@ if (verbose) message("'sf' loaded") # p4s <- try(sf::st_crs(as.integer(code))$proj4string) ## 'code', not 'p4epsg' - p4s <- try(sf::st_crs(.p4s2epsg(p4epsg))$proj4string) + if (.crsForceProj4()) { + p4s <- try(.proj4string(.p4s2epsg(p4epsg)),silent=!verbose) + } + else { + p4s <- try(.WKT(p4epsg),silent=!verbose) + } if (!inherits(p4s,"try-error")) fail <- FALSE } @@ -307,7 +373,8 @@ message("'sp'/'rgdal' loaded") if (dismissEPSG) { opW <- options(warn=ifelse(verbose,0,-1)) - p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs")) + p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs") + ,silent=!verbose) options(opW) } else { @@ -317,7 +384,8 @@ ##~ str(p4s) ##~ # sp::CRS(SRS_string=p4epsg) ##~ q() - p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs")) ## -- 20220124 FALSE + p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs") + ,silent=!verbose) ## -- 20220124 FALSE } if (!inherits(p4s,"try-error")) { fail <- FALSE @@ -325,23 +393,30 @@ # requireNamespace("rgdal",quietly=.isPackageInUse()) } } - if ((fail)&&(!FALSE)&&(requireNamespace("sf",quietly=.isPackageInUse()))) { + if ((fail)&&(!isNamespaceLoaded("sf"))&& + (requireNamespace("sf",quietly=.isPackageInUse()))) { if (verbose) message("force to load 'sf'") - p4s <- try(sf::st_crs(code)$proj4string) + if (.crsForceProj4()) + p4s <- try(.proj4string(code),silent=!verbose) + else { + p4s <- try(.WKT(code),silent=!verbose) + } if (!inherits(p4s,"try-error")) fail <- FALSE } - if (fail) { + if ((fail)&&(nchar(system.file(package="sp"))>0)) { if (verbose) message("Otherwise, use 'sp' + ('rgdal' for reprojection - SKIPPED)") if (dismissEPSG) { opW <- options(warn=ifelse(verbose,0,-1)) - p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs")) + p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs") + ,silent=!verbose) options(opW) } else { - p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs")) ## -- 20220124 FALSE + p4s <- try(methods::slot(sp::CRS(p4epsg,doCheckCRSArgs=TRUE),"projargs") + ,silent=!verbose) ## -- 20220124 FALSE } if (inherits(p4s,"try-error")) { fail <- TRUE @@ -369,7 +444,7 @@ xy } '.p4s2epsg' <- function(p4s) { - patt <- "\\+init=epsg\\:(\\d+)$" + patt <- "EPSG\\:(\\d+)$" if (!length(grep(patt,p4s))) return(p4s) code <- gsub(patt,"\\1",p4s) diff --git a/R/yyy.tile.R b/R/yyy.tile.R index 11941b8..a465b7b 100644 --- a/R/yyy.tile.R +++ b/R/yyy.tile.R @@ -356,7 +356,7 @@ s <- paste0("i",(x %% 4)+(y %% 4)*4L) tile <- gsub("\\{s\\}",s,tile) } - if ((!FALSE)&&(.lgrep("\\{..+}",tile))) { + if ((FALSE)&&(.lgrep("\\{..+}",tile))) { dom <- unlist(strsplit(.gsub2("\\{(.+)\\}","\\1",gsub("\\{.\\}","",tile)),"")) ##~ print(tile) ##~ print(dom) @@ -397,8 +397,9 @@ else if (file.exists(tile)) { fname <- tile } - else + else { fname <- .ursaCacheDownload(tile,mode="wb",cache=cache,quiet=!verbose) + } if (inherits(fname,"try-error")) { return(fname) # message(a) @@ -410,11 +411,13 @@ isPNG <- FALSE isJPEG <- FALSE isGIF <- FALSE - if (isPNG <- fileext %in% c("png")) + isGDAL <- FALSE + if (isPNG <- fileext %in% c("png")) { a <- try(255*png::readPNG(fname),silent=!verbose) + } else if (isJPEG <- fileext %in% c("jpg","jpeg")) { - if (!requireNamespace("jpeg",quietly=.isPackageInUse())) - stop("Suggested package 'jpeg' missed, but is required here.") + # if (!requireNamespace("jpeg",quietly=.isPackageInUse())) + # stop("Suggested package 'jpeg' missed, but is required here.") a <- try(255*jpeg::readJPEG(fname),silent=!verbose) } else { @@ -437,22 +440,12 @@ if (inherits(a,"try-error")) a <- try(255*jpeg::readJPEG(fname),silent=!verbose) if (inherits(a,"try-error")) { - # if (requireNamespace("miss_caTools",quietly=.isPackageInUse())) { - # stop("caTools") - # } - g0 <- session_grid() - a <- read_gdal(fname) - session_grid(g0) - if (inherits(a,"try-error")) - cat(geterrmessage()) - if (ursa_blank(a,NA)) - ursa_value(a) <- 0 - a <- as.array(a) + a <- 255*.readPNG(fname) } } else cat(geterrmessage()) - return(a) + # return(a) } # file.remove(fname) dima <- dim(a) @@ -470,7 +463,7 @@ ,cover=1e-6,verbose=0L)) dima <- dim(a) if (isPNG) - png::writePNG(a/256,fname) + .writePNG(a/256,fname) else if (isJPEG) jpeg::writeJPEG(a/256,fname) else @@ -499,3 +492,62 @@ # display(b,scale=1,coast=FALSE) b } +'.readPNG' <- function(fname,...) { + if (requireNamespace("png",quietly=T | .isPackageInUse())) + return(png::readPNG(fname,...)) + .readGRAPHICS(fname,...) +} +'.readJPEG' <- function(fname,...) { + if (requireNamespace("jpeg",quietly=T | .isPackageInUse())) + return(jpeg::readJPEG(fname,...)) + .readGRAPHICS(fname,...) +} +'.writePNG' <- function(obj,fileout,...) { + if (requireNamespace("png",quietly=T | .isPackageInUse())) + return(png::writePNG(obj,fileout,...)) + .writeGRAPHICS(obj,fileout,...) +} +'.writeJPEG' <- function(obj,fileout,...) { + if (requireNamespace("jpeg",quietly=T | .isPackageInUse())) + return(jpeg::writeJPEG(obj,fileout,...)) + .writeGRAPHICS(obj,fileout,...) +} +'.readGRAPHICS' <- function(fname,...) { + # g0 <- options()[c("ursaSessionGrid","ursaSessionGrid_prev")] + g0 <- session_grid() + session_grid(NULL) + b <- read_gdal(fname,engine="sf") + if (ursa_blank(b,NA)) + a <- ursa(0L) + if (!is.na(nodata <- ignorevalue(b))) + b[is.na(b)] <- nodata + # if (inherits(b,"try-error")) + # cat(geterrmessage()) + if (nband(b)<3) { + ct <- ursa_colortable(b) + lut <- col2rgb(ct,alpha=any(nchar(substr(ct,8,9))>0)) + ind <- match(ursa_value(b),as.integer(colnames(lut))) + a <- ursa(nband=nrow(lut)) + for (i in seq(a)) { + ursa_value(a)[,i] <- lut[i,ind] + } + } else { + a <- b + } + a <- as.array(a,aperm=TRUE) + session_grid(g0) + # options(g0) + a/255 +} +'.writeGRAPHICS' <- function(obj,fileout,...) { + g0 <- session_grid() + a <- as.ursa(obj*255,aperm=TRUE,flip=TRUE) + # write_gdal(a,fileout) + # q() + ret <- ursa_write(a,fileout) + auxfile <- paste0(fileout,".aux.xml") + if (file.exists(auxfile)) + file.remove(auxfile) + session_grid(g0) + ret +} diff --git a/R/yyy.util.R b/R/yyy.util.R index beeb659..a805847 100644 --- a/R/yyy.util.R +++ b/R/yyy.util.R @@ -228,7 +228,7 @@ op <- options() op <- op[.grep("^ursa(Png|[A-Z]).+",names(op))] indPng <- .grep("^ursaPng.+",names(op)) - if (length(indPng)) + if (F & length(indPng)) return(str(op[indPng])) str(op) } @@ -261,7 +261,7 @@ try(res <- x[which.max(predict(locfit::locfit(~x),newdata=x))]) res } - isLonLat <- .lgrep("(\\+proj=longlat|epsg:4326)",spatial_crs(src))>0 + isLonLat <- .isLongLat(spatial_crs(src)) isUrsa <- FALSE if ((is_spatial(src))&&((is_spatial(dst)))) { if (!identical(spatial_crs(src),spatial_crs(dst))) @@ -376,29 +376,6 @@ message(".is.near: fuzzy matching") b1 } -'.getMajorSemiAxis' <- function(proj4) { - ell <- .gsub(".*\\+ellps=(\\S+)\\s.*","\\1",proj4) - if (ell=="WGS84") - B <- 6378137 - else if (ell==proj4) { - B <- .gsub(".*\\+a=(\\S+)\\s.*","\\1",proj4) - if (B!=proj4) - B <- as.numeric(B) - else { - opW <- options(warn=-1) - warning("Supposed that this projection is not supported yet") - options(opW) - B <- 6378137 - } - } - else { - opW <- options(warn=-1) - warning("Supposed that this projection is not supported yet") - options(opW) - B <- 6378137 - } - B -} '.degminsec' <- function(x,suffix=c("A","B"),unique=FALSE) { s <- sign(x) x <- abs(x) @@ -597,6 +574,8 @@ return(x) if (missing(n)) return(sample(x)) + if (!length(n)) + return(sample(x)) if (n>=length(x)) return(sample(x)) sample(x,n) @@ -719,11 +698,14 @@ '.isColor' <- function(x) !inherits(try(col2rgb(x),silent=TRUE),"try-error") '.isWeb' <- function(grid) { if (missing(grid)) - grid <- session_grid() + grid <- getOption("ursaSessionGrid") + if (is.null(grid)) + return(FALSE) crs <- ursa(grid,"crs") v1 <- ursa(grid,"cellsize") v2 <- 2*6378137*pi/(2^(1:21+8)) - cond1 <- grepl("\\+proj=merc",crs)>0 + cond1 <- .isMerc(crs) + # cond1 <- grepl("\\+proj=merc",crs)>0 # print(format(v2,sci=FALSE),quote=FALSE) cond2 <- !is.na(.is.near(v1,v2)) cond1 & cond2 @@ -740,19 +722,17 @@ options(ursaForceRGDAL=value) invisible(value) } -'.forceProj4' <- function(value) { +'.forceProj4package' <- function(value) { if (missing(value)) return(isTRUE(getOption("ursaForceProj4"))) - if (isTRUE(value)) { - if (T & .isPackageInUse()) - value <- FALSE - else - value <- .proj4_requireNamespace() - } + if (!nchar(system.file(package="proj4"))) + return(FALSE) + # if (isTRUE(value)) + # value <- requireNamespace("proj4",quietly=.isPackageInUse()) options(ursaForceProj4=value) invisible(value) } -'.forceSF' <- function(value) { +'.forceSFpackage' <- function(value) { if (missing(value)) return(isTRUE(getOption("ursaForceSF"))) options(ursaForceSF=value) diff --git a/R/zzz.R b/R/zzz.R index 8f0f813..347bb3c 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -13,6 +13,18 @@ p <- proc.time() options(ursaTimeStart=p,ursaTimeDelta=p) # ,ursaForceSF=TRUE rm(p) + options(ursaNoticeMatchCall=FALSE & !.isPackageInUse()) + if (!.isPackageInUse()) + options(show.error.messages=TRUE) + if (is.null(getOption("ursaProj4Legacy"))) + options(ursaProj4Legacy=TRUE) + if (is.null(getOption("ursaForceWKT"))) + options(ursaForceWKT=FALSE) ## sf_project: proj4 is faster than WKT + # if (is.null(getOption("ursaTolerance"))) + # options(ursaTolerance=1e-8) + if ((FALSE)&&(nchar(system.file(package="proj4"))>0)) { + .forceProj4package(TRUE) + } # session_pngviewer() fpath <- getOption("ursaCacheDir") ## e.g., from ~/.Rprofile if (is.null(fpath)) @@ -50,7 +62,6 @@ } # try(Sys.setenv(R_RMAP_TEMPLATE=fpath)) try(options(ursaRequisite=fpath0)) - options(ursaNoticeMatchCall=FALSE & !.isPackageInUse()) invisible(0L) } .onAttach <- function(lib, pkg) { ## FAILED for 'Rscript -e "ursa::display()"' diff --git a/inst/requisite/template.hdr b/inst/requisite/template.hdr index f642511..8c89578 100644 --- a/inst/requisite/template.hdr +++ b/inst/requisite/template.hdr @@ -8,7 +8,7 @@ file type = ENVI Standard data type = 1 interleave = bsq byte order = 0 -map info = {NSIDC Sea Ice North,1.000000,1.000000,-3850000.000000,5850000.000000,25000.000000,25000.000000,Hughes,units=meters} -projection info = {31,6378273.000,6356889.449,70.0,-45.0,0.0,0.0,NSIDC Sea Ice North,units=meters} +map info = {R, 1, 1, -3850000, 5850000, 25000, 25000, unknown, units=meters} +coordinate system string = {PROJCS["NSIDC Sea Ice Polar Stereographic North",GEOGCS["Hughes 1980",DATUM["Hughes_1980",SPHEROID["Hughes 1980",6378273,298.279411123064]],PRIMEM["Greenwich",0],UNIT["degree",0.0174532925199433,AUTHORITY["EPSG","9122"]],AUTHORITY["EPSG","10345"]],PROJECTION["Polar_Stereographic"],PARAMETER["latitude_of_origin",70],PARAMETER["central_meridian",-45],PARAMETER["false_easting",0],PARAMETER["false_northing",0],UNIT["metre",1],AXIS["Easting",SOUTH],AXIS["Northing",SOUTH],AUTHORITY["EPSG","3411"]]} band names = { areassmi} diff --git a/man/___prompt.R b/man/___prompt.R index 785d3d7..c96dc8a 100644 --- a/man/___prompt.R +++ b/man/___prompt.R @@ -1,5 +1,5 @@ invisible({ plutil::ursula(3) session_grid(NULL) - prompt(filename="zzz.new.Rd",name=c("whiteboxing"),forceFunction=TRUE) + prompt(filename="zzz.new.Rd",name=c("print.ursaCRS"),forceFunction=TRUE) }) diff --git a/man/classCRS.Rd b/man/classCRS.Rd new file mode 100644 index 0000000..406521f --- /dev/null +++ b/man/classCRS.Rd @@ -0,0 +1,52 @@ +\name{ursaCRS} +\alias{class-ursaCRS} +\alias{print.ursaCRS} +\alias{str.ursaCRS} +\title{ +Coordinate Reference System (CRS) for raster images. +} +\description{ +Class \code{ursaCRS} is a part of class \code{ursaGrid}. It defines map projection. +} +\usage{ +\method{print}{ursaCRS}(x, ...) +\method{str}{ursaCRS}(object, ...) +} +\arguments{ + \item{x}{ +\code{ursaCRS} object in function \code{print}. +} + \item{object}{ +\code{ursaCRS} object in function \code{str}. +} + \item{\dots}{ +Further arguments passed to generic functions \code{\link[base]{print}}, and \code{\link[utils]{str}}. +} +} +\value{ +Functions print information about CRS and return invisible \code{NULL} value. +} +\author{ +Nikita Platonov \email{platonov@sevin.ru} +} + +%% ~Make other sections like Warning with \section{Warning }{....} ~ + +\examples{ +session_grid(NULL) +a <- ursa_dummy() +crs <- ursa_crs(a) +print(c('Is proj4string used?'=p4 <- isTRUE(getOption("ursaProj4Legacy")))) +print(crs) +str(crs) +op <- options(ursaProj4Legacy=!p4) +print(c('Is proj4string used?'=p4 <- isTRUE(getOption("ursaProj4Legacy")))) +session_grid(NULL) +a <- ursa_dummy() +crs <- ursa_crs(a) +print(crs) +str(crs) +options(op) +} +\keyword{classes} +\keyword{print} diff --git a/man/classRaster.Replace.Rd b/man/classRaster.Replace.Rd index c418899..2a9de35 100644 --- a/man/classRaster.Replace.Rd +++ b/man/classRaster.Replace.Rd @@ -86,7 +86,7 @@ try({ b2["fourth"] <- 40+as.matrix(b1[3]) b2[5] <- 50+as.array(b1[4]) set.seed(352) -b2["six"] <- 60+6+runif(5,min=-1,max=1) ## only first value is used (66.42849) +try(b2["six"] <- 60+6+runif(5,min=-1,max=1)) ## Data structures mismatching print(b2) print(object.size(b2)) diff --git a/man/colorize.Rd b/man/colorize.Rd index dbdcd24..989a585 100644 --- a/man/colorize.Rd +++ b/man/colorize.Rd @@ -16,7 +16,7 @@ colorize(obj, value = NULL, breakvalue = NULL, name = NULL, pal = NULL, inv = NA "grayscale", "greyscale", ".onetoone"), minvalue = NA, maxvalue = NA, byvalue = NA, ltail = NA, rtail = NA, tail = NA, ncolor = NA, nbreak = NA, interval = 0L, ramp = TRUE, byte = FALSE, - lazyload = FALSE, reset = FALSE, origin = "1970-01-01" ,format = "", + lazyload = TRUE, reset = FALSE, origin = "1970-01-01" ,format = "", alpha = "", colortable = NULL, verbose = FALSE, ...) palettize(...) ## wrapper for non-spatial vectors @@ -87,7 +87,7 @@ palettize(...) ## wrapper for non-spatial vectors Logical. Forcing to produce color table for storage in byte format (not more than 255 colors). Default is \code{FALSE}. } \item{lazyload}{ - Logical. If \code{FALSE} then raster is reclassified to categories. If \code{TRUE} then color table is created without any change to source raster. Default is \code{FALSE}. + Logical. If \code{FALSE} then raster is reclassified to categories. If \code{TRUE} then color table is created without any change to source raster and raster value just postponed for change. Default is \code{TRUE}. } \item{reset}{ Logical. If \code{TRUE} and source raster has color table, then this color table is destroyed, and new one is created. Default is \code{FALSE}. diff --git a/man/compose_design.Rd b/man/compose_design.Rd index 09782b1..97301c0 100644 --- a/man/compose_design.Rd +++ b/man/compose_design.Rd @@ -19,7 +19,7 @@ compose_design(\dots) \item{\dots}{Set of arguments, which are recognized via their names and classes: \describe{ \item{\code{obj}}{Object of class \code{ursaRaster} or list of objects of class \code{ursaRaster} or \code{NULL}. Default is \code{NULL}. Used to detect panel layout and coordinate reference system.} - \item{\code{layout}}{Integer of length 2 or \code{NA}. Layout matrix has dimensions\code{c(nr, nc)}, where \code{nr} is number of rows, and \code{nc} is number of columns. If \code{layout=NA} then layout matrix is recognized internally using number of bands of \code{obj} and argument \code{ratio}. If \code{layout=NA} and \code{obj=NULL} then matrix \code{c(1,1)} is used.} + \item{\code{layout}}{Integer of length 2, integer of length 1, two-dimensional matrix or \code{NA}. Layout matrix has dimensions\code{c(nr, nc)}, where \code{nr} is number of rows, and \code{nc} is number of columns. If \code{layout} is positive integer of length 1, then sequense of this value unfolds to layout matrix using argument \code{ratio}. If \code{layout=NA} then layout matrix is recognized internally using number of bands of \code{obj} and argument \code{ratio}. If \code{layout=NA} and \code{obj=NULL} then matrix \code{c(1,1)} is used.} \item{\code{byrow}}{Logical. The order of filling of layout matrix. Default is \code{TRUE}. If \code{byrow=TRUE} then matrix is filled by rows (from top row, consequently from left element to right element, then next row). If \code{byrow=FALSE} then matrix is filled by columns.} \item{\code{skip}}{Positive integer of variable length. Default in \code{NULL} (length is zero). Indices of panels in the layout matrix, which are not used.} \item{\code{legend}}{The descripition of rules how color bars (legends) or panel captions are located in the layout. It is the list of embedded lists of two elements, which describe the color bars position in the layout. of Default is \code{NA}, it means using of internal rules. If \code{legend=NULL} then no plotting of color bars. If \code{legend} is positive integer in the range \code{1L:4L}, then sinlge color bar is used and legend's side is corresponded to margins of \R graphic system.} @@ -179,6 +179,11 @@ cl6 <- compose_design(layout=c(2,3),skip=NA,legend=leg) print(cl6) compose_open(cl6,scale=3,pointsize=16) compose_close("nocrop") + +cl7 <- compose_design(layout=matrix(c(1,1,3,2,2,0),nrow=2,byrow=TRUE)) +print(cl7) +compose_open(cl7) +compose_close() } % 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 6074874..d17699d 100644 --- a/man/conn.read_gdal.Rd +++ b/man/conn.read_gdal.Rd @@ -9,7 +9,7 @@ Read GDAL supported raster files. } \usage{ read_gdal(fname, resetGrid = TRUE, band = NULL, - engine = c("native", "sf", "gdalraster", "vapour"), + engine = c("native", "sf"), verbose = FALSE, ...) ursa_read(fname, verbose = FALSE) @@ -74,13 +74,11 @@ session_grid(NULL) # 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") +if (file.exists(Fin1 <- system.file("gdal/gdalicon.png",package="sf"))) { + a1 <- read_gdal(Fin1) + print(a1) + display(a1) +} 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")) @@ -88,11 +86,19 @@ 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))) +print(c('same colortable?'=identical(ursa_colortable(b1),ursa_colortable(b2)))) print(ursa_colortable(b1)) print(as.table(b1)) +print(c('same values?'=identical(ursa_value(b1),ursa_value(b2)))) +print(c('same grid?'=identical(ursa_grid(b1),ursa_grid(b2)))) +if (requireNamespace("sf")) { + p1 <- sf::st_crs(ursa_crs(b1)) + p2 <- sf::st_crs(ursa_crs(b2)) + print(c('same proj4string for CRS?'=identical(p1$proj4string,p2$proj4string))) + print(c('same WKT for CRS?'=identical(p1$Wkt,p2$Wkt))) + ursa_crs(b1) <- ursa_crs(b2) + print(c('after same CRS, same grid?'=identical(ursa_grid(b1),ursa_grid(b2)))) +} display(b1,detail="l") } % Add one or more standard keywords, see file 'KEYWORDS' in the diff --git a/man/conn.write_gdal.Rd b/man/conn.write_gdal.Rd index b747846..cd54586 100644 --- a/man/conn.write_gdal.Rd +++ b/man/conn.write_gdal.Rd @@ -9,7 +9,7 @@ Write raster image to GDAL file(s) } \usage{ write_gdal(obj, ...) -ursa_write(obj, fname) +ursa_write(obj, fname, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ @@ -17,7 +17,14 @@ ursa_write(obj, fname) Object of class \code{ursaRaster}. } \item{\dots}{ -Arguments, which are passed to \code{\link[ursa:conn.create_any]{create_gdal}}. Usually, only file name with extension (character) is required. If extension is ".envi", then GDAL driver "ENVI" is used. If extension is ".tif", then GDAL driver "GTiff" is used. If extension is ".img", then GDAL driver "HFA" is used. If extension is ".jpg" or "*.jpeg", then GDAL driver "JPEG" is used. If extension is ".bmp", then GDAL driver "BMP" is used. If extension is ".png", then GDAL driver "PNG" is used. Additionally, argument \code{driver} should be specified. If argument \code{\dots} is \link[base]{missing}, then occasional name is assigned. +Arguments, which are passed to \code{\link[ursa:conn.create_any]{create_gdal}}. Usually, only file name with extension (character) is required. If extension is ".envi", then GDAL driver "ENVI" is used. If extension is ".tif", then GDAL driver "GTiff" is used. If extension is ".img", then GDAL driver "HFA" is used. If extension is ".jpg" or "*.jpeg", then GDAL driver "JPEG" is used. If extension is ".bmp", then GDAL driver "BMP" is used. If extension is ".png", then GDAL driver "PNG" is used. Additionally, argument \code{driver} should be specified. If argument \code{\dots} is \link[base]{missing}, then occasional name is assigned. + +For GDAL formats it is creation options \code{"-co"}, e. g., \code{compress="LZW",tiled="NO"} are interpeted as \code{-co "COMPRESS=LZW" -co "TILED=NO"}. + +For GDAL formats \code{options=} (named list \code{list(foo="bar1", foo2="bar2")}, named characters \code{c(foo="bar1", foo2="bar2")}, characters in format \code{"foo1=bar1 foo2=bar2"}) is interpeted as creation options (\code{-co}) explicitly. + +For GDAL formats \code{driver=} is interpeted as driver short name (\code{-fo}) explicitly. + } \item{fname}{ Character. File name with extension. diff --git a/man/glance.Rd b/man/glance.Rd index f814f1a..f70cc3c 100644 --- a/man/glance.Rd +++ b/man/glance.Rd @@ -148,7 +148,7 @@ Command line usage implies external software for PNG view \code{\link[ursa:sessi Nikita Platonov \email{platonov@sevin.ru} } \note{ -Package \pkg{sf} is 'Suggested' for package \pkg{ursa}. +Package \pkg{sp} is 'Suggested' for package \pkg{ursa}. } %% ~Make other sections like Warning with \section{Warning }{....} ~ @@ -169,27 +169,24 @@ cat(" ----------- end of quoting ---------------\n") try(system(cmd,wait=FALSE)) } -if (isSP <- require(sp)) { - a <- data.frame(lat=c(70.734,71.657),lon=c(178.577,-177.38),place="Wrangel Island") - coordinates(a) <- ~lon+lat - proj4string(a) <- "EPSG:4326" +a <- data.frame(lat=c(70.734,71.657),lon=c(178.577,-177.38),place="Wrangel Island") +if (requireNamespace("sp")) { + sp::coordinates(a) <- ~lon+lat + sp::proj4string(a) <- "EPSG:4326" +} else { + a <- sf::st_as_sf(a,coords=c("lon","lat"),crs=4326) } - \donttest{ ## internet connection is required -if (isSP) - glance(a,style="google color maptype=terrain") +glance(a,style="google color maptype=terrain") } \donttest{ ## internet connection is required -if (isSP) - glance(a,style="Positron",border=0) +glance(a,style="Positron",border=0) } \donttest{ ## internet connection is required -if (isSP) - glance(a,style="mapnik color tile",border=0) +glance(a,style="opentopomap grey",border=0) } \donttest{ ## internet connection is required -if (isSP) - glance("Svalbard",resetGrid=TRUE) +glance("Svalbard",resetGrid=TRUE) } } % Add one or more standard keywords, see file 'KEYWORDS' in the diff --git a/man/panel_new.Rd b/man/panel_new.Rd index 08107db..6d76345 100644 --- a/man/panel_new.Rd +++ b/man/panel_new.Rd @@ -11,8 +11,8 @@ Start plotting on the new image panel panel_new(...) # non-public -.panel_new(col = "chessboard", density = NA, angle = NA, lwd = 1, lty = 1, - asp = NA, mar = rep(0, 4), verbose = FALSE) +.panel_new(col = "chessboard", alpha = NA, density = NA, angle = NA, + lwd = 1, lty = 1, asp = NA, mar = rep(0, 4), grid = NULL, verbose = FALSE) } %%~ ## coerced to 'panel_new(fill = "grey80", density = NA, angle = NA, lwd = 1, lty = 1L, asp = 1, mar = rep(0, 4))' @@ -23,24 +23,28 @@ panel_new(...) \strong{Pattern} (\code{panel_new}) \tab \strong{Argument} (\code{.panel_new}) \tab \strong{Description} %%~ \cr \code{blank} \tab \code{} \tab \var{See below.} \cr \code{(blank\\\\.)*(^$|bg|fill)} \tab \code{col} \tab \var{See below.} Keyword \code{"chessboard"} is used by default to produce original background texture. However argument \code{col} has other default value. + \cr \code{(blank\\\\.)*aphpa} \tab \code{alpha} \tab \var{See below.} \cr \code{(blank\\\\.)*density} \tab \code{density} \tab \var{See below.} \cr \code{(blank\\\\.)*angle} \tab \code{angle} \tab \var{See below.} \cr \code{(blank\\\\.)*lwd} \tab \code{lwd} \tab \var{See below.} \cr \code{(blank\\\\.)*lty} \tab \code{lty} \tab \var{See below.} \cr \code{(blank\\\\.)*asp} \tab \code{asp} \tab \var{See below.} \cr \code{(blank\\\\.)*mar} \tab \code{mar} \tab \var{See below.} + \cr \code{(blank\\\\.)*grid} \tab \code{grid} \tab \var{See below.} \cr \code{(blank\\\\.)*verb(ose)*} \tab \code{verbose} \tab \var{See below.} } } %%~ \item{\code{blank}}{Prefix for indirect use. Separated by a dot \code{"."}, e.g., \code{blank.col="transparent"}.} - \item{col}{Character. Color code/name for panel filling/shadowing. Default is \code{"grey80"} for georeferenced images, and \code{"grey90"} for non-projected images.} + \item{col}{Character. Color code/name for panel filling/shadowing. Default is \code{"chessboard"} (lightened background for controlling transparency) for georeferenced images, and \code{"grey90"} for non-projected images.} + \item{alpha}{Numeric, \verb{0 <= alpha <= 1}. Level of transparency. Default is \code{1}, without transparency.} \item{density}{Numeric. The density of shading lines for fill/shadowing. If \code{NA} then no shading lines are drawn. Default is \code{NA}. See \code{density} in \code{\link[graphics]{rect}}.} \item{angle}{Numeric. The slope of shading lines, given as an angle in degrees (counter-clockwise). If \code{NA} then no shading lines are drawn. Default is \code{NA}. See \code{angle} in \code{\link[graphics]{rect}}.} \item{lwd}{Positive numeric. Width of coastline. Default is \code{1}. See \code{lwd} in \code{\link[graphics]{rect}}.} \item{lty}{Character or positive integer. Type (pattern) of coastline. Default is \code{1L} (solid). See \code{lty} in \code{\link[graphics]{rect}}.} \item{asp}{Positive numeric. The \emph{y/x} aspect ration. Default is \code{1}. See \code{asp} in \code{\link[graphics]{plot.window}}.} \item{mar}{Positive numeric of length 4. Plot margins. Default is \code{rep(0,4L)}. See \code{mar} in \code{\link[graphics]{par}}.} + \item{grid}{Object of class \code{ursaGrid} or converted to it, to define spatial extent and projection for this panel. Default is \code{NULL}, which repeats previous state.} \item{verbose}{Logical. Value \code{TRUE} may provide some additional information on console. Default is \code{FALSE}.} } \details{ @@ -74,12 +78,15 @@ Nikita Platonov \email{platonov@sevin.ru} \examples{ session_grid(NULL) # example no.1 -- direct use -compose_open(layout=c(1,2),legend=NULL) +compose_open(layout=c(1,3),legend=NULL) panel_new() panel_annotation(label="Default + Empty") panel_new(col="#0000FF3F",density=15,angle=45,lwd=3) panel_decor() panel_annotation(label="Settings + Grid") +panel_new("#FFFF0040",grid=regrid(expand=0.5)) +panel_decor() +panel_annotation(label="Another spatial extent") compose_close() # example no.2 -- indirect use diff --git a/man/panel_plot.Rd b/man/panel_plot.Rd index 4da05b7..a91a6ed 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) ## 'rgdal is retired' +# require(rgdal) ## 'rgdal' is retired a <- pixelsize() g1 <- session_grid() n <- 12L @@ -88,21 +88,37 @@ k <- 5L x <- with(g1,runif(n,min=minx,max=maxx)) y <- with(g1,runif(n,min=miny,max=maxy)) panel_plot(x,y) ## plots nothing, because 'compose_open(...,dev=F)' is not called yet -sl <- lapply(seq(k),function(id){ - x <- sort(with(g1,runif(n,min=minx,max=maxx))) - y <- sort(with(g1,runif(n,min=miny,max=maxy))) - sp::Lines(sp::Line(cbind(x,y)),ID=id) -}) -sl <- sp::SpatialLines(sl,proj4string=sp::CRS(ursa_proj(g1)))#,id=length(sl)) -lab <- t(sapply(sp::coordinates(sl),function(xy) xy[[1]][round(n/2),])) -lab <- as.data.frame(cbind(lab,z=seq(k))) -sl <- sp::SpatialLinesDataFrame(sl - ,data=data.frame(ID=runif(k,min=5,max=9),desc=LETTERS[seq(k)])) -print(sl@data) -ct <- colorize(sl@data$ID)#,name=sldf@data$desc) -shpname <- tempfile(pattern = "___tmp",tmpdir=".",fileext=".shp") +shpname <- tempfile(fileext=".shp") layername <- gsub("\\\\.shp$","",basename(shpname)) -try(writeOGR(sl,dirname(shpname),layername,driver="ESRI Shapefile")) +if (requireNamespace("sp")) { + sl <- lapply(seq(k),function(id){ + x <- sort(with(g1,runif(n,min=minx,max=maxx))) + y <- sort(with(g1,runif(n,min=miny,max=maxy))) + sp::Lines(sp::Line(cbind(x,y)),ID=id) + }) + sl <- sp::SpatialLines(sl,proj4string=sp::CRS(ursa_proj(g1)))#,id=length(sl)) + lab <- t(sapply(sp::coordinates(sl),function(xy) xy[[1]][round(n/2),])) + lab <- as.data.frame(cbind(lab,z=seq(k))) + sl <- sp::SpatialLinesDataFrame(sl + ,data=data.frame(ID=runif(k,min=5,max=9),desc=LETTERS[seq(k)])) + print(sl@data) + ct <- colorize(sl@data$ID)#,name=sldf@data$desc) + try(writeOGR(sl,dirname(shpname),layername,driver="ESRI Shapefile")) ## 'rgdal' is retired + spatial_write(sl,shpname) +} else if (requireNamespace("sf")) { + sl <- lapply(seq(k),function(id) { + x <- sort(with(g1,runif(n,min=minx,max=maxx))) + y <- sort(with(g1,runif(n,min=miny,max=maxy))) + sf::st_linestring(cbind(x,y)) + }) + sl <- sf::st_sfc(sl,crs=as.character(ursa_crs(g1))) + sl <- sf::st_sf(ID=runif(k,min=5,max=9),desc=LETTERS[seq(k)],geometry=sl) + print(spatial_data(sl)) + lab <- do.call("rbind",lapply(sf::st_geometry(sl),colMeans)) + lab <- as.data.frame(cbind(lab,z=seq(k))) + ct <- colorize(sl$ID) + sf::st_write(sl,shpname) +} compose_open(layout=c(1,2),legend=list(list("bottom",2))) panel_new() panel_decor() @@ -112,11 +128,14 @@ panel_points(0,0,pch=3) panel_text(0,0,"North\nPole",pos=4,cex=1.5,family="Courier New",font=3) panel_new() panel_decor() -panel_plot(sl,lwd=4,col="grey20") -if (file.exists(shpname)) +if (exists("sl")) + panel_plot(sl,lwd=4,col="grey20") +if ((exists("ct"))&&(file.exists(shpname))) panel_plot(shpname,lwd=3,col=ct$colortable[ct$index]) -panel_points(lab$x,lab$y,pch=as.character(lab$z),cex=2) -compose_legend(ct$colortable) +if (exists("lab")) + panel_points(lab$x,lab$y,pch=as.character(lab$z),cex=2) +if (exists("ct")) + compose_legend(ct$colortable) compose_close() file.remove(dir(path=dirname(shpname) ,pattern=paste0(layername,"\\\\.(cpg|dbf|prj|shp|shx)") diff --git a/man/panel_scalebar.Rd b/man/panel_scalebar.Rd index 8b31875..28f71a5 100644 --- a/man/panel_scalebar.Rd +++ b/man/panel_scalebar.Rd @@ -99,7 +99,7 @@ session_grid(NULL) ,scalebar=TRUE,scalebar.col="white",scalebar.fill="black") # example no.3 -- for paper copy - a <- colorize(pixelsize(),breakvalue=seq(400,650,by=50),pal="Greys",inv=FALSE) + a <- colorize(pixelsize(),breakvalue=seq(400,650,by=50),pal=c("gray90","gray30")) compose_open(scale="1:95000000",dpi=150,device="cairo",family="Times") compose_plot(a,graticule=TRUE,coastline=FALSE,scalebar=TRUE,scalebar.x=1,units=expression(km^2)) compose_close(bpp=8) diff --git a/man/polygonize.Rd b/man/polygonize.Rd index c68c526..0a42e39 100644 --- a/man/polygonize.Rd +++ b/man/polygonize.Rd @@ -7,7 +7,7 @@ Raster to vector (polygon) conversion. Representing each raster cell as a polygon. In comparison to common GIS raster to vector conversion, where neighbor cells with the same value are combined to the single polygon, the number of output polygons is equal to number of non-\code{NA} values. } \usage{ -polygonize(obj, fname, engine = c("native", "sp", "sf"), verbose = NA, ...) +polygonize(obj, fname, engine = c("native", "sf"), verbose = NA, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ @@ -18,7 +18,7 @@ Object of class \code{ursaRaster}. Missing or character. If specified, then ESRI Shapefile is created. Default is \link[base]{missing}. } \item{engine}{ -Character keyword from list \code{c("native","sp","sf")}. Define package with tools for creating spatial data. If \code{engine="sp"}, then functions from package \pkg{sp} are used. If \code{engine="sf"}, then functions from package \pkg{sf} are used. If \code{engine="native"}, then appropriate package is used based on loaded namespaces before. +Character keyword from list \code{c("native", "sf")}. Define package with tools for creating spatial data. If suggested packaged \pkg{"sp"} is loaded or can be loaded from default location, then \code{"sp"} is added to this list. If \code{engine="sf"}, then functions from package \pkg{sf} are used. If \code{engine="sp"}, then functions from package \pkg{sp} are used. If \code{engine="native"}, then appropriate package is used based on loaded namespaces before. } \item{verbose}{ Logical. If \code{TRUE} then convertion is attended by progress bar. Default is \code{NA}; it means \code{TRUE} for \code{engine="sp"} and \code{FALSE} for \code{engine="sp"}. @@ -64,10 +64,13 @@ a <- ursa_dummy(mul=1/16) a <- a[a>100] print(a) print(band_mean(a)) -b2 <- polygonize(a,engine="sp") ## try 'engine="sf"' +b2 <- polygonize(a,engine=ifelse(requireNamespace("sp"),"sp","sf")) +print(class(b2)) print(colMeans(spatial_data(b2),na.rm=TRUE)) -print(ursa_bbox(a)) -print(spatial_bbox(b2)) +str(e1 <- spatial_bbox(a)) +str(e2 <- spatial_bbox(b2)) +print(as.numeric(e1)) +print(as.numeric(e2)) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. diff --git a/man/spatial_engine.Rd b/man/spatial_engine.Rd index fe4443d..b0c71a6 100644 --- a/man/spatial_engine.Rd +++ b/man/spatial_engine.Rd @@ -44,6 +44,7 @@ \alias{spatial_grid} \alias{spatial_centroid} \alias{spatial_bind} +\alias{spatial_crop} \title{ Wrapper functions for manipulation with non-raster spatial objects } @@ -51,6 +52,9 @@ Wrapper functions for manipulation with non-raster spatial objects These wrappers return iniform properties or do consimilar manipulations for spatial objects of different types: simple features (package \pkg{sf}) and abstract class Spatial (package \pkg{sp}). Appropriate functionality (\emph{\dQuote{engine}}) of respective packages is used. } +%%~ spatial_crs(obj, beauty = FALSE, verbose = FALSE) +%%~ spatial_proj(obj, beauty = FALSE, verbose = FALSE) +%%~ spatial_proj4(obj, beauty = FALSE, verbose = FALSE) \usage{ spatial_engine(obj, verbose = FALSE) @@ -114,6 +118,7 @@ spatial_intersection(x, y, spatial_symdifference(x, y, verbose = FALSE) spatial_difference(x, y, verbose = FALSE) spatial_union(x, y, byid=NA, verbose = FALSE) +spatial_crop(x, y) spatial_buffer(obj, dist = 0, quadsegs = 30L, verbose = FALSE) @@ -132,7 +137,7 @@ spatial_bind(...) Simple feature (package \pkg{sf}) or Spatial abstract class (package \pkg{sp}) for all functions, excepting \code{spatial_geometry<-}. Data frame for \emph{Replace} function \code{spatial_geometry<-}. } \item{x, y}{ -Objects of simple feature (package \pkg{sf}) class or Spatial abstract class (package \pkg{sp}). +Objects of simple feature (package \pkg{sf}) class or Spatial abstract class (package \pkg{sp}). Spatial abstracts are not applicable for \code{spatial_crop()}. } \item{crs}{ Projection EPSG code or projection PROJ.4 string. @@ -186,6 +191,9 @@ Character. Desired output geometry for \code{engine="sf"}. If \code{"default"} t \item{reason}{ Logical. If \code{TRUE}, then the reason for validity ("Valid Geomerty") or invalidity is returned. If \code{FALSE}, then logical value of validity is returned. Default is \code{FALSE}. } +%%~ \item{beauty}{ +%%~ Logical. If \code{TRUE} and projection is in WKT string, then simplified representation is given in output. If procection is in PROJ4 string, then this argument is ignored. Default is \code{FALSE}. +%%~ } \item{verbose}{ Logical. Value \code{TRUE} provides information on console. Default is \code{FALSE}. } @@ -255,6 +263,8 @@ Logical. Value \code{TRUE} provides information on console. Default is \code{FAL \code{spatial_union} returns combined geometry without internal boundaries. +\code{spatial_crop} returns cropped geometry of first spatial object by second spatial object of boundary box derived from spatial object. + \code{spatial_trim} returns spatial object without extra attributes added by \pkg{ursa} package. \code{spatial_grid} generates suitable spatial grid from input vector and returns object of class \code{ursaGrid}. diff --git a/man/spatial_read.Rd b/man/spatial_read.Rd index 82cf94f..b330ebf 100644 --- a/man/spatial_read.Rd +++ b/man/spatial_read.Rd @@ -9,14 +9,14 @@ Read either simple features (package \pkg{sf}) from disk using appropriate functionality (\emph{\dQuote{engine}}) of respective packages is used. } \usage{ -spatial_read(dsn, engine = c("native", "sf", "geojsonsf")) +spatial_read(dsn, engine = c("native", "sf")) } \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. +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"} and package \pkg{sp} can be loaded, then Spatial abstracts (package \pkg{sp}) 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. @@ -26,8 +26,8 @@ If value is \code{"native"} then engine selection depends on has suggested packa 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}). -Object of Simple Features (package \pkg{sf}). +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} diff --git a/man/spatial_write.Rd b/man/spatial_write.Rd index 252db15..40cf249 100644 --- a/man/spatial_write.Rd +++ b/man/spatial_write.Rd @@ -5,20 +5,19 @@ 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. +If spatial objest are abstract of class Spatial (package \pkg{sp}) then preliminarly transformation to Simple Features is performed. } \usage{ -spatial_write(obj, fname, layer, driver = NA, compress = "", - ogr2ogr = nchar(Sys.which("ogr2ogr")) > 0, verbose = FALSE) +spatial_write(obj, fname, layer, driver = NA, compress = "", verbose = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{obj}{ Spatial object: -%%~ either -Simple Features (\pkg{sf}). -%%~ or Spatial Abstract (\pkg{sp}). +Either +Simple Features (\pkg{sf}) +or Spatial Abstract (\pkg{sp}). \link[base:list]{List} of spatial objects can be used. } \item{fname}{ @@ -33,9 +32,10 @@ Character. Driver for specification of output file format. Default is \code{NA}; \item{compress}{ Character or logical. Will output file or list of files be packed after writing and what archive format will be used. Available character values are \code{""} (default; no compression), \code{"gz"}, \code{"gzip"}, \code{"bz2"}, \code{"bzip2"}, \code{"zip"}, \code{"xz"}. If logical and \code{TRUE}, then "zip" is used for \code{driver} "ESRI Shapefile" and "gzip" otherwise. If logical and \code{FALSE}, then no compression. } - \item{ogr2ogr}{ -Logical. If \code{"ogr2ogr"} is found in system path, then GDAL utils are used for speed up and layer merge (if \code{obj} is list of spatial objects) -} +%%~ \item{ogr2ogr}{ +%%~ DEPRECATED: ogr2ogr = nchar(Sys.which("ogr2ogr"))>0 +%%~ Logical. If \code{"ogr2ogr"} is found in system path, then GDAL utils are used for speed up and layer merge (if \code{obj} is list of spatial objects) +%%~ } \item{verbose}{ Logical. Value \code{TRUE} provides information on console. Default is \code{FALSE}. } diff --git a/man/segmentize.Rd b/man/trackline.Rd similarity index 79% rename from man/segmentize.Rd rename to man/trackline.Rd index 64c0c52..f528a5f 100644 --- a/man/segmentize.Rd +++ b/man/trackline.Rd @@ -1,5 +1,5 @@ -\name{segmentize} -\alias{segmentize} +\name{trackline} +\alias{trackline} \title{ Create segmented line from points' sequence } @@ -7,7 +7,7 @@ Create segmented line from points' sequence Connect sequence of points (locations) by direct lines (tracks) } \usage{ -segmentize(obj, by=NULL, connect=c("united", "consequent")) +trackline(obj, by=NULL, connect=c("united", "consequent")) } \arguments{ \item{obj}{ @@ -35,10 +35,15 @@ n <- 15 lon <- rev(sort(runif(n,min=40,max=60))) lat <- sort(runif(n,min=30,max=50)) pt <- data.frame(lon=lon,lat=lat,value=seq(n)) -sp::coordinates(pt) <- c("lon","lat") -sp::proj4string(pt) <- "+proj=longlat" +if (requireNamespace("sp")) { + sp::coordinates(pt) <- c("lon","lat") + sp::proj4string(pt) <- "EPSG:4326" +} else { + pt <- sf::st_as_sf(pt,coords=c("lon","lat"),crs="WGS84") +} ct <- ursa_colortable(colorize(pt$value)) -tr <- segmentize(pt) +tr <- trackline(pt,connect="consequent") +#opW <- options(warn=0) session_grid(pt,expand=1.1) compose_open(2) panel_new() @@ -47,7 +52,7 @@ panel_decor() panel_new() panel_plot(tr,col=ct,lwd=3) panel_decor() -compose_legend(ct) +compose_legend(ct,unit="step number") compose_close() } \keyword{attribute} diff --git a/man/ursa_proj.Rd b/man/ursa_crs.Rd similarity index 100% rename from man/ursa_proj.Rd rename to man/ursa_crs.Rd diff --git a/man/ursa_new.Rd b/man/ursa_new.Rd index 267bdc9..923e807 100644 --- a/man/ursa_new.Rd +++ b/man/ursa_new.Rd @@ -79,7 +79,7 @@ print(a3) dima <- c(200,300,4) b1 <- as.ursa(array(runif(prod(dima)),dim=dima)) print(b1) -display_brick(b1,scale=1,palname="Greys",decor=FALSE) +display_brick(b1,scale=1,pal=c("white","black"),decor=FALSE) session_grid(NULL) diff --git a/man/whiteboxing.Rd b/man/whiteboxing.Rd index 6b623de..7704455 100644 --- a/man/whiteboxing.Rd +++ b/man/whiteboxing.Rd @@ -44,8 +44,7 @@ Internally, for piping support, first character argument without \code{*.tif} su } \examples{ -if ((requireNamespace("whitebox"))&&(isTRUE(whitebox::wbt_init()))&& - (requireNamespace("stars"))) { +if ((requireNamespace("whitebox"))&&(isTRUE(whitebox::wbt_init()))) { dem <- whitebox::sample_dem_data() a1 <- c(DEM=read_gdal(dem)) a2 <- whiteboxing("BreachDepressions",input=a1)