Torch model

.Rbuildignore

@@ -12,3 +12,4 @@
 ^LICENSE\.md$
 paper/
 ^CRAN-SUBMISSION$
+^data-raw$

.gitignore

@@ -52,3 +52,7 @@ cran-comments.md
 raw-data
 
 /.quarto/
+
+# Neural network model artifacts (hosted on Hugging Face)
+inst/model/*.pt
+inst/model/*.rds

DESCRIPTION

@@ -1,22 +1,25 @@
 Package: genderBR
 Type: Package
 Title: Predict Gender from Brazilian First Names
-Version: 1.2.1
+Version: 1.3.0
 Authors@R: person("Fernando", "Meireles", , "fernando.meireles@iesp.uerj.br", c("aut", "cre"), c(ORCID = "0000-0002-7027-2058"))
 Description: A method to predict and report gender from Brazilian first names
     using the Brazilian Institute of Geography and Statistics' Census data.
 License: GPL (>= 2)
 Depends: R (>= 4.1.0)
-Imports: 
+Imports:
     data.table,
     jsonlite,
     httr,
-    purrr
+    purrr,
+    torch (>= 0.13.0)
 Encoding: UTF-8
 URL: https://github.com/meirelesff/genderBR
 BugReports: https://github.com/meirelesff/genderBR/issues
-RoxygenNote: 7.3.2
-Suggests: 
+RoxygenNote: 7.3.3
+Suggests:
     testthat (>= 3.0.0),
-    covr
+    covr,
+    httr2,
+    luz
 Config/testthat/edition: 3

NAMESPACE

@@ -1,7 +1,11 @@
 # Generated by roxygen2: do not edit by hand
 
+export(clear_nn_cache)
+export(download_gender_model)
 export(get_gender)
+export(get_gender_nn)
 export(get_states)
 export(map_gender)
 import(data.table)
+import(torch)
 importFrom(purrr,possibly)

NEWS.md

@@ -1,4 +1,10 @@
-# genderBR 1.2.1
+# genderBR 1.3.0
+
+- Added `get_gender_nn()`, a new exported function that uses a character-level neural network to predict gender from Brazilian first names. Unlike `get_gender()`, this function can generalise to names not present in the IBGE census dataset.
+- The model is a bidirectional GRU (embedding dim = 32, hidden dim = 128, single layer) trained on 107k names from the IBGE dataset using the `luz` framework. On a held-out test set (10% of data), it achieves 95.1% accuracy and 0.141 BCE loss.
+- Added `clear_nn_cache()` to manage the in-memory model cache.
+- Model weights and vocabulary are hosted on Hugging Face and downloaded on first use; subsequent calls within the same session are served from an in-memory cache.
+- Added `torch` to `Imports`; `luz` and `httr2` to `Suggests`.
 
 
 # genderBR 1.2.0

R/get_gender.R

@@ -32,6 +32,12 @@
 #' Defaults to \code{ASCII//TRANSLIT}.
 #' @param year Census year used in the prediction. Supported values are \code{2010}
 #' and \code{2022} (default).
+#' @param nn Logical. If \code{TRUE}, use a character-level neural network model
+#' to predict gender instead of the IBGE Census data. This allows the function to
+#' generalise to names not present in the IBGE dataset. When \code{nn = TRUE}, the
+#' \code{state}, \code{internal}, and \code{year} arguments are ignored. Model files
+#' must be downloaded first with \code{\link{download_gender_model}}. Defaults to
+#' \code{FALSE}.
 #'
 #' @section Data:
 #'
@@ -89,7 +95,7 @@
 
 get_gender <- function(names, state = NULL, prob = FALSE, threshold = 0.9,
                        internal = TRUE, encoding = "ASCII//TRANSLIT",
-                       year = 2022){
+                       year = 2022, nn = FALSE){
 
 
   # Inputs
@@ -99,6 +105,11 @@ get_gender <- function(names, state = NULL, prob = FALSE, threshold = 0.9,
   if(!is.logical(internal)) stop("'internal' must be logical.")
   if(!is.character(names)) stop("'names' must be character.")
   if(!is.logical(prob)) stop("'Prob' must be logical.")
+  if(!is.logical(nn)) stop("'nn' must be logical.")
+
+  # Neural network prediction
+  if(nn) return(get_gender_nn(names, prob = prob, threshold = threshold, encoding = encoding))
+
   if(!is.numeric(year)) stop("'year' must be numeric, either 2010 or 2022.")
   year <- as.integer(year)
   if(!year %in% c(2010, 2022)) stop("'year' must be either 2010 or 2022.")

R/get_gender_nn.R

@@ -0,0 +1,220 @@
+# Inputs
+.hf_user <- "fmeireles"
+.hf_repo <- "genderBR"
+.gbr_cache <- new.env(parent = emptyenv())
+
+
+#' Predict gender from Brazilian first names using a neural network
+#'
+#' \code{get_gender_nn} uses a character-level GRU neural network to predict
+#' gender from Brazilian first names. Unlike \code{\link{get_gender}}, this
+#' function can generalise to names not present in the IBGE census dataset.
+#'
+#' Model weights and vocabulary must be downloaded before first use with
+#' \code{\link{download_gender_model}}. If the files are not found in an
+#' interactive session, you will be prompted to download them. Subsequent
+#' calls within the same session use an in-memory cache.
+#'
+#' @param names A character vector specifying a person's first name. Names can
+#'   also be passed to the function as a full name (e.g., Ana Maria de Souza).
+#'   \code{get_gender_nn} is case insensitive.
+#' @param prob Report the proportion of female uses of the name? Defaults to
+#'   \code{FALSE}.
+#' @param threshold Numeric indicating the threshold used in predictions.
+#'   Defaults to 0.9.
+#' @param encoding Encoding used to read Brazilian names and strip accents.
+#'   Defaults to \code{ASCII//TRANSLIT}.
+#'
+#' @return \code{get_gender_nn} may return three different values:
+#'   \code{Female}, if the name provided is female; \code{Male}, if the name
+#'   provided is male; or \code{NA}, if we can not predict gender from the
+#'   name given the chosen threshold.
+#'
+#'   If the \code{prob} argument is set to \code{TRUE}, then the function
+#'   returns the proportion of females uses of the provided name.
+#'
+#' @seealso \code{\link{get_gender}}, \code{\link{download_gender_model}}
+#'
+#' @examples
+#' \dontrun{
+#' get_gender_nn("Maria")
+#' get_gender_nn(c("Maria", "Joao"), prob = TRUE)
+#' get_gender_nn("Ana Maria de Souza")
+#' }
+#'
+#' @export
+
+get_gender_nn <- function(names, prob = FALSE, threshold = 0.9,
+                          encoding = "ASCII//TRANSLIT") {
+
+  if (!is.character(names)) {
+    stop("'names' must be character.", call. = FALSE)
+  }
+  if (!is.logical(prob)) stop("'prob' must be logical.", call. = FALSE)
+  if (!is.numeric(threshold)) stop("'threshold' must be numeric, between 0 and 1.", call. = FALSE)
+  if (threshold < 0 || threshold > 1) stop("'threshold' must be between 0 and 1.", call. = FALSE)
+
+  .load_nn_model()
+  meta <- .gbr_cache$meta
+  model <- .gbr_cache$model
+
+  # Clean names (same logic as get_gender)
+  cleaned <- clean_names(name = names, encoding = encoding)
+
+  # Pre-allocate result
+  n <- length(names)
+  probs <- rep(NA_real_, n)
+
+  # Identify valid (non-NA, non-empty) entries
+  valid <- !is.na(cleaned) & nchar(cleaned) > 0
+  if (any(valid)) {
+    encoded <- vapply(
+      cleaned[valid],
+      .encode_name,
+      integer(meta$max_len),
+      meta = meta,
+      USE.NAMES = FALSE
+    )
+    # encoded is (max_len, n_valid) matrix; transpose to (n_valid, max_len)
+    x <- torch::torch_tensor(t(encoded), dtype = torch::torch_long())
+
+    model$eval()
+    torch::with_no_grad({
+      logits <- model(x)
+    })
+    probs[valid] <- as.numeric(torch::torch_sigmoid(logits)$squeeze(2L))
+  }
+
+  if (prob) {
+    return(probs)
+  }
+
+  # Apply threshold
+  result <- rep(NA_character_, n)
+  female <- !is.na(probs) & probs >= threshold
+  male   <- !is.na(probs) & probs <= (1 - threshold)
+  result[female] <- "Female"
+  result[male]   <- "Male"
+  result
+}
+
+
+#' Clear the neural network in-memory cache
+#'
+#' Removes the model and vocabulary metadata from the in-memory session cache.
+#' The next call to \code{\link{get_gender_nn}} will reload them from the
+#' on-disk cache (no re-download needed if the files are already cached).
+#'
+#' @return Invisible \code{NULL}.
+#'
+#' @examples
+#' \dontrun{
+#' clear_nn_cache()
+#' }
+#'
+#' @export
+clear_nn_cache <- function() {
+  rm(list = ls(.gbr_cache), envir = .gbr_cache)
+  invisible(NULL)
+}
+
+
+# --- Private helpers --------------------------------------------------------
+
+.hf_resolve_url <- function(filename) {
+  paste0(
+    "https://huggingface.co/", .hf_user, "/", .hf_repo,
+    "/resolve/main/", filename
+  )
+}
+
+.cache_dir <- function() {
+  d <- tools::R_user_dir("genderBR", "cache")
+  if (!dir.exists(d)) dir.create(d, recursive = TRUE)
+  d
+}
+
+#' Download neural network model files
+#'
+#' Downloads the pre-trained model weights and vocabulary from Hugging Face
+#' to a local cache directory. This is required before using
+#' \code{\link{get_gender_nn}}.
+#'
+#' Files are stored in \code{tools::R_user_dir("genderBR", "cache")} and
+#' only downloaded if not already present.
+#'
+#' @return Invisible character vector with the paths to the downloaded files.
+#'
+#' @examples
+#' \dontrun{
+#' download_gender_model()
+#' }
+#'
+#' @export
+
+download_gender_model <- function() {
+  files <- c("genderbr_weights.pt", "genderbr_vocab.rds")
+  paths <- vapply(files, function(f) {
+    dest <- file.path(.cache_dir(), f)
+    if (!file.exists(dest)) {
+      url <- .hf_resolve_url(f)
+      utils::download.file(url, dest, mode = "wb", quiet = TRUE)
+    }
+    dest
+  }, character(1), USE.NAMES = FALSE)
+  invisible(paths)
+}
+
+.load_nn_model <- function() {
+  if (!is.null(.gbr_cache$model)) return(invisible(NULL))
+
+  vocab_path   <- file.path(.cache_dir(), "genderbr_vocab.rds")
+  weights_path <- file.path(.cache_dir(), "genderbr_weights.pt")
+
+  if (!file.exists(vocab_path) || !file.exists(weights_path)) {
+    if (interactive()) {
+      ans <- readline(
+        "Model files not found. Download them from Hugging Face? (Y/n) "
+      )
+      if (!tolower(trimws(ans)) %in% c("y", "yes", "")) {
+        stop("Model files are required. Run download_gender_model() to ",
+             "download them.", call. = FALSE)
+      }
+      download_gender_model()
+    } else {
+      stop("Model files not found. Run download_gender_model() first.",
+           call. = FALSE)
+    }
+  }
+
+  meta <- readRDS(vocab_path)
+  model <- name_gru_model(
+    vocab_size = meta$vocab_size,
+    embed_dim  = meta$embed_dim,
+    hidden_dim = meta$hidden_dim
+  )
+  model$load_state_dict(torch::torch_load(weights_path))
+  model$eval()
+
+  .gbr_cache$model <- model
+  .gbr_cache$meta  <- meta
+  invisible(NULL)
+}
+
+.encode_name <- function(nm, meta) {
+
+  chars <- strsplit(nm, "")[[1]]
+  if (length(chars) > meta$max_len) {
+    chars <- chars[seq_len(meta$max_len)]
+  }
+
+  idx <- vapply(chars, function(ch) {
+    if (ch %in% names(meta$char2idx)) meta$char2idx[[ch]] else 1L
+  }, integer(1), USE.NAMES = FALSE)
+
+  # Right-pad with PAD index (1L in 1-based R torch)
+  pad_idx <- meta$char2idx[["<PAD>"]]
+  out <- rep(pad_idx, meta$max_len)
+  out[seq_along(idx)] <- idx
+  out
+}

R/model.R

@@ -0,0 +1,40 @@
+# Model used to predict the probability of a name being female
+# based on a bidirectional GRU architecture. Trained on the Brazilian name dataset
+# with the luz training framework.
+# @noRd
+
+#' @import torch
+name_gru_model <- torch::nn_module(
+  "NameGRU",
+
+  initialize = function(vocab_size = 40L, embed_dim = 32L, hidden_dim = 64L) {
+    self$embedding <- torch::nn_embedding(
+      num_embeddings = vocab_size,
+      embedding_dim = embed_dim,
+      padding_idx = 1L
+    )
+    self$gru <- torch::nn_gru(
+      input_size = embed_dim,
+      hidden_size = hidden_dim,
+      num_layers = 1L,
+      batch_first = TRUE,
+      bidirectional = TRUE
+    )
+    self$dropout <- torch::nn_dropout(p = 0.3)
+    self$fc <- torch::nn_linear(hidden_dim * 2L, 1L)
+  },
+
+  forward = function(x) {
+    emb <- self$embedding(x)
+    out <- self$gru(emb)
+    h <- out[[2]]
+
+    h_fwd <- h[1L, , ]
+    h_bwd <- h[2L, , ]
+
+    hidden <- torch::torch_cat(list(h_fwd, h_bwd), dim = 2L)
+
+    hidden <- self$dropout(hidden)
+    self$fc(hidden)
+  }
+)