Merge branch 'dev'

Author: Doug Leasure

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: wopr
 Title: An R Package to access the WorldPop Open Population Repository (WOPR)
 Description: Provides access to the WorldPop Open Population Repository (WOPR) data catalogue and population estimates for specific locations via REST API.
-Version: 0.3.2
-Date: 2020-05-27
+Version: 0.3.3
+Date: 2020-06-11
 Author: Douglas R Leasure, Maksym Bondarenko, Andrew J Tatem
 Maintainer: Doug Leasure <D.R.Leasure@soton.ac.uk>
 License: GNU GPLv3

NAMESPACE

@@ -14,6 +14,7 @@ export(map)
 export(mapProxyFile)
 export(mapProxyMarker)
 export(mapProxyPoly)
+export(parseFilename)
 export(plotPanel)
 export(plotPop)
 export(plotPyramid)

R/checkLocal.R

@@ -6,26 +6,32 @@
 
 checkLocal <- function(dir, info=wopr:::woprVision_global$version_info){
 
-  info$local_sql <- info$local_tiles <- FALSE
+  info$local_sql <- info$local_tiles <- info$local_mastergrid <- FALSE
 
   if(dir.exists(dir)){
     for(i in 1:nrow(info)){
 
       path <- file.path(dir,info$country[i],'population',info$version[i])
 
-      prefix <- paste0(info$country[i],
-                       '_population_',
-                       gsub('.','_',as.character(info$version[i]), fixed=T),'_')
-      
-      sql_path <- paste0(file.path(path, prefix),'sql.sql')
-      mastergrid_path <- paste0(file.path(path,prefix),'mastergrid.tif')
-      tile_path <- paste0(file.path(path, prefix), 'tiles')
-      
-      if(file.exists(sql_path) & file.exists(mastergrid_path)) {
-        info[i,'local_sql'] <- TRUE}
-      if(dir.exists(tile_path)){
-        info[i,'local_tiles'] <- TRUE}
+      if(dir.exists(path)){
+        
+        parsed <- parseFilename(list.files(path))
+        
+        if(any(parsed$file_type=='sql') & any(parsed$file_type=='mastergrid')){
+          info[i,'local_sql'] <- TRUE
+          info[i,'local_sql_path'] <- file.path(path, parsed[which(parsed$file_type=='sql'),'filename'])
+          info[i,'local_mastergrid_path'] <- file.path(path, parsed[which(parsed$file_type=='mastergrid'),'filename'])
+        }
+        
+        if(any(parsed$file_type=='tiles' & parsed$file_extension=='')){
+          info[i,'local_tiles'] <- TRUE
+          info[i,'local_tiles_path'] <- file.path(path, parsed[which(parsed$file_type=='tiles' & parsed$file_extension==''),'filename'])
+        } else if(any(parsed$file_type=='tiles' & parsed$file_extension=='zip')){
+          warning(paste('Tiles for',info$country[i],info$version[i],'still need to be unzipped.'), call.=F)
+        }
+      }
     }
   }
+  
   return(info)
-}
+}

R/map.R

