Merge pull request #238 from mhpob/dev-rm-purrr

Remove `purrr` dependency

DESCRIPTION

@@ -14,7 +14,6 @@ Imports:
 		jsonlite,
 		lubridate,
 		plotrix,
-		purrr,
 		raster,
 		readxl,
 		sf,

R/load-prepare_tag_sheet.R

@@ -38,7 +38,7 @@ prepare_tag_sheet <- function(path, header_line = 5, sheet_name = 2) {
   tag_sheet <- readxl::read_excel(path, sheet = sheet_name, skip = header_line - 1)
   tag_sheet <- tag_sheet %>% dplyr::mutate(
     transmitter_id = paste(TAG_CODE_SPACE, TAG_ID_CODE, sep = "-"),
-    est_tag_life = as.integer(purrr::map(EST_TAG_LIFE, convert_life_to_days))
+    est_tag_life = convert_life_to_days(EST_TAG_LIFE)
   )
   tag_sheet <- tag_sheet %>% dplyr::rename(
     animal_id = "ANIMAL_ID   (floy tag ID, pit tag code, etc.)",
@@ -53,17 +53,22 @@ prepare_tag_sheet <- function(path, header_line = 5, sheet_name = 2) {
 
 # For converting tag life column to a count of days
 convert_life_to_days <- function(tagLife) {
-  if (!grepl("[a-zA-Z]", tagLife)) {
-    return(as.integer(tagLife))
-  } else if (grepl("days?", tolower(tagLife))) {
-    days <- gsub("days?", "", tolower(tagLife))
-    return(as.integer(days))
-  } else {
-    stop(
-      sprintf(
-        "Cannot convert %s to time days. Please change the est_tag_life in the tagging metadata sheet to days",
-        tagLife
-      )
-    )
-  }
+  sapply(tagLife,
+    function(x) {
+      if (!grepl("[a-zA-Z]", x)) {
+        return(as.integer(x))
+      } else if (grepl("days?", tolower(x))) {
+        days <- gsub("days?", "", tolower(x))
+        return(as.integer(days))
+      } else {
+        stop(
+          sprintf(
+            "Cannot convert %s to time days. Please change the est_tag_life in the tagging metadata sheet to days",
+            x
+          )
+        )
+      }
+    },
+    USE.NAMES = FALSE
+  )
 }

R/load-read_otn_detections.r

@@ -51,7 +51,7 @@ read_otn_detections <- function(det_file) {
     dtc$receiver_group <- substr(dtc$station, 1, nchar(dtc$station) - 3)
     dtc$receiver <- dtc$collectornumber
     dtc$tagname <- dtc$fieldnumber
-    dtc$codespace <- purrr::map(dtc$fieldnumber, get_codemap)
+    dtc$codespace <- get_codemap(dtc$fieldnumber)
   }
   # coerce timestamps to POSIXct
   for (j in timestamp_cols) {
@@ -74,6 +74,11 @@ read_otn_detections <- function(det_file) {
 }
 
 get_codemap <- function(x) {
-  x0 <- unlist(strsplit(x, "-"))
-  return(paste0(x0[1:2], collapse = "-"))
+  sapply(x,
+    FUN = function(.) {
+      x0 <- unlist(strsplit(., "-"))
+      return(paste0(x0[1:2], collapse = "-"))
+    },
+    USE.NAMES = FALSE
+  )
 }

R/util-convert_glatos_to_att.r

@@ -86,10 +86,9 @@ convert_glatos_to_att <- function(detectionObj,
     Common.Name = unique(tagMetadata$Common.Name)
   )
   nameLookup <- dplyr::mutate(nameLookup, # Add scinames to the name lookup
-    Sci.Name = as.factor(purrr::map(nameLookup$Common.Name,
-      query_worms_common,
-      silent = TRUE
-    ))
+    Sci.Name = as.factor(
+      query_worms_common(nameLookup$Common.Name, silent = TRUE)
+    )
   )
   # Apply sci names to frame
   tagMetadata <- dplyr::left_join(tagMetadata, nameLookup, by = "Common.Name")
@@ -106,7 +105,7 @@ convert_glatos_to_att <- function(detectionObj,
 
   releaseData <- dplyr::mutate(releaseData,
     # Convert sex text and null missing columns
-    Sex = as.factor(purrr::map(Sex, convert_sex)),
+    Sex = as.factor(convert_sex(Sex)),
     Tag.Life = as.integer(NA),
     Tag.Status = as.factor(NA),
     Bio = as.factor(NA)

R/util-convert_otn_erddap_to_att.r

@@ -116,10 +116,11 @@ convert_otn_erddap_to_att <- function(detectionObj,
 
   # Add scinames to the name lookup
   nameLookup <- dplyr::mutate(nameLookup,
-    Sci.Name = as.factor(purrr::map(nameLookup$Common.Name,
-      query_worms_common,
-      silent = TRUE
-    ))
+    Sci.Name = as.factor(
+      query_worms_common(nameLookup$Common.Name,
+        silent = TRUE
+      )
+    )
   )
 
   # Apply sci names to frame
@@ -135,9 +136,8 @@ convert_otn_erddap_to_att <- function(detectionObj,
     by = "transmitter_id"
   )
   erdRcv <- dplyr::mutate(erdRcv,
-    station = as.character(purrr::map(
-      erdRcv$receiver_reference_id,
-      extract_station
+    station = as.character(extract_station(
+      erdRcv$receiver_reference_id
     ))
   )
 
@@ -164,7 +164,7 @@ convert_otn_erddap_to_att <- function(detectionObj,
 
   releaseData <- dplyr::mutate(releaseData,
     # Convert sex text and null missing columns
-    Sex = as.factor(purrr::map(Sex, convert_sex)),
+    Sex = as.factor(convert_sex(Sex)),
     Tag.Life = as.integer(NA),
     Tag.Status = as.factor(NA),
     Bio = as.factor(NA)
@@ -271,12 +271,17 @@ concat_list_strings <- function(list1, list2, sep = "-") {
 }
 
 
-# Converts the reciever reference id to station name
-extract_station <- function(reciever_ref) {
-  reciever_ref <- as.character(reciever_ref)
-  return( # Split the string by _ and drop the array name
-    unlist(
-      strsplit(c(reciever_ref), c("_"))
-    )[-1]
+# Converts the receiver reference id to station name
+extract_station <- function(receiver_ref) {
+  sapply(receiver_ref,
+    FUN = function(x) {
+      x <- as.character(x)
+      return( # Split the string by _ and drop the array name
+        unlist(
+          strsplit(c(x), c("_"))
+        )[-1]
+      )
+    },
+    USE.NAMES = FALSE
   )
 }

R/util-convert_otn_to_att.r

@@ -188,7 +188,7 @@ convert_otn_to_att <- function(detectionObj,
 
   releaseData <- dplyr::mutate(releaseData,
     # Convert sex text and null missing columns
-    Sex = purrr::map(Sex, convert_sex),
+    Sex = convert_sex(Sex),
     Tag.Status = as.factor(NA),
     Bio = as.factor(NA)
   ) %>% unique()
@@ -258,30 +258,40 @@ query_worms_common <- function(commonName,
     )
   )
 
-  sciname <- tryCatch(
-    {
-      if (!silent) print(url)
-      payload <- jsonlite::fromJSON(url)
-      sciname <- payload$scientificname
+  sapply(
+    url,
+    FUN = function(x) {
+      tryCatch(
+        {
+          if (!silent) print(x)
+          payload <- jsonlite::fromJSON(x)
+          sciname <- list(payload$scientificname)
+        },
+        error = function(e) {
+          print(geterrmessage())
+          stop(sprintf(
+            "Error in querying WoRMS, %s was probably not found.",
+            utils::URLdecode(gsub(".*/", "", x))
+          ))
+        }
+      )
+      return(sciname)
     },
-    error = function(e) {
-      print(geterrmessage())
-      stop(sprintf(
-        "Error in querying WoRMS, %s was probably not found.",
-        commonName
-      ))
-    }
+    USE.NAMES = FALSE
   )
-
-  return(sciname)
 }
 
 convert_sex <- function(sex) {
-  if (toupper(sex) %in% c("F", "FEMALE")) {
-    return("FEMALE")
-  }
-  if (toupper(sex) %in% c("M", "MALE")) {
-    return("MALE")
-  }
-  return(sex)
+  sapply(sex,
+    FUN = function(.) {
+      if (toupper(.) %in% c("F", "FEMALE")) {
+        return("FEMALE")
+      }
+      if (toupper(.) %in% c("M", "MALE")) {
+        return("MALE")
+      }
+      return(.)
+    },
+    USE.NAMES = FALSE
+  )
 }

tests/testthat/test-convert_life_to_days.R

@@ -0,0 +1,39 @@
+test_that("converts number stored as text", {
+  life_text <- convert_life_to_days("5")
+
+  expect_equal(life_text, 5)
+  expect_type(life_text, "integer")
+})
+
+test_that("converts number stored as numeric", {
+  life_numeric <- convert_life_to_days(5)
+
+  expect_equal(life_numeric, 5)
+  expect_type(life_numeric, "integer")
+})
+
+test_that("strips 'days'", {
+  life_days <- convert_life_to_days("10 days")
+
+  expect_equal(life_days, 10)
+  expect_type(life_days, "integer")
+})
+
+test_that("errors if different unit", {
+  expect_error(
+    convert_life_to_days("10 weeks"),
+    "Cannot convert 10 weeks to time days."
+  )
+
+  expect_error(
+    convert_life_to_days("parsecs"),
+    "Cannot convert parsecs to time days."
+  )
+})
+
+test_that("handles vectors", {
+  expect_identical(
+    convert_life_to_days(c("5", 5, "10 days")),
+    as.integer(c(5, 5, 10))
+  )
+})

tests/testthat/test-convert_otn_erddap_to_att.r

@@ -97,15 +97,3 @@ test_that("internal function concat_list_strings errors with unequal length", {
     "Lists are not the same size."
   )
 })
-
-
-
-# Test non-exported extract_station function
-test_that("internal function extract_station works", {
-  expect_no_error(
-    station_extracted <- extract_station(stations$receiver_reference_id[1])
-  )
-
-  expect_length(station_extracted, 1)
-  expect_type(station_extracted, "character")
-})

tests/testthat/test-convert_otn_to_att.r

@@ -28,16 +28,3 @@ test_that("matches type/class of internal data: blue_shark_att", {
   expect_s3_class(bs_att, "ATT")
   expect_type(bs_att, "list")
 })
-
-
-
-##### TBD: TEST NON-EXPORTED FUNCTIONS ####
-# Test non-exported query_worms_common function
-test_that("internal function query_worms_common", {
-  skip("Test needs to be created.")
-})
-
-# Test non-exported query_worms_common function
-test_that("internal function query_worms_common", {
-  skip("Test needs to be created.")
-})

tests/testthat/test-convert_sex.R

@@ -0,0 +1,22 @@
+test_that("converts M/MALE/Male/male and F/FEMALE/Female/female", {
+  sex <- convert_sex(c(
+    "M", "MALE", "Male", "male",
+    "F", "FEMALE", "Female", "female"
+  ))
+
+  expect_identical(sex, c(rep("MALE", 4), rep("FEMALE", 4)))
+})
+
+test_that("can handle a vector", {
+  sex_vec <- convert_sex(c("FEMALE", "MALE"))
+
+  expect_identical(sex_vec, c("FEMALE", "MALE"))
+  expect_type(sex_vec, "character")
+})
+
+test_that("handles missing values correctly", {
+  sex_na <- convert_sex(NA)
+
+  expect_identical(sex_na, NA)
+  expect_type(sex_na, "logical")
+})

tests/testthat/test-extract_station.R

@@ -0,0 +1,13 @@
+test_that("drops array", {
+  expect_identical(
+    extract_station("HFX_HFX028"),
+    "HFX028"
+  )
+})
+
+test_that("handles vectors", {
+  expect_identical(
+    extract_station(c("HFX_HFX028", "WAKA_WAKA4")),
+    c("HFX028", "WAKA4")
+  )
+})

tests/testthat/test-get_codemap.R

@@ -0,0 +1,13 @@
+test_that("returns codemap", {
+  expect_equal(
+    get_codemap("A69-1601-12345"),
+    "A69-1601"
+  )
+})
+
+test_that("handles vectors", {
+  expect_identical(
+    get_codemap(c("A69-1601-12345", "A69-1601-54321", "A69-1303-2222")),
+    c("A69-1601", "A69-1601", "A69-1303")
+  )
+})

tests/testthat/test-prepare_tag_sheet.R

@@ -0,0 +1,3 @@
+test_that("Tests TBD", {
+  skip("Test needs to be created.")
+})

tests/testthat/test-query_worms_common.R

@@ -0,0 +1,26 @@
+test_that("can be silenced", {
+  expect_silent(
+    query_worms_common("striped bass", silent = TRUE)
+  )
+})
+
+test_that("outputs url to console if not silenced", {
+  expect_output(
+    query_worms_common("weakfish"),
+    "https://www.marinespecies.org/rest/AphiaRecordsByVernacular/weakfish"
+  )
+})
+
+test_that("encodes spaces in URL", {
+  expect_output(
+    query_worms_common("Atlantic sturgeon"),
+    "%20"
+  )
+})
+
+test_that("returns list", {
+  expect_type(
+    query_worms_common("Atlantic cod", silent = TRUE),
+    "list"
+  )
+})