ongoing

DESCRIPTION

@@ -11,6 +11,6 @@ URL: https://github.com/nplatonov/ursa
 BugReports: https://github.com/nplatonov/ursa/issues
 Depends: R (>= 4.1.0)
 Imports: utils, graphics, grDevices, stats, rgdal, png, jpeg
-Suggests: jsonlite, proj4, sf (>= 0.6-1), raster, ncdf4, locfit, knitr, rmarkdown, tcltk, sp, methods, fasterize, IRdisplay, caTools, shiny, rgeos, tools, webp, htmlwidgets, htmltools, leaflet, leafem, leafpop, RColorBrewer, ragg, widgetframe, geojsonsf (>= 2.0.0), leaflet.providers, magick, terra, stars, vapour, sys
+Suggests: jsonlite, proj4, sf (>= 0.6-1), raster, ncdf4, locfit, knitr, rmarkdown, tcltk, sp, methods, fasterize, IRdisplay, caTools, shiny, rgeos, tools, webp, htmlwidgets, htmltools, leaflet, leafem, leafpop, RColorBrewer, ragg, widgetframe, geojsonsf (>= 2.0.0), leaflet.providers, magick, terra, stars, vapour, sys, RSQLite
 NeedsCompilation: yes
 ByteCompile: no

NEWS.md

@@ -1,4 +1,4 @@
-2023-03-24
+2023-08-24
 
 <!--
 + Depends on R (>= 4.1.0) instead of R (>= 3.0.0) due to using native pipes `|>` in code
@@ -8,11 +8,19 @@
 
 ### version 3.9.11
 
--   ongoing…
+-   Repaired parsing of Nominatim responses.
+
+-   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
+    `type` argument is reversed to `c("united","conseqwent")`
+
+-   Coastline is updated to version 2023-08-24T03:31.
 
 ### version 3.9.10
 
