From 5af986f48bda647162b27816954067d19747c40c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Bos?= Date: Fri, 10 Jul 2020 15:09:35 +0200 Subject: [PATCH 1/5] fixed bug such that the clean_up value is passed to the model parameters --- R/add_trajectory_params.R | 11 ++++++++++- R/run_model.R | 6 ++++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/R/add_trajectory_params.R b/R/add_trajectory_params.R index aaf102de..fa60927d 100644 --- a/R/add_trajectory_params.R +++ b/R/add_trajectory_params.R @@ -82,6 +82,10 @@ add_trajectory_params <- function(model, model$binary_path <- binary_path } + if (!is.null(clean_up)) { + model$clean_up <- clean_up + } + model } @@ -96,7 +100,8 @@ add_dispersion_params <- function(model, model_height = NULL, exec_dir = NULL, met_dir = NULL, - binary_path = NULL) { + binary_path = NULL, + clean_up = TRUE) { if (!is.null(start_time)) { model$start_time <- start_time @@ -134,5 +139,9 @@ add_dispersion_params <- function(model, model$binary_path <- binary_path } + if (!is.null(clean_up)) { + model$clean_up <- clean_up + } + model } diff --git a/R/run_model.R b/R/run_model.R index a89c6a9d..0ac97915 100644 --- a/R/run_model.R +++ b/R/run_model.R @@ -29,7 +29,8 @@ run_model <- function(model) { traj_name = model$traj_name, exec_dir = model$exec_dir, met_dir = model$met_dir, - binary_path = model$binary_path + binary_path = model$binary_path, + clean_up = model$clean_up ) model$traj_df <- traj_df @@ -80,7 +81,8 @@ run_model <- function(model) { species = species_list, exec_dir = model$exec_dir, met_dir = model$met_dir, - binary_path = model$binary_path + binary_path = model$binary_path, + clean_up = model$clean_up ) model$disp_df <- disp_df From 3c2b9da3d85e00d513f21cd86825483a412fa915 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Bos?= Date: Tue, 14 Jul 2020 17:11:46 +0200 Subject: [PATCH 2/5] allow for a custom binary_name --- R/add_trajectory_params.R | 5 +++++ R/hysplit_dispersion.R | 8 ++++++-- R/run_model.R | 1 + R/utils.R | 6 +++++- 4 files changed, 17 insertions(+), 3 deletions(-) diff --git a/R/add_trajectory_params.R b/R/add_trajectory_params.R index fa60927d..597ee7b0 100644 --- a/R/add_trajectory_params.R +++ b/R/add_trajectory_params.R @@ -101,6 +101,7 @@ add_dispersion_params <- function(model, exec_dir = NULL, met_dir = NULL, binary_path = NULL, + binary_name = NULL, clean_up = TRUE) { if (!is.null(start_time)) { @@ -139,6 +140,10 @@ add_dispersion_params <- function(model, model$binary_path <- binary_path } + if (!is.null(binary_name)) { + model$binary_name <- binary_name + } + if (!is.null(clean_up)) { model$clean_up <- clean_up } diff --git a/R/hysplit_dispersion.R b/R/hysplit_dispersion.R index 1f31b887..387f6d96 100644 --- a/R/hysplit_dispersion.R +++ b/R/hysplit_dispersion.R @@ -4,6 +4,7 @@ #' runs using specified meteorological datasets. #' #' @inheritParams hysplit_trajectory +#' @param binary_name An optional file name for the hysplit binary code. Defaults to "hycs_std", but could be "hycm_std", for example. #' @param start_day the day that the model will initialize and run. This should #' take the form of a single-length vector for a day (`"YYYY-MM-DD"`). #' @param start_hour a single daily hour as an integer hour (from `0` to `23`). @@ -31,6 +32,7 @@ hysplit_dispersion <- function(lat = 49.263, species, disp_name = NULL, binary_path = NULL, + binary_name = NULL, exec_dir = NULL, met_dir = NULL, clean_up = TRUE) { @@ -41,11 +43,13 @@ hysplit_dispersion <- function(lat = 49.263, # If the meteorology dir isn't specified, use the working directory if (is.null(met_dir)) met_dir <- getwd() - # Set the path for the `hycs_std` binary file + # Set the path for the binary file. Defaults to "hycs_std" + if (is.null(binary_name)) binary_name <- "hycs_std" + hycs_std_binary_path <- set_binary_path( binary_path = binary_path, - binary_name = "hycs_std" + binary_name = binary_name ) parhplot_binary_path <- diff --git a/R/run_model.R b/R/run_model.R index 0ac97915..7d2b665c 100644 --- a/R/run_model.R +++ b/R/run_model.R @@ -82,6 +82,7 @@ run_model <- function(model) { exec_dir = model$exec_dir, met_dir = model$met_dir, binary_path = model$binary_path, + binary_name = model$binary_name, clean_up = model$clean_up ) diff --git a/R/utils.R b/R/utils.R index a75cc7bb..0bd4d4b0 100644 --- a/R/utils.R +++ b/R/utils.R @@ -179,10 +179,12 @@ execute_on_system <- function(sys_cmd, system_type) { set_binary_path <- function(binary_path, binary_name) { - # binary names should be either: + # By default, binary names should be either: # - hyts_std (trajectory models) # - hycs_std (dispersion models) + # If a user uses another binary name, the path to it should also be specified + if (is.null(binary_path)) { system_os <- get_os() @@ -210,6 +212,8 @@ set_binary_path <- function(binary_path, package = "splitr" ) } + } else { + binary_path <- paste0(binary_path, binary_name) } binary_path From 81717a182fc3d31e5832e83ee707763d921cf65c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Bos?= Date: Fri, 24 Jul 2020 18:11:51 +0200 Subject: [PATCH 3/5] allow for softrun --- R/add_trajectory_params.R | 10 ++++++++-- R/hysplit_dispersion.R | 12 ++++++++++-- R/run_model.R | 2 ++ 3 files changed, 20 insertions(+), 4 deletions(-) diff --git a/R/add_trajectory_params.R b/R/add_trajectory_params.R index 597ee7b0..9ec185f6 100644 --- a/R/add_trajectory_params.R +++ b/R/add_trajectory_params.R @@ -24,6 +24,7 @@ add_trajectory_params <- function(model, binary_path = NULL, met_dir = NULL, exec_dir = NULL, + softrun = FALSE, clean_up = TRUE) { if (!is.null(lat)) { @@ -82,6 +83,10 @@ add_trajectory_params <- function(model, model$binary_path <- binary_path } + if (!is.null(softrun)) { + model$softrun <- softrun + } + if (!is.null(clean_up)) { model$clean_up <- clean_up } @@ -102,6 +107,7 @@ add_dispersion_params <- function(model, met_dir = NULL, binary_path = NULL, binary_name = NULL, + softrun = FALSE, clean_up = TRUE) { if (!is.null(start_time)) { @@ -140,8 +146,8 @@ add_dispersion_params <- function(model, model$binary_path <- binary_path } - if (!is.null(binary_name)) { - model$binary_name <- binary_name + if (!is.null(softrun)) { + model$softrun <- softrun } if (!is.null(clean_up)) { diff --git a/R/hysplit_dispersion.R b/R/hysplit_dispersion.R index 387f6d96..18d6d9c6 100644 --- a/R/hysplit_dispersion.R +++ b/R/hysplit_dispersion.R @@ -35,6 +35,7 @@ hysplit_dispersion <- function(lat = 49.263, binary_name = NULL, exec_dir = NULL, met_dir = NULL, + softrun = NULL, clean_up = TRUE) { # If the execution dir isn't specified, use the working directory @@ -155,6 +156,7 @@ hysplit_dispersion <- function(lat = 49.263, exec_dir = exec_dir ) + # The CONTROL file is now complete and in the # working directory, so, execute the model run sys_cmd <- @@ -168,7 +170,9 @@ hysplit_dispersion <- function(lat = 49.263, ")" ) - execute_on_system(sys_cmd, system_type = system_type) + if (isFALSE(softrun)) { + execute_on_system(sys_cmd, system_type = system_type) + } # Extract the particle positions at every hour sys_cmd <- @@ -182,8 +186,11 @@ hysplit_dispersion <- function(lat = 49.263, ")" ) - execute_on_system(sys_cmd, system_type = system_type) + if (isFALSE(softrun)) { + execute_on_system(sys_cmd, system_type = system_type) + } + if (isFALSE(softrun)) { dispersion_file_list <- list.files( path = exec_dir, @@ -219,6 +226,7 @@ hysplit_dispersion <- function(lat = 49.263, dispersion_tbl <- dplyr::bind_rows(dispersion_tbl, disp_tbl) + } } if (clean_up) { diff --git a/R/run_model.R b/R/run_model.R index 7d2b665c..cfe3a1fa 100644 --- a/R/run_model.R +++ b/R/run_model.R @@ -30,6 +30,7 @@ run_model <- function(model) { exec_dir = model$exec_dir, met_dir = model$met_dir, binary_path = model$binary_path, + softrun = model$softrun, clean_up = model$clean_up ) @@ -83,6 +84,7 @@ run_model <- function(model) { met_dir = model$met_dir, binary_path = model$binary_path, binary_name = model$binary_name, + softrun = model$softrun, clean_up = model$clean_up ) From eb1b3017406311bf9f5780848de811a8d41704e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Bos?= Date: Thu, 30 Jul 2020 11:58:52 +0200 Subject: [PATCH 4/5] added softrun parameter to supress warning message --- R/hysplit_trajectory.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/hysplit_trajectory.R b/R/hysplit_trajectory.R index d92bda4e..9540b9c4 100644 --- a/R/hysplit_trajectory.R +++ b/R/hysplit_trajectory.R @@ -87,6 +87,7 @@ hysplit_trajectory <- function(lat = 49.263, binary_path = NULL, met_dir = NULL, exec_dir = NULL, + softrun = NULL, # This is not evaluated, yet clean_up = TRUE) { # If the execution dir isn't specified, use the working directory From 70bf3c7490ba68475ea4e2f0ccd1c3d637a84997 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Bj=C3=B6rn=20Bos?= Date: Thu, 30 Jul 2020 12:06:33 +0200 Subject: [PATCH 5/5] fixed issues with leap years and use only necessay gdas1 file(s) --- R/get_met_gdas1.R | 64 +++++++++++++++++++++-------------------------- R/run_model.R | 4 +-- 2 files changed, 31 insertions(+), 37 deletions(-) diff --git a/R/get_met_gdas1.R b/R/get_met_gdas1.R index 0badf135..1131a9a9 100644 --- a/R/get_met_gdas1.R +++ b/R/get_met_gdas1.R @@ -14,64 +14,58 @@ get_met_gdas1 <- function(days, direction, path_met_files) { - # Determine the minimum month (as a `Date`) for the model run + # Determine the minimum date (as a `Date`) for the model run if (direction == "backward") { - min_month <- + min_date <- (lubridate::as_date(days[1]) - (duration / 24)) %>% - lubridate::floor_date(unit = "month") + lubridate::floor_date(unit = "day") } else if (direction == "forward") { - min_month <- - (lubridate::as_date(days[1]) + (duration / 24)) %>% - lubridate::floor_date(unit = "month") + min_date <- + (lubridate::as_date(days[1])) %>% + lubridate::floor_date(unit = "day") } - # Determine the maximum month (as a `Date`) for the model run + # Determine the maximum date (as a `Date`) for the model run if (direction == "backward") { - max_month <- - (lubridate::as_date(days[length(days)]) - (duration / 24)) %>% - lubridate::floor_date(unit = "month") + max_date <- + (lubridate::as_date(days[length(days)])) %>% + lubridate::floor_date(unit = "day") } else if (direction == "forward") { - max_month <- + max_date <- (lubridate::as_date(days[length(days)]) + (duration / 24)) %>% - lubridate::floor_date(unit = "month") + lubridate::floor_date(unit = "day") } - met_months <- - seq(min_month, max_month, by = "1 month") %>% - rep(each = 5) + met_days <- + seq(min_date, max_date, by = "1 day") %>% + lubridate::day() - month_names <- - met_months %>% - lubridate::month(label = TRUE, abbr = TRUE) %>% + month_names <- + seq(min_date, max_date, by = "1 day") %>% + lubridate::month(label = TRUE, abbr = TRUE, locale = "en_US.UTF-8") %>% as.character() %>% tolower() met_years <- - met_months %>% + seq(min_date, max_date, by = "1 day") %>% + lubridate::year() %>% substr(3, 4) - if (!all(lubridate::leap_year(lubridate::year(days)))) { - - not_leap_years_lgl <- !lubridate::leap_year(lubridate::ymd(days)) - - exclusion_years_feb_5 <- - lubridate::year(days[not_leap_years_lgl]) %>% - unique() - - excluded_files <- - paste0("gdas1.feb", substr(exclusion_years_feb_5, 3, 4), ".w5") - - } else { - excluded_files <- character(0) - } + # Only consider the weeks of the month we need: + #.w1 - days 1-7 + #.w2 - days 8-14 + #.w3 - days 15-21 + #.w4 - days 22-28 + #.w5 - days 29 - rest of the month - files <- paste0("gdas1.", month_names, met_years, ".w", 1:5) + met_week <- ceiling(met_days / 7) - files <- files %>% base::setdiff(excluded_files) + files <- paste0("gdas1.", month_names, met_years, ".w", met_week) %>% unique() get_met_files( files = files, path_met_files = path_met_files, ftp_dir = "ftp://arlftp.arlhq.noaa.gov/archives/gdas1" ) + } diff --git a/R/run_model.R b/R/run_model.R index cfe3a1fa..01dec470 100644 --- a/R/run_model.R +++ b/R/run_model.R @@ -48,8 +48,8 @@ run_model <- function(model) { # Get time window for observations start_day <- model$start_time %>% lubridate::floor_date() start_hour <- model$start_time %>% lubridate::hour() - duration <- as.numeric(model$end_time - model$start_time) - + duration <- as.numeric(difftime(model$end_time, model$start_time, units = "hours")) + # Get ith source parameters lat <- model$sources[i, ][["lat"]] lon <- model$sources[i, ][["lon"]]