Merge pull request #21 from inbo/inla_poisson

use single class for inla models
inbo · Mar 15, 2019 · ce66051 · ce66051
2 parents cf4caff + 9a6539b
commit ce66051
Show file tree

Hide file tree

Showing 85 changed files with 2,273 additions and 2,161 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: n2kanalysis
 Title: Generic Functions to Analyse Data from the Natura 2000 Monitoring
-Version: 0.2.4.4
-Date: 2018-09-23
+Version: 0.2.6
+Date: 2019-03-13
 Authors@R: c(
   person(
     "Thierry", "Onkelinx", role = c("aut", "cre"), 
@@ -17,6 +17,7 @@ Depends:
 License: GPL-3
 LazyData: true
 Suggests:
+    littler,
     Matrix,
     optimx,
     parallel,
@@ -53,7 +54,7 @@ Collate:
     'import_S3_classes.R'
     'delete_model.R'
     'n2kModel_class.R'
-    'n2kInlaNbinomial_class.R'
+    'n2kInla_class.R'
     'extract.R'
     'fit_every_model.R'
     'fit_model.R'
@@ -64,9 +65,9 @@ Collate:
     'fit_model_n2kComposite.R'
     'n2kGlmerPoisson_class.R'
     'fit_model_n2kGlmerPoisson.R'
+    'fit_model_n2kInla.R'
     'n2kInlaComparison_class.R'
     'fit_model_n2kInlaComparison.R'
-    'fit_model_n2kInlaNbinomial.R'
     'n2kLrtGlmer_class.R'
     'fit_model_n2kLrtGlmer.R'
     'n2kManifest_class.R'
@@ -78,7 +79,7 @@ Collate:
     'get_analysis_version.R'
     'get_anomaly.R'
     'get_anomaly_n2kGlmerPoisson.R'
-    'get_anomaly_n2kInlaNbinomial.R'
+    'get_anomaly_n2kInla.R'
     'get_anomaly_n2kModel.R'
     'get_data.R'
     'get_file_fingerprint.R'
@@ -89,15 +90,15 @@ Collate:
     'get_model_parameter_n2kAggregated.R'
     'get_model_parameter_n2kComposite.R'
     'get_model_parameter_n2kGlmerPoisson.R'
+    'get_model_parameter_n2kInla.R'
     'get_model_parameter_n2kInlaComparison.R'
-    'get_model_parameter_n2kInlaNbinomial.R'
     'get_model_parameter_n2kLrtGlmer.R'
     'get_model_parameter_n2kModelImputed.R'
     'get_model_type.R'
     'get_parents.R'
     'get_result.R'
     'get_result_character.R'
-    'get_result_n2kInlaNbinomial.R'
+    'get_result_n2kInla.R'
     'get_result_n2kModel.R'
     'get_result_s3_object.R'
     'get_scheme_id.R'
@@ -111,8 +112,8 @@ Collate:
     'n2k_composite.R'
     'n2k_glmer_poisson.R'
     'n2k_import.R'
+    'n2k_inla.R'
     'n2k_inla_comparison.R'
-    'n2k_inla_nbinomial.R'
     'n2k_lrt_glmer.R'
     'n2k_manifest.R'
     'n2k_model_imputed.R'
@@ -130,4 +131,6 @@ Collate:
     'store_model.R'
     'union.R'
     'validOject.R'
-RoxygenNote: 6.0.1
+Encoding: UTF-8
+RoxygenNote: 6.1.0
+Roxygen: list(markdown = TRUE)
diff --git a/NAMESPACE b/NAMESPACE
@@ -21,8 +21,8 @@ exportClasses(n2kComposite)
 exportClasses(n2kContrast)
 exportClasses(n2kGlmerPoisson)
 exportClasses(n2kImport)
+exportClasses(n2kInla)
 exportClasses(n2kInlaComparison)
-exportClasses(n2kInlaNbinomial)
 exportClasses(n2kLrtGlmer)
 exportClasses(n2kManifest)
 exportClasses(n2kModel)
@@ -54,8 +54,8 @@ exportMethods(n2k_aggregate)
 exportMethods(n2k_composite)
 exportMethods(n2k_glmer_poisson)
 exportMethods(n2k_import)
+exportMethods(n2k_inla)
 exportMethods(n2k_inla_comparison)
-exportMethods(n2k_inla_nbinomial)
 exportMethods(n2k_lrt_glmer)
 exportMethods(n2k_manifest)
 exportMethods(n2k_model_imputed)
@@ -74,6 +74,8 @@ importClassesFrom(multimput,inla)
 importClassesFrom(multimput,rawImputed)
 importFrom(INLA,inla)
 importFrom(INLA,inla.emarginal)
+importFrom(INLA,inla.make.lincombs)
+importFrom(INLA,inla.models)
 importFrom(INLA,inla.qmarginal)
 importFrom(INLA,inla.tmarginal)
 importFrom(MASS,glm.nb)
@@ -88,6 +90,7 @@ importFrom(assertthat,is.string)
 importFrom(assertthat,is.time)
 importFrom(assertthat,noNA)
 importFrom(aws.s3,bucket_exists)
+importFrom(aws.s3,copy_object)
 importFrom(aws.s3,delete_object)
 importFrom(aws.s3,get_bucket)
 importFrom(aws.s3,s3readRDS)
@@ -105,21 +108,27 @@ importFrom(dplyr,data_frame)
 importFrom(dplyr,desc)
 importFrom(dplyr,distinct)
 importFrom(dplyr,distinct_)
+importFrom(dplyr,filter)
 importFrom(dplyr,filter_)
 importFrom(dplyr,funs)
-importFrom(dplyr,group_by_)
+importFrom(dplyr,group_by)
 importFrom(dplyr,inner_join)
 importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
 importFrom(dplyr,mutate_)
 importFrom(dplyr,mutate_all)
-importFrom(dplyr,rename_)
+importFrom(dplyr,n)
+importFrom(dplyr,n_distinct)
+importFrom(dplyr,pull)
+importFrom(dplyr,rename)
 importFrom(dplyr,rowwise)
 importFrom(dplyr,select)
 importFrom(dplyr,select_)
 importFrom(dplyr,semi_join)
+importFrom(dplyr,slice)
 importFrom(dplyr,slice_)
-importFrom(dplyr,summarise_)
+importFrom(dplyr,summarise)
+importFrom(dplyr,tibble)
 importFrom(dplyr,transmute)
 importFrom(dplyr,transmute_)
 importFrom(dplyr,ungroup)
@@ -146,8 +155,13 @@ importFrom(n2khelper,check_single_probability)
 importFrom(n2khelper,is.chartor)
 importFrom(n2khelper,read_object_environment)
 importFrom(purrr,map)
+importFrom(purrr,map2_chr)
+importFrom(purrr,map_chr)
+importFrom(purrr,map_df)
 importFrom(purrr,map_lgl)
 importFrom(purrr,pmap_chr)
+importFrom(purrr,walk)
+importFrom(rlang,"!!")
 importFrom(rlang,.data)
 importFrom(stats,anova)
 importFrom(stats,as.formula)
@@ -160,8 +174,10 @@ importFrom(stats,quantile)
 importFrom(stats,terms)
 importFrom(tibble,rowid_to_column)
 importFrom(tibble,rownames_to_column)
+importFrom(tibble,tibble)
 importFrom(tidyr,gather_)
 importFrom(utils,file_test)
+importFrom(utils,flush.console)
 importFrom(utils,head)
 importFrom(utils,read.table)
 importFrom(utils,sessionInfo)

diff --git a/R/extract.R b/R/extract.R
@@ -52,12 +52,12 @@ setMethod(
 )
 
 #' @rdname extract
-#' @aliases extract,n2kInlaNbinomial-methods
+#' @aliases extract,n2kInla-methods
 #' @importFrom methods setMethod new
-#' @include n2kInlaNbinomial_class.R
+#' @include n2kInla_class.R
 setMethod(
   f = "extract",
-  signature = signature(object = "n2kInlaNbinomial"),
+  signature = signature(object = "n2kInla"),
   definition = function(extractor, object, base = NULL, project = NULL){
     assert_that(inherits(extractor, "function"))
     extractor(object@Model)

diff --git a/R/fit_model_character.R b/R/fit_model_character.R
@@ -2,66 +2,62 @@
 #' @importFrom methods setMethod new
 #' @importFrom assertthat assert_that is.flag noNA
 #' @importFrom aws.s3 get_bucket
-#' @details
-#' \describe{
-#'  \item{\code{status}}{A vector with status levels naming the levels which should be recalculated. Defaults to \code{"new"}}
-#'  \item{\code{verbose}}{A logical indicating if the function should display the name of the file and the status. Defaults to \code{TRUE}}
-#' }
+#' @param base the root of a project. Can be either a directory on a file system or an AWS S3 bucket object. Extracted from `bucket` or `x` when missing.
+#' @param project the subdirectory of the project. Is relative the `base`. Extracted from `x` when missing.
+#' @param status A vector with status levels naming the levels which should be calculated. Defaults to `"new"`.
+#' @param verbose A logical indicating if the function should display the name of the file and the status. Defaults to `TRUE`.
+#' @param bucket the name of the AWS S3 bucket. Only used when `base` is missing.
 setMethod(
   f = "fit_model",
   signature = signature(x = "character"),
-  definition = function(x, ...){
+  definition = function(
+    x, base, project, status = c("new", "waiting"), verbose = TRUE, ..., bucket
+  ){
     assert_that(is.string(x))
-    dots <- list(...)
-    if (is.null(dots$verbose)) {
-      dots$verbose <- TRUE
+    assert_that(is.flag(verbose))
+    if (isTRUE(verbose)) {
+      message(x)
+    }
+    manifest <- grepl("\\.manifest$", x)
+    if (manifest) {
+      pattern <- "(.*\\/)?(.*)\\/+manifest\\/([[:xdigit:]]{40})\\.manifest"
     } else {
-      assert_that(is.flag(dots$verbose))
-      assert_that(noNA(dots$verbose))
+      pattern <-
+        "(.*\\/)?(.*)\\/+[[:xdigit:]]{4}\\/.*\\/([[:xdigit:]]{40})\\.rds$"
     }
-    if (dots$verbose) {
-      message(x)
+    if (missing(project)) {
+      project <- gsub(pattern = pattern, replacement = "\\2", x = x)
     }
-    if (is.null(dots$base)) {
-      if (is.null(dots$bucket)) {
-        dots$base <- gsub(
-          pattern = "(.*)/(.*)/.*/[[:xdigit:]]{40}\\.(rds|manifest)",
-          replacement = "\\1",
-          x = x
-        )
+    if (missing(base)) {
+      if (missing(bucket)) {
+        base <- gsub(pattern = pattern, replacement = "\\1", x = x) %>%
+          gsub(pattern = "\\/$", replacement = "")
       } else {
-        dots$base <- get_bucket(dots$bucket)
+        base <- get_bucket(bucket, prefix = project, max = 1)
       }
     }
-    if (is.null(dots$project)) {
-      dots$project <- gsub(
-        pattern = "(.*)/(.*)/.*/[[:xdigit:]]{40}\\.(rds|manifest)",
-        replacement = "\\2",
-        x = x
-      )
-    }
-    hash <- gsub("(.*/)?([[:xdigit:]]{40})\\.(rds|manifest)", "\\2", x)
-    if (grepl("\\.manifest$", x)) {
-      read_manifest(hash, base = dots$base, project = dots$project) %>%
-        fit_model(base = dots$base, project = dots$project, ...)
+    hash <- gsub(pattern, "\\3", x)
+    if (manifest) {
+      read_manifest(hash, base = base, project = project) %>%
+        fit_model(base = base, project = project, verbose = verbose, ...)
       return(invisible(NULL))
     }
-    analysis <- read_model(hash, base = dots$base, project = dots$project)
-    if (dots$verbose) {
+    analysis <- read_model(hash, base = base, project = project)
+    if (isTRUE(verbose)) {
       message(status(analysis), " -> ", appendLF = FALSE)
       utils::flush.console()
     }
     analysis <- fit_model(
       x = analysis,
-      status = dots$status,
-      base = dots$base,
-      project = dots$project
+      status = status,
+      base = base,
+      project = project
     )
-    if (dots$verbose) {
+    if (verbose) {
       message(status(analysis))
       utils::flush.console()
     }
-    store_model(analysis, base = dots$base, project = dots$project)
+    store_model(analysis, base = base, project = project)
     rm(analysis)
     gc(verbose = FALSE)
     return(invisible(NULL))