~hrbrmstr/uaparserjs

bef63f1612cdcc527114b5677b54b0862c55847f — hrbrmstr 10 months ago 5dc20f9
R CMD check and cinc
4 files changed, 9 insertions(+), 269 deletions(-)

M R/uaparser.R
M R/utils-mappers.R
M README.md
M man/ua_parse.Rd
M R/uaparser.R => R/uaparser.R +1 -0
@@ 53,5 53,6 @@ ua_parse <- function(user_agents, .progress=FALSE) {

}

#' @rdname ua_parse
#' @export
get_cache <- function() { .pkgenv$cache }

M R/utils-mappers.R => R/utils-mappers.R +0 -266
@@ 1,154 1,8 @@
# NOTE: At the bottom of this source file show the equivalents to purrr mappers
#
# NOTE these aren't 100% equivalent to the purrr mappers but cover very common use-cases
#
# NOTE formula function (e.g. ~{}) are 100% supported
#
# NOTE: THESE DO NOT SUPPORT list EXTRACTORS

set_names <- function(object = nm, nm) {
  names(object) <- nm
  object
}

map <- function(.x, .f, ..., .default) {

  default_exists <- !missing(.default)

  if (inherits(.f, "formula")) {
    .body <- dimnames(attr(terms(.f), "factors"))[[1]]
    .f <- function(.x, . = .x) {}
    body(.f) <- as.expression(parse(text=.body))
  }

  nm <- names(.x)

  if (inherits(.f, "function")) {

    lapply(.x, function(x) {
      res <- .f(x, ...)
      if ((length(res) == 0) & default_exists) res <- .default
      res
    }) -> out

  } else if (is.numeric(.f) | is.character(.f)) {

    lapply(.x, function(x) {
      res <- try(x[[.f]], silent = TRUE)
      if (inherits(res, "try-error")) res <- NULL
      if ((length(res) == 0) & default_exists) res <- .default
      res
    }) -> out

  }

  if (length(nm) > 0) out <- set_names(out, nm)

  out

}

map2 <- function(.x, .y, .f, ..., .default) {

  default_exists <- !missing(.default)

  if (inherits(.f, "formula")) {
    .body <- dimnames(attr(terms(.f), "factors"))[[1]]
    .f <- function(.x, .y, . = .x) {}
    body(.f) <- as.expression(parse(text=.body))
  }

  if (inherits(.f, "function")) {
    mapply(
      function(x, ...) {
        res <- .f(x, ...)
        if ((length(res) == 0) & default_exists) res <- .default
        res
      },
      .x, .y,
      ...,
      SIMPLIFY=FALSE, USE.NAMES=FALSE
    )
  }

}

map_chr <- function(.x, .f, ...) {
  nm <- names(.x)
  out <- as.character((map(.x, .f, ..., .default = .default)))
  if (length(nm) > 0) set_names(out, nm) else out
}

map2_chr <- function(.x, .y, .f, ...) {
  as.character(unlist(map2(.x, .y, .f, ..., .default = .default)))
}

map_lgl <- function(.x, .f, ...) {
  nm <- names(.x)
  out <- as.logical(unlist(map(.x, .f, ..., .default = .default)))
  if (length(nm) > 0) set_names(out, nm) else out
}

map2_lgl <- function(.x, .y, .f, ...) {
  as.logical(unlist(map2(.x, .y, .f, ..., .default = .default)))
}

map_dbl <- function(.x, .f, ...) {
  nm <- names(.x)
  out <- as.double(unlist(map(.x, .f, ..., .default = .default)))
  if (length(nm) > 0) set_names(out, nm) else out
}

map2_dbl <- function(.x, .y, .f, ...) {
  as.double(unlist(map2(.x, .y, .f, ..., .default = .default)))
}

map_int <- function(.x, .f, ..., .default) {
  nm <- names(.x)
  out <- as.integer(unlist(map(.x, .f, ..., .default = .default)))
  if (length(nm) > 0) set_names(out, nm) else out
}

map2_int <- function(.x, .y, .f, ...) {
  as.integer(unlist(map2(.x, .y, .f, ..., .default = .default)))
}


map_df <- function(.x, .f, ..., .id=NULL) {

  res <- map(.x, .f, ...)
  out <- bind_rows(res, .id=.id)
  out

}

map_dfr <- map_df

map_dfc <- function(.x, .f, ...) {

  res <- map(.x, .f, ...)
  out <- bind_cols(res)
  out

}

map2_df <- function(.x, .y, .f, ..., .id=NULL) {

  res <- map2(.x, .y, .f, ...)
  out <- bind_rows(res, .id = .id)
  out

}


map2_dfc <- function(.x, .y, .f, ...) {

  res <- map2(.x, .y, .f, ...)
  out <- bind_cols(res)
  out

}

