Merge pull request #138 from ropensci/dev

Dev

.github/workflows/pkgdown.yaml

@@ -0,0 +1,46 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [dev]
+  pull_request:
+    branches: [dev]
+  workflow_dispatch:
+
+name: pkgdown
+
+jobs:
+  pkgdown:
+    runs-on: ubuntu-latest
+    # Only restrict concurrency for non-PR jobs
+    concurrency:
+      group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }}
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+    permissions:
+      contents: write
+    steps:
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::pkgdown, local::., any::svglite
+          needs: website
+
+      - name: Build site
+        run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE)
+        shell: Rscript {0}
+
+      - name: Deploy to GitHub pages 🚀
+        if: github.event_name != 'pull_request'
+        uses: JamesIves/github-pages-deploy-action@v4.4.1
+        with:
+          clean: false
+          branch: gh-pages
+          folder: docs

.gitignore

@@ -12,3 +12,4 @@ inst/doc
 devtests.R
 /doc/
 /Meta/
+docs

DESCRIPTION

@@ -1,9 +1,9 @@
 Package: weathercan
 Type: Package
 Title: Download Weather Data from Environment and Climate Change Canada
-Version: 0.6.3
+Version: 0.7.0
 Authors@R: c(
-     person("Steffi", "LaZerte", email = "steffi@steffi.ca", role = c("aut","cre"), comment = c(ORCID = "0000-0002-7690-8360")),
+     person("Steffi", "LaZerte", email = "sel@steffilazerte.ca", role = c("aut","cre"), comment = c(ORCID = "0000-0002-7690-8360")),
      person("Sam", "Albers", email = "sam.albers@gmail.com", role = c("ctb"), comment = c(ORCID = "0000-0002-9270-7884")),
      person("Nick", "Brown", email = "nicholas512@gmail.com", role = c("ctb"), comment = c(ORCID = "0000-0002-2719-0671")),
      person("Kevin", "Cazelles", email = "kevin.cazelles@gmail.com", role = c("ctb"), comment = c(ORCID = "0000-0001-6619-9874")))
@@ -35,7 +35,7 @@ Imports:
     tidyselect (>= 1.0.0),
     xml2 (>= 0.1.2),
     rappdirs (>= 0.3.3)
-RoxygenNote: 7.1.2
+RoxygenNote: 7.2.3
 Roxygen: list(markdown = TRUE)
 Suggests:
     devtools,
@@ -48,10 +48,10 @@ Suggests:
     naniar,
     rmarkdown,
     sf,
-    sp,
-    testthat,
-    vcr (>= 1.0.2)
+    testthat (>= 3.0.0),
+    vcr (>= 1.0.2),
+    withr
 VignetteBuilder: 
     knitr
 Encoding: UTF-8
-Config/Needs/website: meteoland
+Config/testthat/edition: 3

NEWS.md

@@ -1,3 +1,17 @@
+# weathercan 0.7.0
+- Internal updates to tests (testthat 3rd edition)
+- Small changes to messages
+- Switch completely to sf (remove sp dependency)
+- Remove "Use with tidyverse" vignette - better to go to the source: https://r4ds.hadley.nz/
+- Remove "Meteoland" vignette as functions are defunct
+
+## Bug fixes
+- Fix bug with Interpolate where silently transforms non-matching timezones.
+  This can produce incorrect matching when using "local-UTC" timezones
+  (as weathercan does as of v0.3.0). Now timezone mismatch results in an error
+  so users can decide how it should be handled.
+
+
 # weathercan 0.6.3
 - Internal re-arranging and clean up
 - Stations without lat/lon now have NA timezone

R/interpolate.R

