Skip to content

Commit

Permalink
Merge pull request #22 from inbo/bugfix
Browse files Browse the repository at this point in the history
Improvements on imputed data
  • Loading branch information
ThierryO authored Mar 29, 2019
2 parents ce66051 + 0e1ec15 commit 80e28de
Show file tree
Hide file tree
Showing 13 changed files with 161 additions and 23 deletions.
1 change: 0 additions & 1 deletion .gitignore
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
.Rproj.user
.Rhistory
.RData
*.Rproj
8 changes: 4 additions & 4 deletions DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: n2kanalysis
Title: Generic Functions to Analyse Data from the Natura 2000 Monitoring
Version: 0.2.6
Date: 2019-03-13
Version: 0.2.7
Date: 2019-03-29
Authors@R: c(
person(
"Thierry", "Onkelinx", role = c("aut", "cre"),
Expand All @@ -23,7 +23,7 @@ Suggests:
parallel,
testthat
Imports:
assertthat,
assertthat (>= 0.2.1),
aws.s3,
digest (>= 0.6.14),
dplyr,
Expand Down Expand Up @@ -132,5 +132,5 @@ Collate:
'union.R'
'validOject.R'
Encoding: UTF-8
RoxygenNote: 6.1.0
RoxygenNote: 6.1.1
Roxygen: list(markdown = TRUE)
14 changes: 13 additions & 1 deletion R/fit_model_n2kAggregate.R
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,19 @@ setMethod(
status(x) <- "error"
return(x)
}
x@RawImputed <- parent@RawImputed
if (inherits(parent, "n2kInla")) {
x@RawImputed <- parent@RawImputed
} else if (inherits(parent, "n2kAggregate")) {
x@RawImputed <- new(
"rawImputed",
Data = cbind(parent@AggregatedImputed@Covariate, Count = NA),
Response = "Count",
Minimum = "",
Imputation = parent@AggregatedImputed@Imputation
)
} else {
stop("cannot handle a parent of class ", class(parent))
}
x@AnalysisRelation$ParentStatus <- parent@AnalysisMetadata$Status
x@AnalysisRelation$ParentStatusFingerprint <-
parent@AnalysisMetadata$StatusFingerprint
Expand Down
7 changes: 6 additions & 1 deletion R/fit_model_n2kModelImputed.R
Original file line number Diff line number Diff line change
Expand Up @@ -40,12 +40,17 @@ setMethod(
status(x) <- "new"
}
sapply(x@Package, require, quietly = TRUE, character.only = TRUE)
if (length(x@PrepareModelArgs)) {
model_args <- c(x@ModelArgs, x@PrepareModelArgs[[1]](x))
} else {
model_args <- x@ModelArgs
}
model <- try(
model_impute(
object = x@AggregatedImputed,
model.fun = x@Function,
rhs = gsub("~", "", x@AnalysisMetadata$Formula),
model.args = x@ModelArgs,
model.args = model_args,
extractor = x@Extractor,
extractor.args = x@ExtractorArgs,
filter = x@Filter,
Expand Down
5 changes: 4 additions & 1 deletion R/n2kModelImputed_class.R
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@
#' \item{\code{Function}}{The object to pass to the \code{model.fun} argument of \code{\link[multimput]{model_impute}}}
#' \item{\code{Package}}{A vector of package names which must be loaded to run the function.}
#' \item{\code{ModelArgs}}{The object to pass to the \code{model.args} argument of \code{\link[multimput]{model_impute}}}
#' \item{\code{PrepareModelArgs}}{An optional list containing a single function that will be applied to the object. The result of the function will be appended to the \code{ModelsArgs}}
#' \item{\code{Extractor}}{The object to pass to the \code{extractor} argument of \code{\link[multimput]{model_impute}}}
#' \item{\code{ExtractorArgs}}{The object to pass to the \code{extractor.args} argument of \code{\link[multimput]{model_impute}}}
#' \item{\code{Filter}}{The object to pass to the \code{filter} argument of \code{\link[multimput]{model_impute}}}
Expand All @@ -27,6 +28,7 @@ setClass(
Function = "function",
Package = "character",
ModelArgs = "list",
PrepareModelArgs = "list",
Extractor = "function",
ExtractorArgs = "list",
Filter = "list",
Expand Down Expand Up @@ -58,7 +60,8 @@ setValidity(
object@AnalysisMetadata$Seed,
object@AnalysisRelation$ParentAnalysis,
object@Function, object@Filter, object@Mutate, object@ModelArgs,
object@Extractor, object@ExtractorArgs, object@Package
object@PrepareModelArgs, object@Extractor, object@ExtractorArgs,
object@Package
),
environment = FALSE
)
Expand Down
16 changes: 13 additions & 3 deletions R/n2k_model_imputed.R
Original file line number Diff line number Diff line change
Expand Up @@ -97,10 +97,19 @@ setMethod(
assert_that(is.function(dots$model.fun))
assert_that(is.function(dots$extractor))
if (is.null(dots$model.args)) {
dots$models.args <- list()
dots$model.args <- list()
} else {
assert_that(is.list(dots$model.args))
}
if (is.null(dots$prepare.model.args)) {
dots$prepare.model.args <- list()
} else {
assert_that(is.list(dots$prepare.model.args),
length(dots$prepare.model.args) <= 1)
if (length(dots$prepare.model.args)) {
assert_that(is.function(dots$prepare.model.args[[1]]))
}
}
if (is.null(dots$extractor.args)) {
dots$extractor.args <- list()
} else {
Expand All @@ -121,8 +130,8 @@ setMethod(
dots$last.imported.year, dots$duration, dots$last.analysed.year,
format(dots$analysis.date, tz = "UTC"),
dots$seed, dots$parent, dots$model.fun, dots$filter,
dots$mutate, dots$model.args, dots$extractor, dots$extractor.args,
dots$package
dots$mutate, dots$model.args, dots$prepare.model.args, dots$extractor,
dots$extractor.args, dots$package
),
environment = FALSE
)
Expand Down Expand Up @@ -187,6 +196,7 @@ setMethod(
Filter = dots$filter,
Mutate = dots$mutate,
ModelArgs = dots$model.args,
PrepareModelArgs = dots$prepare.model.args,
Extractor = dots$extractor,
ExtractorArgs = dots$extractor.args,
AggregatedImputed = NULL,
Expand Down
1 change: 1 addition & 0 deletions man/n2kModelImputed-class.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

24 changes: 24 additions & 0 deletions n2kanalysis.Rproj
Original file line number Diff line number Diff line change
@@ -0,0 +1,24 @@
Version: 1.0

RestoreWorkspace: No
SaveWorkspace: No
AlwaysSaveHistory: No

EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8

RnwWeave: knitr
LaTeX: XeLaTeX

AutoAppendNewline: Yes
StripTrailingWhitespace: Yes

BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageCheckArgs: --as-cran
PackageRoxygenize: rd,collate,namespace

QuitChildProcessesOnExit: Yes
6 changes: 3 additions & 3 deletions tests/testthat/test_aaa_n2k_manifest.R
Original file line number Diff line number Diff line change
Expand Up @@ -137,15 +137,15 @@ describe("n2k_manifest", {
it("checks the content of manifest", {
expect_error(
n2k_manifest(data.frame(junk = 1)),
"manifest does not have name Fingerprint"
"manifest does not have .*name.*Fingerprint"
)
expect_error(
n2k_manifest(data.frame(Parent = 1)),
"manifest does not have name Fingerprint"
"manifest does not have .*name.*Fingerprint"
)
expect_error(
n2k_manifest(data.frame(Fingerprint = 1)),
"manifest does not have name Parent"
"manifest does not have .*name.*Parent"
)
})

Expand Down
8 changes: 4 additions & 4 deletions tests/testthat/test_aba_n2k_glmer_poisson.R
Original file line number Diff line number Diff line change
Expand Up @@ -732,7 +732,7 @@ outside imported range."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name incidence")
throws_error("object@Data does not have .*name.*incidence")
)
expect_that(
n2k_glmer_poisson(
Expand All @@ -749,7 +749,7 @@ outside imported range."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name size")
throws_error("object@Data does not have .*name.*size")
)
expect_that(
n2k_glmer_poisson(
Expand All @@ -766,7 +766,7 @@ outside imported range."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name period")
throws_error("object@Data does not have .*name.*period")
)
expect_that(
n2k_glmer_poisson(
Expand All @@ -783,7 +783,7 @@ outside imported range."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name herd")
throws_error("object@Data does not have .*name.*herd")
)
})
})
Expand Down
8 changes: 4 additions & 4 deletions tests/testthat/test_aba_n2k_inla.R
Original file line number Diff line number Diff line change
Expand Up @@ -622,7 +622,7 @@ outside imported range\\."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name Count")
throws_error("object@Data does not have .*name.*Count")
)
expect_that(
n2k_inla(
Expand All @@ -637,7 +637,7 @@ outside imported range\\."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name A")
throws_error("object@Data does not have .*name.*A")
)
expect_that(
n2k_inla(
Expand All @@ -652,7 +652,7 @@ outside imported range\\."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name F")
throws_error("object@Data does not have .*name.*F")
)
expect_that(
n2k_inla(
Expand All @@ -667,7 +667,7 @@ outside imported range\\."
analysis.date = this.analysis.date,
scheme.id = this.scheme.id
),
throws_error("object@Data does not have name D")
throws_error("object@Data does not have .*name.*D")
)
})
})
Expand Down
2 changes: 1 addition & 1 deletion tests/testthat/test_aca_n2kanomaly.R
Original file line number Diff line number Diff line change
Expand Up @@ -133,7 +133,7 @@ expect_error(
Anomaly = cbind(anomaly, anomaly)
),
paste(
"must have.*unique name"
"must not be duplicated"
)
)
expect_error(
Expand Down
84 changes: 84 additions & 0 deletions tests/testthat/test_cba_model_impute.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,84 @@
context("model imputed")
test_that("model imputation works", {
this.result.datasource.id <- sha1(letters)
this.scheme.id <- sha1(letters)
this.species.group.id <- sha1(letters)
this.location.group.id <- sha1(letters)
this.analysis.date <- Sys.time()
this.model.type <- "inla poisson: A * (B + C) + C:D"
this.first.imported.year <- 1990L
this.last.imported.year <- 2015L
this.last.analysed.year <- 2014L
this.duration <- 1L
dataset <- test_data(missing = 0.2)
base <- tempdir()
project <- "imputation"

imputation <- n2k_inla(
data = dataset, scheme.id = this.scheme.id,
result.datasource.id = this.result.datasource.id,
species.group.id = this.species.group.id,
location.group.id = this.location.group.id, model.type = this.model.type,
first.imported.year = this.first.imported.year, imputation.size = 100,
last.imported.year = this.last.imported.year, family = "poisson",
last.analyses.year = this.last.analysed.year, duration = this.duration,
formula = "Count ~ A * (B + C) + f(E, model = \"iid\")",
analysis.date = Sys.time(),
)
aggregation <- n2k_aggregate(
scheme.id = this.scheme.id,
result.datasource.id = this.result.datasource.id, formula = "~ A + B",
species.group.id = this.species.group.id,
location.group.id = this.location.group.id, model.type = this.model.type,
first.imported.year = this.first.imported.year, analysis.date = Sys.time(),
last.imported.year = this.last.imported.year, fun = sum,
last.analyses.year = this.last.analysed.year, duration = this.duration,
parent = get_file_fingerprint(imputation)
)
aggregation2 <- n2k_aggregate(
scheme.id = this.scheme.id,
result.datasource.id = this.result.datasource.id, formula = "~ A",
species.group.id = this.species.group.id,
location.group.id = this.location.group.id, model.type = this.model.type,
first.imported.year = this.first.imported.year, analysis.date = Sys.time(),
last.imported.year = this.last.imported.year, fun = sum,
last.analyses.year = this.last.analysed.year, duration = this.duration,
parent = get_file_fingerprint(aggregation)
)
extractor <- function(model) {
model$summary.fixed[, c("mean", "sd")]
}
mi <- n2k_model_imputed(
scheme.id = this.scheme.id, model.args = list(family = "poisson"),
result.datasource.id = this.result.datasource.id, model.fun = INLA::inla,
species.group.id = this.species.group.id, extractor = extractor,
location.group.id = this.location.group.id, model.type = this.model.type,
first.imported.year = this.first.imported.year, analysis.date = Sys.time(),
last.imported.year = this.last.imported.year, formula = "~ A",
last.analyses.year = this.last.analysed.year, duration = this.duration,
parent = get_file_fingerprint(aggregation)
)
pma <- list( function(x) {
return(list(family = "poisson"))
} )
mi2 <- n2k_model_imputed(
scheme.id = this.scheme.id, model.args = list(),
result.datasource.id = this.result.datasource.id, model.fun = INLA::inla,
species.group.id = this.species.group.id, extractor = extractor,
location.group.id = this.location.group.id, model.type = this.model.type,
first.imported.year = this.first.imported.year, analysis.date = Sys.time(),
last.imported.year = this.last.imported.year, formula = "~ A",
last.analyses.year = this.last.analysed.year, duration = this.duration,
parent = get_file_fingerprint(aggregation), prepare.model.args = pma
)
store_model(imputation, base, project)
store_model(aggregation, base, project)
store_model(mi, base, project)
store_model(aggregation2, base, project)
store_model(mi2, base, project)
fit_model(get_file_fingerprint(imputation), base, project)
fit_model(get_file_fingerprint(aggregation), base, project)
fit_model(get_file_fingerprint(mi), base, project)
fit_model(get_file_fingerprint(aggregation2), base, project)
fit_model(get_file_fingerprint(mi2), base, project)
})

0 comments on commit 80e28de

Please sign in to comment.