Vectorised functions

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: nhiValidator
 Type: Package
 Title: Check the Internal Validity of New Zealand NHI Numbers
-Version: 0.5.1
+Version: 0.6.1
 Authors@R: c(
     person('Michael', 'MacAskill', email = 'michael.macaskill@nzbri.org', 
     role = c('aut', 'cre')))

R/check_format.R

@@ -1,38 +1,3 @@
-# Check an NHI for being in a correct format.
-#
-# This hidden function checks only one scalar value. See the exported,
-# vector-safe nhi_format() function for documentation.
-#
-.nhi_format <- function(nhi, allow_test_cases = FALSE) {
-
-    if (is.na(nhi)) {
-        return(NA)
-    }
-
-    nhi = toupper(nhi)
-
-    if (allow_test_cases == TRUE) {
-        # allow NHIs that start with Z (reserved for test cases).
-        # Original format is 3 letters excluding O and I, followed by 4 digits.
-        original_pattern = '^[A-HJ-NP-Z]{3}[0-9]{4}$'
-        # Revised format is 3 letters followed by 2 digits followed 2 letters:
-        revised_pattern  = '^[A-HJ-NP-Z]{3}[0-9]{2}[A-HJ-NP-Z]{2}$'
-    } else { # don't allow Z in the first position (most common use case):
-        original_pattern = '^[A-HJ-NP-Y][A-HJ-NP-Z]{2}[0-9]{4}$'
-        revised_pattern  = '^[A-HJ-NP-Y][A-HJ-NP-Z]{2}[0-9]{2}[A-HJ-NP-Z]{2}$'
-    }
-
-    if (grepl(pattern = original_pattern, x = nhi)) {
-        return('original format')
-    }
-
-    if (grepl(pattern = revised_pattern, x = nhi)) {
-        return('revised format')
-    } else {
-        return('invalid format')
-    }
-}
-
 #' Check NHIs for correct format.
 #'
 #' \code{nhi_format} Check whether NHIs have the basic
@@ -61,15 +26,27 @@
 #' nhi_format('ZZZ00AX', allow_test_cases = TRUE)
 #'
 #' @export
