Support for alliterative adjective animals

DESCRIPTION

@@ -1,14 +1,14 @@
 Package: ids
 Title: Generate Random Identifiers
-Version: 1.0.1
+Version: 1.1.0
 Authors@R: person("Rich", "FitzJohn", role = c("aut", "cre"),
     email = "rich.fitzjohn@gmail.com")
 Description: Generate random or human readable and pronounceable identifiers.
 License: MIT + file LICENSE
 URL: https://github.com/richfitz/ids
 BugReports: https://github.com/richfitz/ids/issues
 Imports:
-    openssl,
+    openssl (>= 0.9.6),
     uuid
 Suggests:
     knitr,

NEWS.md

@@ -1,6 +1,10 @@
-# ids 1.1.0 (2017-05-22)
+# ids 1.1.0 (unreleased)
 
-* Fix occasionally failing text (removes one animal from the pool)
+* The `adjective_animal` generator now supports alliterative adjective animals (such as `convectional_conflictory_cod`), though this reduces the pool size (#5, requested by @gadenbuie).
+
+# ids 1.0.1 (2017-05-22)
+
+* Fix occasionally failing test (removes one animal from the pool)
 * New identifier type "proquint"
 
 # ids 1.0.0 (2016-11-03)

R/adjective_animal.R

@@ -15,6 +15,12 @@
 #'   first element will apply to the adjectives (all of them) and the
 #'   second element will apply to the animals.
 #'
+#' @param alliterate Produce "alliterative" adjective animals (e.g.,
+#'   \code{hessian_hamster}).  Note that this cannot provide an equal
+#'   probability of any particuilar combination because it forces a
+#'   weighted sampling.  Adjectives may also be repeated if
+#'   \code{n_adjectives} is more than 1.
+#'
 #' @inheritParams ids
 #' @export
 #' @author Rich FitzJohn
@@ -48,8 +54,11 @@
 #' id <- adjective_animal(NULL, n_adjectives = 2, style = "dot", max_len = 6)
 #' id()
 #' id(10)
+#'
+#' # Alliterated adjective animals aid awesomeness
+#' adjective_animal(10, n_adjectives = 3, alliterate = TRUE)
 adjective_animal <- function(n = 1, n_adjectives = 1, style = "snake",
-                             max_len = Inf) {
+                             max_len = Inf, alliterate = FALSE) {
   if (any(is.finite(max_len))) {
     if (any(max_len < 3)) {
       stop("max_len must be at least 3")
@@ -64,5 +73,50 @@ adjective_animal <- function(n = 1, n_adjectives = 1, style = "snake",
     gfycat_animals <- gfycat_animals[nchar(gfycat_animals) <= max_len[2]]
   }
   vals <- c(rep(list(gfycat_adjectives), n_adjectives), list(gfycat_animals))
-  ids(n, vals = vals, style = style)
+  if (alliterate) {
+    aa_alliterate(n, vals, style)
+  } else {
+    vals <- c(rep(list(gfycat_adjectives), n_adjectives), list(gfycat_animals))
+    ids(n, vals = vals, style = style)
+  }
+}
+
+
+## We can generate alliterative ids by either rejection sampling
+## (which will be hard with multiple adjectives) or by doing a
+## weighted sample of letters and then working with each letter
+## separately.  To do this properly we should compute the number of
+## distinct combinations and avoid duplications but that seems
+## excessive for this and is only an issue if the number of adjectives
+## is greater than one.  Practically we found the number of duplicated
+## names low enough when the max_len is not set too low and some were
+## quite amusing, such as "hot_hot_hot_hen".
+aa_alliterate <- function(n, vals, style) {
+  m <- lapply(vals, function(x) split(x, factor(substr(x, 1, 1), letters)))
+  m <- matrix(unlist(m, FALSE, FALSE), 26, length(vals),
+              dimnames = list(letters, NULL))
+
+  p <- rowSums(log(lengths(m)))
+  p <- exp(p - max(p))
+  p <- p / sum(p)
+
+  gen1 <- function(start, n) {
+    ids(n, vals = m[start, , drop = TRUE], style = style)
+  }
+
+  gen <- function(n = 1) {
+    start <- letters[sample.int(26, n, prob = p, replace = TRUE)]
+    ret <- character(n)
+    for (i in unique(start)) {
+      j <- start == i
+      ret[j] <- gen1(i, sum(j))
+    }
+    ret
+  }
+
+  if (is.null(n)) {
+    gen
+  } else {
+    gen(n)
+  }
 }

R/proquint.R

@@ -158,11 +158,11 @@ int_to_proquint <- function(x, use_cache = TRUE) {
     f <- function(el) {
       n_words <- big_log_ceil(el, PROQUINT_WORD)
       if (n_words == 1L) {
-        as_integer_bignum(el)
+        as.integer(el)
       } else {
         pow <- rsequence(n_words) - 1L
         vapply(n_words - seq_len(n_words),
-               function(pow) as_integer_bignum(el %/% (base^pow) %% base),
+               function(pow) as.integer(el %/% (base^pow) %% base),
                integer(1))
       }
     }
@@ -325,29 +325,6 @@ is_bignum_list <- function(x) {
     inherits(el, "bignum") || is.null(el), logical(1)))
 }
 
-## This is a hack until openssl is updated; the development version
-## has a new as.integer method that should works nicely.
-##
-## TODO: before CRAN release, check that this does actually work!  See
-## the relevant test in test-proquint.R
-as_integer_bignum <- function(x) {
-  if (openssl_supports_as_integer()) {
-    as.integer(x) # nocov
-  } else {
-    x <- as.raw(x)
-    i <- length(x) - seq_along(x)
-    as.integer(sum(256^i * as.integer(x)))
-  }
-}
-
-openssl_supports_as_integer <- function() {
-  if (is.null(cache$openssl_supports_as_integer)) {
-    cache$openssl_supports_as_integer <-
-      utils::packageVersion("openssl") > "0.9.6"
-  }
-  cache$openssl_supports_as_integer
-}
-
 na_recall <- function(x, na, fun, ..., missing = is.na(x)) {
   ret <- rep(na, length(x))
   i <- !missing

tests/testthat/test-adjective-animal.R

@@ -63,3 +63,19 @@ test_that("functional interface", {
   x <- f(100)
   expect_true(all(grepl(re, x)))
 })
+
+
+test_that("alliterate", {
+  res <- adjective_animal(10, alliterate = TRUE)
+  res <- strsplit(res, "_", fixed = TRUE)
+  m <- vapply(res, substr, character(2), 1, 1)
+  expect_equal(m[1, ], m[2, ])
+})
+
+
+test_that("alliterate: functional", {
+  res <- adjective_animal(NULL, n_adjective = 4, alliterate = TRUE)
+  expect_is(res, "function")
+  s <- strsplit(res(1), "_", fixed = TRUE)[[1]]
+  expect_equal(length(unique(substr(s, 1, 1))), 1)
+})

tests/testthat/test-proquint.R

@@ -319,11 +319,3 @@ test_that("numeric overflow", {
   expect_identical(proquint_to_int(pq, "bignum"),
                    list(openssl::bignum(big)))
 })
-
-## This supports my temporary as_integer_bignum function:
-test_that("as_integer_bignum", {
-  x <- c(0L, 255L, 256L, 1000L, 200000L, .Machine$integer.max)
-  for (i in x) {
-    expect_identical(as_integer_bignum(openssl::bignum(i)), i)
-  }
-})