Skip to content

Commit

Permalink
Merge pull request #22 from SticsRPacks/Fix-weight-test
Browse files Browse the repository at this point in the history 
Fix weight test
  • Loading branch information
@sbuis
sbuis authored Aug 30, 2024
2 parents a580367 + 6f8037d commit 8283f4d
Show file tree
Hide file tree
Showing 4 changed files with 27 additions and 57 deletions.
7 changes: 6 additions & 1 deletion R/ls_criteria.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -121,7 +121,12 @@ crit_wls <- function(sim_list, obs_list, weight) {
if (any(sigma==0)) {
stop(paste("Error in crit_wls: weight is zero for variable",var,
". The wls criterion takes Inf value.",
"Please handle this case in the weight argument of estim_param."))
"Please handle this case in the function given in weight argument of estim_param."))
}
if (any(is.na(sigma))) {
stop(paste("Error in crit_wls: weight is NA for variable",var,
". The wls criterion takes NA value.",
"Please handle this case in the function given in weight argument of estim_param."))
}

sz <- length(res)
Expand Down
8 changes: 4 additions & 4 deletions R/main_crit.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -432,11 +432,11 @@ main_crit <- function(param_values, crit_options) {
# Test weight function is well defined
if (!is.null(crit_options$weight)) {

var_list_tmp <- names(obs_sim_list$sim_list[[1]])
var_list_tmp <- names(obs_sim_list$obs_list[[1]])
var_tmp <- setdiff(var_list_tmp, "Date")[1]
simvec_tmp <- obs_sim_list$sim_list[[1]][,var_tmp]
obsvec_tmp <- obs_sim_list$obs_list[[1]][,var_tmp]
tryCatch(
w <- crit_options$weight(simvec_tmp, var_tmp),
w <- crit_options$weight(na.omit(obsvec_tmp), var_tmp),
error = function(cond) {
message(paste("Caught an error while testing argument weight: \n
it must be a function that takes 2 input arguments (vector of observed
Expand All @@ -449,7 +449,7 @@ main_crit <- function(param_values, crit_options) {
stop("Caught an error while testing argument weight: \n
it must be function that returns a numeric value (or vector of).")
}
if (length(w)!=1 & length(w)!=length(simvec_tmp)) {
if (length(w)!=1 & length(w)!=length(na.omit(obsvec_tmp))) {
stop("Caught an error while testing argument weight: \n
it must be a function that returns a single value or a vector of values of size the size of
the vector of observed values given as first argument.")
Expand Down
27 changes: 14 additions & 13 deletions tests/testthat/test-ls_criteria.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,20 +16,21 @@ test_that("crit_ols", {
expect_equal(crit_ols(sim_list, obs_list), 8)
expect_equal(crit_ols(sim_list2, obs_list2), 21)
})
w_inf <- function(...) {
return(Inf)
}
w_1 <- function(...) {
return(1)
}
w_obs <- function(obs, ...) {
return(obs)
}

test_that("crit_wls", {
expect_equal(crit_wls(sim_list, sim_list, w_1), 0)
expect_equal(crit_wls(sim_list2, obs_list2, w_1), crit_ols(obs_list2, sim_list2))
expect_equal(crit_wls(sim_list2, obs_list2, w_inf), 0)
expect_equal(crit_wls(sim_list2, obs_list2, w_obs), 10)
expect_equal(crit_wls(sim_list, sim_list,
function(...) { return(Inf) }), 0)
expect_equal(crit_wls(sim_list2, obs_list2,
function(...) { return(1) }),
crit_ols(obs_list2, sim_list2))
expect_equal(crit_wls(sim_list2, obs_list2,
function(...) { return(Inf) }), 0)
expect_equal(crit_wls(sim_list2, obs_list2,
function(obs, ...) { return(obs) }), 10)
expect_error(crit_wls(sim_list2, obs_list2,
function(obs, ...) { return(0) }))
expect_error(crit_wls(sim_list2, obs_list2,
function(obs, ...) { return(NA) }))
})
test_that("crit_log_cwss", {
expect_equal(crit_log_cwss(sim_list, sim_list), -Inf)
Expand Down
42 changes: 3 additions & 39 deletions tests/testthat/test-obsSim_consistency.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,19 +71,8 @@ sim_list$sit1$var1[[1]] <- Inf
param_values <- c(p1=1.0, p2=2.0)
test_that("Check is_sim_inf_or_na return TRUE when sim is Inf or NA when there is a corresponding observed value, case 1", {
expect_warning(eval(parse(
text = "CroptimizR:::is_sim_inf_or_na(sim_list, obs_list, param_values)")))

withCallingHandlers(eval(parse(
text = "CroptimizR:::is_sim_inf_or_na(sim_list, obs_list, param_values)")),
warning = function(w) {
# Check if the warning message contains all expected substrings

expected_substrings <- c("var1", "2009-11-30", "sit1")

expect_true(all(stringr::str_detect(w$message,expected_substrings)),
info = paste("Not all expected substrings found in the warning message:", w$message))
}
)
"sit1.*var1.*2009-11-30")
})

# Check if is_sim_inf_or_na return TRUE when it must, missing values for several dates
Expand All @@ -92,20 +81,8 @@ sim_list$sit3$var2 <- NA
param_values <- c(p1=1.0, p2=2.0)
test_that("Check is_sim_inf_or_na return TRUE when sim is Inf or NA when there is a corresponding observed value, case 1", {
expect_warning(eval(parse(
text = "CroptimizR:::is_sim_inf_or_na(sim_list, obs_list, param_values)")))

withCallingHandlers(eval(parse(
text = "CroptimizR:::is_sim_inf_or_na(sim_list, obs_list, param_values)")),
warning = function(w) {
# Check if the warning message contains all expected substrings

expected_substrings <- c("var2", "2010-10-03",
"2010-10-04", "sit3")

expect_true(all(stringr::str_detect(w$message,expected_substrings)),
info = paste("Not all expected substrings found in the warning message:", w$message))
}
)
"sit3.*var2.*2010-10-03.*2010-10-04")
})


Expand All @@ -117,20 +94,7 @@ sim_list$sit3$var2 <- NA
param_values <- c(p1=1.0, p2=2.0)
test_that("Check is_sim_inf_or_na return TRUE when sim is Inf or NA when there is a corresponding observed value, case 1", {
expect_warning(eval(parse(
text = "CroptimizR:::is_sim_inf_or_na(sim_list, obs_list, param_values)")))

withCallingHandlers(eval(parse(
text = "CroptimizR:::is_sim_inf_or_na(sim_list, obs_list, param_values)")),
warning = function(w) {
# Check if the warning message contains all expected substrings

expected_substrings <- c("var1", "2009-11-30", "sit1",
"var2", "2010-10-03",
"2010-10-04", "sit3")

expect_true(all(stringr::str_detect(w$message,expected_substrings)),
info = paste("Not all expected substrings found in the warning message:", w$message))
}
)
"sit1.*var1.*2009-11-30.*sit3.*var1.*2010-10-04.*var2.*2010-10-03.*2010-10-04")
})

0 comments on commit 8283f4d

Please sign in to comment.