-nhi_format <- function(nhi, allow_test_cases = FALSE) {
+nhi_format <- function(nhis, allow_test_cases = FALSE) {
 
-    # allow for more than one value to be processed:
-    n = length(nhi)
-    result = rep(NA, n) # create a same-length vector to return
+    nhis = toupper(nhis)
 
-    for (i in 1:n) {
-        result[i] = .nhi_format(nhi[i], allow_test_cases = allow_test_cases)
+    if (allow_test_cases == TRUE) {
+        # allow NHIs that start with Z (reserved for test cases).
+        # Original format is 3 letters excluding O and I, followed by 4 digits.
+        original_pattern = '^[A-HJ-NP-Z]{3}[0-9]{4}$'
+        # Revised format is 3 letters followed by 2 digits followed 2 letters:
+        revised_pattern  = '^[A-HJ-NP-Z]{3}[0-9]{2}[A-HJ-NP-Z]{2}$'
+    } else { # don't allow Z in the first position (most common use case):
+        original_pattern = '^[A-HJ-NP-Y][A-HJ-NP-Z]{2}[0-9]{4}$'
+        revised_pattern  = '^[A-HJ-NP-Y][A-HJ-NP-Z]{2}[0-9]{2}[A-HJ-NP-Z]{2}$'
     }
-
-    return(result)
+
+
+    nhiformat <- rep(NA_character_,length(nhis))
+    nhiformat[grepl(pattern = original_pattern, x = nhis)] <- 'original format'
+    nhiformat[grepl(pattern = revised_pattern, x = nhis)] <- 'revised format'
+    nhiformat[is.na(nhiformat)] <- 'invalid format'
+
+    return(nhiformat)
 }
+

R/check_validity.R

@@ -1,48 +1,3 @@
-# Conduct internal validity check of an NHI.
-#
-# This hidden function checks only one scalar value. See the exported,
-# vector-safe nhi_valid() function for documentation.
-#
-.is_valid_nhi <- function(nhi, nhi_type = 'original format') {
-
-    checksum = 0
-    nhi = toupper(nhi)
-    characters = strsplit(nhi, split = '')[[1]][1:7]
-
-    if (nhi_type == 'original format') {
-        modulus = 11
-    } else {
-        modulus = 24 # for revised format
-    }
-
-    # multiply each character's looked-up numeric value by its reversed
-    # position in the string (ie multiply the 1st by 7, the 2nd by 6, etc):
-    for (j in 7:2) {
-        checksum = (nhi_env$lookup[characters[8 - j]] * j) + checksum
-    }
-
-    checksum = checksum %% modulus
-    if (checksum == 0) { # defined to be incorrect
-        return(FALSE)
-    } else {
-        checksum = (modulus - checksum)
-
-        if (nhi_type == 'original format') {
-            # change 10 to 0, otherwise left unchanged:
-            checksum = as.character(checksum %% 10)
-        } else {
-            # in the new format, convert it to a letter:
-            checksum = names(nhi_env$lookup)[checksum]
-        }
-
-        # compare to the final check digit:
-        if (checksum == characters[7]) {
-            return(TRUE)
-        } else {
-            return(FALSE)
-        }
-    }
-}
 
 #' Conduct internal validity check of an NHI.
 #'
@@ -57,6 +12,9 @@
 #' them as invalid (almost certainly the right choice in real-world
 #' situations).
 #'
+#' @param error_if_invalid If any value is an invalid NHI, option to throw 
+#' an error and list the problem indexes
+#' 
 #' @return \code{TRUE} if the format is correct and the final check digit
 #' matches the calculated value, \code{FALSE} otherwise.
 #'
@@ -70,29 +28,69 @@
 #' nhi_valid('ZZZ00AX') # FALSE in real-world situations
 #'
 #' @export
-nhi_valid <- function(nhi, allow_test_cases = FALSE) {
-
-    # allow for more than one value to be processed:
-    n = length(nhi)
-    result = rep(NA, n) # create a same-length vector to return
-
-    for (i in 1:n) {
-
-        # check if empty:
-        if (is.na(nhi[i])) {
-            result[i] = NA
 
-        } else {
-            # check for the basic sequential structure of valid letters and digits:
-            nhi_type = nhi_format(nhi[i], allow_test_cases = allow_test_cases)
+nhi_valid <- function(
+    nhis, 
+    nhi_type = 'original format',
+    allow_test_cases = FALSE,
+    error_if_invalid = FALSE) {
+
+    checksum = 0
+
+    sum_first_six_nhi_characters <- function(x){
+      sum(
+        nhi_env$lookup[x[-length(x)]]*(7:2)
+      )
+    }
+
+    nhis = toupper(nhis)
+    nhi_df <- data.frame(nhis = nhis)
+    # nhi_format takes care of steps 1-3
+    nhi_df$type <- nhi_format(nhi_df$nhis,allow_test_cases = allow_test_cases)
+    nhi_df$characters <- strsplit(nhi_df$nhis, split = '')
+    nhi_df$characters[is.na(nhi_df$characters)] <- list(rep(NA_character_,7))
+
+
+    nhi_df$modulo <- c(    
+      'original format' = 11,
+      'revised format' = 23
+    )[nhi_df$type]
+
+    nhi_df$last_character <- 
+      lapply(nhi_df$characters,\(x)tail(x,n=1)) |> 
+      unlist()
+
+    nhi_df$checksum <- nhi_env$lookup[nhi_df$last_character]
 
-            if (nhi_type == 'original format' | nhi_type == 'revised format') {
-                result[i] = .is_valid_nhi(nhi[i], nhi_type) # TRUE or FALSE
-            } else { # was invalid format:
-                result[i] = FALSE
-            }
-            }
+    nhi_df$sumtocheck <- 
+      lapply(
+        nhi_df$characters,
+        sum_first_six_nhi_characters
+        ) |> unlist()
+
+    nhi_df$is_valid <- 
+      nhi_df$checksum == 
+      (nhi_df$modulo - (nhi_df$sumtocheck %% nhi_df$modulo))
+
+    if(error_if_invalid){
+      if(any(!nhi_df$is_valid)){
+
+        invalid_indices <- which(!nhi_df$is_valid)
+        truncated <- ifelse(
+          length(invalid_indices)>10,
+          paste(paste(invalid_indices[1:10],collapse = ', '),'...'),
+          paste(invalid_indices,collapse = ", ")
+        )
+
+        stop(paste0(
+          'Invalid NHI(s) in ',length(invalid_indices),' row(s): ',
+          truncated
+          )
+        )
+      }
     }
 
-    return(result)
+       return(nhi_df$is_valid)
 }
+
+

R/nhiValidator.R

@@ -10,7 +10,8 @@ nhi_env <- new.env(emptyenv())
 
 # define values for 24 letters (excluding I and O) and 10 digits:
 nhi_env$lookup = c(1:24, 0:9)
+nhi_env$letters <- LETTERS  |> setdiff(c('I','O'))
+nhi_env$numbers <- 0:9 |> as.character()
 
 # to look up values by name:
-names(nhi_env$lookup) =
-    strsplit('ABCDEFGHJKLMNPQRSTUVWXYZ0123456789', split =  '')[[1]]
+names(nhi_env$lookup) = c(nhi_env$letters,nhi_env$numbers)

README.Rmd

@@ -112,13 +112,7 @@ you can override that behaviour by setting the
 No further feature development is envisaged but issue reports and pull requests 
 are certainly welcome.
 
-The package functions are vectorised only to the extent that they can be passed 
-a vector of values and return a corresponding vector of results. Under the hood,
-however, the functions iterate over each entry in the vector and process them 
-sequentially. This can lead to slow performance when processing a lot of values. 
-If for some reason you need to validate a million NHIs, for example, expect to 
-wait for half an hour. Performance optimisation is not a priority for the 
-original developer but pull requests in that regard will be gratefully received.
+As of version 0.6.1 the primary functions are vectorised, but there is still optimisation potential. Pull requests in that regard will be gratefully received.
 
 ## Licence
 
@@ -127,5 +121,7 @@ at the New Zealand Brain Research Institute. It is released as open-source
 software under an [MIT licence](https://opensource.org/licenses/MIT). Note the 
 provisions under that licence about warranties and liability.
 
+Vectorisation was added by [Giles Graham](emailto:giles.graham@phfscience.nz)
+
 Please report any issues or suggestions using the [Github issues page for this project](https://github.com/nzbri/nhiValidator/issues).