Tools to work with the Google DNS over HTTPS API in R https://cinc.rud.is/web/packages/gdns/
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

utils-mappers.R 2.9KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132
  1. # NOTE these aren't 100% equivalent to the purrr mappers but cover very common use-cases
  2. #
  3. # NOTE formula function (e.g. ~{}) are 100% supported
  4. map <- function(.x, .f, ...) {
  5. if (inherits(.f, "formula")) {
  6. .body <- dimnames(attr(terms(.f), "factors"))[[1]]
  7. .f <- function(.x, . = .x) {}
  8. body(.f) <- as.expression(parse(text=.body))
  9. }
  10. if (inherits(.f, "function")) {
  11. lapply(.x, .f, ...)
  12. } else if (is.numeric(.f)) {
  13. lapply(.x, `[`, .f)
  14. }
  15. }
  16. map2 <- function(.x, .y, .f, ...) {
  17. if (inherits(.f, "formula")) {
  18. .body <- dimnames(attr(terms(.f), "factors"))[[1]]
  19. .f <- function(.x, .y, . = .x) {}
  20. body(.f) <- as.expression(parse(text=.body))
  21. }
  22. if (inherits(.f, "function")) {
  23. mapply(.f, .x, .y, ..., SIMPLIFY=FALSE, USE.NAMES=FALSE)
  24. }
  25. }
  26. map_chr <- function(.x, .f, ...) {
  27. as.character(unlist(map(.x, .f, ...), use.names = FALSE))
  28. }
  29. map2_chr <- function(.x, .y, .f, ...) {
  30. as.character(unlist(map2(.x, .y, .f, ...), use.names = FALSE))
  31. }
  32. map_lgl <- function(.x, .f, ...) {
  33. as.logical(unlist(map(.x, .f, ...), use.names = FALSE))
  34. }
  35. map2_lgl <- function(.x, .y, .f, ...) {
  36. as.logical(unlist(map2(.x, .y, .f, ...), use.names = FALSE))
  37. }
  38. map_dbl <- function(.x, .f, ...) {
  39. as.double(unlist(map(.x, .f, ...), use.names = FALSE))
  40. }
  41. map2_dbl <- function(.x, .y, .f, ...) {
  42. as.double(unlist(map2(.x, .y, .f, ...), use.names = FALSE))
  43. }
  44. map_int <- function(.x, .f, ...) {
  45. as.integer(unlist(map(.x, .f, ...), use.names = FALSE))
  46. }
  47. map2_int <- function(.x, .y, .f, ...) {
  48. as.integer(unlist(map2(.x, .y, .f, ...), use.names = FALSE))
  49. }
  50. map_df <- function(.x, .f, ..., .id=NULL) {
  51. res <- map(.x, .f, ...)
  52. out <- bind_rows(res, .id=.id)
  53. out
  54. }
  55. map2_df <- function(.x, .y, .f, ..., .id=NULL) {
  56. res <- map(.x, .y, .f, ...)
  57. out <- bind_rows(res, .id = .id)
  58. out
  59. }
  60. # this has limitations and is more like 75% of dplyr::bind_rows()
  61. # this is also orders of magnitude slower than dplyr::bind_rows()
  62. bind_rows <- function(..., .id = NULL) {
  63. res <- list(...)
  64. if (length(res) == 1) res <- res[[1]]
  65. cols <- unique(unlist(lapply(res, names), use.names = FALSE))
  66. if (!is.null(.id)) {
  67. inthere <- cols[.id %in% cols]
  68. if (length(inthere) > 0) {
  69. .id <- make.unique(c(inthere, .id))[2]
  70. }
  71. }
  72. id_vals <- if (is.null(names(res))) 1:length(res) else names(res)
  73. saf <- default.stringsAsFactors()
  74. options(stringsAsFactors = FALSE)
  75. on.exit(options(stringsAsFactors = saf))
  76. idx <- 1
  77. do.call(
  78. rbind.data.frame,
  79. lapply(res, function(.x) {
  80. x_names <- names(.x)
  81. moar_names <- setdiff(cols, x_names)
  82. if (length(moar_names) > 0) {
  83. for (i in 1:length(moar_names)) {
  84. .x[[moar_names[i]]] <- rep(NA, length(.x[[1]]))
  85. }
  86. }
  87. if (!is.null(.id)) {
  88. .x[[.id]] <- id_vals[idx]
  89. idx <<- idx + 1
  90. }
  91. .x
  92. })
  93. ) -> out
  94. rownames(out) <- NULL
  95. class(out) <- c("tbl_df", "tbl", "data.frame")
  96. out
  97. }