--   Foreign functions are symbolic insead of character after [R-devel
+-   Foreign functions are symbolic instead of character after [R-devel
     BUG FIXES
     2023-03-20](https://developer.r-project.org/blosxom.cgi/R-devel/NEWS/2023/03/20#n2023-03-20).
 

R/compose_legend.R

@@ -148,7 +148,7 @@
          arglist2 <- c(quote(obj[[i]]),arglist) ## 20180308 change 'arglist[-1]'?
         # arglist[[1]] <- quote(obj[[i]])
          if (.is.colortable(obj[[i]])) {
-            arglist2[["units"]] <- units[i]
+            arglist2[["unit"]] <- units[i]
            # str(arglist2)
             do.call("legend_colorbar",arglist2)
            # arglist[["units"]] <- NULL

R/conn.open_gdal.R

@@ -8,9 +8,9 @@
   #    .elapsedTime("rgdal has been loaded")
    opW <- options(warn=0-!verbose,show.error.messages=TRUE) ## to prevent 'GeoTransform values not available'
    on.exit(options(opW))
-   if (devel <- T) {
-      a <- vapour:::gdalinfo_internal(fname,json=TRUE,stats=FALSE)
-      a <- jsonlite::fromJSON(a)
+   if (devel <- F) {
+     # a <- vapour:::gdalinfo_internal(fname,json=TRUE,stats=FALSE)
+     # a <- jsonlite::fromJSON(a)
    }
    a <- try(rgdal::GDALinfo(fname,returnStats=FALSE,returnRAT=FALSE
                 ,returnColorTable=TRUE,returnCategoryNames=TRUE),silent=TRUE)

R/conn.read_gdal.R

@@ -81,7 +81,6 @@
      # 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 (!is.null(band))
          res <- res[band]
    }
@@ -92,7 +91,8 @@
       res <- if (!is.null(band)) obj[band] else obj[]
       close(obj)
    }
-   if (T & length(grep("^\\d{8}\\.s1ab\\.1km\\.n\\.mos[13]d\\.jpg$",basename(fname)))) {
+   if (T & length(grep("^(\\d{8}\\.s1ab\\.1km\\.n\\.mos[13]d|.+sentinel1-n-[13]daymos)\\.jpg$"
+                      ,basename(fname)))) {
      ## patch to seaice.dk Sentinel-1 mosaic
       g0 <- ursa_grid(res)
       if ((g0$columns==4500L)&&(g0$rows==5500L)) {

R/glance.R

@@ -247,7 +247,19 @@
       s2 <- strsplit(style,split="\\s+")
       s <- expand.grid(s1,s2)
    }
-   isUrl <- .lgrep("http(s)*://",style)
+   canUrl <- length(unlist(regmatches(style,gregexpr("\\{[xyz]\\}",style))))==3
+   if (!canUrl) {
+      sascache <- gsub("\\s(color|grey|gray)$","",style)
+      if (!length(ind <- which(dir.exists(sascache))))
+         sascache <- file.path(getOption("SAS_Planet_cache"),sascache)
+      if (length(ind <- which(dir.exists(sascache)))>0) {
+         list1 <- dir(path=sascache[ind],pattern="\\.sqlitedb$",recursive=TRUE)
+         canUrl <- length(list1)>0
+         if (canUrl)
+            style <- basename(sascache)
+      }
+   }
+   isUrl <- .lgrep("http(s)*://",style) | canUrl
    if (isUrl) {
       ind <- .grep("http(s)*://",style)
       style[ind] <- unlist(strsplit(style[ind],split="\\s+"))[1]
@@ -282,7 +294,7 @@
          nextStyle <- .grep(ostyle[1],staticMap
                            ,invert=TRUE,value=TRUE)
       else
-         nextStyle <- .grep(ostyle[1],c("mapnik","mapsurfer","cartoDB","opentopomap")
+         nextStyle <- .grep(ostyle[1],c("mapnik","cartoDB","opentopomap")
                            ,invert=TRUE,value=TRUE)[seq(3)]
       nsize <- length(nextStyle)+1
       cache <- .getPrm(arglist,"cache",class=c("logical","character"),default=TRUE)
@@ -510,6 +522,8 @@
             panel_new(...) #fill=ifelse(isWeb,"transparent","chessboard"))
          if (before) {
             panel_plot(basemap,alpha=basemap.alpha)
+            if (toCoast)
+               panel_coastline(cline)
          }
         # if ((!length(ct))||(all(is.na(ct[[i]]$index)))) {
          if ((!length(ct))||(!hasField)) {
@@ -583,9 +597,9 @@
          }
          if (after) {
             panel_plot(basemap,alpha=basemap.alpha)
+            if (toCoast)
+               panel_coastline(cline)
          }
-         if (toCoast)
-            panel_coastline(cline)
          if ((geocodeStatus)||(!length(ct)))
             panel_graticule(gline,margin=c(T,T,F,F))
          else

R/legend_colorbar.R

@@ -36,7 +36,7 @@
    }
    units <- .getPrm(arglist,name="unit(s)*",kwd=kwd
                    ,class=list("character","expression"),default="",verbose=FALSE)
-   if (!nchar(units)) {
+   if (all(!nchar(units))) {
       aname <- names(arglist[1])
       if (!is.null(aname))
          units <- names(arglist[1])
@@ -799,7 +799,7 @@
       panel_box()
    }
   # options(ursaWidth=width,ursaHeight=height)
-   if (((is.character(units))&&(is.na(units)))||(!nchar(units)))
+   if (((is.character(units))&&(is.na(units[1])))||(!nchar(units[1])))
       return(invisible(10L))
   # b <- 2*width+0.5+height
   # print(b)

R/panel_annotation.R

@@ -75,7 +75,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 <- session_grid()
+   g1 <- getOption("ursaPngPanelGrid") # session_grid()
    minx <- g1$minx
    miny <- g1$miny
    maxx <- g1$maxx
@@ -98,8 +98,8 @@
       pos <- c((xy[1,1]-minx)/(maxx-minx),(xy[1,2]-miny)/(maxy-miny))
    }
    else if ((!is.na(x))&&(!is.na(y))) {
-      if ((x<minx)||(x>maxx)||(y<miny)||(y>maxy))
-         return(NULL)
+     # if ((x<minx)||(x>maxx)||(y<miny)||(y>maxy))
+     #    return(NULL)
       pos <- c((x-minx)/(maxx-minx),(y-miny)/(maxy-miny))
    }
    else
@@ -117,7 +117,7 @@
       if (!isE)
          label <- paste(label,collapse="\n")
       if (!nchar(label))
-         return (10L)
+         return(invisible(NULL)) ## 10L
    }
    if (is.factor(pos))
       pos <- as.character(pos)
@@ -237,6 +237,8 @@
       if (verbose)
          .elapsedTime("label:finish")
    }
+   if (verbose)
+      str(list(x=x,y=y,adj=c(adjust,vadj),labels=label,cex=mycex,col=fg,srt=srt))
    text(x=x,y=y,adj=c(adjust,vadj),labels=label,cex=mycex,col=fg,srt=srt)
    par(opt)
    invisible(NULL)

R/panel_coastline.R

@@ -628,13 +628,11 @@
 
 'update_coastline' <- function(merge=TRUE) {
    missedSF <- !requireNamespace("sf",quietly=TRUE) 
-   missedLW <- !requireNamespace("lwgeom",quietly=TRUE)
-   if ((missedSF)&&(missedLW))
-      stop("Suggested packages 'sf' and 'lwgeom' are required for this operation")
-   else if (missedSF)
+   if (missedSF)
       stop("Suggested package 'sf' is required for this operation")
-   else if (missedLW)
-      stop("Suggested package 'lwgeom' is required for this operation")
+  # missedLW <- !requireNamespace("lwgeom",quietly=TRUE)
+  # if (missedLW)
+  #    stop("Suggested package 'lwgeom' is required for this operation")
    dpath <- getOption("ursaRequisite")
    ftemp <- tempfile(tmpdir=dpath)
    opW <- options(warn=-1)

R/regrid.R

@@ -11,7 +11,7 @@
          session_grid(result)
       return(result)
    }
-   fun <- "resize" #as.character(match.call())[1]
+   fun <- "regrid" #as.character(match.call())[1]
    if (.is.ursa_stack(x)) {
       return(lapply(x,regrid,...))
    }

R/session.R

@@ -127,8 +127,11 @@
 'session_proj' <- 'session_proj4' <- 'session_crs' <- function() session_grid()$crs
 'session_cellsize' <- function() with(session_grid(),sqrt(as.numeric(resx)*as.numeric(resy)))
 'session_dim' <- function() with(session_grid(),c(lines=rows,samples=columns))
-'session_bbox' <- function() with(session_grid()
-                                 ,c(minx=minx,miny=miny,maxx=maxx,maxy=maxy))
+'session_bbox' <- function() {
+   ret <- with(session_grid(),c(minx=minx,miny=miny,maxx=maxx,maxy=maxy))
+   attr(ret,"crs") <- session_crs()
+   ret
+}
 'session_pngviewer' <- function(allow=NA) {
    opV <- getOption("ursaAllowPngViewer")
   # str(list(allow=allow,opV=opV,isRscript=.isRscript()))

R/spatial_engine.R

@@ -814,10 +814,13 @@
                                                ,recursive=FALSE,ignore.case=TRUE) {
    patt0 <- "\\.(gpkg|tab|kml|json|geojson|mif|sqlite|shp|osm)(\\.(zip|gz|bz2))*$"
    if (devel <- TRUE & all(!dir.exists(path))) {
-      dpath <- list.dirs(dirname(path),full.names=FALSE)
-      ind <- grep(basename(path),dpath,ignore.case=ignore.case)
-      if (length(ind)==1)
-         path <- file.path(dirname(path),dpath[ind])
+      dname <- dirname(path)
+      if (dname!=".") {
+         dpath <- list.dirs(dirname(path),full.names=FALSE)
+         ind <- grep(basename(path),dpath,ignore.case=ignore.case)
+         if (length(ind)==1)
+            path <- file.path(dirname(path),dpath[ind])
+      }
    }
    res <- dir(path=path,pattern=patt0,full.names=full.names
              ,recursive=recursive,ignore.case=ignore.case)
@@ -1299,12 +1302,14 @@
 }
 'spatial_bind' <- function(...) {
    arglist <- list(...)
+   if (length(ind <- which(sapply(arglist,is.null))))
+      arglist <- arglist[-ind]
+   if (!length(arglist))
+      return(NULL)
    if ((length(arglist)==1)&&
        (any(sapply(arglist[[1]],is_spatial)))&&
        (!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)

R/ursa_as.R

@@ -400,10 +400,14 @@
          ##~ str(a1[[1]]$finalize())
          ##~ q()
       }
-      bbox <- obj@ptr$extent$vector[c(1,3,2,4)]
-      res <- obj@ptr$res
-      crs <- obj@ptr$get_crs("proj4")
-      aname <- obj@ptr$names
+     # bbox <- obj@ptr$extent$vector[c(1,3,2,4)]
+     # res <- obj@ptr$res
+     # crs <- obj@ptr$get_crs("proj4")
+     # aname <- obj@ptr$names
+      bbox <- as.vector(obj)[c(1,3,2,4)]
+      res <- terra::res(obj)
+      crs <- terra::crs(obj,proj=TRUE)
+      aname <- terra::names(obj)
       g1 <- regrid(bbox=bbox,res=res,crs=crs)
       if (identical(bbox,c(0,0,1,1)))
          g1 <- regrid(bbox=c(0,0,rev(dim(g1))),res=1,crs=crs)

R/xxx.geocode.R

@@ -52,6 +52,7 @@
                   # ,"&polygon_text=1"
                    ,"&format=xml","&bounded=0","&accept-language=en-US,ru")
      # dst <- tempfile() # "nominatim.xml" # tempfile()
+     # print(src)
       dst <- .ursaCacheDownload(src,quiet=!verbose)
       xmlstring <- scan(dst,character(),quiet=!verbose)
      # Encoding(xmlstring) <- "UTF-8"
@@ -64,11 +65,11 @@
          print(geotext)
       }
       ptype <- .grep("^type=",xmlstring,value=TRUE)
-      ptype <- .gsub(".*\'(.+)\'.*","\\1",ptype)
+      ptype <- .gsub(".*(\'|\")(.+)(\'|\").*","\\2",ptype)
       pclass <- .grep("^class=",xmlstring,value=TRUE)
-      pclass <- .gsub(".*\'(.+)\'.*","\\1",pclass)
+      pclass <- .gsub(".*(\'|\")(.+)(\'|\").*","\\2",pclass)
       prank <- .grep("^place_rank=",xmlstring,value=TRUE)
-      prank <- .gsub(".*\'(.+)\'.*","\\1",prank)
+      prank <- .gsub(".*(\'|\")(.+)(\'|\").*","\\2",prank)
       if (FALSE) {
          prank[prank=="8"] <- "state"
          prank[prank=="10"] <- "region"
@@ -77,12 +78,12 @@
         # prank[prank=="17"] <- "town|island"
         # prank[prank=="18"] <- "village|"
         # prank[prank=="19"] <- ""
-     }
+      }
       ptype <- paste(pclass,ptype,prank,sep=":")
       lon <- .grep("lon=",xmlstring,value=TRUE)
-      lon <- as.numeric(.gsub(".*\'(.+)\'.*","\\1",lon))
+      lon <- as.numeric(.gsub(".*(\'|\")(.+)(\'|\").*","\\2",lon))
       lat <- .grep("lat=",xmlstring,value=TRUE)
-      lat <- as.numeric(.gsub(".*\'(.+)\'.*","\\1",lat))
+      lat <- as.numeric(.gsub(".*(\'|\")(.+)(\'|\").*","\\2",lat))
       pt <- cbind(lon=lon,lat=lat)
       if (!nrow(pt))
          return(NULL)
@@ -99,7 +100,7 @@
       ann <- .grep("display_name=",xmlstring,value=TRUE)
       ann <- .gsub(".*\"(.+)\".*","\\1",ann)
       importance <- .grep("importance",xmlstring,value=TRUE)
-      importance <- as.numeric(.gsub(".*\'(.+)\'.*","\\1",importance))
+      importance <- as.numeric(.gsub(".*(\'|\")(.+)(\'|\").*","\\2",importance))
      # type <- NULL ## debug
       typeInd <- integer()
       if ((is.character(place))&&(nchar(place))) {
@@ -140,8 +141,8 @@
               # print(file.size(dst))
                b <- unlist(strsplit(b,split="'"))
                b <- .grep("(MULTI)*(POLYGON|LINESTRING)",b,value=TRUE,ignore.case=FALSE)
-               b <- .gsub("((MULTI)*(POLYGON|LINESTRING)|\\(|\\))"," ",b)
-               b <- .gsub("(^\\s+|\\s+$)","",b)
+               b <- .gsub("(^.+(MULTI)*(POLYGON|LINESTRING)|\\(|\\))"," ",b)
+               b <- .gsub("(^\\s+|\\s+(\".+)*$)","",b)
                b <- lapply(b,function(b2) {
                   b3 <- unlist(strsplit(b2,split=","))
                   b3 <- unlist(strsplit(b3,split="\\s+"))