Merge pull request #17 from bcgov/devel

v0.2.4

Author: boshek

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: tidyhydat
 Title: Extract tidy hydrometric data
-Version: 0.2.3
+Version: 0.2.4
 Authors@R: c(person("Sam", "Albers", email = "sam.albers@gov.bc.ca", role = c("aut", "cre"),
            ), person("Dave", "Hutchinson", email = "david.hutchinson@canada.ca", role = "ctb"))
 Description: tidyhydat provides functions to extract river data from Water Survey of Canada sources and make it tidy.

NAMESPACE

@@ -18,6 +18,7 @@ export(STN_OPERATION_SCHEDULE)
 export(STN_REGULATION)
 export(STN_REMARKS)
 export(VERSION)
+export(download_hydat)
 export(download_realtime_dd)
 export(download_realtime_ws)
 export(get_ws_token)
@@ -35,3 +36,5 @@ importFrom(lubridate,year)
 importFrom(lubridate,ymd)
 importFrom(tibble,tibble)
 importFrom(tidyr,gather)
+importFrom(utils,download.file)
+importFrom(utils,unzip)

NEWS.md

@@ -1,9 +1,15 @@
+#tidyhydat 0.2.4
+* download_realtime_dd can now accept stations from multiple provinces or simply select multiple provinces
+* better error messages for get_ws_token and download_realtime_ws
+* All functions that previously accepted STATION_NUMBER == "ALL" now throw an error. 
+* Added function to download hydat
+
 #tidyhydat 0.2.3
 * Remove significant redundancy in station selecting mechanism
 * Added package startup message when HYDAT is out of date  
 * Add internal allstations data
 * Added all the tables as functions or data from HYDAT
-* Made missing station ouput truncated at 10 missign stations
+* Made missing station ouput truncated at 10 missing stations
 
 # tidyhdyat 0.2.2
 * Adding several new tables

R/ANNUAL_STATISTICS.R