@@ -50,7 +50,7 @@ map <- function(country, version, local_tiles=F, southern=F,
     addLegend(position='bottomright',
               pal=pal,
               values=bins,
-              title='People per grid cell',
+              title='People per grid cell<br>(all age-sex groups)',
               opacity=1,
               group='Population') %>%
 

R/parseFilename.R

@@ -0,0 +1,70 @@
+#' Parse WOPR file names
+#' @description Parse WOPR file names to return the country, category, version, file type, optional info, and the file extension.
+#' @param filenames character vector. WOPR file name.
+#' @return data.frame. Table of results.
+#' @export
+
+parseFilename <- function(filenames){
+  
+  if(length(filenames)==0) {
+    result <- NA
+  } else {
+    result <- data.frame(filename=filenames,
+                         country = NA,
+                         category = NA,
+                         version_major = NA,
+                         version_minor = NA,
+                         version_patch = NA,
+                         file_type = NA,
+                         file_optional = NA,
+                         file_extension = NA
+    )
+    
+    
+    testNumeric <- function(y){
+      !is.na(suppressWarnings(as.numeric(y)))
+    }
+    
+    for(i in 1:nrow(result)){
+      
+      x_split <- unlist(strsplit(filenames[i], '_'))
+      
+      result[i,'country'] <- x_split[1]
+      result[i,'category'] <- x_split[2]
+      result[i,'version_major'] <- as.numeric(gsub('v','',unlist(strsplit(x_split[3], '-'))[1]))
+      
+      # version format x-y-z
+      if(grepl('-',x_split[3])){
+        x3_split <- unlist(strsplit(x_split[3], '-'))
+        result[i,'version_minor'] <- x3_split[2]
+        if(length(x3_split) > 2){
+          result[i,'version_patch'] <- x3_split[3]
+        } else {
+          result[i,'version_patch'] <- 0
+        }
+        
+      } else {
+        result[i,'version_minor'] <- as.numeric(tools::file_path_sans_ext(x_split[4]))
+        if(testNumeric(x_split[5])){
+          result[i,'version_patch'] <- as.numeric(x_split[5])
+        } else {
+          result[i,'version_patch'] <- 0
+        }
+      }
+      
+      n <- length(x_split)
+      if(testNumeric(tools::file_path_sans_ext(x_split[n]))){
+        result[i,'file_extension'] <- tools::file_ext(x_split[n])
+      } else if(n==4 | testNumeric(x_split[n-1])){
+        result[i,'file_type'] <- tools::file_path_sans_ext(x_split[n])
+        result[i,'file_extension'] <- tools::file_ext(x_split[n])
+      } else {
+        result[i,'file_type'] <- x_split[n-1]
+        result[i,'file_optional'] <- tools::file_path_sans_ext(x_split[n])
+        result[i,'file_extension'] <- tools::file_ext(x_split[n])
+      }
+    }
+  }
+  
+  return(result)
+}

R/plotPop.R

@@ -8,10 +8,11 @@
 
 plotPop <- function(N, confidence=95, tails='Interval', popthresh=100){
 
-  s <- summaryPop(N=N, 
-                  confidence=confidence/100, 
-                  tails=ifelse(tails=='Interval',2,1), 
-                  abovethresh=popthresh)
+  s <- summaryPop(N = N, 
+                  confidence = confidence/100, 
+                  tails = ifelse(tails=='Interval',2,1), 
+                  abovethresh = popthresh,
+                  round_result = FALSE)
 
   # plot margins
   par(mar=c(4.5,1,4.5,0.5))
@@ -50,8 +51,19 @@ plotPop <- function(N, confidence=95, tails='Interval', popthresh=100){
       s$lower <- 0
     }
 
-    ilow <- min(which(d$x >= s$lower))
-    iup <- max(which(d$x <= s$upper))
+    # ilow <- min(which(d$x >= s$lower))
+    # iup <- max(which(d$x <= s$upper)) 
+    
+    if(any(d$x >= s$lower)){
+      ilow <- min(which(d$x >= s$lower))
+    } else{
+      ilow <- 1
+    }
+    if(any(d$x <= s$upper)){
+      iup <- max(which(d$x <= s$upper)) 
+    } else{
+      iup <- nrow(d)
+    }
 
     dsub <- d[ilow:iup,]
     dsub <- rbind(data.frame(x=rep(s$lower,2), 
@@ -94,34 +106,40 @@ plotPop <- function(N, confidence=95, tails='Interval', popthresh=100){
 
   if(is.numeric(N)){
 
+    # data
+    pop_mean <- ifelse(s$mean > 5, round(s$mean), round(s$mean,1))
+    pop_lower <- ifelse(s$mean > 5, round(s$lower), round(s$lower,1))
+    pop_upper <- ifelse(s$mean > 5, round(s$upper), round(s$upper,1))
+    pop_abovethresh <- round(s$abovethresh*100)
+    
     # Main title
     line <- 3
-    mtext(paste0('Population Estimate: ',prettyNum(s$mean,big.mark=','),' people'),
+    mtext(paste0('Population Estimate: ',prettyNum(pop_mean,big.mark=','),' people'),
           line=line, cex=1.5)
 
     # Sub title A
     line <- 1.5
     cex <- 1.25
     if(tails=='Interval'){
 
-      mtext(paste0(round(confidence),'% probability: ', prettyNum(s$lower,big.mark=','),' - ', prettyNum(s$upper, big.mark=','),' people'), 
+      mtext(paste0(round(confidence),'% probability: ', prettyNum(pop_lower,big.mark=','),' - ', prettyNum(pop_upper, big.mark=','),' people'), 
             line=line, cex=cex)
 
     } else if(tails=='Lower Limit'){
 
-      mtext(paste0(round(confidence),'% probability: > ', prettyNum(s$lower,big.mark=','), ' people'), 
+      mtext(paste0(round(confidence),'% probability: > ', prettyNum(pop_lower,big.mark=','), ' people'), 
             line=line, cex=cex)
 
     } else if(tails=='Upper Limit'){
 
-      mtext(paste0(round(confidence),'% probability: < ', prettyNum(s$upper,big.mark=','),' people'), 
+      mtext(paste0(round(confidence),'% probability: < ', prettyNum(pop_upper,big.mark=','),' people'), 
             line=line, cex=cex)
     }
 
     # Sub title B
     if(is.numeric(popthresh)){
       line <- 0.25
-      mtext(paste0(round(s$abovethresh*100),'% probability: > ', prettyNum(popthresh,big.mark=','), ' people (threshold)'),
+      mtext(paste0(pop_abovethresh,'% probability: > ', prettyNum(popthresh,big.mark=','), ' people (threshold)'),
             line=line, cex=cex)
     }
   }

R/resultTable.R

@@ -6,16 +6,11 @@
 
 resultTable <- function(inp, rval){
 
-  if(inp$pointpoly=='Upload File'){
-    woprized <- T
-    s <- sf::st_drop_geometry(rval$feature)
-  } else {
-    woprized <- F
-    s <- summaryPop(N=rval$N, 
-                    confidence=inp$ci_level/100, 
-                    tails=ifelse(inp$ci_type=='Interval',2,1), 
-                    abovethresh=inp$popthresh)
-  }
+  s <- summaryPop(N = rval$N, 
+                  confidence = inp$ci_level/100, 
+                  tails = ifelse(inp$ci_type=='Interval',2,1), 
+                  abovethresh = inp$popthresh,
+                  round_result = FALSE)
 
   names.result <- c('name','data','mode',
                     'pop','pop_lower','pop_upper','abovethresh','popthresh',
@@ -24,12 +19,8 @@ resultTable <- function(inp, rval){
   result <- data.frame(matrix(NA, nrow=nrow(s), ncol=length(names.result)))
   names(result) <- names.result
 
-  if(woprized){
-    result$name <- paste0('location_',1:nrow(result))
-  } else {
-    result$name <- inp$save_name
-  }
-  
+  result$name <- inp$save_name
+
   result$data <- inp$data_select
   result$mode <- inp$pointpoly
   result$popthresh <- inp$popthresh
@@ -78,17 +69,6 @@ resultTable <- function(inp, rval){
     result$male_age <- ''
   }
 
-  if(inp$ci_type=='Interval'){
-    result$pop_lower <- s$lower
-    result$pop_upper <- s$upper
-  } else if(inp$ci_type=='Upper Limit'){
-    result$pop_lower <- NA
-    result$pop_upper <- s$upper
-  } else if(inp$ci_type=='Lower Limit'){
-    result$pop_lower <- s$lower
-    result$pop_upper <- NA
-  }
-
   for(i in 1:nrow(result)){
     result[i,'pop'] <- s[i,'mean']
     result[i,'pop_lower'] <- s[i,'lower']
@@ -97,9 +77,21 @@ resultTable <- function(inp, rval){
 
     result[i,'geojson'] <- as.character(geojsonio::geojson_json(rval$feature[i,]))
   }
-  result$pop <- as.integer(round(result$pop))
-  result$pop_lower <- as.integer(round(result$pop_lower))
-  result$pop_upper <- as.integer(round(result$pop_upper))
 
+  if(inp$ci_type=='Upper Limit'){
+    result$pop_lower <- NA
+  } else if(inp$ci_type=='Lower Limit'){
+    result$pop_upper <- NA
+  }
+  
+  result$pop <- ifelse(s$mean > 5, 
+                       as.integer(round(result$pop)), 
+                       round(result$pop,3))
+  result$pop_lower <- ifelse(s$mean > 5, 
+                             as.integer(round(result$pop_lower)), 
+                             round(result$pop_lower,3))
+  result$pop_upper <- ifelse(s$mean > 5, 
+                             as.integer(round(result$pop_upper)), 
+                             round(result$pop_upper,3))
   return(result)
 }

R/summaryPop.R

@@ -1,17 +1,18 @@
 #' Summary statistics
 #' @description Summarize predicted posterior probability distribution for population estimates
-#' @param N Vector of posterior samples for the population total
-#' @param confidence The confidence level for the confidence intervals (e.g. 0.95 = 95 percent confidence intervals)
-#' @param tails The number of tails for the confidence intervals
-#' @param belowthresh The function will return the probability that the population size is less than _belowthresh_
-#' @param abovethresh The function will return the probability that the population size exceeds _abovethresh_
+#' @param N numeric vector. Vector of posterior samples for the population total
+#' @param confidence numeric. The confidence level for the confidence intervals (e.g. 0.95 = 95 percent confidence intervals)
+#' @param tails integer. The number of tails for the confidence intervals
+#' @param belowthresh numeric. The function will return the probability that the population size is less than _belowthresh_
+#' @param abovethresh numeric. The function will return the probability that the population size exceeds _abovethresh_
+#' @param round_result logical. If TRUE the results will be rounded to a pre-determined number of digits for each column.
 #' @return A data.frame with columns containing the mean, median, lower and upper confidence intervals for the estimated population total. 
 #' The 'abovethresh' column reports the probability that the population is greater than _abovethresh_. 
 #' The 'belowthresh' column reports the probability that the population is less than _abovethresh_.
 #' Note: One minus 'abovethresh' is the probability that the population is equal to or less than _abovethresh_.
 #' @export
 
-summaryPop <- function(N, confidence=0.95, tails=2, belowthresh=NA, abovethresh=NA){
+summaryPop <- function(N, confidence=0.95, tails=2, belowthresh=NA, abovethresh=NA, round_result=F){
 
   N <- as.numeric(N)
 
@@ -29,8 +30,10 @@ summaryPop <- function(N, confidence=0.95, tails=2, belowthresh=NA, abovethresh=
   round0_cols <- c('mean','median','lower','upper')
   round3_cols <- c('abovethresh', 'belowthresh')
 
-  result[,round0_cols] <- as.integer(round(result[,round0_cols]))
-  result[,round3_cols] <- round(result[,round3_cols], 3)
+  if(round_result){
+    result[,round0_cols] <- as.integer(round(result[,round0_cols]))
+    result[,round3_cols] <- round(result[,round3_cols], 3)
+  }
 
   return(result)
 }

R/sysdata.rda

@@ -1,6 +1,6 @@
 #' Write WOPR catalogue
 #' @description Creates a catalogue of the WOPR data currently in the output directory.
-#' @param outdir Output folder where data from the WorldPop GridFree catalogue are stored
+#' @param outdir Output folder where data from the WOPR catalogue are stored
 #' @return Writes an updated data catalogue to disk as a .csv file.
 #' @export