diff --git a/R/add_trajectory_params.R b/R/add_trajectory_params.R index aaf102d..9ec185f 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,14 @@ 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 + } + model } @@ -96,7 +105,10 @@ add_dispersion_params <- function(model, model_height = NULL, exec_dir = NULL, met_dir = NULL, - binary_path = NULL) { + binary_path = NULL, + binary_name = NULL, + softrun = FALSE, + clean_up = TRUE) { if (!is.null(start_time)) { model$start_time <- start_time @@ -134,5 +146,13 @@ add_dispersion_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 + } + model } diff --git a/R/get_met_gdas1.R b/R/get_met_gdas1.R index 0badf13..1131a9a 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/hysplit_dispersion.R b/R/hysplit_dispersion.R index 1f31b88..18d6d9c 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,8 +32,10 @@ hysplit_dispersion <- function(lat = 49.263, species, disp_name = NULL, binary_path = NULL, + 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 @@ -41,11 +44,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 <- @@ -151,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 <- @@ -164,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 <- @@ -178,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, @@ -215,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/hysplit_trajectory.R b/R/hysplit_trajectory.R index d92bda4..9540b9c 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 diff --git a/R/run_model.R b/R/run_model.R index a89c6a9..01dec47 100644 --- a/R/run_model.R +++ b/R/run_model.R @@ -29,7 +29,9 @@ 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, + softrun = model$softrun, + clean_up = model$clean_up ) model$traj_df <- traj_df @@ -46,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"]] @@ -80,7 +82,10 @@ 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, + binary_name = model$binary_name, + softrun = model$softrun, + clean_up = model$clean_up ) model$disp_df <- disp_df diff --git a/R/utils.R b/R/utils.R index a75cc7b..0bd4d4b 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