@@ -83,8 +83,8 @@ weather_interp <- function(data, weather,
 
   ## If 'time', convert to same timezone
   if(interval == "hour") {
-    if(attr(data[['time']], "tzone") != attr(weather[['time']], "tzone")) {
-      weather[['time']] <- lubridate::with_tz(weather[['time']], attr(data[['time']], "tzone"))
+    if(lubridate::tz(data$time) != lubridate::tz(weather$time)) {
+      stop("`data` and `weather` timezones must match", call. = FALSE)
     }
   }
 
@@ -144,11 +144,19 @@ weather_interp <- function(data, weather,
 
 
 approx_na_rm <- function(x, y, xout, na_gap = NULL) {
+
   if(!all(class(x) == class(xout)) & !(is.numeric(xout) & is.numeric(x))) {
     stop("'xout' must be the same class as 'x'")
   }
 
-  new <- as.data.frame(stats::approx(x = x, y = y, xout = xout))
+  if(lubridate::is.POSIXct(x) &&
+     lubridate::is.POSIXct(xout) &&
+     lubridate::tz(x) != lubridate::tz(xout)) {
+    stop("Timezone of `x` doesn't match `xout`", call. = FALSE)
+  }
+
+  new <- as.data.frame(stats::approx(x = x, y = y, xout = xout,
+                                     yleft = NA, yright = NA))
 
   if(any(is.na(y)) & !is.null(na_gap)) {
     if(lubridate::is.Date(x) | lubridate::is.POSIXct(x)) {

R/normals.R

@@ -336,7 +336,7 @@ frost_extract <- function(f, climate_id) {
     readr::local_edition(1)
     f1 <- readr::read_csv(I(f[frost_free:last]),
                           col_names = c("variable", "value", "frost_code"),
-                          col_types = readr::cols()) %>%
+                          col_types = readr::cols(), progress = FALSE) %>%
       tidyr::spread(key = "variable", value = "value")
 
     n <- tibble_to_list(f_names[f_names$variable %in% names(f1),
@@ -353,7 +353,8 @@ frost_extract <- function(f, climate_id) {
   if(length(frost_probs) > 0) {
     readr::local_edition(1)
     f2 <- readr::read_csv(I(f[frost_probs:length(f)]),
-                          col_names = FALSE, col_types = readr::cols()) %>%
+                          col_names = FALSE, col_types = readr::cols(),
+                          progress = FALSE) %>%
       as.data.frame()
     f2 <- data.frame(prob = rep(c("10%", "25%", "33%", "50%",
                                   "66%", "75%", "90%"), 3),
@@ -373,7 +374,8 @@ frost_extract <- function(f, climate_id) {
   } else {
     r <- dplyr::full_join(
       dplyr::mutate(f1, climate_id = climate_id),
-      dplyr::mutate(f2, climate_id = climate_id), by = "climate_id") %>%
+      dplyr::mutate(f2, climate_id = climate_id),
+      by = "climate_id", relationship = "many-to-many") %>%
       dplyr::select(-climate_id)
   }
 

R/stations.R

@@ -186,7 +186,7 @@ stations_dl_internal <- function(skip = NULL, verbose = FALSE, quiet = FALSE,
 
   headings <- readr::read_lines(httr::content(resp, as = "text",
                                               encoding = "Latin1"),
-                                n_max = 5)
+                                n_max = 5, progress = FALSE)
   if(!any(stringr::str_detect(headings, "Climate ID"))){
     stop("Could not read stations list (",
          getOption("weathercan.urls.stations"), ")", call. = FALSE)
@@ -216,7 +216,8 @@ stations_dl_internal <- function(skip = NULL, verbose = FALSE, quiet = FALSE,
 
   raw <- httr::content(resp, as = "text", encoding = "Latin1")
 
-  s <- readr::read_delim(raw, skip = skip, col_types = readr::cols())
+  s <- readr::read_delim(raw, skip = skip, col_types = readr::cols(),
+                         progress = FALSE)
   s <- dplyr::select(s,
                      "prov" = "Province",
                      "station_name" = "Name",
@@ -256,7 +257,7 @@ stations_dl_internal <- function(skip = NULL, verbose = FALSE, quiet = FALSE,
     dplyr::distinct() %>%
     dplyr::mutate(
       tz = lutz::tz_lookup_coords(.data$lat, .data$lon, method = "accurate"),
-      tz = purrr::map_chr(.data$tz, ~tz_offset(.x)),
+      tz = purrr::map_chr(.data$tz, ~tz_diff(.x)),
       tz = dplyr::if_else(is.na(.data$lat) | is.na(.data$lon), NA_character_, .data$tz))
 
   s <- s %>%
@@ -366,7 +367,7 @@ stations_dl_internal <- function(skip = NULL, verbose = FALSE, quiet = FALSE,
 #' stations_search(name = "Ottawa", normals_years = "1981-2010") # Same as above
 #' stations_search(name = "Ottawa", normals_years = "1971-2000") # 1971-2010
 #'
-#' if(requireNamespace("sp")) {
+#' if(requireNamespace("sf")) {
 #'   stations_search(coords = c(53.915495, -122.739379))
 #' }
 #'
@@ -416,9 +417,9 @@ stations_search <- function(name = NULL,
       stop("'coord' takes one pair of lat and lon in a numeric vector")
     }
 
-    if(!requireNamespace("sp", quietly = TRUE)) {
-     stop("Package 'sp' required to search for stations using coordinates. ",
-          "Use the code \"install.packages('sp')\" to install.", call. = FALSE)
+    if(!requireNamespace("sf", quietly = TRUE)) {
+     stop("Package 'sf' required to search for stations using coordinates. ",
+          "Use the code \"install.packages('sf')\" to install.", call. = FALSE)
     }
 
   }
@@ -481,18 +482,25 @@ stations_search <- function(name = NULL,
 
   if(!is.null(coords)){
     if(verbose) message("Calculating station distances")
-    coords <- as.numeric(as.character(coords[c(2,1)]))
-    locs <- as.matrix(stn[!is.na(stn$lat), c("lon", "lat")])
-    stn$distance <- NA
-    stn$distance[!is.na(stn$lat)] <- sp::spDistsN1(pts = locs,
-                                                   pt = coords, longlat = TRUE)
-    stn <- dplyr::arrange(stn, .data$distance)
+
+    coords <- sf::st_point(coords[c(2,1)]) %>%
+      sf::st_sfc(crs = 4326)
+
+    locs <- dplyr::select(stn, "station_id", "lon", "lat") %>%
+      tidyr::drop_na() %>%
+      dplyr::distinct() %>%
+      sf::st_as_sf(coords = c("lon", "lat"), crs = 4326) %>%
+      dplyr::mutate(distance = as.vector(sf::st_distance(coords, .data$geometry))/1000) %>%
+      sf::st_drop_geometry()
+
+    stn <- dplyr::left_join(stn, locs, by = "station_id") %>%
+      dplyr::arrange(.data$distance)
 
     i <- which(stn$distance <= dist)
     if(length(i) == 0) {
      i <- 1:10
      if(!quiet) message("No stations within ", dist,
-                        "km. Returning closest 10 stations.")
+                        "km. Returning closest 10 records")
     }
   }
 

R/utils.R

@@ -1,11 +1,13 @@
-tz_offset <- function(tz, as = "tz") {
-  t <- as.numeric(difftime(as.POSIXct("2016-01-01 00:00:00", tz = "UTC"),
-                           as.POSIXct("2016-01-01 00:00:00", tz = tz), units = "hours"))
+tz_diff <- function(tz, as = "tz") {
+  if(!is.na(tz)) {
+    t <- as.numeric(difftime(as.POSIXct("2016-01-01 00:00:00", tz = "UTC"),
+                             as.POSIXct("2016-01-01 00:00:00", tz = tz), units = "hours"))
 
-  if(as == "tz"){
-    if(t > 0) t <- paste0("Etc/GMT-", t)
-    if(t <= 0) t <- paste0("Etc/GMT+", abs(t))
-  }
+    if(as == "tz"){
+      if(t > 0) t <- paste0("Etc/GMT-", t)
+      if(t <= 0) t <- paste0("Etc/GMT+", abs(t))
+    }
+  } else t <- NA_character_
   t
 }
 

R/weather.R

@@ -147,7 +147,7 @@ weather_dl <- function(station_ids,
     if(nrow(stn1) == 0) {
       if(length(station_ids) > 1) {
         missing <- c(missing, s)
-        if(!quiet) message("No data for station ", s)
+        if(verbose) message("No data for station ", s)
         next
       } else {
 
@@ -163,13 +163,13 @@ weather_dl <- function(station_ids,
       }
     }
 
-    if(inherits(try(as.Date(stn1$start), silent = TRUE), "try-error")) {
+    if(!lubridate::is.Date(stn1$start)) {
       stn1 <- dplyr::mutate(stn1,
                             start = lubridate::ymd(as.character(.data$start),
                                                    truncated = 2),
                             start = lubridate::floor_date(.data$start, "year"))
     }
-    if(inherits(try(as.Date(stn1$end), silent = TRUE), "try-error")) {
+    if(!lubridate::is.Date(stn1$end)) {
       stn1 <- dplyr::mutate(stn1,
                             end = lubridate::ymd(as.character(.data$end),
                                                  truncated = 2),
@@ -263,7 +263,7 @@ weather_dl <- function(station_ids,
 
       if(nrow(temp) == 0 || all(is.na(temp) | temp == "")) {
         if(length(station_ids) > 1) {
-          if(!quiet) message("No data for station ", s)
+          if(verbose) message("No data for station ", s)
           missing <- c(missing, s)
           next
         } else {
@@ -456,7 +456,8 @@ weather_raw <- function(html, skip = 0,
   readr::local_edition(1)
   suppressWarnings({ # when some data are missing, final columns not present
     w <- readr::read_csv(I(raw), n_max = nrows, skip = skip,
-                         col_types = paste(rep("c", ncols), collapse = ""))})
+                         col_types = paste(rep("c", ncols), collapse = ""),
+                         progress = FALSE)})
   # Get rid of special symbols right away
   w <- remove_sym(w)
 
@@ -657,7 +658,8 @@ meta_raw <- function(html, encoding = "UTF-8", interval, return = "meta") {
       stringr::str_replace_all("(\\t)+", "\\\t") %>%
       readr::read_tsv(., n_max = i,
                       col_names = FALSE,
-                      col_types = readr::cols())
+                      col_types = readr::cols(),
+                      progress = FALSE)
 
     if(ncol(r) > 2) {
       stop("Problems parsing metadata. Submit an issue at ",
@@ -671,7 +673,8 @@ meta_raw <- function(html, encoding = "UTF-8", interval, return = "meta") {
       stringr::str_remove("\\*https\\:\\/\\/climate.weather.gc.ca\\/FAQ_e.html#Q5") %>%
       readr::read_tsv(., skip = stringr::str_which(split, "Legend") + 1,
                       col_names = FALSE,
-                      col_types = readr::cols())
+                      col_types = readr::cols(),
+                      progress = FALSE)
   }
   # Get rid of any special symbols
   remove_sym(r)

README.Rmd

@@ -34,7 +34,7 @@ For more details and tutorials checkout the [weathercan website](https://docs.ro
 
 ## Installation
 
-You can install `weathercan` from the [rOpenSci r-Universe](https://ropensci.r-universe.dev/ui):
+You can install `weathercan` from the [rOpenSci r-Universe](https://ropensci.r-universe.dev/ui/):
 
 ```{r, eval = FALSE}
 install.packages("weathercan",