diff --git a/R/A_swGenericMethods.R b/R/A_swGenericMethods.R index 9d403ca4..130b58de 100644 --- a/R/A_swGenericMethods.R +++ b/R/A_swGenericMethods.R @@ -137,7 +137,7 @@ check_version <- function( expected[[c(1, 3)]] <- 0 } - if (level %in% "major") { + if (identical(level, "major")) { # zero the minor-level has[[c(1, 2)]] <- 0 expected[[c(1, 2)]] <- 0 diff --git a/R/B_swFiles.R b/R/B_swFiles.R index 5d2e6f34..437d6267 100644 --- a/R/B_swFiles.R +++ b/R/B_swFiles.R @@ -143,7 +143,7 @@ setMethod( # Maintenance: # update `do_upgrade` when `n_exp` changes or new upgrades required! do_upgrade <- c( - from_v230 = n_has == 22L && n_exp %in% 23L + from_v230 = n_has == 22L && n_exp == 23L ) do_upgrade <- do_upgrade[do_upgrade] diff --git a/R/D_swCloud.R b/R/D_swCloud.R index ca09fd56..a2b9fb4e 100644 --- a/R/D_swCloud.R +++ b/R/D_swCloud.R @@ -145,12 +145,12 @@ swCloud <- function(...) { # We don't set values for slot `Cloud` (except SnowDensity and RainEvents) # if not passed via ...; this is to prevent simulation runs with # accidentally incorrect values - if (!("Cloud" %in% dns)) { - ids <- 4:5 - def@Cloud[- ids, ] <- NA_real_ - } else { + if ("Cloud" %in% dns) { # Guarantee names dimnames(dots[["Cloud"]]) <- dimnames(def@Cloud) + } else { + ids <- 4:5 + def@Cloud[- ids, ] <- NA_real_ } tmp <- lapply( diff --git a/R/D_swWeather.R b/R/D_swWeather.R index dee9b45b..5f4cc74b 100644 --- a/R/D_swWeather.R +++ b/R/D_swWeather.R @@ -133,12 +133,12 @@ sw_upgrade_MonthlyScalingParams <- function( # nolint: object_length_linter. vars_exp <- colnames(default@MonthlyScalingParams) vars_has <- colnames(MonthlyScalingParams) - if (!all(vars_exp %in% vars_has)) { + if (all(vars_exp %in% vars_has)) { + MonthlyScalingParams + } else { res <- default@MonthlyScalingParams res[, vars_has] <- MonthlyScalingParams[, vars_has] res - } else { - MonthlyScalingParams } } @@ -243,7 +243,7 @@ setValidity( sns <- setdiff(slotNames("swWeather"), inheritedSlotNames("swWeather")) for (sn in sns) { - n_exp <- if (sn %in% "dailyInputFlags") { + n_exp <- if (identical(sn, "dailyInputFlags")) { rSW2_glovars[["kSOILWAT2"]][["kINT"]][["MAX_INPUT_COLUMNS"]] } else { 1L diff --git a/R/D_swWeatherData.R b/R/D_swWeatherData.R index 38c07ddc..ea83e788 100644 --- a/R/D_swWeatherData.R +++ b/R/D_swWeatherData.R @@ -44,20 +44,20 @@ weather_dataColumns <- function() { #' @export weather_dataAggFun <- function() { c( - "Tmax_C" = mean, - "Tmin_C" = mean, - "PPT_cm" = sum, - "cloudCov_pct" = mean, - "windSpeed_mPERs" = mean, - "windSpeed_east_mPERs" = mean, - "windSpeed_north_mPERs" = mean, - "rHavg_pct" = mean, - "rHmax_pct" = mean, - "rHmin_pct" = mean, - "specHavg_pct" = mean, - "Tdewpoint_C" = mean, - "actVP_kPa" = mean, - "shortWR" = mean + Tmax_C = mean, + Tmin_C = mean, + PPT_cm = sum, + cloudCov_pct = mean, + windSpeed_mPERs = mean, + windSpeed_east_mPERs = mean, + windSpeed_north_mPERs = mean, + rHavg_pct = mean, + rHmax_pct = mean, + rHmin_pct = mean, + specHavg_pct = mean, + Tdewpoint_C = mean, + actVP_kPa = mean, + shortWR = mean ) } diff --git a/R/F_swSite.R b/R/F_swSite.R index be5fa293..0220a6ba 100644 --- a/R/F_swSite.R +++ b/R/F_swSite.R @@ -211,14 +211,14 @@ swSite <- function(...) { tmp <- c("Longitude", "Latitude", "Altitude", "Slope", "Aspect") def@IntrinsicSiteParams[tmp] <- NA_real_ } - if (!("TranspirationRegions" %in% dns)) { - def@TranspirationRegions[, "layer"] <- NA_integer_ - } else { + if ("TranspirationRegions" %in% dns) { # Guarantee names dimnames(dots[["TranspirationRegions"]]) <- list( NULL, colnames(def@TranspirationRegions) ) + } else { + def@TranspirationRegions[, "layer"] <- NA_integer_ } if ("swrc_flags" %in% dns) { diff --git a/R/F_swSoils.R b/R/F_swSoils.R index def1e8f2..62f6a060 100644 --- a/R/F_swSoils.R +++ b/R/F_swSoils.R @@ -185,24 +185,24 @@ swSoils <- function(...) { # We don't set values for slot `Layers` if not passed via ...; this # is to prevent simulation runs with accidentally incorrect values - if (!("Layers" %in% dns)) { - def@Layers <- def@Layers[1, , drop = FALSE] - def@Layers[] <- NA_real_ - ntmp <- 1 - } else { + if ("Layers" %in% dns) { # Guarantee names dimnames(dots[["Layers"]]) <- list(NULL, colnames(def@Layers)) ntmp <- nrow(dots[["Layers"]]) + } else { + def@Layers <- def@Layers[1, , drop = FALSE] + def@Layers[] <- NA_real_ + ntmp <- 1 } # We don't set values for slot `SWRCp` if not passed via ...; this # is to prevent simulation runs with accidentally incorrect values - if (!("SWRCp" %in% dns)) { - def@SWRCp <- def@SWRCp[rep.int(1, ntmp), , drop = FALSE] - def@SWRCp[] <- NA_real_ - } else { + if ("SWRCp" %in% dns) { # Guarantee names dimnames(dots[["SWRCp"]]) <- list(NULL, colnames(def@SWRCp)) + } else { + def@SWRCp <- def@SWRCp[rep.int(1, ntmp), , drop = FALSE] + def@SWRCp[] <- NA_real_ } # Copy from SOILWAT2 "testing" (defaults), but dot arguments take precedence diff --git a/R/G_swOut.R b/R/G_swOut.R index 8d87a039..c2a6becb 100644 --- a/R/G_swOut.R +++ b/R/G_swOut.R @@ -281,7 +281,7 @@ setMethod( # update `do_upgrade` when `n_exp` changes or new upgrades required! do_upgrade <- c( from_v230 = n_has == 30L && n_exp %in% 31L:32L, - from_v310 = n_has == 31L && n_exp %in% 32L + from_v310 = n_has == 31L && n_exp == 32L ) do_upgrade <- do_upgrade[do_upgrade] diff --git a/R/Rsw.R b/R/Rsw.R index bd4e2e70..6e27c7f0 100644 --- a/R/Rsw.R +++ b/R/Rsw.R @@ -502,15 +502,8 @@ set_requested_flags <- function(swIn, tag, use, values, fun, reset = TRUE, # Check dimensional agreement ndim_gt1_vals <- sum(dim(data.frame(vals)) > 1) ndim_gt1_def <- sum(dim(data.frame(def)) > 1) - if (!(ndim_gt1_vals == 1 && ndim_gt1_def == 1)) { - stop( - "ERROR: ", - toString(shQuote(val_names)), - " are not represented as 1-dimensional objects in", - " class 'swInputData'." - ) - } else { + if (ndim_gt1_vals == 1 && ndim_gt1_def == 1) { # Transfer values itemp <- sapply(names(def), function(x) { k <- grep(substr(x, 1, 4), val_names) @@ -522,6 +515,14 @@ set_requested_flags <- function(swIn, tag, use, values, fun, reset = TRUE, } swIn <- get(paste0(fun, "<-"))(swIn, def) + + } else { + stop( + "ERROR: ", + toString(shQuote(val_names)), + " are not represented as 1-dimensional objects in", + " class 'swInputData'." + ) } } } diff --git a/R/swWeatherGenerator.R b/R/swWeatherGenerator.R index e5ac54d7..dfecbbc6 100644 --- a/R/swWeatherGenerator.R +++ b/R/swWeatherGenerator.R @@ -1705,10 +1705,7 @@ dbW_fixWeather <- function( dif_wd3 <- rSOILWAT2::calc_dailyInputFlags(weatherData3) vars_wd3 <- names(dif_wd3)[dif_wd3] - if (!any(is_missing_weather(weatherData3[, vars_wd3]))) { - weatherData4 <- weatherData3 - - } else { + if (any(is_missing_weather(weatherData3[, vars_wd3]))) { daymeans <- data.frame( Year = NA, aggregate( @@ -1773,6 +1770,9 @@ dbW_fixWeather <- function( is_miss4 <- is_missing_weather(weatherData4[, weather_dataColumns()]) meta[!is_miss4 & is_miss3] <- "longTermDailyMean" + + } else { + weatherData4 <- weatherData3 } diff --git a/R/sw_Pedotransfer_Functions.R b/R/sw_Pedotransfer_Functions.R index 33aa001a..067c9d7c 100644 --- a/R/sw_Pedotransfer_Functions.R +++ b/R/sw_Pedotransfer_Functions.R @@ -769,7 +769,7 @@ rSW2_SWRC_PTF_estimate_parameters <- function( # nolint: object_length_linter. fail = TRUE, ... ) { - ptf_name <- std_ptf(ptf_name)[1] + ptf_name <- std_ptf(ptf_name)[[1L]] has_ptf <- ptf_name %in% ptfs_implemented_by_rSW2() list_soilargs <- list( @@ -778,7 +778,7 @@ rSW2_SWRC_PTF_estimate_parameters <- function( # nolint: object_length_linter. bdensity = bdensity ) - if (has_ptf && ptf_name %in% "Rosetta3") { + if (has_ptf && ptf_name == "Rosetta3") { dots <- list(...) dots[["version"]] <- if ("version" %in% names(dots)) { as.character(dots[["version"]]) @@ -791,7 +791,7 @@ rSW2_SWRC_PTF_estimate_parameters <- function( # nolint: object_length_linter. args = c(list_soilargs, dots) ) - } else if (has_ptf && ptf_name %in% "neuroFX2021") { + } else if (has_ptf && ptf_name == "neuroFX2021") { do.call( ptf_neuroFX2021_for_FXW, args = c(list_soilargs, list(...)) diff --git a/tests/testthat/test_exec_and_aggregate.R b/tests/testthat/test_exec_and_aggregate.R index 69f75a12..5aa84cea 100644 --- a/tests/testthat/test_exec_and_aggregate.R +++ b/tests/testthat/test_exec_and_aggregate.R @@ -164,11 +164,14 @@ for (it in tests) { #------ Run SOILWAT2 test_that("Simulate and aggregate", { - rd <- sw_exec( - inputData = sw_input, - weatherList = sw_weather, - echo = FALSE, - quiet = TRUE + # Run silently + expect_silent( + rd <- sw_exec( + inputData = sw_input, + weatherList = sw_weather, + echo = FALSE, + quiet = TRUE + ) ) # Check rSOILWAT2 output object @@ -177,23 +180,6 @@ for (it in tests) { expect_false(has_soilTemp_failed()) expect_true(all(sw_out_flags() %in% slotNames(rd))) - # Run silently/verbosely - expect_silent(sw_exec( - inputData = sw_input, - weatherList = sw_weather, - echo = FALSE, quiet = TRUE - )) - - # This doesn't work; apparently, testthat::expect_message and similar - # functions don't capture text written by LogError directly to the console. - if (FALSE) { - expect_message(sw_exec( - inputData = sw_input, - weatherList = sw_weather, - echo = FALSE, quiet = FALSE - )) - } - # Check that input weather is identical to output weather # (don't check missing days that the weather generator filled in) diff --git a/tests/testthat/test_iOUT_macros.R b/tests/testthat/test_iOUT_macros.R index e21eba07..fa31cda1 100644 --- a/tests/testthat/test_iOUT_macros.R +++ b/tests/testthat/test_iOUT_macros.R @@ -58,10 +58,6 @@ test_that("Tests of iOUT and iOUT2", { for (i in seq_len(n_vars)) { # test `iOUT` for 'key = 1' icol <- ncol_TimeOUT[pd] + i - if (FALSE) { - print(paste("key =", key, "var =", i, "irow =", irow_OUT[pd], - "icol =", icol, "iOUT =", iOUT(i, pd, irow_OUT))) - } p_OUT[key, pd][[1]][irow_OUT[pd], icol] <- iOUT(i, pd, irow_OUT) } @@ -70,11 +66,6 @@ test_that("Tests of iOUT and iOUT2", { for (k in seq_len(NVEGTYPES)) { for (i in seq_len(n_layers)) { icol <- ncol_TimeOUT[pd] + i + n_layers * (k - 1) - if (FALSE) { - print(paste("key =", key, "veg =", k, "slyr =", i, "irow =", - irow_OUT[pd], "icol =", icol, "iOUT =", - iOUT2(i, k, pd, irow_OUT))) - } p_OUT[key, pd][[1]][irow_OUT[pd], icol] <- iOUT2(i, k, pd, irow_OUT) } diff --git a/tests/testthat/test_pedotransferfunctions.R b/tests/testthat/test_pedotransferfunctions.R index 946e708e..a5cf0e03 100644 --- a/tests/testthat/test_pedotransferfunctions.R +++ b/tests/testthat/test_pedotransferfunctions.R @@ -52,7 +52,10 @@ vwc_fix <- data.frame( row.names(vwc_fix) <- row.names(texture) ftemp <- file.path("..", "test_data", "swp_values.rds") -if (FALSE) { +if (file.exists(ftemp)) { + swp_vals <- readRDS(ftemp) + +} else { swp_vals <- unlist(lapply( row.names(texture), function(itext) { @@ -70,9 +73,6 @@ if (FALSE) { row.names(texture) ) saveRDS(swp_vals, file = ftemp) - -} else { - swp_vals <- readRDS(ftemp) } #--- Tests diff --git a/vignettes/rSOILWAT2_demo.Rmd b/vignettes/rSOILWAT2_demo.Rmd index 57e263dd..61df6c7f 100644 --- a/vignettes/rSOILWAT2_demo.Rmd +++ b/vignettes/rSOILWAT2_demo.Rmd @@ -189,16 +189,14 @@ options(tinytex.verbose = TRUE) ## Create base rSOILWAT2 input object ```{r, input_object} - # Preferred option: + ## Quick option + # Note: This approach is discouraged because it is very easy to miss to + # set all relevant parameters and variables to site-specific values + sw_in__bad <- rSOILWAT2::sw_exampleData ## Don't do this! + + ## Preferred option # All relevant site-specific parameters and variables are set to NA sw_in <- rSOILWAT2::swInputData() - - # Quick option: - # This approach is discouraged because it is very easy to miss to - # set all relevant parameters and variables to site-specific values - if (FALSE) { - sw_in <- rSOILWAT2::sw_exampleData - } ``` ## Simulation time and location @@ -644,10 +642,9 @@ by `SOILWAT2` with the selected pedotransfer function. # Declare that parameter values are already estimated rSOILWAT2::swSite_hasSWRCp(sw_in) <- TRUE - if (FALSE) { - # Alternatively, set soil properties and SWRC parameters at once - rSOILWAT2::set_swSoils(sw_in) <- list(Layers = soil_new, SWRCp = swrcp) - } + # Alternatively (and equivalently), + # set soil properties and SWRC parameters with one assignment + rSOILWAT2::set_swSoils(sw_in) <- list(Layers = soil_new, SWRCp = swrcp) ```