diff --git a/DESCRIPTION b/DESCRIPTION index 229a4be..9bcbbf8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: LWFBrook90R Title: Simulate Evapotranspiration and Soil Moisture with the SVAT Model LWF-Brook90 -Version: 0.5.3 +Version: 0.5.4.9000 Authors@R: c(person("Paul", "Schmidt-Walter", , "paulsw@posteo.de", role = c("aut", "cre"),comment=c(ORCID="0000-0003-2699-0893")), person("Volodymyr", "Trotsiuk", , ,role = c("aut"),comment=c(ORCID="0000-0002-8363-656X")), person("Klaus", "Hammel", , ,role = c("aut")), diff --git a/NEWS.md b/NEWS.md index 56075a4..a67b10f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# LWFBrook90R 0.5.4.9000 + +## Bug fixes + + - fixed problem in parameter replacement multirun-permutations [#65](https://github.com/pschmidtwalter/LWFBrook90R/issues/70) + # LWFBrook90R 0.5.3 ## Bug fixes diff --git a/R/mrunLWFB90.R b/R/mrunLWFB90.R index 4a2d60e..2b3d92c 100644 --- a/R/mrunLWFB90.R +++ b/R/mrunLWFB90.R @@ -81,17 +81,19 @@ run_multi_LWFB90 <- function(paramvar, # determine list and vector elements in param_b90 is_ll <- lapply(param_b90, function(x) is.list(x) | length(x) > 1 ) - # which of the columns in paramvar belong to the list-parameters? + # which of paramvar's columns belong to the list-parameters? param_ll <- sapply(names(param_b90[names(is_ll)[which(is_ll == TRUE)]]), simplify = FALSE, - FUN = grep, - x = paramvar_nms) + FUN = function(x) { + which(grepl(x,paramvar_nms, fixed = TRUE) & + grepl("[[:digit:].]",paramvar_nms)) + }) # determine number of nonzero list entries param_ll_len <- length(param_ll[sapply(param_ll, function(x) length(x) > 0)]) # check if all the names of paramvar can be found in param_b90 - if (param_ll_len > 0L) { #length > 1 includede in paramvar + if (param_ll_len > 0L) { #length > 1 included in paramvar # remove zeros param_ll <- param_ll[sapply(param_ll, function(x) length(x) > 0)] singlepar_nms <- paramvar_nms[-unlist(param_ll)] @@ -101,6 +103,7 @@ run_multi_LWFB90 <- function(paramvar, nms <- paramvar_nms } + if (!all(nms %in% names(param_b90))) { stop( paste( "Not all names of 'paramvar' were found in 'param_b90'! Check names:", paste(nms[which(!nms %in% names(param_b90))], collapse =", ") )) diff --git a/tests/testthat/test-multirun.R b/tests/testthat/test-multirun.R new file mode 100644 index 0000000..aa998f7 --- /dev/null +++ b/tests/testthat/test-multirun.R @@ -0,0 +1,53 @@ +library(LWFBrook90R) +library(data.table) +data("slb1_soil") +data("slb1_meteo") + +if (parallelly::availableCores() > 1) { + cores <- 2 +} else { + cores <- 1 +} + +soil <- cbind(slb1_soil, hydpar_wessolek_tab(texture = slb1_soil$texture)) +soil_lay_mat <- soil_to_param(soil) + +opts <- set_optionsLWFB90(startdate = as.Date("2002-12-15"), enddate = as.Date("2003-01-15")) +parms <- set_paramLWFB90(sai = c(0.5,1.2),maxlai = c(2,5), + soil_nodes = soil_lay_mat$soil_nodes, + soil_materials = soil_lay_mat$soil_materials) + + +vary_parms <- data.frame(maxlai = c(0.941, 0.952), + sai2 = c(0.951, 0.952), + fsintlai = c(0.961,0.962), + frintsai = c(0.971, 0.972), + fsintsai = c(0.981, 0.982), + soil_materials.ths2 = c(0.991,0.992)) + +res_multi <- run_multi_LWFB90(paramvar = vary_parms[1:N,], + param_b90 = parms, + options_b90 = opts, + climate = slb1_meteo) + + +used_singleparms = rbindlist( + lapply(res_multi, function(x) { + x$model_input$param_b90[c("fsintlai","frintsai", "fsintsai" )] + })) + +used_annual_vegparms = rbindlist(lapply(res_multi, function(x) { + x$model_input$param_b90[c("maxlai", "sai")] +}), idcol="No.") + +used_listparms = unlist(lapply(res_multi, function(x) { + x$model_input$param_b90$soil_materials$ths[2] +}), use.names = FALSE) + +setDT(vary_parms) +test_that("multi-run: all vary_parms at the right place",{ + expect_equal(used_singleparms,vary_parms[,names(used_singleparms), with = F]) + expect_equal(used_annual_vegparms$maxlai, rep(vary_parms$maxlai, each = 2)) + expect_equal(used_annual_vegparms$sai[c(2,4)], vary_parms$sai2) + expect_equal(used_listparms, vary_parms$soil_materials.ths2) +})