diff --git a/R/qr_vcard.R b/R/qr_vcard.R index b83a49c..07be287 100644 --- a/R/qr_vcard.R +++ b/R/qr_vcard.R @@ -22,6 +22,7 @@ #' @param middle Optionally one or more middle names. #' @param prefix Optionally one or more prefixes. #' @param suffix Optionally one or more suffixes. +#' @param version The vCard version. Must be one of "4.0", "3.0" or "2.1". #' @inheritParams qr_code #' @param ... Additional arguments are silently ignored. #' @export @@ -29,13 +30,15 @@ qr_vcard <- function( given, family, address, email, telephone, organisation, job_title, url, gender, logo, photo, middle = character(0), prefix = character(0), - suffix = character(0), ecl = c("L", "M", "Q", "H"), ... + suffix = character(0), version = c("4.0", "3.0", "2.1"), + ecl = c("L", "M", "Q", "H"), ... ) { assert_that( is.string(given), is.string(family), noNA(given), noNA(family), is.character(middle), is.character(prefix), is.character(suffix), noNA(middle), noNA(prefix), noNA(suffix) ) + version <- match.arg(version) ecl <- match.arg(ecl) given <- vcard_escape(given) family <- vcard_escape(family) @@ -43,7 +46,7 @@ qr_vcard <- function( prefix <- vcard_escape(prefix) suffix <- vcard_escape(suffix) c( - "BEGIN:VCARD", "VERSION:4.0", + "BEGIN:VCARD", sprintf("VERSION:%s", version), vcard_fname( given = given, family = family, middle = middle, prefix = prefix, suffix = suffix @@ -57,8 +60,8 @@ qr_vcard <- function( vcard_multi(x = organisation, element = "ORG"), vcard_multi(x = job_title, element = "TITLE"), vcard_multi_type(x = url, element = "URL"), - vcard_multi_type(x = logo, element = "LOGO"), - vcard_multi_type(x = photo, element = "PHOTO"), + vcard_media(x = logo, element = "LOGO"), + vcard_media(x = photo, element = "PHOTO"), vcard_single(x = gender, element = "GENDER"), "END:VCARD" ) |> vapply(vcard_wrap, character(1), width = 75) |> @@ -192,6 +195,31 @@ vcard_multi_type <- function(x, element) { ) } +#' @importFrom assertthat assert_that is.string noNA +vcard_media <- function(x, element = c("LOGO", "PHOTO")) { + if (missing(x)) { + return(character(0)) + } + assert_that(check_url(x)) + element <- match.arg(element) + if (is.null(names(x))) { + names(x) <- NA + } + vcard_escape(x) |> + sprintf(fmt = "%1$s;%2$s", element) +} + +#' @importFrom assertthat assert_that noNA +check_url <- function(x) { + assert_that(is.character(x), noNA(x)) + paste0( + "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}", + "\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)" + ) |> + grepl(pattern = _, x = x, perl = TRUE) -> checked + all(checked) +} + #' @importFrom assertthat assert_that is.string noNA vcard_single <- function(x, element) { if (missing(x)) { diff --git a/man/qr_vcard.Rd b/man/qr_vcard.Rd index d5b72df..6c8ff05 100644 --- a/man/qr_vcard.Rd +++ b/man/qr_vcard.Rd @@ -19,6 +19,7 @@ qr_vcard( middle = character(0), prefix = character(0), suffix = character(0), + version = c("4.0", "3.0", "2.1"), ecl = c("L", "M", "Q", "H"), ... ) @@ -61,6 +62,8 @@ The names of the vector are used as the type of the URL.} \item{suffix}{Optionally one or more suffixes.} +\item{version}{The vCard version. Must be one of "4.0", "3.0" or "2.1".} + \item{ecl}{the required error correction level. Available options are \code{"L"} (7\%), \code{"M"} (15\%), \code{"Q"} (25\%) and \code{"H"} (30\%). Defaults to \code{"L"}.} diff --git a/tests/testthat/test_e_qr_vcard.R b/tests/testthat/test_e_qr_vcard.R index 641e78d..90ff273 100644 --- a/tests/testthat/test_e_qr_vcard.R +++ b/tests/testthat/test_e_qr_vcard.R @@ -24,7 +24,7 @@ test_that("qr_vcard()", { address = list( work = c( street_nr = "123 Main St.", city = "Anytown", region = "NY", - postal_code = "12345", country = "USA", pobox = "PO Box 123" + postal_code = "12345", country = "USA" ), home = c( street_nr = "321 Main St.", city = "Anytown", region = "NY", diff --git a/tests/testthat/test_f_opencv.R b/tests/testthat/test_f_opencv.R index 54b8f0f..ab22217 100644 --- a/tests/testthat/test_f_opencv.R +++ b/tests/testthat/test_f_opencv.R @@ -25,4 +25,9 @@ test_that("test generated codes", { Encoding(input) <- "latin1" test_read_qr(input) test_read_qr("\u00E6") + + sharp_s <- "stra\u00DFe" #UTF-8 encoding + test_read_qr(sharp_s) + Encoding(sharp_s) <- "latin1" #latin1 encoding + test_read_qr(sharp_s) })