From 5e4906b9028aee60943e7c12da14c0280538d60a Mon Sep 17 00:00:00 2001 From: "tadhg.m" Date: Mon, 2 Nov 2020 12:21:36 -0500 Subject: [PATCH 1/6] Updated yaml functionality --- DESCRIPTION | 2 +- NAMESPACE | 3 ++ R/get_yaml_value.R | 95 +++------------------------------------------- 3 files changed, 10 insertions(+), 90 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 358c473..875e312 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,4 +36,4 @@ Suggests: rmarkdown Encoding: UTF-8 LazyData: true -RoxygenNote: 7.1.0 +RoxygenNote: 7.1.1 diff --git a/NAMESPACE b/NAMESPACE index 979db57..de70a41 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,12 +1,14 @@ # Generated by roxygen2: do not edit by hand export(NSE) +export(analyse_strat) export(calc_cc) export(calc_dens) export(calc_in_lwr) export(calc_sp_hum) export(calc_swr) export(conv_hypso) +export(create_init_prof) export(dbsummary) export(diag_plots) export(extractDepths) @@ -102,4 +104,5 @@ importFrom(stats,na.exclude) importFrom(tidyr,separate) importFrom(utils,read.delim) importFrom(utils,write.csv) +importFrom(yaml,read_yaml) importFrom(zoo,na.approx) diff --git a/R/get_yaml_value.R b/R/get_yaml_value.R index bc3119e..bcd5567 100644 --- a/R/get_yaml_value.R +++ b/R/get_yaml_value.R @@ -10,99 +10,16 @@ #' @examples #' yaml_file <- system.file('extdata/gotm.yaml', package = 'GOTMr') #' get_yaml_value(file = yaml_file, label = 'airp', key = 'file') +#' @importFrom yaml read_yaml #' @export #' get_yaml_value <- function(file = 'gotm.yaml', label, key){ - yml <- readLines(file) - - # Prevent from finding labels/keys in comments - yml_no_comments <- unname(sapply(yml, function(x) strsplit(x, "#")[[1]][1])) - #Find index of label - if(is.null(label)){ - ind_label = 0 - }else{ - label_id <- paste0(label,':') - ind_label <- grep(label_id, yml_no_comments) - - if(length(ind_label) == 0){ - stop(label, ' not found in ', file) - } - } - - #Find index of key to replace - key_id <- paste0(' ',key, ':') - ind_key = grep(key_id, yml_no_comments) - if(length(ind_key) == 0){ - stop(key, ' not found in ', label, ' in ', file) - } - ind_key = ind_key[ind_key > ind_label] - ind_map <- ind_key[which.min(ind_key - ind_label)] - if(length(ind_map) == 0){ - stop(key, ' not found in ', label, ' in ', file) - } - - #Split to extract comment - spl1 <- strsplit(yml[ind_map], c('#'))[[1]] - spl2 <- strsplit(spl1[1], ': ')[[1]][2] - - - if(grepl(':', spl2)){ - spl3 = strsplit(spl2, ' ')[[1]] - val = paste(spl3[1], spl3[2]) - }else{ - val <- gsub(" ", "", spl2, fixed = TRUE) - } + yml <- yaml::read_yaml(file) + val <- yml[[label]][[key]] - # check if item is a list - if(length(grep(" - ",yml[ind_map+1]))>0){ - lst <- list(yml[ind_map + 1]) - k <- 2 - while (length(grep(" - ",yml[ind_map + k]))>0) { - lst[[k]] <- yml[ind_map + k] - k <- k+1 - } - val <- unlist(lapply(lst,function(x){strsplit(x,"- ")[[1]][2]})) + if(is.null(val)) { + stop(paste0(label, "/", key), ' not found in ', file) } - - if (length(val)==1){ - val2 <- NULL - - if(val == 'false'){ - val2 = FALSE - } - if(val == 'true'){ - val2 = TRUE - } - flg <- TRUE - flg <- tryCatch({!is.na(as.numeric(val))}, - warning = function(x)return(FALSE)) - if(flg){ - val2 = as.numeric(val) - } - if(is.null(val2)){ - val2 <- gsub('\"',"", val) - val2 <- as.character(val2) - } - } else { - val2 <- NULL - - if(all(val %in% c('false','true'))){ - val2 <- rep(TRUE,length(val)) - val2[val %in% 'false'] = FALSE - } - - flg <- TRUE - flg <- tryCatch({!is.na(as.numeric(val))}, - warning = function(x)return(FALSE)) - if(all(flg)){ - val2 = as.numeric(val) - } - if(is.null(val2)){ - val2 <- gsub('\"',"", val) - val2 <- as.character(val2) - } - } - - return(val2) + return(val) } From c029e991e2ff924d81e74655d2b71511b04503cf Mon Sep 17 00:00:00 2001 From: tadhg-moore Date: Tue, 23 Mar 2021 10:08:27 -0400 Subject: [PATCH 2/6] Added new yaml files --- NAMESPACE | 4 ++ R/get_yaml_value.R | 109 +++++++++++++++++++++++++++------ R/input_yaml.R | 14 ++--- R/read_yaml.R | 32 ++++++++++ R/set_yaml.R | 137 ++++++++++++++++++++++++++++++++++++++++++ R/write_yaml.R | 32 ++++++++++ man/get_yaml_value.Rd | 26 +++++--- man/read_yaml.Rd | 44 ++++++++++++++ man/set_yaml.Rd | 42 +++++++++++++ man/write_yaml.Rd | 35 +++++++++++ 10 files changed, 440 insertions(+), 35 deletions(-) create mode 100644 R/read_yaml.R create mode 100644 R/set_yaml.R create mode 100644 R/write_yaml.R create mode 100644 man/read_yaml.Rd create mode 100644 man/set_yaml.Rd create mode 100644 man/write_yaml.Rd diff --git a/NAMESPACE b/NAMESPACE index de70a41..51c3c2a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -46,10 +46,12 @@ export(plot_wbal) export(plot_wtemp) export(readAcpyParams) export(read_bestparam) +export(read_yaml) export(rmse) export(scan_timeseries) export(setAcpyDb) export(setRange) +export(set_yaml) export(setmodDepths) export(setspinup) export(streams_switch) @@ -61,6 +63,7 @@ export(ts_stat) export(ts_whole_laketemp) export(view_nc) export(wide2long) +export(write_yaml) import(RSQLite) import(XML) import(ggplot2) @@ -105,4 +108,5 @@ importFrom(tidyr,separate) importFrom(utils,read.delim) importFrom(utils,write.csv) importFrom(yaml,read_yaml) +importFrom(yaml,write_yaml) importFrom(zoo,na.approx) diff --git a/R/get_yaml_value.R b/R/get_yaml_value.R index bcd5567..57a4bef 100644 --- a/R/get_yaml_value.R +++ b/R/get_yaml_value.R @@ -1,25 +1,96 @@ -#' @title Extract values from yaml file -#' @description -#'Inputs values into yaml file by locating the label and key within the yaml file. Preserves comments (#) if present. NOTE: this does not use a yaml parser so if there are yaml formatting errors this function will not pick them up. -#' @param file filepath; to .yaml which you wish to edit -#' @param label string; which corresponds to section where the key is located -#' @param key string; name of key in which to input the value +#' Get a value from the loaded yaml file +#' +#' Get a value from a loaded yaml file. +#' @param yaml list; loaded using `read_yaml()` +#' @param ... character string with the keys from the yaml file. They need to be in consecutive order #' @export +#' @return list with updated yaml parameters #' @author -#'Tadhg Moore +#' Tadhg Moore #' @examples -#' yaml_file <- system.file('extdata/gotm.yaml', package = 'GOTMr') -#' get_yaml_value(file = yaml_file, label = 'airp', key = 'file') -#' @importFrom yaml read_yaml -#' @export #' -get_yaml_value <- function(file = 'gotm.yaml', label, key){ - - yml <- yaml::read_yaml(file) - val <- yml[[label]][[key]] +#' \dontrun{ +#' config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") +#' +#' yaml <- read_yaml(config_file) +#' +#' lat <- get_yaml_value(yaml, "location", "latitude") +#' kmin_init <- get_yaml_value(yaml, "calibration", "GOTM", "turb_param/k_min", "initial") +#' } - if(is.null(val)) { - stop(paste0(label, "/", key), ' not found in ', file) +get_yaml_value <- function(yaml, ...) { + + if(!is.list(yaml)) { + stop("yaml is not in the correct format. Load the yaml file using 'LakeEnsemblR::read_yaml()'") + } + + all_args <- list(...) + + nams1 <- names(yaml) + if(!(all_args[[1]] %in% nams1)) { + stop(paste0(all_args[[1]], " is not found in the first level in the yaml object. Options include: '", paste0(nams1, collapse = "', '"), "'.")) + } + + + if(length(all_args) == 1) { + if(length(names(yaml[[all_args[[1]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]]), collapse = "', '"), "'\n + You will need to add another argument")) + } + value <- yaml[[all_args[[1]]]] + } else if(length(all_args) == 2) { + nams2 <- names(yaml[[all_args[[1]]]]) + + if(!(all_args[[2]] %in% nams2)) { + stop(paste0(all_args[[2]], " is not found in the second level in the yaml object. Options include: '", paste0(nams2, collapse = "', '"), "'.")) + } + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]]), collapse = "', '"), "'\n + You will need to add another argument")) + } + value <- yaml[[all_args[[1]]]][[all_args[[2]]]] + } else if(length(all_args) == 3) { + nams2 <- names(yaml[[all_args[[1]]]]) + + if(!(all_args[[2]] %in% nams2)) { + stop(paste0(all_args[[2]], " is not found in the second level in the yaml object. Options include: '", paste0(nams2, collapse = "', '"), "'.")) + } + + nams3 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]]) + + if(!(all_args[[3]] %in% nams3)) { + stop(paste0(all_args[[3]], " is not found in the third level in the yaml object. Options include: '", paste0(nams3, collapse = "', '"), "'.")) + } + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]), collapse = "', '"), "'\n + You will need to add another argument")) + } + + + value <- yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]] + } else if(length(all_args) == 4) { + nams2 <- names(yaml[[all_args[[1]]]]) + + if(!(all_args[[2]] %in% nams2)) { + stop(paste0(all_args[[2]], " is not found in the first level in the yaml object. Options include: '", paste0(nams2, collapse = "', '"), "'.")) + } + + nams3 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]]) + + if(!(all_args[[3]] %in% nams3)) { + stop(paste0(all_args[[3]], " is not found in the second level in the yaml object. Options include: '", paste0(nams3, collapse = "', '"), "'.")) + } + + nams4 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]) + + if(!(all_args[[4]] %in% nams4)) { + stop(paste0(all_args[[3]], " is not found in the third level in the yaml object. Options include: '", paste0(nams4, collapse = "', '"), "'.")) + } + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]]), collapse = "', '"), "'\n + You will need to add another argument")) + } + value <- yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]] } - return(val) -} + return(value) +} \ No newline at end of file diff --git a/R/input_yaml.R b/R/input_yaml.R index b4a8378..aa1d304 100644 --- a/R/input_yaml.R +++ b/R/input_yaml.R @@ -16,10 +16,10 @@ input_yaml <- function(file = 'gotm.yaml', label, key, value, out_file = NULL){ yml <- readLines(file) - + # Prevent from finding labels/keys in comments yml_no_comments <- unname(sapply(yml, function(x) strsplit(x, "#")[[1]][1])) - + if(is.null(out_file)){ out_file = file } @@ -30,14 +30,14 @@ input_yaml <- function(file = 'gotm.yaml', label, key, value, out_file = NULL){ }else{ label_id <- paste0(label,':') ind_label <- grep(label_id, yml_no_comments) - + if(length(ind_label) == 0){ stop(label, ' not found in ', file) } } #Find index of key to replace - key_id <- paste0(' ',key, ':') + key_id <- paste0('\\b',key, ':') ind_key = grep(key_id, yml_no_comments) if(length(ind_key) == 0){ stop(key, ' not found in ', label, ' in ', file) @@ -63,9 +63,9 @@ input_yaml <- function(file = 'gotm.yaml', label, key, value, out_file = NULL){ } # if(!is.na(comment)){ - # sub = paste0(' ', value,' #', comment) + # sub = paste0(' ', value,' #', comment) # }else{ - sub = paste0(value,' ') + sub = paste0(value,' ') # } #Sub in new value @@ -75,7 +75,7 @@ input_yaml <- function(file = 'gotm.yaml', label, key, value, out_file = NULL){ yml[ind_map] <- gsub(pattern = paste0("\\Q", spl1[1], "\\E"), replacement = paste0(spl_tmp[1], ": ", sub), x = yml[ind_map]) - + #Write to file writeLines(yml, out_file) old_val <- gsub(" ", "", spl2, fixed = TRUE) #remove white space for printing diff --git a/R/read_yaml.R b/R/read_yaml.R new file mode 100644 index 0000000..068bcef --- /dev/null +++ b/R/read_yaml.R @@ -0,0 +1,32 @@ +#' Read a YAML file +#' +#' Read a YAML document from a file and create an R object from it. This is from the `yaml` package and is built to replicate the functionality used in the `glmtools` +#' package. +#' @param file filepath; to yaml file which you wish to edit +#' @param fileEncoding character string: if non-empty declares the encoding used on a file (not a connection) so the character data can be re-encoded. See file. +#' @param text character string: if file is not supplied and this is, then data are read from the value of text via a text connection. Notice that a literal string can be used to include (small) data sets within R code. +#' @param error.label a label to prepend to error messages (see Details). +#' @param ... arguments to pass to yaml.load +#' @return A list with the yaml file +#' @export +#' @author +#' Jeremy Stephens +#' @importFrom yaml read_yaml +#' @examples +#' +#' \dontrun{ +#' config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") +#' +#' yaml <- read_yaml(config_file) +#' yaml <- set_yaml(yaml, value = 23, key1 = "location", key2 = "latitude") +#' yaml <- set_yaml(yaml, value = "2010-06-01 00:00:00", key1 = "time", key2 = "start") +#' yaml <- set_yaml(yaml, value = "meteo.csv", key1 = "input", key2 = "meteo", key3 = "file") +#' yaml <- set_yaml(yaml, value = TRUE, key1 = "calibration", key2 = "GOTM", key3 = "turb_param/k_min", key4 = "log") +#' yaml <- set_yaml(yaml, value = c("temp", "salt"), key1 = "output", key2 = "variables") +#' +#' write_yaml(yaml, "LakeEnsemblR.yaml") +#' } + +read_yaml <- function(file, fileEncoding = "UTF-8", text, error.label, ...) { + yaml::read_yaml(file, fileEncoding = fileEncoding, text = text, error.label = error.label, ...) +} diff --git a/R/set_yaml.R b/R/set_yaml.R new file mode 100644 index 0000000..a3aae20 --- /dev/null +++ b/R/set_yaml.R @@ -0,0 +1,137 @@ +#' Set a value within the loaded yaml file +#' +#' Set the value within a yaml file. +#' @param yaml list; loaded using `read_yaml()` +#' @param value string; to be input into the the yaml file. +#' Note boolean values must be input as "true"/"false" as per the json format +#' @param ... string key1, key2, etc.: multiple keys pointing toward the line +#' that you want to edit in the yaml file. Keys must be listed consecutively, +#' without skipping numbers. +#' @export +#' @return list with updated yaml parameters +#' @author +#' Tadhg Moore +#' @examples +#' +#' \dontrun{ +#' config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") +#' +#' yaml <- read_yaml(config_file) +#' yaml <- set_yaml(yaml, value = 23, key1 = "location", key2 = "latitude") +#' yaml <- set_yaml(yaml, value = "2010-06-01 00:00:00", key1 = "time", key2 = "start") +#' yaml <- set_yaml(yaml, value = "meteo.csv", key1 = "input", key2 = "meteo", key3 = "file") +#' yaml <- set_yaml(yaml, value = TRUE, key1 = "calibration", key2 = "GOTM", key3 = "turb_param/k_min", key4 = "log") +#' yaml <- set_yaml(yaml, value = c("temp", "salt"), key1 = "output", key2 = "variables") +#' +#' write_yaml(yaml, "LakeEnsemblR.yaml") +#' } + +set_yaml <- function(yaml, value, ...) { + + if(!is.list(yaml)) { + stop("yaml is not in the correct format. Load the yaml file using 'LakeEnsemblR::read_yaml()'") + } + + # Users can provide multiple keys, named key1, key2, key3, etc. + all_args <- list(...) + # all_keys <- all_args[grepl("key", names(all_args))] + + nams1 <- names(yaml) + if(!(all_args[[1]] %in% nams1)) { + stop(paste0(all_args[[1]], " is not found in the first level in the yaml object. Options include: '", paste0(nams1, collapse = "', '"), "'.")) + } + + if(length(all_args) == 1) { + + if(length(names(yaml[[all_args[[1]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]]), collapse = "', '"), "'\n + You will need to add a key2 to your argument")) + } + + # Check classes + c1 <- class(yaml[[all_args[[1]]]]) + c2 <- class(value) + if(c1 != c2 & c1 != "NULL") { + stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]], " (", c1, ").")) + } + yaml[[all_args[[1]]]] <- value + } else if(length(all_args) == 2) { + + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]]), collapse = "', '"), "'\n + You will need to add a key3 to your argument")) + } + + # Check if second key is under the first key + nams1 <- names(yaml[[all_args[[1]]]]) + if(!(all_args[[2]] %in% nams1)) { + stop(paste0("'", all_args[[2]], "' is not nested under '", all_args[[1]], "'. Please select one of '", paste0(nams1, collapse = "', '"), "'.")) + } + # Check classes + c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]]) + c2 <- class(value) + if(c1 != c2 & c1 != "NULL") { + stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]], " (", c1, ").")) + } + yaml[[all_args[[1]]]][[all_args[[2]]]] <- value + } else if(length(all_args) == 3) { + + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]), collapse = "', '"), "'\n + You will need to add a key4 to your argument")) + } + + # Check if second key is under the first key + nams1 <- names(yaml[[all_args[[1]]]]) + if(!(all_args[[2]] %in% nams1)) { + stop(paste0("'", all_args[[2]], "' is not nested under '", all_args[[1]], "'. Please select one of '", paste0(nams1, collapse = "', '"), "'.")) + } + # Check if second key is under the first key + nams2 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]]) + + if(!(all_args[[3]] %in% nams2)) { + stop(paste0("'", all_args[[3]], "' is not nested under '", all_args[[2]], "'. Please select one of '", paste0(nams2, collapse = "', '"), "'.")) + } else { + c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]) + c2 <- class(value) + if(c1 != c2 & c1 != "NULL") { + stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]], " (", c1, ").")) + } + yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]] <- value + } + } else if(length(all_args) == 4) { + + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]])) > 1) { + stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]]), collapse = "', '"), "'\n + You will need to add a key5 to your argument")) + } + + # Check if second key is under the first key + nams1 <- names(yaml[[all_args[[1]]]]) + if(!(all_args[[2]] %in% nams1)) { + stop(paste0("'", all_args[[2]], "' is not nested under '", all_args[[1]], "'. Please select one of '", paste0(nams1, collapse = "', '"), "'.")) + } + # Check if second key is under the first key + nams2 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]]) + + if(!(all_args[[3]] %in% nams2)) { + stop(paste0("'", all_args[[3]], "' is not nested under '", all_args[[2]], "'. Please select one of '", paste0(nams2, collapse = "', '"), "'.")) + } + # Check if second key is under the first key + nams3 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]) + + if(!(all_args[[4]] %in% nams3)) { + stop(paste0("'", all_args[[4]], "' is not nested under '", all_args[[3]], "'. Please select one of '", paste0(nams3, collapse = "', '"), "'.")) + } else { + c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]]) + c2 <- class(value) + if(c1 != c2 & c1 != "NULL") { + stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]], " (", c1, ").")) + } + yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]] <- value + } + } + + return(yaml) + +} diff --git a/R/write_yaml.R b/R/write_yaml.R new file mode 100644 index 0000000..deb1383 --- /dev/null +++ b/R/write_yaml.R @@ -0,0 +1,32 @@ +#' Write a yaml object to file +#' +#' Write the YAML representation of an R object (list) to a file. Taken from the `yaml` package but added catch to replace 'yes' with 'true' and 'no' with 'false' +#' @param yaml list; loaded using `read_yaml()` +#' @param file filepath; to yaml file which you wish to edit +#' Note boolean values must be input as "true"/"false" as per the json format +#' @export +#' @importFrom yaml write_yaml +#' @author +#' Jeremy Stephens , Tadhg Moore +#' @examples +#' +#' \dontrun{ +#' config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") +#' +#' yaml <- read_yaml(config_file) +#' yaml <- set_yaml(yaml, value = 23, key1 = "location", key2 = "latitude") +#' yaml <- set_yaml(yaml, value = "2010-06-01 00:00:00", key1 = "time", key2 = "start") +#' yaml <- set_yaml(yaml, value = "meteo.csv", key1 = "input", key2 = "meteo", key3 = "file") +#' yaml <- set_yaml(yaml, value = TRUE, key1 = "calibration", key2 = "GOTM", key3 = "turb_param/k_min", key4 = "log") +#' yaml <- set_yaml(yaml, value = c("temp", "salt"), key1 = "output", key2 = "variables") +#' +#' write_yaml(yaml, "LakeEnsemblR.yaml") +#' } + +write_yaml <- function(x, file, fileEncoding = "UTF-8", ...) { + yaml::write_yaml(x, file, fileEncoding, ...) + lins <- readLines(file) + lins <- gsub("\\byes", "true", lins) + lins <- gsub("\\bno", "false", lins) + writeLines(lins, file) +} \ No newline at end of file diff --git a/man/get_yaml_value.Rd b/man/get_yaml_value.Rd index f908efe..a83c5b3 100644 --- a/man/get_yaml_value.Rd +++ b/man/get_yaml_value.Rd @@ -2,23 +2,31 @@ % Please edit documentation in R/get_yaml_value.R \name{get_yaml_value} \alias{get_yaml_value} -\title{Extract values from yaml file} +\title{Get a value from the loaded yaml file} \usage{ -get_yaml_value(file = "gotm.yaml", label, key) +get_yaml_value(yaml, ...) } \arguments{ -\item{file}{filepath; to .yaml which you wish to edit} +\item{yaml}{list; loaded using `read_yaml()`} -\item{label}{string; which corresponds to section where the key is located} - -\item{key}{string; name of key in which to input the value} +\item{...}{character string with the keys from the yaml file. They need to be in consecutive order} +} +\value{ +list with updated yaml parameters } \description{ -Inputs values into yaml file by locating the label and key within the yaml file. Preserves comments (#) if present. NOTE: this does not use a yaml parser so if there are yaml formatting errors this function will not pick them up. +Get a value from a loaded yaml file. } \examples{ -yaml_file <- system.file('extdata/gotm.yaml', package = 'GOTMr') -get_yaml_value(file = yaml_file, label = 'airp', key = 'file') + +\dontrun{ +config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") + +yaml <- read_yaml(config_file) + +lat <- get_yaml_value(yaml, "location", "latitude") +kmin_init <- get_yaml_value(yaml, "calibration", "GOTM", "turb_param/k_min", "initial") +} } \author{ Tadhg Moore diff --git a/man/read_yaml.Rd b/man/read_yaml.Rd new file mode 100644 index 0000000..e59dea0 --- /dev/null +++ b/man/read_yaml.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_yaml.R +\name{read_yaml} +\alias{read_yaml} +\title{Read a YAML file} +\usage{ +read_yaml(file, fileEncoding = "UTF-8", text, error.label, ...) +} +\arguments{ +\item{file}{filepath; to yaml file which you wish to edit} + +\item{fileEncoding}{character string: if non-empty declares the encoding used on a file (not a connection) so the character data can be re-encoded. See file.} + +\item{text}{character string: if file is not supplied and this is, then data are read from the value of text via a text connection. Notice that a literal string can be used to include (small) data sets within R code.} + +\item{error.label}{a label to prepend to error messages (see Details).} + +\item{...}{arguments to pass to yaml.load} +} +\value{ +A list with the yaml file +} +\description{ +Read a YAML document from a file and create an R object from it. This is from the `yaml` package and is built to replicate the functionality used in the `glmtools` +package. +} +\examples{ + +\dontrun{ +config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") + +yaml <- read_yaml(config_file) +yaml <- set_yaml(yaml, value = 23, key1 = "location", key2 = "latitude") +yaml <- set_yaml(yaml, value = "2010-06-01 00:00:00", key1 = "time", key2 = "start") +yaml <- set_yaml(yaml, value = "meteo.csv", key1 = "input", key2 = "meteo", key3 = "file") +yaml <- set_yaml(yaml, value = TRUE, key1 = "calibration", key2 = "GOTM", key3 = "turb_param/k_min", key4 = "log") +yaml <- set_yaml(yaml, value = c("temp", "salt"), key1 = "output", key2 = "variables") + +write_yaml(yaml, "LakeEnsemblR.yaml") +} +} +\author{ +Jeremy Stephens +} diff --git a/man/set_yaml.Rd b/man/set_yaml.Rd new file mode 100644 index 0000000..3e60a82 --- /dev/null +++ b/man/set_yaml.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/set_yaml.R +\name{set_yaml} +\alias{set_yaml} +\title{Set a value within the loaded yaml file} +\usage{ +set_yaml(yaml, value, ...) +} +\arguments{ +\item{yaml}{list; loaded using `read_yaml()`} + +\item{value}{string; to be input into the the yaml file. +Note boolean values must be input as "true"/"false" as per the json format} + +\item{...}{string key1, key2, etc.: multiple keys pointing toward the line +that you want to edit in the yaml file. Keys must be listed consecutively, +without skipping numbers.} +} +\value{ +list with updated yaml parameters +} +\description{ +Set the value within a yaml file. +} +\examples{ + +\dontrun{ +config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") + +yaml <- read_yaml(config_file) +yaml <- set_yaml(yaml, value = 23, key1 = "location", key2 = "latitude") +yaml <- set_yaml(yaml, value = "2010-06-01 00:00:00", key1 = "time", key2 = "start") +yaml <- set_yaml(yaml, value = "meteo.csv", key1 = "input", key2 = "meteo", key3 = "file") +yaml <- set_yaml(yaml, value = TRUE, key1 = "calibration", key2 = "GOTM", key3 = "turb_param/k_min", key4 = "log") +yaml <- set_yaml(yaml, value = c("temp", "salt"), key1 = "output", key2 = "variables") + +write_yaml(yaml, "LakeEnsemblR.yaml") +} +} +\author{ +Tadhg Moore +} diff --git a/man/write_yaml.Rd b/man/write_yaml.Rd new file mode 100644 index 0000000..920adf9 --- /dev/null +++ b/man/write_yaml.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write_yaml.R +\name{write_yaml} +\alias{write_yaml} +\title{Write a yaml object to file} +\usage{ +write_yaml(x, file, fileEncoding = "UTF-8", ...) +} +\arguments{ +\item{file}{filepath; to yaml file which you wish to edit +Note boolean values must be input as "true"/"false" as per the json format} + +\item{yaml}{list; loaded using `read_yaml()`} +} +\description{ +Write the YAML representation of an R object (list) to a file. Taken from the `yaml` package but added catch to replace 'yes' with 'true' and 'no' with 'false' +} +\examples{ + +\dontrun{ +config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") + +yaml <- read_yaml(config_file) +yaml <- set_yaml(yaml, value = 23, key1 = "location", key2 = "latitude") +yaml <- set_yaml(yaml, value = "2010-06-01 00:00:00", key1 = "time", key2 = "start") +yaml <- set_yaml(yaml, value = "meteo.csv", key1 = "input", key2 = "meteo", key3 = "file") +yaml <- set_yaml(yaml, value = TRUE, key1 = "calibration", key2 = "GOTM", key3 = "turb_param/k_min", key4 = "log") +yaml <- set_yaml(yaml, value = c("temp", "salt"), key1 = "output", key2 = "variables") + +write_yaml(yaml, "LakeEnsemblR.yaml") +} +} +\author{ +Jeremy Stephens , Tadhg Moore +} From 19da420c1f16f313f2c1c19a55c68d4ae994dc80 Mon Sep 17 00:00:00 2001 From: tadhg-moore Date: Tue, 23 Mar 2021 12:12:07 -0400 Subject: [PATCH 3/6] Add required functions --- R/analyse_strat.R | 302 ++++++++++++++++++++++++++++++++++++++++ R/create_init_prof.R | 31 +++++ man/analyse_strat.Rd | 31 +++++ man/create_init_prof.Rd | 25 ++++ 4 files changed, 389 insertions(+) create mode 100644 R/analyse_strat.R create mode 100644 R/create_init_prof.R create mode 100644 man/analyse_strat.Rd create mode 100644 man/create_init_prof.Rd diff --git a/R/analyse_strat.R b/R/analyse_strat.R new file mode 100644 index 0000000..5e46a23 --- /dev/null +++ b/R/analyse_strat.R @@ -0,0 +1,302 @@ +#' Returns stratification statstics +#' +#'Returns stratification statstics: annual mean, max and total +#'length of summer, winter stratification and ice duration. +#'NOTE: summer strat periods are allocated to the year in which the period starts. Winter stratification and ice periods are allocated to the year in which they end. +#' +#' @param data dataframe; water temperature data in long format with date, depths, value +#' @param H_ice vector; of ice thickness which corresponds to date vector, set to NULL if analysis not required. Defaults to NULL +#' @param drho numeric; density difference between top and bottom indicating stratificaiton [kg m^-3] +#' @param NH boolean; northern hemisphere? TRUE or FALSE. Defaults to true +#' @author Tom Shatwell, Tadhg Moore +#' +#' @examples +#' \dontrun{ +#' strat <- analyse_strat(Ts = df[,2], Tb = df[,ncol(df)], dates = df[,1]) +#' } +#' +#' @export + +analyse_strat <- function(data, H_ice = NULL, drho = 0.1, NH = TRUE){ + + data[,2] <- abs(data[,2]) + depths <- unique(data[,2]) + depths <- depths[order(depths)] + + # Find closest depth near the surface without NA + for(i in 1:length(depths)){ + Ts = data[data[,2] == depths[i],3] + if(sum(is.na(Ts))/length(Ts) < 0.25){ + if(i != 1){ + message('Warning: Using ', depths[i], ' as the surface.') + } + break + } + } + # Find closest depth near the bottom without NA + for(i in length(depths):1){ + Tb = data[data[,2] == depths[i],3] + if(sum(is.na(Tb))/length(Tb) < 0.25){ + if(i != 1){ + message('Warning: Using ', depths[i], ' as the bottom.') + } + break + } + } + + + + dates = unique(data[,1]) + + # Put into data frame and remove NA's + if(!is.null(H_ice)){ + df <- data.frame(dates, Ts, Tb, H_ice) + }else{ + df <- data.frame(dates, Ts, Tb) + } + df <- na.exclude(df) + if(nrow(df) == 0){ + message('Not enough data to calculate statification and/or ice statistics') + return() + } + dates <- df$dates + Ts <- df$Ts + Tb <- df$Tb + if(!is.null(H_ice)){ + H_ice <- df$H_ice + } + + + + the_years <- as.POSIXlt(dates)$year+1900 + yrs <- unique(the_years) + doys <- as.POSIXlt(dates)$yday # day of the year [0..364] + alt_doys <- doys # alternative counting from [-182 .. 182] for ice in northern hemisphere or strat in southern hemisphere + alt_doys[doys>182] <- doys[doys>182] - (365 + leap(the_years[doys>182])) # Jan 1 is day 0, correct for leap years + alt_years <- the_years + alt_years[alt_doys<0] <- the_years[alt_doys<0] +1 # alternative counting of years (shifted forward by half a year) + + if(NH) { # NH ice and SH stratification use alternative doy and year counts to adjust for ice and stratification events that span more than one calendar year + ice_yrs <- alt_years + ice_doys <- alt_doys + strat_yrs <- the_years + strat_doys <- doys + } else { + ice_yrs <- the_years + ice_doys <- doys + strat_yrs <- alt_years + strat_doys <- alt_doys + } + + s_strat <- (rho_water(t=Tb) - rho_water(t=Ts)) >= drho & Ts > Tb # logical whether stratified at each time step + # s_strat <- Ts - Tb > dT # logical whether stratified at each time step + + i_s_st <- diff(c(s_strat[1],s_strat))==1 # indices of stratification onset + i_s_en <- diff(c(s_strat[1],s_strat))==-1 # indices of stratification end + if(s_strat[1]) i_s_st <- c(NA, i_s_st) # if stratified at beginning of simulation, make first date NA + if(s_strat[length(s_strat)]) i_s_en <- c(i_s_en, NA) # if stratified at end of sim, set last strat date to NA + s_start <- dates[i_s_st] # summer strat start dates + s_end <- dates[i_s_en] # summer strat end dates + # if(sum(s_strat)==0) s_start <- s_end <- dates[1] # if never stratifies, set to time=0 + s_dur <- as.double(difftime(s_end, s_start, units="days")) # duration of summer strat periods + + a1 <- data.frame(year=strat_yrs[i_s_st], + start=s_start, end=s_end, dur=s_dur, + startday = strat_doys[i_s_st], + endday = strat_doys[i_s_en]) + a1 <- subset(a1, year %in% yrs) + + s.max <- s.mean <- s.tot <- s.on <- s.off <- + s.first <- s.last <- yr <- NULL + for(mm in unique(a1$year[!is.na(a1$year)])) { # remove NAs which are generated when the lake is stratified at the satrt or end of the simulation + a2 <- subset(a1, year==mm) + ind <- which.max(a2$dur) + if(nrow(a2)==1) if(is.na(a2$dur)) ind <- NA # fixes issue if stratified at end of data period + yr <- c(yr,mm) + s.max <- c(s.max,max(a2$dur)) + s.mean <- c(s.mean,mean(a2$dur)) + s.tot <- c(s.tot,sum(a2$dur)) + s.on <- c(s.on, as.POSIXlt(a2$start[ind])$yday) + s.off <- c(s.off, as.POSIXlt(a2$end[ind])$yday) + s.first <- c(s.first, min(a2$startday)) + s.last <- c(s.last, max(a2$endday)) + } + + # maximum surface temperature + # loop thru years to find Tmax and its day of year + TsMax <- NULL + for(ii in unique(strat_yrs)) { + Ts_maxi <- which.max(Ts[strat_yrs == ii]) + TsMaxOut <- data.frame(year=ii, + TsMax = Ts[strat_yrs == ii][Ts_maxi], + TsMaxDay = strat_doys[strat_yrs==ii][Ts_maxi], + TsMaxDate = dates[strat_yrs == ii][Ts_maxi] + ) + + TsMax <- rbind(TsMax, TsMaxOut) + } + + # minimum surface temperature + # loop thru years to find Tmax and its day of year + TsMin <- NULL + for(ii in unique(strat_yrs)) { + Ts_mini <- which.min(Ts[strat_yrs == ii]) + TsMinOut <- data.frame(year=ii, + TsMin = Ts[strat_yrs == ii][Ts_mini], + TsMinDay = strat_doys[strat_yrs==ii][Ts_mini], + TsMinDate = dates[strat_yrs == ii][Ts_mini] + ) + + TsMin <- rbind(TsMin, TsMinOut) + } + + # maximum bottom temperature + # loop thru years to find Tbmax and its day of year + TbMax <- NULL + for(ii in unique(strat_yrs)) { + Tb_maxi <- which.max(Tb[strat_yrs == ii]) + TbMaxOut <- data.frame(year=ii, + TbMax = Tb[strat_yrs == ii][Tb_maxi], + TbMaxDay = strat_doys[strat_yrs==ii][Tb_maxi], + TbMaxDate = dates[strat_yrs == ii][Tb_maxi] + ) + + TbMax <- rbind(TbMax, TbMaxOut) + } + + # minimum bottom temperature + # loop thru years to find Tbmax and its day of year + TbMin <- NULL + for(ii in unique(strat_yrs)) { + Tb_mini <- which.min(Tb[strat_yrs == ii]) + TbMinOut <- data.frame(year=ii, + TbMin = Tb[strat_yrs == ii][Tb_mini], + TbMinDay = strat_doys[strat_yrs==ii][Tb_mini], + TbMinDate = dates[strat_yrs == ii][Tb_mini] + ) + + TbMin <- rbind(TbMin, TbMinOut) + } + + # create empty data frame to fill with data (not all years may have strat or ice) + out <- data.frame(year=yrs, TsMax=NA, TsMaxDay=NA, TsMin=NA, TsMinDay=NA, TbMax=NA, TbMaxDay=NA, TbMin=NA, TbMinDay=NA, + MaxStratDur=NA, MeanStratDur=NA, TotStratDur=NA, + StratStart=NA, StratEnd=NA, + StratFirst=NA, StratLast=NA) + + out[match(TsMax$year, yrs), c("TsMax","TsMaxDay")] <- + TsMax[,c("TsMax","TsMaxDay")] + + out[match(TsMin$year, yrs), c("TsMin","TsMinDay")] <- + TsMin[,c("TsMin","TsMinDay")] + + out[match(TbMax$year, yrs), c("TbMax","TbMaxDay")] <- + TbMax[,c("TbMax","TbMaxDay")] + + out[match(TbMin$year, yrs), c("TbMin","TbMinDay")] <- + TbMin[,c("TbMin","TbMinDay")] + + out[match(yr, yrs), -1:-9] <- + data.frame(s.max,s.mean,s.tot,s.on,s.off,s.first,s.last) + + + # ice cover + if(!is.null(H_ice)) { # only do this if ice data provided + ice <- H_ice > 0 + i_i_st <- diff(c(ice[1],ice))==1 # indices of ice cover onset + i_i_en <- diff(c(ice[1],ice))==-1 # # indices of ice cover end + if(ice[1]) i_i_st <- c(NA, i_i_st) # if initially frozen, set first start date to NA + if(ice[length(ice)]) i_i_en <- c(i_i_en, NA) # if frozen at end, set last thaw date to NA + ice_st <- dates[i_i_st] # ice start dates + ice_en <- dates[i_i_en] # ice end dates + # if(sum(ice)==0) # if there is no ice at all, set start and end to time=0 + + # maximum ice thickness + IceMax <- NULL + for(ii in unique(ice_yrs)) { + Hice_maxi <- which.max(H_ice[ice_yrs == ii]) + IceMaxOut <- data.frame(year=ii, + HiceMax = H_ice[ice_yrs == ii][Hice_maxi], + HiceMaxDay = ice_doys[ice_yrs==ii][Hice_maxi], + HiceMaxDate = dates[ice_yrs == ii][Hice_maxi]) + if(sum(H_ice[ice_yrs == ii])==0) IceMaxOut[1,c("HiceMaxDay","HiceMaxDate")] <- NA + IceMax <- rbind(IceMax, IceMaxOut) + } + + ice_start_doys <- ice_doys[i_i_st] # day of year of start of ice cover events + ice_end_doys <- ice_doys[i_i_en] # day of year of end of ice cover events + ice_event_yrs <- ice_yrs[i_i_en] # the years assigned to each ice event + + # if there is no ice, set values to NA ... + if(sum(ice)==0) { + ice_start_doys <- ice_end_doys <- ice_event_yrs <- ice_st <- ice_en <- NA + } + ice_dur <- as.double(difftime(ice_en, ice_st, units="days")) # duration of ice periods + + + # summary of ice cover events + ice.summary <- data.frame(year = ice_event_yrs, + start = ice_st, + end = ice_en, + dur = ice_dur, + startday = ice_start_doys, + endday = ice_end_doys) + + ice_out <- NULL + for(mm in unique(ice.summary$year[!is.na(ice.summary$year)])) { + ice2 <- subset(ice.summary, year==mm) + ice2_on <- ice2[which.max(ice2$dur),"startday"] + ice2_off <- ice2[which.max(ice2$dur),"endday"] + if(anyNA(ice2$dur)) ice2_on <- ice2_off <- NA + + ice_out <- rbind(ice_out, + data.frame(year=mm, + MeanIceDur=mean(ice2$dur), + MaxIceDur=max(ice2$dur), + TotIceDur=sum(ice2$dur), + ice_on=ice2_on, + ice_off=ice2_off, + firstfreeze=min(ice2$startday), + lastthaw=max(ice2$endday))) + } + + ice_out <- ice_out[ice_out$year %in% yrs,] # trim years outside the simulation range (eg ice that forms at the end of the last year, which should be assigned to the following year outside the simulation period) + + ice_out1 <- data.frame(year=yrs, MeanIceDur=NA, MaxIceDur=NA, + TotIceDur=NA, IceOn=NA, IceOff=NA, FirstFreeze=NA, + LastThaw=NA, HiceMax=NA, HiceMaxDay=NA) + ice_out1[match(ice_out$year, yrs), + c("MeanIceDur","MaxIceDur","TotIceDur", + "IceOn","IceOff","FirstFreeze","LastThaw")] <- ice_out[,-1] + ice_out1[,c("HiceMax","HiceMaxDay")] <- IceMax[which(IceMax$year %in% ice_out1$year),c("HiceMax","HiceMaxDay")] + + out <- data.frame(out, ice_out1[,-1]) + + } + + # adjust some exceptions where stratification or ice extend longer than the cutoff period + i6 <- out$StratEnd < out$StratStart + i6[is.na(i6)]<-FALSE # this gets rid of any NAs + if(sum(i6, na.rm=TRUE)>0) out[i6, "StratEnd"] <- out[i6,"StratStart"] + out[i6,"MaxStratDur"] + i7 <- out$StratLast < out$StratStart & out$TotStratDur < 365 + i7[is.na(i7)]<-FALSE # this gets rid of any NAs + if(sum(i7, na.rm=TRUE)>0) out[i7, "StratLast"] <- out[i7,"StratLast"] + 364 + i8 <- out$IceOff < out$IceOn + i8[is.na(i8)]<-FALSE # this gets rid of any NAs + if(sum(i8, na.rm=TRUE)>0) out[i8, "IceOff"] <- out[i8,"IceOn"] + out[i8,"MaxIceDur"] + i9 <- out$LastThaw < out$IceOn & out$TotIceDur < 365 + i9[is.na(i9)]<-FALSE # this gets rid of any NAs + if(sum(i9, na.rm=TRUE)>0) out[i9, "LastThaw"] <- out[i9,"LastThaw"] + 364 + + return(out) +} + +# is it a leap year? +leap <- function(yr) ((yr%%4)==0) - ((yr%%100)==0) + ((yr%%400)==0) + +# Calculate density from temperature using the formula (Millero & Poisson, 1981): +# this is the method stated in the isimip 2b protocol in July 2019 +rho_water <- function(t) { + 999.842594 + (6.793952e-2 * t) - (9.095290e-3 * t^2) + + (1.001685e-4 * t^3) - (1.120083e-6 * t^4) + (6.536336e-9 * t^5) +} diff --git a/R/create_init_prof.R b/R/create_init_prof.R new file mode 100644 index 0000000..32d98c2 --- /dev/null +++ b/R/create_init_prof.R @@ -0,0 +1,31 @@ +#' Create initial profile for GOTM +#' +#' Extract and format the initial profile for GOTM from the observation file used in ACPy. +#' +#' @param obs_file filepath; Path to observation file +#' @param date character; Date in "YYYY-mm-dd HH:MM:SS" format to extract the initial profile. +#' @param tprof_file filepath; For the new initial temperature profile file. +#' @param print logical; Prints the temperature profile to the con +#' @param ... arguments to be passed to read.delim() for reading in observed file e.g "header <- TRUE, sep <- ','" +#' @return Message stating if the file has been created +#' @import utils +#' @export +create_init_prof <- function(obs_file, date, tprof_file, print = TRUE, ...){ + obs <- read.delim(obs_file, stringsAsFactors <- F, ...) + #obs[,1] <- as.POSIXct(obs[,1], tz <- 'UTC') + dat <- which(obs[,1] == date) + ndeps <- length(dat) + deps <- obs[dat,2] + tmp <- obs[dat,3] + df <- matrix(NA, nrow =1+ndeps, ncol =2) + df[1,1] <- date + df[1,2] <- paste0(ndeps,' ',2) + df[(2):(1+ndeps),1] <- as.numeric(obs[dat,2]) + df[(2):(1+ndeps),2] <- as.numeric(obs[dat,3]) + write.table(df, tprof_file, quote <- F, row.names <- F, col.names <- F, + sep <- "\t") + message('New inital temperature file ', tprof_file, ' has been created.') + if (print) { + print(df) + } +} diff --git a/man/analyse_strat.Rd b/man/analyse_strat.Rd new file mode 100644 index 0000000..4f97965 --- /dev/null +++ b/man/analyse_strat.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/analyse_strat.R +\name{analyse_strat} +\alias{analyse_strat} +\title{Returns stratification statstics} +\usage{ +analyse_strat(data, H_ice = NULL, drho = 0.1, NH = TRUE) +} +\arguments{ +\item{data}{dataframe; water temperature data in long format with date, depths, value} + +\item{H_ice}{vector; of ice thickness which corresponds to date vector, set to NULL if analysis not required. Defaults to NULL} + +\item{drho}{numeric; density difference between top and bottom indicating stratificaiton [kg m^-3]} + +\item{NH}{boolean; northern hemisphere? TRUE or FALSE. Defaults to true} +} +\description{ +Returns stratification statstics: annual mean, max and total +length of summer, winter stratification and ice duration. +NOTE: summer strat periods are allocated to the year in which the period starts. Winter stratification and ice periods are allocated to the year in which they end. +} +\examples{ +\dontrun{ +strat <- analyse_strat(Ts = df[,2], Tb = df[,ncol(df)], dates = df[,1]) +} + +} +\author{ +Tom Shatwell, Tadhg Moore +} diff --git a/man/create_init_prof.Rd b/man/create_init_prof.Rd new file mode 100644 index 0000000..c2122eb --- /dev/null +++ b/man/create_init_prof.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/create_init_prof.R +\name{create_init_prof} +\alias{create_init_prof} +\title{Create initial profile for GOTM} +\usage{ +create_init_prof(obs_file, date, tprof_file, print = TRUE, ...) +} +\arguments{ +\item{obs_file}{filepath; Path to observation file} + +\item{date}{character; Date in "YYYY-mm-dd HH:MM:SS" format to extract the initial profile.} + +\item{tprof_file}{filepath; For the new initial temperature profile file.} + +\item{print}{logical; Prints the temperature profile to the con} + +\item{...}{arguments to be passed to read.delim() for reading in observed file e.g "header <- TRUE, sep <- ','"} +} +\value{ +Message stating if the file has been created +} +\description{ +Extract and format the initial profile for GOTM from the observation file used in ACPy. +} From 9027e21800430c29ea2ef8357212a4350e3ec9a8 Mon Sep 17 00:00:00 2001 From: Tadhg Moore Date: Fri, 28 May 2021 16:47:20 -0400 Subject: [PATCH 4/6] Added catch for RelHum values outside 0-100 --- R/calc_cc.R | 16 ++++++++++------ man/calc_cc.Rd | 12 +++++++++++- 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/R/calc_cc.R b/R/calc_cc.R index 3f3629b..8b3d1cb 100644 --- a/R/calc_cc.R +++ b/R/calc_cc.R @@ -24,19 +24,20 @@ #' plot(cc) #' @importFrom stats aggregate #' @importFrom zoo na.approx +#' @importFrom lubridate hours hour yday #' @export -calc_cc <- function(date, airt, relh = NULL, dewt = NULL, swr, lat, lon, elev, daily = F){ +calc_cc <- function(date, airt, relh = NULL, dewt = NULL, swr, lat, lon, elev, daily = FALSE){ orig_date = date timestep = difftime(orig_date[2], orig_date[1], units = "secs") - + # If the time step is 24 hours or more, create artificial hourly time steps if(timestep >= as.difftime(24, units = "hours")){ - date = seq.POSIXt(from = date[1], to = (date[length(date)] + timestep - hours(1)), by = '1 hour') + date = seq.POSIXt(from = date[1], to = (date[length(date)] + timestep - lubridate::hours(1)), by = '1 hour') } - - yday <- yday(date) - hour <- hour(date) + + yday <- lubridate::yday(date) + hour <- lubridate::hour(date) hour[hour == 0] <- 24 std.mer = seq(-90,90, 15) @@ -99,6 +100,9 @@ calc_cc <- function(date, airt, relh = NULL, dewt = NULL, swr, lat, lon, elev, d # Dewpoint temperature if(is.null(dewt)){ + if(any(relh <= 0 | relh > 100)) { + stop("Some of the relative humidity values are outside the bounds 0-100. Please inspect values.") + } dewt <- 243.04*(log(relh/100)+((17.625*airt)/(243.04+airt)))/(17.625-log(relh/100)-((17.625*airt)/(243.04+airt))) } if(timestep >= as.difftime(2, units = "hours")){ diff --git a/man/calc_cc.Rd b/man/calc_cc.Rd index 8ab71e5..bc4dee5 100644 --- a/man/calc_cc.Rd +++ b/man/calc_cc.Rd @@ -4,7 +4,17 @@ \alias{calc_cc} \title{Calculate cloud cover} \usage{ -calc_cc(date, airt, relh = NULL, dewt = NULL, swr, lat, lon, elev, daily = F) +calc_cc( + date, + airt, + relh = NULL, + dewt = NULL, + swr, + lat, + lon, + elev, + daily = FALSE +) } \arguments{ \item{date}{vector; Dates in as.POSixct class} From 8d99fa46d55fa8f88404ca76e51296fed3c118a8 Mon Sep 17 00:00:00 2001 From: Tadhg Moore Date: Fri, 28 May 2021 16:47:36 -0400 Subject: [PATCH 5/6] Added dependencies for calc_cc --- NAMESPACE | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 51c3c2a..f8f13eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -92,7 +92,10 @@ importFrom(graphics,legend) importFrom(gridExtra,grid.arrange) importFrom(hydroGOF,NSE) importFrom(hydroGOF,rmse) +importFrom(lubridate,hour) +importFrom(lubridate,hours) importFrom(lubridate,month) +importFrom(lubridate,yday) importFrom(lubridate,year) importFrom(ncdf4,nc_close) importFrom(ncdf4,nc_open) From 77cf6cff3950b5bd90e04b48d8386e99c68e97ec Mon Sep 17 00:00:00 2001 From: Tadhg Moore Date: Mon, 28 Jun 2021 11:12:22 -0400 Subject: [PATCH 6/6] Remove class check --- R/set_yaml.R | 76 ++++++++++++++++++++++++++-------------------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/R/set_yaml.R b/R/set_yaml.R index a3aae20..67dcdd5 100644 --- a/R/set_yaml.R +++ b/R/set_yaml.R @@ -15,72 +15,72 @@ #' #' \dontrun{ #' config_file <- system.file("extdata/feeagh/LakeEnsemblR.yaml", package = "LakeEnsemblR") -#' +#' #' yaml <- read_yaml(config_file) #' yaml <- set_yaml(yaml, value = 23, key1 = "location", key2 = "latitude") #' yaml <- set_yaml(yaml, value = "2010-06-01 00:00:00", key1 = "time", key2 = "start") #' yaml <- set_yaml(yaml, value = "meteo.csv", key1 = "input", key2 = "meteo", key3 = "file") #' yaml <- set_yaml(yaml, value = TRUE, key1 = "calibration", key2 = "GOTM", key3 = "turb_param/k_min", key4 = "log") #' yaml <- set_yaml(yaml, value = c("temp", "salt"), key1 = "output", key2 = "variables") -#' +#' #' write_yaml(yaml, "LakeEnsemblR.yaml") #' } set_yaml <- function(yaml, value, ...) { - + if(!is.list(yaml)) { stop("yaml is not in the correct format. Load the yaml file using 'LakeEnsemblR::read_yaml()'") } - + # Users can provide multiple keys, named key1, key2, key3, etc. all_args <- list(...) # all_keys <- all_args[grepl("key", names(all_args))] - + nams1 <- names(yaml) if(!(all_args[[1]] %in% nams1)) { stop(paste0(all_args[[1]], " is not found in the first level in the yaml object. Options include: '", paste0(nams1, collapse = "', '"), "'.")) } - + if(length(all_args) == 1) { - + if(length(names(yaml[[all_args[[1]]]])) > 1) { stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]]), collapse = "', '"), "'\n You will need to add a key2 to your argument")) } - + # Check classes - c1 <- class(yaml[[all_args[[1]]]]) - c2 <- class(value) - if(c1 != c2 & c1 != "NULL") { - stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]], " (", c1, ").")) - } + # c1 <- class(yaml[[all_args[[1]]]]) + # c2 <- class(value) + # if(c1 != c2 & c1 != "NULL") { + # stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]], " (", c1, ").")) + # } yaml[[all_args[[1]]]] <- value } else if(length(all_args) == 2) { - + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]])) > 1) { stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]]), collapse = "', '"), "'\n You will need to add a key3 to your argument")) } - + # Check if second key is under the first key nams1 <- names(yaml[[all_args[[1]]]]) if(!(all_args[[2]] %in% nams1)) { stop(paste0("'", all_args[[2]], "' is not nested under '", all_args[[1]], "'. Please select one of '", paste0(nams1, collapse = "', '"), "'.")) } # Check classes - c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]]) - c2 <- class(value) - if(c1 != c2 & c1 != "NULL") { - stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]], " (", c1, ").")) - } + # c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]]) + # c2 <- class(value) + # if(c1 != c2 & c1 != "NULL") { + # stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]], " (", c1, ").")) + # } yaml[[all_args[[1]]]][[all_args[[2]]]] <- value } else if(length(all_args) == 3) { - + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]])) > 1) { stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]), collapse = "', '"), "'\n You will need to add a key4 to your argument")) } - + # Check if second key is under the first key nams1 <- names(yaml[[all_args[[1]]]]) if(!(all_args[[2]] %in% nams1)) { @@ -88,24 +88,24 @@ set_yaml <- function(yaml, value, ...) { } # Check if second key is under the first key nams2 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]]) - + if(!(all_args[[3]] %in% nams2)) { stop(paste0("'", all_args[[3]], "' is not nested under '", all_args[[2]], "'. Please select one of '", paste0(nams2, collapse = "', '"), "'.")) } else { - c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]) - c2 <- class(value) - if(c1 != c2 & c1 != "NULL") { - stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]], " (", c1, ").")) - } + # c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]) + # c2 <- class(value) + # if(c1 != c2 & c1 != "NULL") { + # stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]], " (", c1, ").")) + # } yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]] <- value } } else if(length(all_args) == 4) { - + if(length(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]])) > 1) { stop(paste0("There are multiple keys on this level: '", paste0(names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]]), collapse = "', '"), "'\n You will need to add a key5 to your argument")) } - + # Check if second key is under the first key nams1 <- names(yaml[[all_args[[1]]]]) if(!(all_args[[2]] %in% nams1)) { @@ -113,25 +113,25 @@ set_yaml <- function(yaml, value, ...) { } # Check if second key is under the first key nams2 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]]) - + if(!(all_args[[3]] %in% nams2)) { stop(paste0("'", all_args[[3]], "' is not nested under '", all_args[[2]], "'. Please select one of '", paste0(nams2, collapse = "', '"), "'.")) } # Check if second key is under the first key nams3 <- names(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]]) - + if(!(all_args[[4]] %in% nams3)) { stop(paste0("'", all_args[[4]], "' is not nested under '", all_args[[3]], "'. Please select one of '", paste0(nams3, collapse = "', '"), "'.")) } else { - c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]]) - c2 <- class(value) - if(c1 != c2 & c1 != "NULL") { - stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]], " (", c1, ").")) - } + # c1 <- class(yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]]) + # c2 <- class(value) + # if(c1 != c2 & c1 != "NULL") { + # stop(paste0(value, " (", c2, ") is not the same class as ", yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]], " (", c1, ").")) + # } yaml[[all_args[[1]]]][[all_args[[2]]]][[all_args[[3]]]][[all_args[[4]]]] <- value } } - + return(yaml) }