# this has limitations and is more like 75% of dplyr::bind_rows()
# this is also orders of magnitude slower than dplyr::bind_rows()
bind_rows <- function(..., .id = NULL) {


@@ 198,123 52,3 @@ bind_rows <- function(..., .id = NULL) {
  out

}

bind_cols <- function(...) {

  res <- list(...)

  row_mismatch <- lapply(res, nrow) != nrow(res[[1]])

  if (any(row_mismatch)) {
    first_mismatch_pos <- which(row_mismatch)[1]
    stop(paste0("Argument ", first_mismatch_pos,
                " must be length ", nrow(res[[1]]),
                ", not ", nrow(res[[first_mismatch_pos]])))
    }

  if (length(res) == 1) res <- res[[1]]

  col_names <- unlist(lapply(res, names), use.names = FALSE)
  col_names <- make.unique(col_names, sep = "")

  saf <- default.stringsAsFactors()
  options(stringsAsFactors = FALSE)
  on.exit(options(stringsAsFactors = saf))

  out <- do.call(cbind.data.frame, res)

  names(out) <- col_names
  rownames(out) <- NULL

  class(out) <- c("tbl_df", "tbl", "data.frame")

  out

}


# set.seed(1)
# 1:10 %>%
#   map(rnorm, n = 10) %>%
#   map_dbl(mean)
#
# set.seed(1)
# 1:10 %>%
#   purrr::map(rnorm, n = 10) %>%
#   purrr::map_dbl(mean)
#
#
# # Or use an anonymous function
# set.seed(1)
# 1:10 %>%
#   map(function(x) rnorm(10, x))
#
# set.seed(1)
# 1:10 %>%
#   purrr::map(function(x) rnorm(10, x))
#
# # Or a formula
# set.seed(1)
# 1:10 %>%
#   map(~ rnorm(10, .x))
#
# set.seed(1)
# 1:10 %>%
#   purrr::map(~ rnorm(10, .x))
#
# # Extract by name or position
# # .default specifies value for elements that are missing or NULL
# l1 <- list(list(a = 1L), list(a = NULL, b = 2L), list(b = 3L))
# l1 %>% map("a", .default = "???")
# l1 %>% purrr::map("a", .default = "???")
#
# l1 %>% map_int("b", .default = NA)
# l1 %>% purrr::map_int("b", .default = NA)
#
# l1 %>% map_int(2, .default = NA)
# l1 %>% purrr::map_int(2, .default = NA)
#
# # Supply multiple values to index deeply into a list
# l2 <- list(
#   list(num = 1:3,     letters[1:3]),
#   list(num = 101:103, letters[4:6]),
#   list()
# )
# l2 %>% map(c(2, 2))
# l2 %>% purrr::map(c(2, 2))
#
#
# # A more realistic example: split a data frame into pieces, fit a
# # model to each piece, summarise and extract R^2
# mtcars %>%
#   split(.$cyl) %>%
#   map(~ lm(mpg ~ wt, data = .x)) %>%
#   map(summary) %>%
#   map_dbl("r.squared")
#
# mtcars %>%
#   split(.$cyl) %>%
#   purrr::map(~ lm(mpg ~ wt, data = .x)) %>%
#   purrr::map(summary) %>%
#   purrr::map_dbl("r.squared")
#
#
# # Use map_lgl(), map_dbl(), etc to reduce to a vector.
# # * list
# mtcars %>% map(sum)
# mtcars %>% purrr::map(sum)
# # * vector
# mtcars %>% map_dbl(sum)
# mtcars %>% purrr::map_dbl(sum)
#
# # If each element of the output is a data frame, use
# # map_dfr to row-bind them together:
# mtcars %>%
#   split(.$cyl) %>%
#   map(~ lm(mpg ~ wt, data = .x)) %>%
#   map_dfr(~ as.data.frame(t(as.matrix(coef(.)))))
#
# mtcars %>%
#   split(.$cyl) %>%
#   purrr::map(~ lm(mpg ~ wt, data = .x)) %>%
#   purrr::map_dfr(~ as.data.frame(t(as.matrix(coef(.)))))

M README.md => README.md +5 -3
@@ 51,6 51,8 @@ The following functions are implemented:
## Installation

``` r
install.packages("uaparserjs", repos = "https://cinc.rud.is")
# or
remotes::install_git("https://git.rud.is/hrbrmstr/uaparserjs.git")
# or
remotes::install_git("https://git.sr.ht/~hrbrmstr/uaparserjs")


@@ 70,7 72,7 @@ NOTE: To use the ‘remotes’ install options you will need to have the
``` r
library(uaparserjs)

# current verison
# current version
packageVersion("uaparserjs")
## [1] '0.3.1'



@@ 112,8 114,8 @@ microbenchmark::microbenchmark(
  ua_parse(batch_100)
)
## Unit: milliseconds
##                 expr      min      lq     mean   median       uq      max neval
##  ua_parse(batch_100) 19.44652 20.2158 21.42222 20.66315 22.56606 31.78299   100
##                 expr      min       lq   mean   median       uq      max neval
##  ua_parse(batch_100) 19.68229 20.69247 22.213 21.62138 23.32668 35.13708   100
```

## uaparserjs Metrics

M man/ua_parse.Rd => man/ua_parse.Rd +3 -0
@@ 2,9 2,12 @@
% Please edit documentation in R/uaparser.R
\name{ua_parse}
\alias{ua_parse}
\alias{get_cache}
\title{Parse a vector of user agents into a data frame}
\usage{
ua_parse(user_agents, .progress = FALSE)

get_cache()
}
\arguments{
\item{user_agents}{a character vector of user agents}