diff --git a/.Rbuildignore b/.Rbuildignore index da248cd..2862990 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -18,4 +18,8 @@ test_stats_huc12_modeled_performance.R appveyor.yml EflowStats.bbl ^appveyor\.yml$ -CONDUCT.md \ No newline at end of file +CONDUCT.md +code.json +DISCLAIMER.md +LICENSE.md +README.Rmd \ No newline at end of file diff --git a/R/calc_durationLow.R b/R/calc_durationLow.R index d348c9f..8267fb4 100644 --- a/R/calc_durationLow.R +++ b/R/calc_durationLow.R @@ -93,10 +93,10 @@ calc_durationLow <- function(x,yearType = "water",wyMonth=10L,digits=3,pref="mea meanFlow = mean(discharge), totalFlow = sum(discharge)) minRollingMean <- dplyr::summarize(dplyr::group_by(x,year_val), - minRoll3Mean = min(roll3Mean), - minRoll7Mean = min(roll7Mean), - minRoll30Mean = min(roll30Mean), - minRoll90Mean = min(roll90Mean) + minRoll3Mean = min(roll3Mean,na.rm=TRUE), + minRoll7Mean = min(roll7Mean,na.rm=TRUE), + minRoll30Mean = min(roll30Mean,na.rm=TRUE), + minRoll90Mean = min(roll90Mean,na.rm=TRUE) ) medFlow <- median(x$discharge) diff --git a/R/calc_timingAverage.R b/R/calc_timingAverage.R index f9e6bfe..4acfb46 100644 --- a/R/calc_timingAverage.R +++ b/R/calc_timingAverage.R @@ -57,17 +57,18 @@ calc_timingAverage <- function(x,yearType = "water",wyMonth=10L,digits=3,pref="m #calculate some stuff for use later x$month_val <- lubridate::month(x$date) + x$dayom_val <- lubridate::mday(x$date) meanFlow <- mean(x$discharge) - ###Remove leap year data to calculate Colwell matrix - #Remove feb29th for Colwell matrix - x <- x[!(x$month_val == 2 & - yday(x$date) == 29),] + # remove all February 29th from the time series to calculate + # Colwell matrix + x <- x[!((x$month_val == 2) & (x$dayom_val == 29)),] + + # #Get a new julian day value that does not count leap years + # after removing the 29th of Feb, we can count the rows sequentially + # for each unique water year; https://stackoverflow.com/a/46613159 + x$day <- sequence(rle(x$year_val)$lengths) - #Get a new julian day value that does not count leap years - x$day[is.leapyear(x$year_val) & - x$day > 152] <- x$day[is.leapyear(x$year_val) & - x$day > 152] - 1 #Calculate the colwell matrix... log_meanFlow = log10(meanFlow) x$log_discharge = log10(x$discharge) diff --git a/R/cut_dataToWaterYear.R b/R/cut_dataToWaterYear.R index a162a14..bc5c1ec 100644 --- a/R/cut_dataToWaterYear.R +++ b/R/cut_dataToWaterYear.R @@ -1,6 +1,8 @@ #' Cuts the discharge time series to full water years #' @param x data.frame containing a vector of date values in the first #' column and vector of numeric flow values in the second column. +#' @param yearType A character of either "water" or "calendar" indicating +#' whether to use water years or calendar years, respectively. #' @param wyMonth A numeric. The month of the year in which the water year starts #' (1=January, 12=December). The water year begins on the first day of wyMonth. #' @return data.frame in original structure, but cut to full water years @@ -9,6 +11,7 @@ #' #' \enumerate{ #' \item First column must be of class `Date`. #' \item Second must be of class `numeric`. +#' \item `yearType` input must be either "water" or "calendar". #' \item `wyMonth`input must be of class `integer`. #' } #' @examples @@ -16,7 +19,7 @@ #' cut_dataToWaterYear(x,10L) #' @export #' -cut_dataToWaterYear <- function(x,wyMonth=10L) { +cut_dataToWaterYear <- function(x, yearType, wyMonth=10L) { ###rename dataframe for convenient use inside function old_names <- colnames(x) names(x) <- c("date","discharge") @@ -34,8 +37,8 @@ cut_dataToWaterYear <- function(x,wyMonth=10L) { ndays_last_year <- nrow(x[x$year_val == last_year,]) # get the target number of days (depends if water year is in a leap year or not) - ndays_first_year_target <- ifelse(lubridate::leap_year(first_year), 366, 365) - ndays_last_year_target <- ifelse(lubridate::leap_year(last_year), 366, 365) + ndays_first_year_target <- ifelse(is.leapyear(first_year, yearType, wyMonth), 366, 365) + ndays_last_year_target <- ifelse(is.leapyear(last_year, yearType, wyMonth), 366, 365) # remove the first and last year if number of days is less than target number if(ndays_first_year < ndays_first_year_target){ diff --git a/R/get_waterYear.R b/R/get_waterYear.R index 4eb29f5..243e67e 100644 --- a/R/get_waterYear.R +++ b/R/get_waterYear.R @@ -10,19 +10,41 @@ #' get_waterYear(sampleData$date) #' get_waterYear <- function(x, wyMonth=10L, numeric=TRUE) { - ## Coding history: - ## 2005Jul14 DLLorenz Initial dated verion - ## 2010Feb17 DLLorenz Added option to return numerics - ## 2011Jun07 DLLorenz Conversion to R - ## 2012Aug11 DLLorenz Integer fixes - ## 2013Feb15 DLLorenz Prep for gitHub - ## 2016Aug12 Joe Mills copied this from smwrBase - x <- as.POSIXlt(x) - yr <- x$year + 1900L - mn <- x$mon + 1L - ## adjust for water year - yr <- yr + ifelse(mn < wyMonth, 0L, 1L) - if(numeric) - return(yr) - ordered(yr) + ## Coding history: + ## 2005Jul14 DLLorenz Initial dated verion + ## 2010Feb17 DLLorenz Added option to return numerics + ## 2011Jun07 DLLorenz Conversion to R + ## 2012Aug11 DLLorenz Integer fixes + ## 2013Feb15 DLLorenz Prep for gitHub + ## 2016Aug12 Joe Mills copied this from smwrBase + ## 2023Aug04 Jens Kiesel added different calculation if wyMonth < 7 + ## (see explanation below) + x <- as.POSIXlt(x) + yr <- x$year + 1900L + mn <- x$mon + 1L # x$mon starts at 0 for Jan! + if (wyMonth < 7){ + # it is most intuitive that the water year value should be the calendar + # year with the most dates in the water year. Jan.-Jun. would be assigned + # the previous calendar year as the water year value and Jul.-Dec. would be assigned + + # the current calendar year as the water year value. + + + # If the water year is supposed to start in Jan-Jun (e.g. April): + # yr for Jan-Mar must be the previous calendar year, + + # yr for Apr-Dec must be the current calendar year + + yr <- yr - ifelse(mn < wyMonth, 1L, 0L) + }else{ + # If the water year is supposed to start in Jul-Dec (e.g. September): + # yr for Jan-August must be the current calendar year, + + # yr for Sep-Dec must be the next calendar year + + yr <- yr + ifelse(mn < wyMonth, 0L, 1L) + } + if(numeric) + return(yr) + ordered(yr) } diff --git a/R/isleapYear.R b/R/isleapYear.R index 8313aca..46fe922 100644 --- a/R/isleapYear.R +++ b/R/isleapYear.R @@ -1,5 +1,22 @@ #courtesy of R bloggers for is.leapyear -is.leapyear <- function(year){ - #http://en.wikipedia.org/wiki/Leap_year - return(((year %% 4 == 0) & (year %% 100 != 0)) | (year %% 400 == 0)) +is.leapyear <- function(year, yearType='calendar', wyMonth=10L){ + if (yearType=='calendar' || wyMonth<3 || wyMonth>6) { + #http://en.wikipedia.org/wiki/Leap_year + return(((year %% 4 == 0) & (year %% 100 != 0)) | (year %% 400 == 0)) + }else if ((yearType=='water') && (wyMonth>=3 && wyMonth <=6)) { + # + # add 1 year if water year is supposed to start in Mar, Apr, May, Jun. + # For these cases, the water year is assigned the previous + # year value but contains the leap day. + # + # Example: + # Time series: 01Apr1999 - 31Mar2000 + # wyMonth = 4 + # Assigned water year: 1999 + # Number of days: 366 (because it contains 29Feb2000) + # -> Function must return true for 1999 (and any other year that + # precedes a leap year) + # + return((((year+1) %% 4 == 0) & ((year+1) %% 100 != 0)) | ((year+1) %% 400 == 0)) + } } \ No newline at end of file diff --git a/R/validate_data.R b/R/validate_data.R index 5448906..bb6de13 100644 --- a/R/validate_data.R +++ b/R/validate_data.R @@ -73,7 +73,8 @@ validate_data <- function(x,yearType,wyMonth=10L) { } #check for complete years - x$leapYear <- is.leapyear(as.numeric(as.character(x$year_val))) + x$leapYear <- is.leapyear(as.numeric(as.character(x$year_val)), + yearType, wyMonth) fullYearCheck <- dplyr::summarize(dplyr::group_by(x,year_val), completeYear = diff --git a/man/cut_dataToWaterYear.Rd b/man/cut_dataToWaterYear.Rd index e8197aa..9cbd390 100644 --- a/man/cut_dataToWaterYear.Rd +++ b/man/cut_dataToWaterYear.Rd @@ -4,12 +4,15 @@ \alias{cut_dataToWaterYear} \title{Cuts the discharge time series to full water years} \usage{ -cut_dataToWaterYear(x, wyMonth = 10L) +cut_dataToWaterYear(x, yearType, wyMonth = 10L) } \arguments{ \item{x}{data.frame containing a vector of date values in the first column and vector of numeric flow values in the second column.} +\item{yearType}{A character of either "water" or "calendar" indicating +whether to use water years or calendar years, respectively.} + \item{wyMonth}{A numeric. The month of the year in which the water year starts (1=January, 12=December). The water year begins on the first day of wyMonth.} } @@ -25,6 +28,7 @@ EflowStats functions. #' \enumerate{ \item First column must be of class `Date`. \item Second must be of class `numeric`. + \item `yearType` input must be either "water" or "calendar". \item `wyMonth`input must be of class `integer`. } } diff --git a/tests/testthat/data/tests_calc_allHIT.rds b/tests/testthat/data/tests_calc_allHIT.rds index e21fcaa..208fd97 100644 Binary files a/tests/testthat/data/tests_calc_allHIT.rds and b/tests/testthat/data/tests_calc_allHIT.rds differ diff --git a/tests/testthat/data/tests_calc_allHIT_bug.rds b/tests/testthat/data/tests_calc_allHIT_bug.rds index 78cd128..94c66dd 100644 Binary files a/tests/testthat/data/tests_calc_allHIT_bug.rds and b/tests/testthat/data/tests_calc_allHIT_bug.rds differ diff --git a/tests/testthat/data/tests_calc_allHIT_med.rds b/tests/testthat/data/tests_calc_allHIT_med.rds index ae56ce2..28a7b7e 100644 Binary files a/tests/testthat/data/tests_calc_allHIT_med.rds and b/tests/testthat/data/tests_calc_allHIT_med.rds differ diff --git a/tests/testthat/data/tests_calc_durationLow.rds b/tests/testthat/data/tests_calc_durationLow.rds index 97dfe31..9887814 100644 Binary files a/tests/testthat/data/tests_calc_durationLow.rds and b/tests/testthat/data/tests_calc_durationLow.rds differ diff --git a/tests/testthat/data/tests_calc_durationLow_nwis_mean.rds b/tests/testthat/data/tests_calc_durationLow_nwis_mean.rds index b761658..140caa9 100644 Binary files a/tests/testthat/data/tests_calc_durationLow_nwis_mean.rds and b/tests/testthat/data/tests_calc_durationLow_nwis_mean.rds differ diff --git a/tests/testthat/data/tests_calc_durationLow_nwis_median.rds b/tests/testthat/data/tests_calc_durationLow_nwis_median.rds index 165a91f..35a0d9a 100644 Binary files a/tests/testthat/data/tests_calc_durationLow_nwis_median.rds and b/tests/testthat/data/tests_calc_durationLow_nwis_median.rds differ diff --git a/tests/testthat/data/tests_calc_timingAverage_1158Thresh.rds b/tests/testthat/data/tests_calc_timingAverage_1158Thresh.rds index ff7ec86..5207740 100644 Binary files a/tests/testthat/data/tests_calc_timingAverage_1158Thresh.rds and b/tests/testthat/data/tests_calc_timingAverage_1158Thresh.rds differ diff --git a/tests/testthat/tests_calc_durationLow.R b/tests/testthat/tests_calc_durationLow.R index 5e8191a..ddbdee4 100644 --- a/tests/testthat/tests_calc_durationLow.R +++ b/tests/testthat/tests_calc_durationLow.R @@ -5,14 +5,14 @@ test_that("duration low pref mean", { x<-sampleData[c("date","discharge")] calc_durationLowTest <- calc_durationLow(x=x,yearType="water",pref = "mean") - calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow.rds") + #calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow.rds") - expect_equal(calc_durationLowTest,calc_durationLowTestCheck) + expect_equal_to_reference(calc_durationLowTest,"data/tests_calc_durationLow.rds") x <- readRDS("data/sample_nwis_data.rds") calc_durationLowTest <- calc_durationLow(x=x,yearType="water",pref = "mean") - calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow_nwis_mean.rds") - expect_equal(calc_durationLowTest,calc_durationLowTestCheck) + #calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow_nwis_mean.rds") + expect_equal_to_reference(calc_durationLowTest,"data/tests_calc_durationLow_nwis_mean.rds") }) @@ -21,12 +21,11 @@ test_that("duration low pref median", { x<-sampleData[c("date","discharge")] calc_durationLowTest <- calc_durationLow(x=x,yearType="water", pref = "median") - calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow.rds") - - expect_equal(calc_durationLowTest,calc_durationLowTestCheck) + #calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow.rds") + expect_equal_to_reference(calc_durationLowTest,"data/tests_calc_durationLow.rds") x <- readRDS("data/sample_nwis_data.rds") calc_durationLowTest <- calc_durationLow(x=x,yearType="water", pref = "median") - calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow_nwis_median.rds") - expect_equal(calc_durationLowTest,calc_durationLowTestCheck) + #calc_durationLowTestCheck <- readRDS("data/tests_calc_durationLow_nwis_median.rds") + expect_equal_to_reference(calc_durationLowTest,"data/tests_calc_durationLow_nwis_median.rds") }) diff --git a/tests/testthat/tests_calc_timingAverage.R b/tests/testthat/tests_calc_timingAverage.R index a3bd14a..281d738 100644 --- a/tests/testthat/tests_calc_timingAverage.R +++ b/tests/testthat/tests_calc_timingAverage.R @@ -5,9 +5,8 @@ test_that("timing average", { x<-sampleData[c("date","discharge")] calc_timingAverageOutTest <- calc_timingAverage(x, floodThreshold = 1158) - calc_timingAverageOut <- readRDS("data/tests_calc_timingAverage_1158Thresh.rds") - - expect_equal(calc_timingAverageOutTest,calc_timingAverageOut) + #calc_timingAverageOut <- readRDS("data/tests_calc_timingAverage_1158Thresh.rds") + expect_equal_to_reference(calc_timingAverageOutTest,"data/tests_calc_timingAverage_1158Thresh.rds") }) test_that("timing average works with very low flows", { @@ -17,7 +16,7 @@ test_that("timing average works with very low flows", { x$discharge <- x$discharge/1000 calc_timingAverageOutTest <- calc_timingAverage(x, floodThreshold = 1) - expect_equal(calc_timingAverageOutTest$statistic,c(0.306,80.386, 0.5)) + expect_equal(calc_timingAverageOutTest$statistic,c(0.305,80.359, 0.5)) }) diff --git a/tests/testthat/tests_cut_dataToWaterYear.R b/tests/testthat/tests_cut_dataToWaterYear.R index cb88179..edf722f 100644 --- a/tests/testthat/tests_cut_dataToWaterYear.R +++ b/tests/testthat/tests_cut_dataToWaterYear.R @@ -1,7 +1,7 @@ test_that("cut water year", { x <- sampleData[, c('date', 'discharge')] - cut <- cut_dataToWaterYear(x, 8) + cut <- cut_dataToWaterYear(x, 'water', 8) expect_equal(cut$date[1], structure(15187, class = "Date")) @@ -13,7 +13,7 @@ test_that("cut water year", { expect_equal(nrow(cut), 366) - cut <- cut_dataToWaterYear(x, 11) + cut <- cut_dataToWaterYear(x, 'water', 11) expect_equal(cut$date[1], structure(14914, class = "Date"))