R/qr_js.R

In brianwdavis/quadrangle: Wrangle QR Codes Out of Images

#' Scan an image within a restricted geometry context.
#' 
#' This function is usually only called by \code{qr_scan}, when a pattern is
#' detected, but decoding it fails. It crops the original image to the 
#' neighborhood of pixels targeting the patterns, and re-scans only that region
#' using the JS library. If your images are particularly high-resolution, this
#' will resize them to 50\%, which seems to increase the chances of recognition.
#' 
#' This uses a double-\code{while} loop that progressively pushes mid-brightness
#' pixels to pure black, and if that fails, progressively pushes mid-brightness
#' pixels to pure white. This algorithm was developed for identifying QR codes
#' on white printed sheets in outdoor images, in bright sun with or without
#' shadows. To speed up scanning, you can use arguments \code{lighten = F,
#' darken = F} which will skip any thresholding. If you use both \code{lighten = T, darken = T},
#' scanning may be quite slow until a decodable QR code is found. In those cases,
#' a progress bar will attempt to be shown, if you have the \pkg{progress}
#' package (\url{https://github.com/r-lib/progress}) available on your machine.
#'
#' To BYO algorithm, you can use this function as a template. For example,
#' \code{\link{image_morphology}} with \code{(..., morphology = "Open", kernel =
#' "Square:n")} (varying \code{n} from 2 to 10) may repair corrupted QR blocks.
#' 
#' @param mgk      A \pkg{magick} image object.
#' @param code_pts A dataframe of columns \strong{x} and \strong{y}, with each row identifying a QR pattern corner, usually generated by \code{qr_scan_cpp_magick}.
#' @param lighten Logical. Should under-exposed areas of the image be lightened to increase contrast? Useful for images in shadow. Default \code{FALSE}.
#' @param darken Logical. Should over-exposed areas of the image be darkened to increase contrast? Useful for images in bright light. Default \code{TRUE}.
#' @param verbose Logical. Should warnings print for potentially slow operations?
#' @return If decodable, a list with metadata about the identified QR code.
qr_scan_js_from_corners <- function(
  mgk, 
  code_pts, 
  lighten = FALSE, 
  darken = TRUE, 
  verbose = interactive()
  ) {
  
  parsedcorners <- qr_parse_corners_(mgk, code_pts)
  mgk <- parsedcorners$mgk
  
  codes <- list()
  thr_w <- paste0(c(100,50,45,40,35,30,25), "%")
  thr_b <- paste0(c(  0,50,60,70,80,90,95), "%")
  
  j <- 0
  
  if (!lighten) thr_w <- thr_w[1]
  if (!darken) thr_b <- thr_b[1]
  if (lighten && darken && verbose) {
    warning(
      "Cleaning up both over-exposed and under-exposed areas may be slow.",
      immediate. = TRUE, call. = FALSE
      )
  }
  
  pb <- qr_pb_("JS", length(thr_w)*length(thr_b))
  
  while (length(codes) == 0 & j < length(thr_w)) {
    j <- j+1
    mgk <- qr_threshold_shortcut_(mgk, "white", thr_w[j])
    i <- 0
    
    while (length(codes) == 0 & i < length(thr_b)) {
      i <- i+1
      pb$tick(tokens = list(l = thr_w[j], d = thr_b[i]))
      
      codes <- qr_threshold_shortcut_(mgk, "black", thr_b[i]) %>% 
        magick::image_data(channels = "rgba") %>% 
        qr_scan_js_array()
      
    }
  }
  
  if (length(codes) != 0) {
    if (parsedcorners$resize_flag) {
      codes$location$x <- codes$location$x * 2
      codes$location$y <- codes$location$y * 2
    }
    
    codes$location$x <- round(codes$location$x + parsedcorners$anc_x)
    codes$location$y <- round(codes$location$y + parsedcorners$anc_y)
  }
  codes
}


#' (Internal) Crop and resize large images to QR corner neighborhoods
#' 
#' This is an internal function used by \code{\link{qr_scan_js_from_corners}}.
#' 
#' @keywords internal
#' 
#' @param mgk      A \pkg{magick} image object.
#' @param code_pts A dataframe of columns \strong{x} and \strong{y}, with each row identifying a QR pattern corner, usually generated by \code{qr_scan_cpp_magick}.
#' @return A list with the altered image, the \strong{x}/\strong{y} anchor pixels, and a resizing flag
qr_parse_corners_ <- function(mgk, code_pts) {
  ret <- 
    sapply(
      c("mgk", "anc_x", "anc_y", "resize_flag"), 
      function(x) FALSE,
      simplify = FALSE
      )
  
  if (nrow(code_pts) != 0) {
    ret$anc_x <- max(min(code_pts$x) - 50, 0)
    ret$anc_y <- max(min(code_pts$y) - 50, 0)
    
    dim_x <- min(diff(range(code_pts$x)) + 100, magick::image_info(mgk)$width-ret$anc_x)
    dim_y <- min(diff(range(code_pts$y)) + 100, magick::image_info(mgk)$height-ret$anc_y)
    
    ret$resize_flag <- max(dim_x, dim_y) > 400
    
    geo <- glue::glue("{dim_x}x{dim_y}+{ret$anc_x}+{ret$anc_y}")
    
    mgk <- magick::image_crop(mgk, geo)
    
    if (ret$resize_flag) {
      mgk <- magick::image_resize(mgk, "50%")
    }
  }
  
  ret$mgk <- mgk
  return(ret)
}


#' Set missing text from bytes assuming latin1
#'
#' This function is only called by \code{\link{qr_parse_js_}}, to fill missing
#' text entries from the bytes integer vector.
#'
#' @keywords internal
#' @param lst A list with dataframe element \strong{values}, used in the internal of \code{\link{qr_parse_js_}}.
#' @return A list with dataframe element \strong{values}.
set_missing_text_to_latin1_ <- function(lst) {
  vs <- lst[["values"]]
  try_latin1_rows <- vs[["type"]] == "byte" & purrr::map_int(vs[["bytes"]], length) > 0 & !nzchar(vs[["text"]])
  if (all(try_latin1_rows == FALSE)) return(lst)
  vs[try_latin1_rows, "text"] <- purrr::map_chr(vs[try_latin1_rows, c("bytes")], function(cv) rawToChar(as.raw(cv)))
  Encoding(vs[try_latin1_rows, "text"]) <- "latin1"
  lst[["values"]] <- vs
  return(lst)
}

#' Parse multiple QR objects into a single object.
#' 
#' This function is usually only called by \code{\link{qr_scan}}, to combine multiple
#' objects returned by \code{\link{qr_scan_js_from_corners}} into a single dataframe,
#' analogous to the output from \code{rcpp_qr_scan_array} or \code{\link{qr_scan_cpp}}.
#' 
#' @keywords internal
#' @param lst A list returned by \code{\link{qr_scan_js_from_corners}}, with dataframe elements \strong{chunks} and \strong{location}.
#' @return If not empty, a list with two dataframe elements, \strong{values} and \strong{points}, identifying all QR codes from an image.
qr_parse_js_ <- function(lst) {
  result <- list()
  
  result$values <- 
    purrr::map(lst, "chunks")  %>% 
    qr_rbind_(.id = "id")

  result <- set_missing_text_to_latin1_(result)

  result$values$bytes <- NULL
  
  names(result$values) <- c("id", "type", "value")[seq_along(names(result$values))]

  result$points <- 
    purrr::map(lst, "location") %>% 
    qr_rbind_(.id = "id") 
  
  result
}