@@ -37,6 +37,10 @@
 ANNUAL_STATISTICS <- function(hydat_path=NULL, STATION_NUMBER =NULL, PROV_TERR_STATE_LOC=NULL, 
                               start_year = "ALL", end_year = "ALL") {
 
+  if(!is.null(STATION_NUMBER) && STATION_NUMBER == "ALL"){
+    stop("Deprecated behaviour.Omit the STATION_NUMBER = \"ALL\" argument. See ?ANNUAL_STATISTICS for examples.")
+  }
+  
   if(is.null(hydat_path)){
     hydat_path = Sys.getenv("hydat")
     if(is.na(hydat_path)){

R/DLY_FLOWS.R

@@ -37,6 +37,10 @@
 
 DLY_FLOWS <- function(hydat_path=NULL, STATION_NUMBER = NULL, PROV_TERR_STATE_LOC = NULL, start_date ="ALL", end_date = "ALL") {
 
+  if(!is.null(STATION_NUMBER) && STATION_NUMBER == "ALL"){
+    stop("Deprecated behaviour.Omit the STATION_NUMBER = \"ALL\" argument. See ?DLY_FLOWS for examples.")
+  }
+  
   if(start_date == "ALL" & end_date == "ALL"){
     message("No start and end dates specified. All dates available will be returned.")
   } else {

R/DLY_LEVELS.R

@@ -35,6 +35,10 @@
 
 DLY_LEVELS <- function(hydat_path=NULL, STATION_NUMBER = NULL, PROV_TERR_STATE_LOC = NULL, start_date ="ALL", end_date = "ALL") {
 
+  if(!is.null(STATION_NUMBER) && STATION_NUMBER == "ALL"){
+    stop("Deprecated behaviour.Omit the STATION_NUMBER = \"ALL\" argument. See ?DLY_LEVELS for examples.")
+  }
+  
   if(start_date == "ALL" & end_date == "ALL"){
     message("No start and end dates specified. All dates available will be returned.")
   } else {

R/STATIONS.R

@@ -41,9 +41,9 @@
 
 STATIONS <- function(hydat_path=NULL, STATION_NUMBER = NULL, PROV_TERR_STATE_LOC = NULL) {
 
-  #if(STATION_NUMBER == "ALL" | PROV_TERR_STATE_LOC == "ALL"){
-  #  stop("Specifying ALL for STATION_NUMBER OR PROV_TERR_STATE_LOC is deprecrated. See examples for usage.")
-  #}
+  if(!is.null(STATION_NUMBER) && STATION_NUMBER == "ALL"){
+    stop("Deprecated behaviour.Omit the STATION_NUMBER = \"ALL\" argument. See ?download_realtime_dd for examples.")
+  }
 
   if(is.null(hydat_path)){
     hydat_path = Sys.getenv("hydat")

R/download.R

@@ -15,11 +15,12 @@
 #' 
 #' @description Download realtime discharge data from the Meteorological Service of Canada (MSC) datamart. The function will prioritize 
 #' downloading data collected at the highest resolution. In instances where data is not available at high (hourly or higher) resolution 
-#' daily averages are used. Currently, if a station does not exist or is not found, no data is returned. Both the province and the station number 
-#' should be specified. 
+#' daily averages are used. Currently, if a station does not exist or is not found, no data is returned. 
 #' 
-#' @param STATION_NUMBER Water Survey of Canada station number. No default. Can also take the "ALL" argument. 
-#' @param PROV_TERR_STATE_LOC Province, state or territory. See also for argument options.
+#' @param STATION_NUMBER Water Survey of Canada station number. If this argument is omitted from the function call, the value of \code{PROV_TERR_STATE_LOC} 
+#' is returned. 
+#' @param PROV_TERR_STATE_LOC Province, state or territory. If this argument is omitted from the function call, the value of \code{STATION_NUMBER} 
+#' is returned. See \code{unique(realtime_network_meta()$PROV_TERR_STATE_LOC)}
 #' 
 #' @return A tibble of water flow and level values
 #' 
@@ -28,39 +29,67 @@
 #' 
 #' 
 #' @examples
-#' download_realtime_dd(STATION_NUMBER="08MF005", PROV_TERR_STATE_LOC="BC")
+#' ## Download from multiple provinces
+#' download_realtime_dd(STATION_NUMBER=c("01CD005","08MF005"))
 #' 
 #' # To download all stations in Prince Edward Island:
-#' download_realtime_dd(STATION_NUMBER = "ALL", PROV_TERR_STATE_LOC = "PE")
+#' download_realtime_dd(PROV_TERR_STATE_LOC = "PE")
 #' 
 #' @export
-download_realtime_dd <- function(STATION_NUMBER, PROV_TERR_STATE_LOC) {
-  
-  if(missing(STATION_NUMBER) | missing(PROV_TERR_STATE_LOC)) 
-    stop("STATION_NUMBER or PROV_TERR_STATE_LOC argument is missing. These arguments must match jurisdictions.")
+download_realtime_dd <- function(STATION_NUMBER = NULL, PROV_TERR_STATE_LOC) {
 
   ## TODO: HAve a warning message if not internet connection exists
-  
-  prov = PROV_TERR_STATE_LOC
-  
-  if(STATION_NUMBER[1] == "ALL"){
-    STATION_NUMBER = realtime_network_meta(PROV_TERR_STATE_LOC = prov)$STATION_NUMBER
+  if(!is.null(STATION_NUMBER) && STATION_NUMBER == "ALL"){
+    stop("Deprecated behaviour.Omit the STATION_NUMBER = \"ALL\" argument. See ?download_realtime_dd for examples.")
   }
 
-  output_c <- c()
-  for (i in 1:length(STATION_NUMBER) ){
-    STATION_NUMBER_SEL = STATION_NUMBER[i]
 
-  base_url = "http://dd.weather.gc.ca/hydrometric"
+  if(!is.null(STATION_NUMBER)){
+    stns = STATION_NUMBER
+    choose_df = realtime_network_meta()
+    choose_df = filter(choose_df, STATION_NUMBER %in% stns)
+    choose_df = select(choose_df, STATION_NUMBER, PROV_TERR_STATE_LOC)
+  }
 
-  # build URL
-  type <- c("hourly", "daily")
-  url <- sprintf("%s/csv/%s/%s", base_url, PROV_TERR_STATE_LOC, type)
-  infile <- sprintf("%s/%s_%s_%s_hydrometric.csv", url, PROV_TERR_STATE_LOC, STATION_NUMBER_SEL, type)
+  if(is.null(STATION_NUMBER) ){
+    choose_df = realtime_network_meta(PROV_TERR_STATE_LOC = PROV_TERR_STATE_LOC)
+    choose_df = select(choose_df, STATION_NUMBER, PROV_TERR_STATE_LOC)
+  } 
 
-  # Define column names as the same as HYDAT
-  colHeaders <- c("STATION_NUMBER", "Date", "LEVEL", "LEVEL_GRADE", "LEVEL_SYMBOL", "LEVEL_CODE",
-                  "FLOW", "FLOW_GRADE", "FLOW_SYMBOL", "FLOW_CODE")
+  output_c <- c()
+  for (i in 1:nrow(choose_df) ){
+    ## Specify from choose_df
+    STATION_NUMBER_SEL = choose_df$STATION_NUMBER[i]
+    PROV_SEL = choose_df$PROV_TERR_STATE_LOC[i]
+    
+    
+    base_url = "http://dd.weather.gc.ca/hydrometric"
+    
+    # build URL
+    type <- c("hourly", "daily")
+    url <-
+      sprintf("%s/csv/%s/%s", base_url, PROV_SEL, type)
+    infile <-
+      sprintf("%s/%s_%s_%s_hydrometric.csv",
+              url,
+              PROV_SEL,
+              STATION_NUMBER_SEL,
+              type)
+    
+    # Define column names as the same as HYDAT
+    colHeaders <-
+      c(
+        "STATION_NUMBER",
+        "Date",
+        "LEVEL",
+        "LEVEL_GRADE",
+        "LEVEL_SYMBOL",
+        "LEVEL_CODE",
+        "FLOW",
+        "FLOW_GRADE",
+        "FLOW_SYMBOL",
+        "FLOW_CODE"
+      )
 
 
   h <- tryCatch(
@@ -126,7 +155,8 @@ download_realtime_dd <- function(STATION_NUMBER, PROV_TERR_STATE_LOC) {
   output = dplyr::mutate(output, key = ifelse(key=="","Value", key)) 
   output = tidyr::spread(output,key, val) 
   output = dplyr::rename(output,Code = CODE, Grade = GRADE, Symbol = SYMBOL)
-  output = dplyr::select(output, STATION_NUMBER, Date, Parameter, Value, Grade, Symbol, Code)
+  output = dplyr::mutate(output, PROV_TERR_STATE_LOC = PROV_SEL)
+  output = dplyr::select(output, STATION_NUMBER, PROV_TERR_STATE_LOC, Date, Parameter, Value, Grade, Symbol, Code)
   output = dplyr::arrange(output, Parameter, STATION_NUMBER, Date)
   output$Value = as.numeric(output$Value)
 
@@ -157,18 +187,19 @@ download_realtime_dd <- function(STATION_NUMBER, PROV_TERR_STATE_LOC) {
 #' 
 #' @description Returns all stations in the Realtime Water Survey of Canada hydrometric network operated by Environment and Cliamte Change Canada
 #' 
-#' @param PROV_TERR_STATE_LOC Province/State/Territory or Location. See examples for list of available options. Use "ALL" for all stations. 
+#' @param PROV_TERR_STATE_LOC Province/State/Territory or Location. See examples for list of available options. realtime_network_meta() for all stations. 
 #' 
 #' @export
 #' 
 #' @examples
 #' ## Available inputs for PROV_TERR_STATE_LOC argument:
-#' unique(realtime_network_meta(PROV_TERR_STATE_LOC = "ALL")$PROV_TERR_STATE_LOC)
+#' unique(realtime_network_meta()$PROV_TERR_STATE_LOC)
 #' 
 #' realtime_network_meta(PROV_TERR_STATE_LOC = "BC")
+#' realtime_network_meta(PROV_TERR_STATE_LOC = c("QC","PE"))
 
 
-realtime_network_meta <- function(PROV_TERR_STATE_LOC){
+realtime_network_meta <- function(PROV_TERR_STATE_LOC = NULL){
   prov = PROV_TERR_STATE_LOC
   ## Need to implement a search by station
   #try((if(hasArg(PROV_TERR_STATE_LOC_SEL) == FALSE) stop("Stopppppte")))
@@ -187,7 +218,7 @@ realtime_network_meta <- function(PROV_TERR_STATE_LOC){
       col_types = readr::cols()
     )
 
-  if((prov == "ALL")[1]){
+  if(is.null(prov) ){
     return(net_tibble)
   } 
 
@@ -221,6 +252,16 @@ get_ws_token <- function(username, password){
 
   ## If the POST request was not a successful, print out why.
   ## Possibly could provide errors as per Webservice guidelines
+  if(httr::status_code(r)==422){
+    stop("422 Unprocessable Entity: Username and/or password are missing or are formatted incorrectly.")
+  }
+  
+  if(httr::status_code(r)==403){
+    stop("403 Forbidden: the webservice is denying your request. Try any of the following options: ensure you are not currently using all 5 tokens, 
+         wait a few minutes and try again or copy the get_ws_token code and paste it directly into the console.")
+  }
+  
+  ## Catch all error for anything not covered above.
   httr::stop_for_status(r)
 
   message(paste0("This token will expire at ",format(Sys.time() + 10*60, "%H:%M:%S")))
@@ -300,6 +341,11 @@ download_realtime_ws <- function(STATION_NUMBER, parameters = c(46,16,52,47,8,5,
   ## Get data
   get_ws = httr::GET(url_for_GET)
 
+  if(httr::status_code(get_ws)==403){
+    stop("403 Forbidden: the webservice is denying your request. Try any of the following options: wait a few minutes and try 
+         again or copy the get_ws_token code and paste it directly into the console.")
+  }
+  
   ## Check the GET status
   httr::stop_for_status(get_ws)
 
@@ -318,10 +364,14 @@ download_realtime_ws <- function(STATION_NUMBER, parameters = c(46,16,52,47,8,5,
   csv_df = dplyr::select(csv_df, STATION_NUMBER, Date, Name_En, Value, Unit, Grade, Symbol, Approval, Parameter, Code)
 
   ## What stations were missed?
-  differ = setdiff(unique(STATION_NUMBER), unique(csv_df$STATION_NUMBER))
+  differ = setdiff(unique(stns), unique(csv_df$STATION_NUMBER))
   if( length(differ) !=0 ){
-    message("The following station(s) were not retrieved: ", paste0(differ, sep = " "))
-    message("See ?download_realtime_ws for possible reasons why.")
+    if( length(differ) <= 10) {
+      message("The following station(s) were not retrieved: ", paste0(differ, sep = " "))
+      message("Check station number typos or if it is a valid station in the network") }
+    else {
+      message("More than 10 stations from the initial query were not returned. Ensure realtime and active status are correctly specified.")
+    }
   } else{
     message("All station successfully retrieved")
   }
@@ -332,18 +382,77 @@ download_realtime_ws <- function(STATION_NUMBER, parameters = c(46,16,52,47,8,5,
   ## Need to output a warning to see if any stations weren't retrieved
   }
 
+#' @title A function to download hydat
+#' 
+#' @description Download the hydat sqlite database. The function will check for a existing sqlite file and stop if the same version 
+#' is already present. \code{download_hydat} also looks to see if you have the hydat environmental variable set. 
+#' 
+#' @param dl_hydat_here Directory to the hydat database. The hydat path can also be set in the \code{.Renviron} file so that it doesn't have to specified every function call. The path should 
+#' set as the variable \code{hydat}. Open the \code{.Renviron} file using this command: \code{file.edit("~/.Renviron")}.
+#' 
+#' @export
+#' 
+#' @examples \donttest{
+#' download_hydat()
+#' }
+#' 
+
+download_hydat <- function(dl_hydat_here = NULL) {
+  
+  response <- readline(prompt="Downloading HYDAT will take approximately 10 minutes. Are you sure you want to continue? (Y/N) ")
+  
+  if(!response %in% c("Y","Yes","yes","y")){
+    stop("Maybe another day...")
+  }
+  
+  if(is.null(dl_hydat_here)){
+    hydat_path = Sys.getenv("hydat")
+    if(is.na(hydat_path)){
+      stop("No Hydat.sqlite3 path set either in this function or in your .Renviron file. See tidyhydat for more documentation.")
+    }
+  } else {
+    ## Create actual hydat_path
+    hydat_path = paste0(dl_hydat_here,"Hydat.sqlite3")
+    #path_to = gsub("Hydat.sqlite3", "",hydat_path)
+  }
+  
 
+  
+  temp = tempfile()
+  
 
-#download_hydat <- function() {
-#  url <- 'http://collaboration.cmc.ec.gc.ca/cmc/hydrometrics/www/'
-#
-#  date_string <- substr(gsub("^.*\\Hydat_sqlite3_","",
-#                             RCurl::getURL(url)), 1,8)
-#  
-#  to_get_hydat <-paste0(url, "Hydat_sqlite3_", date_string,".zip")
-#  
-#  message(paste0("Proceed to this link to download a zip file of hydat", to_get_hydat))
-#  
-#
-#  
-#}
+  
+  ## If there is an existing hydat file get the date of release
+  if( length(list.files(dl_hydat_here, pattern = "Hydat.sqlite3")) == 1 ){
+    VERSION(hydat_path) %>%
+      mutate(condensed_date = paste0(substr(Date, 1,4),
+                    substr(Date, 6,7),
+                    substr(Date, 9,10)
+      )) %>%
+      pull(condensed_date) -> existing_hydat
+  } else{
+    existing_hydat = "HYDAT not present"
+  }
+  
+  
+  ## Create the link to download HYDAT
+  base_url = "http://collaboration.cmc.ec.gc.ca/cmc/hydrometrics/www/"
+  x <- httr::GET(base_url)
+  new_hydat = substr(gsub("^.*\\Hydat_sqlite3_", "", 
+                             httr::content(x, "text")
+                             ), 1, 8)
+  
+  ## Do we need to download a new version?
+  if(new_hydat == existing_hydat){
+    stop(paste0("Existing version of hydat, published on ",lubridate::ymd(existing_hydat),", is the most recent version available."))
+  } else{
+    message(paste0("Downloading version of hydat published on ",lubridate::ymd(new_hydat)))
+  }
+  
+  url = paste0(base_url , "Hydat_sqlite3_", new_hydat , ".zip")
+  
+  utils::download.file(url,temp)
+  
+  utils::unzip(temp, files=(unzip(temp, list=TRUE)$Name[1]), exdir=dl_hydat_here, overwrite=TRUE)
+  
+}