Adding getResol() function to infer data spatial resolution

+ compatibility tweaks with the new calibration database

NEWS.md

@@ -6,6 +6,10 @@
     * Including minGridCell in the algorithm.
     * Adding a global warning if mingridcell is <15, and an error is <2.
     * The plots that require variable names function properly.
+* Minor issues:
+    * Cleaned documentation
+
+
 
 # crestr 1.3.0
 

R/crest.calibrate.R

@@ -85,7 +85,7 @@ crest.calibrate <- function(x,
     }
     x$modelling$ccs <- ccs
 
-    resol <- sort(unique(diff(sort(unique(x$modelling$climate_space[,1])))))[1] / 2.0
+    resol <- getResol(x) / 2.0
     if(x$parameters$xmn == -180) {
         x$parameters$xmn <- min(x$modelling$climate_space[, 1]) - resol
     }

R/crest.get_modern_data.R

@@ -384,7 +384,7 @@ crest.get_modern_data <- function( pse, taxaType, climate,
     crest$misc$site_info[['lat']]    <- site_info[2]
     crest$misc$site_info[['site_name']]    <- site_name
     if((!is.na(crest$misc$site_info[['long']])) & (!is.na(crest$misc$site_info[['lat']]))) {
-        resol <- ifelse(.ifExampleDB(dbname), 0.5, 0.25)
+        resol <- getResol(crest)
         crest$misc$site_info[['climate']] <- climate_from_xy(crest$misc$site_info[['long']],
                                                              crest$misc$site_info[['lat']],
                                                              crest$parameters$climate,
@@ -436,7 +436,6 @@ crest.get_modern_data <- function( pse, taxaType, climate,
 
     }
 
-
     taxonID2proxy <- data.frame("taxonID" = NA, "proxyName" = NA, stringsAsFactors = FALSE)
     pse$Level     <- as.numeric(as.character(pse$Level))
     pse$Family    <- as.character(pse$Family)
@@ -520,7 +519,6 @@ crest.get_modern_data <- function( pse, taxaType, climate,
             cat(paste0('  <> Extracting species distributions ...... ', stringr::str_pad(paste0(round(pbi / length(crest$inputs$taxa.name)),'%\r'), width=4, side='left')))
             utils::flush.console()
         }
-
         if (sum(crest$inputs$selectedTaxa[tax, climate]>=0) > 0) {
             distributions[[tax]] <- getDistribTaxa(
               taxIDs, climate=climate,
@@ -553,7 +551,7 @@ crest.get_modern_data <- function( pse, taxaType, climate,
                     message <- "Present but insufficient data in the study area to fit a pdf"
                     if (! message %in% names(crest$misc[['taxa_notes']])) {
                         crest$misc[['taxa_notes']][[message]] <- c()
-                        warning(paste0("An insufficient amount of calibration data points was available within the study area for one or more taxa. Consider reducing 'minGridCells'. Use PSE_log() with the output of this function for details."))
+                        warning(paste0("An insufficient amount of calibration data points was available within the study area for one or more taxa. Consider reducing 'minGridCells' down to 15-20. Use PSE_log() with the output of this function for details."))
                     }
                     crest$misc[['taxa_notes']][[message]] <- append(crest$misc[['taxa_notes']][[message]], tax)
                 }
@@ -654,7 +652,7 @@ crest.get_modern_data <- function( pse, taxaType, climate,
         }
     }
 
-    resol <- sort(unique(diff(sort(unique(crest$modelling$climate_space[, 1])))))[1] / 2.0
+    resol <- getResol(crest) / 2
     xx <- range(climate_space[, 1])
     if (estimate_xlim) {
         crest$parameters$xmn <- xx[1] - resol
@@ -664,7 +662,6 @@ crest.get_modern_data <- function( pse, taxaType, climate,
         if (crest$parameters$xmx < xx[2] + resol) crest$parameters$xmx <- xx[2] + resol
     }
 
-    resol <- sort(unique(diff(sort(unique(crest$modelling$climate_space[, 2])))))[1] / 2.0
     yy <- range(climate_space[, 2])
     if (estimate_ylim) {
         crest$parameters$ymn <- yy[1] - resol

R/crest.set_modern_data.R

@@ -248,7 +248,7 @@ crest.set_modern_data <- function( distributions, climate,
             if (! message %in% names(taxa_notes)) {
                 #print('in warning')
                 taxa_notes[[message]] <- c()
-                warning(paste0("An insufficient amount of calibration data points was available within the study area for one or more taxa. Consider reducing 'minGridCells'. Use PSE_log() with the output of this function for details."))
+                warning(paste0("An insufficient amount of calibration data points was available within the study area for one or more taxa. Consider reducing 'minGridCells' down to 15-20. Use PSE_log() with the output of this function for details."))
             }
             taxa_notes[[message]] <- append(taxa_notes[[message]], tax)
 

R/dbGetClimateXY.R

@@ -44,7 +44,7 @@ climate_from_xy <- function(long, lat,
     req <- paste0(
       "  SELECT DISTINCT ", paste(climate, collapse=', '),
       "    FROM data_qdgc ",
-      "   WHERE longitude = ", long, " AND latitude = ", lat
+      "   WHERE locid = ", f_locid(long, lat, resol)
     )
 
     res <- dbRequest(req, dbname)

R/dbGetDistribTaxa.R

@@ -30,7 +30,7 @@ getDistribTaxa <- function(taxIDs,
                            realms = NA, biomes = NA, ecoregions = NA,
                            elev_min = NA, elev_max = NA, elev_range = NA,
                            year_min = 1900, year_max = 2021, nodate = TRUE,
-                           type_of_obs = c(1, 2, 3, 8, 9),
+                           type_of_obs = c(1, 2, 7, 8),
                            dbname = "gbif4crest_02") {
 
     if(base::missing(taxIDs)) taxIDs

R/plot.climateSpace.R

@@ -48,7 +48,7 @@ plot_climateSpace <- function( x,
                       width=  7.48,
                       height = min(9, 3.5*length(climate)), y0 = 0.4,
                       add_modern = FALSE,
-                      resol = 0.25
+                      resol = getResol(x)
                       ) {
 
     if(base::missing(x)) x
@@ -223,7 +223,7 @@ plot_climateSpace <- function( x,
 
                 graphics::par(mar=c(0,0,0,0), ps=8*3/2)
                 plot(NA, NA, type='n', xlab='', ylab='', main='', axes=FALSE, frame=FALSE, xlim=xlim, ylim=c(0,0.8), xaxs='i', yaxs='i')
-                graphics::text(mean(c(minx, maxx)),0.15, paste(climate[clim], '(x-axis) vs.', climate[clim+1], '(y-axis)'), adj=c(0.5,0), cex=1, font=1)
+                graphics::text(mean(c(minx, maxx)),0.15, paste(climate[clim], '(x) vs.', climate[clim+1], '(y)'), adj=c(0.5,0), cex=1, font=1)
 
                 graphics::par(mar=c(0,0.2,0,0.2))
                 plot(NA, NA, type='n', xaxs='i', yaxs='i', axes=FALSE, frame=FALSE,
@@ -276,7 +276,7 @@ plot_climateSpace <- function( x,
             plot_map_eqearth(R1, ext, zlim=range(brks), col=viridis::viridis(length(brks)-1),
                             brks.pos = brks, brks.lab = brks,
                             title=accClimateVariables(clim)[3], site_xy = site_xy,
-                            dim=c(x1*width / sum(c(x1,x2,x1)), height / length(climate))
+                            dim=c(x1*width / sum(c(x1,x2,x1)), (height - length(climate)*y0) / length(climate))
             )
         }
 

R/plot.scatterPDFS.R

@@ -153,7 +153,6 @@ plot_scatterPDFs <- function( x,
 
             if(add_modern) {
                 if(is.numeric(x$misc$site_info$climate[, climate[1]])) {
-                    print(x$misc$site_info$climate)
                     graphics::points(x$misc$site_info$climate[, climate[1]], x$misc$site_info$climate[, climate[2]], pch=24, col=NA, bg='red', cex=1.5, lwd=1.5)
                 }
             }

R/plot.speciesCharacteristics.R

@@ -56,7 +56,7 @@ plot_taxaCharacteristics <- function( x, taxanames = x$inputs$taxa.name,
                                       width = 7.48, w0 = 0.2,
                                       height = 3*length(climate)+h0, h0 = 0.4,
                                       add_modern = FALSE,
-                                      resol = 0.25
+                                      resol = getResol(x)
                                       ) {
 
     if(base::missing(x)) x

R/plot.violinPDFS.R

@@ -133,7 +133,6 @@ plot_violinPDFs <- function( x,
             graphics::polygon(c(max_pdf[2*i-1] - x$modelling$pdfs[[taxanames[optima[i]]]][[climate]]$pdfpol / max_abs, rev(max_pdf[2*i-1] + x$modelling$pdfs[[taxanames[optima[i]]]][[climate]]$pdfpol / max_abs)),
                               c(x$modelling$xrange[[climate]], rev(x$modelling$xrange[[climate]])), col=col[i], border='grey80', lwd=0.5)
             graphics::text(max_pdf[2*i-1] - xstep, ylim[1] + ystep, taxanames[optima[i]], srt=90, adj=c(0,0), font=2)
-
         }
 
         graphics::par(las=0)

R/utils.R

@@ -295,12 +295,11 @@ crop <- function(x, shp) {
             }
         }
 
-        resol <- sort(unique(diff(sort(unique(x$modelling$climate_space[, 1])))))[1] / 2.0
+        resol <- getResol(x) / 2.0
         xx <- range(x$modelling$climate_space[, 1])
         x$parameters$xmn <- xx[1] - resol
         x$parameters$xmx <- xx[2] + resol
 
-        resol <- sort(unique(diff(sort(unique(x$modelling$climate_space[, 2])))))[1] / 2.0
         yy <- range(x$modelling$climate_space[, 2])
         x$parameters$ymn <- yy[1] - resol
         x$parameters$ymx <- yy[2] + resol
@@ -445,11 +444,50 @@ crest.simplify <- function(x, optima=TRUE) {
     return(df)
 }
 
-.onAttach <- function(libname, pkgname) {
-  packageStartupMessage('\nIMPORTANT: From May 2024, the cloud-based gbif4crest calibration\ndatabase will be taken down. The database will remain accessible\nthrough the dbDownload() function.\n\n')
-}
+#.onAttach <- function(libname, pkgname) {
+#  packageStartupMessage('\nIMPORTANT: From May 2024, the cloud-based gbif4crest calibration\ndatabase will be taken down. The database will remain accessible\nthrough the dbDownload() function.\n\n')
+#}
 
 #.onLoad <- function(libname, pkgname){
 #    msg <-
 #    cat(msg)
 #}
+
+
+
+#' Calculates a unique identifier from coordinates.
+#'
+#' Calculates a unique identifier from coordinates.
+#'
+#' @param long The longitude of the grid cell of interest
+#' @param lat The latitude of the grid cell of interest
+#' @param resol The spatial resolution of the database to target (1/12 for gbif4crest_03)
+#' @return A unique integer describing the cell.
+#' @export
+#' @examples
+#' f_locid(0, 0, 1/12)
+#'
+f_locid <- function(long, lat, resol) {
+    if(long >= 180) long = 180 - resol/2
+    if(lat >= 90) lat = 90 - resol/2
+    return(((180 + long) %/% resol)%/%1 + 360 / resol * ((90 + lat) %/% resol)%/%1)
+}
+
+
+#' Calculates a unique identifier from coordinates.
+#'
+#' Calculates a unique identifier from coordinates.
+#'
+#' @param crest A crestObj object.
+#' @return A unique integer describing the cell.
+#' @export
+#' @examples
+#' getResol(reconstr)
+#'
+getResol <- function(crest) {
+    if(.ifExampleDB(crest$misc$dbname)) return(0.5)
+    res = dbRequest("SELECT * FROM sqlite_master WHERE type='table'", dbname=crest$misc$dbname)
+    if( 'params' %in% res[,2] ) return(1/12)
+    if(grepl('gbif4crest_02-5m', crest$misc$dbname, fixed = TRUE)) return(1/12)
+    return(1/4)
+}