Merge 788bb6a into ce254c7

DESCRIPTION

@@ -25,4 +25,4 @@ Suggests:
     rmarkdown,
     knitr
 LazyData: true
-RoxygenNote: 7.0.1
+RoxygenNote: 7.1.1

NAMESPACE

@@ -33,6 +33,7 @@ export(pin_age)
 export(pin_birthplace)
 export(pin_coordn)
 export(pin_ctrl)
+export(pin_date)
 export(pin_sex)
 export(pin_to_date)
 export(roin)

R/format.pin.R

@@ -36,5 +36,5 @@ format_pin <- function(x, format. = "%Y%m%d%N", ...) {
   if (format. == "%P") format. <- "(%C) %y-%m-%d - %N"
   gsub_v <- Vectorize(gsub, "replacement")
   f <- gsub_v("%N", substr(x, 9, 12), format.)
-  mapply(format, pin_to_date(x), f)
+  mapply(format, pin_date(x), f)
 }

R/pin.R

@@ -203,7 +203,7 @@ pin_ctrl <- function(pin, force_logical = FALSE){
 
   res <- vapply(pin, luhn_algo, integer(1), USE.NAMES = FALSE, 
                 multiplier = c(0, 0, 2, 1, 2, 1, 2, 1, 2, 1, 2, 0))
-  old_pin_format <- format(pin_to_date(pin), format = "%Y") <= "1967" & grepl("*[ATX]$", pin)
+  old_pin_format <- format(pin_date(pin), format = "%Y") <= "1967" & grepl("*[ATX]$", pin)
   res <- as.integer(substr(pin, 12, 12)) == res | old_pin_format
   if(force_logical) res[is.na(res)] <- FALSE
   res
@@ -333,7 +333,7 @@ pin_age <- function(pin, date=Sys.Date(), timespan = "years") {
   }
   pin <- all_pins[valid_diff]
 
-  pin_dates <- pin_to_date(pin)
+  pin_dates <- pin_date(pin)
   diff <- lubridate::interval(pin_dates, date)
 
   timespan_lubridate <-
@@ -351,6 +351,30 @@ pin_age <- function(pin, date=Sys.Date(), timespan = "years") {
   all_age
 }
 
+## pin_to_date
+#' @title Calculate the date of birth from a \code{pin}
+#' @description Calculates the date of birth in date format.
+#' @param pin Swedish ID number
+#' @return Date of birth as a vector in date format.
+#' 
+#' @name pin_to_date-deprecated
+#' @usage pin_to_date(pin)
+#' @seealso \code{\link{sweidnumbr-deprecated}}
+#' @keywords internal
+NULL
+
+#' @rdname sweidnumbr-deprecated
+#' @section \code{pin_to_date}:
+#' For \code{pin_to_date}, use \code{\link{pin_date}}.
+#' 
+#' @export
+pin_to_date <- function(pin) {
+  .Deprecated(new = "pin_date", package = "sweidnumbr")
+  if(!is.pin(pin)) pin <- as.pin(pin)
+  pin <- pin_coordn_correct(pin)
+  lubridate::ymd(substr(pin,1,8))
+}
+
 
 #' @title
 #' Calculate the date of birth from a \code{pin}
@@ -366,10 +390,10 @@ pin_age <- function(pin, date=Sys.Date(), timespan = "years") {
 #' @examples
 #' # Examples taken from SKV 704 (see references)
 #' ex_pin <- c("196408233234", "186408833224")
-#' pin_to_date(ex_pin)
+#' pin_date(ex_pin)
 #' 
 #' @export
-pin_to_date <- function(pin) {
+pin_date <- function(pin) {
   if(!is.pin(pin)) pin <- as.pin(pin)
   pin <- pin_coordn_correct(pin)
   lubridate::ymd(substr(pin,1,8))

R/sweidnumbr-deprecated.R

@@ -0,0 +1,9 @@
+## sweidnumbr-deprecated.r
+#' @title Deprecated functions in package \pkg{sweidnumbr}.
+#' @description The functions listed below are deprecated and will be defunct in
+#'   the near future. When possible, alternative functions with similar
+#'   functionality are also mentioned. Help pages for deprecated functions are
+#'   available at \code{help("-deprecated")}.
+#' @name sweidnumbr-deprecated
+#' @keywords internal
+NULL

tests/testthat/test-pin_age.R

@@ -39,5 +39,5 @@ test_that(desc="Negative ages",{
 
 test_that("multiple dates", {
   expect_error(pin_age(pin_test, c("2010-10-10", "2000-01-01"), "Multiple dates used."))
-  expect_error(pin_age(pin_test, c("2010-10-10", "2000-01-01", "2002-12-31", "2010-05-06"), "Multiple dates used."))
+  expect_error(pin_age(pin_test, c("2010-10-10", "2000-01-01", "2002-12-31", "2010-05-06", "2012-01-01")))
 })

tests/testthat/test-pin_date.R

@@ -0,0 +1,14 @@
+
+context("pin_date")
+
+test_that(desc="pin_date",{
+  expect_equal(pin_date(pin = c("196408233234", "186408833224")), expected = lubridate::ymd(c("1964-08-23","1864-08-23")))
+  check_class <- pin_date(pin = c("196408233234", "186408833224"))
+  expect_true(inherits(check_class, "POSIXct") | inherits(check_class, "Date"))
+})
+
+test_that(desc="Handle NA and interimn in pin_date",{
+  expect_true(is.na(pin_date(as.pin(c(NA,"198501169885")))[1]))
+  expect_false(is.na(pin_date(as.pin(c(NA,"198501169885")))[2]))
+  suppressWarnings(expect_true(all(is.na(pin_date(pin = c("19640823C234", "18640883D224"))))))
+})

tests/testthat/test-pin_test_file.R

@@ -29,8 +29,8 @@ test_that(desc="Frequencies in test file: pin_birthplace",{
   expect_equal(as.numeric(table(pin_birthplace(test_pins$pin)))[c(1,2,10,27:28)], c(5,3,46,7724,9105))  
 })
 
-test_that(desc="Frequencies in test file: pin_to_date",{
-  expect_equal(as.character(min(unique(pin_to_date(test_pins$pin)))), "1890-01-01")  
-  expect_equal(as.character(max(unique(pin_to_date(test_pins$pin)))), "2014-12-31")  
+test_that(desc="Frequencies in test file: pin_date",{
+  expect_equal(as.character(min(unique(pin_date(test_pins$pin)))), "1890-01-01")  
+  expect_equal(as.character(max(unique(pin_date(test_pins$pin)))), "2014-12-31")  
 })
 

tests/testthat/test-rin.R

@@ -2,10 +2,12 @@
 context("roin and rpin")
 
 test_that(desc="roin",{
+  expect_equal(length(roin(c(1,2))), 2)
   expect_silent(x <- roin(100000))
 })
 
 test_that(desc="rpin",{
+  expect_equal(length(rpin(c(1,2))), 2)
   expect_silent(x <- rpin(100000))
   expect_silent(x <- rpin(100000, p.male = 0))
   expect_equal(as.numeric(table(pin_sex(x))), 100000)

tests/testthat/test_pin_to_date.R

@@ -0,0 +1,5 @@
+context("pin_to_date")
+
+test_that(desc="pin_to_date",{
+  expect_warning(pin_to_date(pin = c("196408233234", "186408833224")), expected = lubridate::ymd(c("1964-08-23","1864-08-23")))
+})