hrbrmstr
/
uaparserjs
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
Browse Source

R CMD check and cinc

master
boB Rudis 4 years ago
parent
5dc20f9862
commit
bef63f1612
No known key found for this signature in database GPG Key ID: 1D7529BE14E2BBA9
4 changed files with 9 additions and 269 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1
      R/uaparser.R
  2. 266
      R/utils-mappers.R
  3. 8
      README.md
  4. 3
      man/ua_parse.Rd

1
R/uaparser.R
View File

@ -53,5 +53,6 @@ ua_parse <- function(user_agents, .progress=FALSE) {
}
#' @rdname ua_parse
#' @export
get_cache <- function() { .pkgenv$cache }

266
R/utils-mappers.R
View File

@ -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(.)))))

8
README.md
View File

@ -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

3
man/ua_parse.Rd
View File

@ -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}

Write Preview
Loading…
Cancel
Save