Updated to version 0.5.3

spatialstatisticsupna · Sep 8, 2023 · e4979db · e4979db
1 parent 6748e40
commit e4979db
Show file tree

Hide file tree

Showing 7 changed files with 70 additions and 60 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: bigDM
 Type: Package
 Title: Scalable Bayesian Disease Mapping Models for High-Dimensional Data
-Version: 0.5.2
-Date: 2023-07-19
+Version: 0.5.3
+Date: 2023-09-08
 Authors@R: 
   c(person(given = "Aritz",
            family = "Adin",
@@ -24,7 +24,7 @@ URL: https://github.com/spatialstatisticsupna/bigDM
 BugReports: https://github.com/spatialstatisticsupna/bigDM/issues
 Depends: R (>= 4.0.0)
 Additional_repositories: https://inla.r-inla-download.org/R/stable
-Imports: crayon, doParallel, fastDummies, foreach, future, future.apply, MASS, Matrix, methods, parallel, RColorBrewer, Rdpack, sf, spatialreg, spdep, stats, utils, rlist
+Imports: crayon, doParallel, fastDummies, foreach, future, future.apply, geos, MASS, Matrix, methods, parallel, RColorBrewer, Rdpack, sf, spatialreg, spdep, stats, utils, rlist
 Suggests: bookdown, INLA (>= 22.12.16), knitr, rmarkdown, testthat (>= 3.0.0), tmap
 RdMacros: Rdpack
 License: GPL-3

diff --git a/NAMESPACE b/NAMESPACE
@@ -28,14 +28,14 @@ importFrom(fastDummies,dummy_cols)
 importFrom(foreach,"%dopar%")
 importFrom(foreach,foreach)
 importFrom(future.apply,future_mapply)
+importFrom(geos,geos_prepared_intersects)
 importFrom(grDevices,boxplot.stats)
 importFrom(methods,as)
 importFrom(methods,is)
 importFrom(rlist,list.flatten)
 importFrom(sf,st_as_sf)
 importFrom(sf,st_bbox)
 importFrom(sf,st_centroid)
-importFrom(sf,st_contains)
 importFrom(sf,st_distance)
 importFrom(sf,st_drop_geometry)
 importFrom(sf,st_geometry)

diff --git a/NEWS b/NEWS
@@ -1,3 +1,7 @@
+version 0.5.3
+- bug fixed
+- faster implementation of divide_carto() function
+
 version 0.5.2
 - 'X' argument included to STCAR_INLA() function
 - changes in mergeINLA() function

diff --git a/R/CAR_INLA.R b/R/CAR_INLA.R
@@ -265,8 +265,8 @@ CAR_INLA <- function(carto=NULL, ID.area=NULL, ID.group=NULL, O=NULL, E=NULL, X=
 
                 cat(sprintf("+ Model %d of %d",d,D),"\n")
 
-                Rs <- as(Rs,"TsparseMatrix")
-                Rs.Leroux <- as(Rs.Leroux,"TsparseMatrix")
+                Rs <- as(Rs,"Matrix")
+                Rs.Leroux <- as(Rs.Leroux,"Matrix")
                 # Rs <- inla.as.sparse(Rs)
                 # Rs.Leroux <- inla.as.sparse(Rs.Leroux)
 
@@ -308,8 +308,8 @@ CAR_INLA <- function(carto=NULL, ID.area=NULL, ID.group=NULL, O=NULL, E=NULL, X=
 
                 W <- aux$W
                 n <- nrow(W)
-                Rs <- as(Diagonal(n,colSums(W))-W,"TsparseMatrix")
-                Rs.Leroux <- as(Diagonal(n)-Rs,"TsparseMatrix")
+                Rs <- as(Diagonal(n,colSums(W))-W,"Matrix")
+                Rs.Leroux <- as(Diagonal(n)-Rs,"Matrix")
                 # Rs <- inla.as.sparse(Diagonal(n,colSums(W))-W)
                 # Rs.Leroux <- inla.as.sparse(Diagonal(n)-Rs)
 
@@ -471,5 +471,5 @@ CAR_INLA <- function(carto=NULL, ID.area=NULL, ID.group=NULL, O=NULL, E=NULL, X=
   }
 }
 
-utils::globalVariables(c("inla.as.sparse"))
+# utils::globalVariables(c("inla.as.sparse"))
 utils::globalVariables(c("inla.setOption"))
diff --git a/R/STCAR_INLA.R b/R/STCAR_INLA.R
@@ -215,7 +215,7 @@ STCAR_INLA <- function(carto=NULL, data=NULL, ID.area=NULL, ID.year=NULL, ID.gro
         if(temporal=="rw1") dif <- 1
         if(temporal=="rw2") dif <- 2
         D <- diff(diag(T), differences=dif)
-        Rt <- as(t(D)%*%D, "TsparseMatrix")
+        Rt <- as(t(D)%*%D, "Matrix")
         # Rt <- inla.as.sparse(t(D)%*%D)
 
         ## Define hyperprior distributions ##
@@ -352,8 +352,8 @@ STCAR_INLA <- function(carto=NULL, data=NULL, ID.area=NULL, ID.year=NULL, ID.gro
 
                 cat(sprintf("+ Model %d of %d",d,D),"\n")
 
-                Rs <- as(Rs,"TsparseMatrix")
-                Rs.Leroux <- as(Rs.Leroux,"TsparseMatrix")
+                Rs <- as(Rs,"Matrix")
+                Rs.Leroux <- as(Rs.Leroux,"Matrix")
                 # Rs <- inla.as.sparse(Rs)
                 # Rs.Leroux <- inla.as.sparse(Rs.Leroux)
                 S <- nrow(Rs)
@@ -435,8 +435,8 @@ STCAR_INLA <- function(carto=NULL, data=NULL, ID.area=NULL, ID.year=NULL, ID.gro
                 cat("STEP 2: Fitting global model with INLA (this may take a while...)\n")
 
                 W <- aux$W
-                Rs <- as(Diagonal(S,colSums(W))-W, "TsparseMatrix")
-                Rs.Leroux <- as(Diagonal(S)-Rs, "TsparseMatrix")
+                Rs <- as(Diagonal(S,colSums(W))-W, "Matrix")
+                Rs.Leroux <- as(Diagonal(S)-Rs, "Matrix")
                 # Rs <- inla.as.sparse(Diagonal(S,colSums(W))-W)
                 # Rs.Leroux <- inla.as.sparse(Diagonal(S)-Rs)
 

diff --git a/R/divide_carto.R b/R/divide_carto.R
@@ -11,8 +11,9 @@
 #'
 #' @return List of \code{sf} objects with the spatial polygons of each subdomain.
 #'
+#' @importFrom geos geos_prepared_intersects
 #' @importFrom RColorBrewer brewer.pal
-#' @importFrom sf st_as_sf st_contains st_intersects st_set_geometry st_union
+#' @importFrom sf st_as_sf st_set_geometry st_union
 #' @importFrom stats aggregate
 #'
 #' @examples
@@ -45,62 +46,63 @@
 #' @export
 divide_carto <- function(carto, ID.group=NULL, k=0, plot=FALSE){
 
-  ## Transform 'SpatialPolygonsDataFrame' object to 'sf' class
-  carto <- sf::st_as_sf(carto)
+        ## Transform 'SpatialPolygonsDataFrame' object to 'sf' class
+        carto <- sf::st_as_sf(carto)
 
-  ## Construct the grouped 'sf' object by ID.group variable ##
-  carto$temp <- seq(1,nrow(carto))
-  Data <- sf::st_set_geometry(carto, NULL)
+        ## Construct the grouped 'sf' object by ID.group variable ##
+        Data <- sf::st_set_geometry(carto, NULL)
+        carto.group <- stats::aggregate(carto[,"geometry"], list(ID.group=Data[,ID.group]), utils::head)
+        D <- nrow(carto.group)
 
-  carto.group <- stats::aggregate(carto[,"geometry"], list(ID.group=Data[,ID.group]), utils::head)
-  D <- nrow(carto.group)
+        ########################
+        ## Disjoint partition ##
+        ########################
+        group.names <- carto.group$ID.group
+        names(group.names) <- group.names
 
-  ########################
-  ## Disjoint partition ##
-  ########################
-  carto.k0 <- vector("list",D)
-  names(carto.k0) <- carto.group$ID.group
+        carto.k0 <- lapply(group.names, function(x) {
+                aux <- carto[st_set_geometry(carto[,ID.group],NULL)==x,]
+                rownames(aux) <- NULL
+                aux
+        })
 
-  for(i in 1:D){
-    loc <- sf::st_contains(carto.group$geometry[i], carto[,"geometry"])
-    carto.k0[[i]] <- merge(carto, data.frame(loc=unlist(loc)), by.x="temp", by.y="loc")
-    carto.k0[[i]]$temp <- NULL
-  }
+        if(k==0){
+                if(plot) lapply(carto.k0, function(x) plot(x$geometry, main=unique(st_set_geometry(x,NULL)[,ID.group])))
+                return(carto.k0)
+        }
 
-  if(k==0){
-    if(plot) lapply(carto.k0, function(x) plot(x$geometry, main=unique(st_set_geometry(x,NULL)[,ID.group])))
-    return(carto.k0)
-  }
+        ############################################
+        ## Partition including k-order neighbours ##
+        ############################################
+        if(k>0){
 
-  ############################################
-  ## Partition including k-order neighbours ##
-  ############################################
-  if(k>0){
+                carto.k <- vector("list",D)
+                names(carto.k) <- names(carto.k0)
 
-    carto.k <- vector("list",D)
-    names(carto.k) <- names(carto.k0)
+                if(plot) color <- RColorBrewer::brewer.pal(k+2,"Blues")
 
-    if(plot) color <- RColorBrewer::brewer.pal(k+2,"Blues")
+                for(i in 1:D){
+                        aux.carto <- carto.group$geometry[i]
 
-    for(i in 1:D){
-      if(plot) plot(carto.k0[[i]]$geometry, col="lightgrey", main=sort(unique(Data[,ID.group]))[i],
-                    xlim=sf::st_bbox(carto.group$geometry[i])[c(1,3)]*c(0.99,1.01),
-                    ylim=sf::st_bbox(carto.group$geometry[i])[c(2,4)]*c(0.99,1.01))
+                        for(j in 1:k){
+                                # loc <- sf::st_intersects(aux.carto, carto[,"geometry"])
+                                # carto.k[[i]] <- merge(carto, data.frame(loc=unlist(loc)), by.x="temp", by.y="loc")
+                                loc <- geos::geos_prepared_intersects(aux.carto, carto[,"geometry"])
+                                carto.k[[i]] <- carto[loc,]
+                                rownames(carto.k[[i]]) <- NULL
 
-      aux.temp <- carto.k0[[i]]$temp
-      aux.carto <- carto.group$geometry[i]
+                                if(plot){
+                                        plot(carto.k[[i]]$geometry, col=color[j+2], main=sort(unique(Data[,ID.group]))[i],
+                                             xlim=sf::st_bbox(carto.group$geometry[i])[c(1,3)]*c(0.99,1.01),
+                                             ylim=sf::st_bbox(carto.group$geometry[i])[c(2,4)]*c(0.99,1.01))
 
-      for(j in 1:k){
-        loc <- sf::st_intersects(aux.carto, carto[,"geometry"])
-        carto.k[[i]] <- merge(carto, data.frame(loc=unlist(loc)), by.x="temp", by.y="loc")
+                                        plot(carto.k0[[i]]$geometry, col=color[1], add=TRUE)
+                                }
 
-        if(plot) plot(carto.k[[i]]$geometry[!(carto.k[[i]]$temp %in% aux.temp)], col=color[j+2], add=TRUE)
-        aux.temp <- carto.k[[i]]$temp
-        aux.carto <- sf::st_union(carto.k[[i]])
-      }
-      carto.k[[i]]$temp <- NULL
-    }
+                                aux.carto <- sf::st_union(carto.k[[i]])
+                        }
+                }
 
-    return(carto.k)
-  }
+                return(carto.k)
+        }
 }
diff --git a/README.md b/README.md
@@ -91,6 +91,10 @@ When using this package, please cite the following papers:
 ```
 news(package="bigDM")
 ```
+__Changes in version 0.5.3__ (2023 Sep 08)
+* small bugs fixed
+* faster implementation of `divide_carto()` function
+
 __Changes in version 0.5.2__ (2023 Jun 14)
 * changes in `mergeINLA()` function
 * 'X' argument included to `STCAR_INLA()` function