Merge pull request #198 from DOI-USGS/contribute

Fix up Check

.Rbuildignore

@@ -18,4 +18,8 @@ test_stats_huc12_modeled_performance.R
 appveyor.yml
 EflowStats.bbl
 ^appveyor\.yml$
-CONDUCT.md
+CONDUCT.md
+code.json
+DISCLAIMER.md
+LICENSE.md
+README.Rmd

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)
 

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)

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,14 +11,15 @@
 #' #' \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
 #' x <- sampleData[, c('date', 'discharge')]
 #' 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){

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)
 }

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)) 
+  }
 }

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 = 

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")
 })

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))
 
 })
 

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"))