Browse Source

(v1.1.0.9004) lose dependencies

main
parent
commit
7f3da74b17
  1. 23
      .gitlab-ci.yml
  2. 32
      DESCRIPTION
  3. 77
      NAMESPACE
  4. 14
      NEWS.md
  5. 253
      R/aa_helper_functions.R
  6. 775
      R/aa_helper_functions_dplyr.R
  7. 3
      R/ab.R
  8. 3
      R/age.R
  9. 2
      R/amr.R
  10. 9
      R/atc_online.R
  11. 1
      R/availability.R
  12. 70
      R/bug_drug_combinations.R
  13. 12
      R/catalogue_of_life.R
  14. 2
      R/count.R
  15. 7
      R/deprecated.R
  16. 3
      R/disk.R
  17. 131
      R/eucast_rules.R
  18. 82
      R/filter_ab_class.R
  19. 266
      R/first_isolate.R
  20. 3
      R/freq.R
  21. 46
      R/ggplot_pca.R
  22. 39
      R/ggplot_rsi.R
  23. 28
      R/guess_ab_col.R
  24. 20
      R/join_microorganisms.R
  25. 72
      R/key_antibiotics.R
  26. 37
      R/like.R
  27. 205
      R/mdro.R
  28. 7
      R/mic.R
  29. 1073
      R/mo.R
  30. 31
      R/mo_property.R
  31. 48
      R/mo_source.R
  32. 39
      R/pca.R
  33. 142
      R/progress_estimated.R
  34. 10
      R/proportion.R
  35. 178
      R/resistance_predict.R
  36. 94
      R/rsi.R
  37. 177
      R/rsi_calc.R
  38. 32
      R/rsi_df.R
  39. BIN
      R/sysdata.rda
  40. 44
      R/tidyverse.R
  41. 21
      R/translate.R
  42. 81
      R/zzz.R
  43. 32
      README.md
  44. 3
      _pkgdown.yml
  45. 2
      data-raw/country_analysis.R
  46. 36
      data-raw/eucast_rules.tsv
  47. 9
      data-raw/internals.R
  48. 44
      data-raw/poorman_prepend.R
  49. 38
      data-raw/reproduction_of_poorman.R
  50. 2
      docs/404.html
  51. 2
      docs/LICENSE-text.html
  52. 2
      docs/articles/index.html
  53. 2
      docs/authors.html
  54. 2
      docs/index.html
  55. 2
      docs/pkgdown.yml
  56. 8
      docs/reference/AMR-deprecated.html
  57. 291
      docs/reference/AMR-tidyverse.html
  58. 2
      docs/reference/antibiotics.html
  59. 9
      docs/reference/as.mic.html
  60. 14
      docs/reference/as.mo.html
  61. 14
      docs/reference/as.rsi.html
  62. 8
      docs/reference/catalogue_of_life_version.html
  63. 22
      docs/reference/count.html
  64. 20
      docs/reference/filter_ab_class.html
  65. 9
      docs/reference/first_isolate.html
  66. 8
      docs/reference/ggplot_pca.html
  67. 28
      docs/reference/ggplot_rsi.html
  68. 18
      docs/reference/index.html
  69. 19
      docs/reference/join.html
  70. 7
      docs/reference/key_antibiotics.html
  71. 18
      docs/reference/like.html
  72. 4
      docs/reference/mdro.html
  73. 2
      docs/reference/microorganisms.html
  74. 2
      docs/reference/mo_property.html
  75. 10
      docs/reference/pca.html
  76. 30
      docs/reference/proportion.html
  77. 4
      docs/reference/reexports.html
  78. 34
      docs/reference/resistance_predict.html
  79. 12
      docs/reference/translate.html
  80. 5
      docs/sitemap.xml
  81. 3
      man/AMR-deprecated.Rd
  82. 14
      man/AMR-tidyverse.Rd
  83. 1
      man/as.mic.Rd
  84. 2
      man/as.mo.Rd
  85. 9
      man/as.rsi.Rd
  86. 5
      man/catalogue_of_life_version.Rd
  87. 2
      man/count.Rd
  88. 29
      man/extended-functions.Rd
  89. 6
      man/filter_ab_class.Rd
  90. 7
      man/first_isolate.Rd
  91. 2
      man/ggplot_pca.Rd
  92. 24
      man/ggplot_rsi.Rd
  93. 8
      man/join.Rd
  94. 4
      man/key_antibiotics.Rd
  95. 16
      man/like.Rd
  96. 4
      man/pca.Rd
  97. 8
      man/proportion.Rd
  98. 28
      man/resistance_predict.Rd
  99. 6
      man/translate.Rd
  100. 2
      tests/testthat/test-count.R
  101. Some files were not shown because too many files have changed in this diff Show More

23
.gitlab-ci.yml

@ -54,7 +54,9 @@ before_script: @@ -54,7 +54,9 @@ before_script:
- echo 'LANG="en_US.utf8"' >> .Renviron
- echo 'LANGUAGE="en_US.utf8"' > ~/.Renviron
R-release-test-only:
# ---- TEST
R-release:
stage: test
when: always
allow_failure: false
@ -68,6 +70,23 @@ R-release-test-only: @@ -68,6 +70,23 @@ R-release-test-only:
paths:
- installed_deps/
R-devel:
stage: test
when: always
image: rocker/r-devel
allow_failure: false
script:
- Rscriptdevel -e 'sessionInfo()'
# install missing and outdated packages
- Rscriptdevel -e 'source(".gitlab-ci.R"); gl_update_pkg_all(repos = "https://cran.rstudio.com", quiet = TRUE, install_pkgdown = TRUE, install_lintr = TRUE)'
- Rscriptdevel -e 'devtools::test(stop_on_failure = FALSE)'
cache:
key: devel
paths:
- installed_deps/
# ---- CHECK
R-release:
stage: check
when: on_success
@ -120,6 +139,8 @@ R-devel: @@ -120,6 +139,8 @@ R-devel:
key: devel
paths:
- installed_deps/
# ---- OTHER
lintr:
stage: lint

32
DESCRIPTION

@ -1,6 +1,6 @@ @@ -1,6 +1,6 @@
Package: AMR
Version: 1.1.0.9003
Date: 2020-05-01
Version: 1.1.0.9004
Date: 2020-05-16
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),
@ -36,30 +36,24 @@ Description: Functions to simplify the analysis and prediction of Antimicrobial @@ -36,30 +36,24 @@ Description: Functions to simplify the analysis and prediction of Antimicrobial
Standards Institute (2014) <isbn: 1-56238-899-1>.
Depends:
R (>= 3.1.0)
Enhances:
ggplot2
Imports:
backports,
cleaner,
crayon (>= 1.3.0),
data.table (>= 1.9.0),
dplyr (>= 0.7.0),
ggplot2,
knitr (>= 1.0.0),
microbenchmark,
pillar,
R6,
rlang (>= 0.3.1),
tidyr (>= 1.0.0),
vctrs (>= 0.2.4)
vctrs
Suggests:
covr (>= 3.0.1),
curl,
readxl,
covr,
dplyr,
knitr,
microbenchmark,
rmarkdown,
rstudioapi,
rvest (>= 0.3.2),
testthat (>= 1.0.2),
xml2 (>= 1.0.0)
VignetteBuilder: knitr
rvest,
testthat,
utils
VignetteBuilder: knitr,rmarkdown
URL: https://msberends.gitlab.io/AMR, https://gitlab.com/msberends/AMR
BugReports: https://gitlab.com/msberends/AMR/issues
License: GPL-2 | file LICENSE

77
NAMESPACE

@ -66,11 +66,11 @@ S3method(skewness,matrix) @@ -66,11 +66,11 @@ S3method(skewness,matrix)
S3method(summary,mic)
S3method(summary,mo)
S3method(summary,rsi)
S3method(vec_cast,character.ab)
S3method(vec_cast,character.mo)
S3method(vec_cast.ab,ab)
S3method(vec_cast.ab,character)
S3method(vec_cast.ab,default)
S3method(vec_cast.character,ab)
S3method(vec_cast.character,mo)
S3method(vec_cast.mo,character)
S3method(vec_cast.mo,default)
S3method(vec_cast.mo,mo)
@ -201,7 +201,6 @@ export(mo_url) @@ -201,7 +201,6 @@ export(mo_url)
export(mo_year)
export(mrgn)
export(n_rsi)
export(p.symbol)
export(p_symbol)
export(pca)
export(portion_I)
@ -297,6 +296,8 @@ exportMethods(summary.mo) @@ -297,6 +296,8 @@ exportMethods(summary.mo)
exportMethods(summary.rsi)
exportMethods(vec_cast.character.ab)
exportMethods(vec_cast.character.mo)
exportMethods(vec_ptype2.character.ab)
exportMethods(vec_ptype2.character.mo)
exportMethods(vec_ptype_abbr.ab)
exportMethods(vec_ptype_abbr.disk)
exportMethods(vec_ptype_abbr.mic)
@ -307,69 +308,8 @@ exportMethods(vec_ptype_full.disk) @@ -307,69 +308,8 @@ exportMethods(vec_ptype_full.disk)
exportMethods(vec_ptype_full.mic)
exportMethods(vec_ptype_full.mo)
exportMethods(vec_ptype_full.rsi)
importFrom(R6,R6Class)
importFrom(cleaner,freq)
importFrom(cleaner,freq.default)
importFrom(cleaner,percentage)
importFrom(cleaner,top_freq)
importFrom(crayon,bgGreen)
importFrom(crayon,bgRed)
importFrom(crayon,bgYellow)
importFrom(crayon,black)
importFrom(crayon,blue)
importFrom(crayon,bold)
importFrom(crayon,green)
importFrom(crayon,italic)
importFrom(crayon,magenta)
importFrom(crayon,make_style)
importFrom(crayon,red)
importFrom(crayon,silver)
importFrom(crayon,strip_style)
importFrom(crayon,underline)
importFrom(crayon,white)
importFrom(crayon,yellow)
importFrom(data.table,as.data.table)
importFrom(data.table,data.table)
importFrom(data.table,setkey)
importFrom(dplyr,"%>%")
importFrom(dplyr,all_vars)
importFrom(dplyr,any_vars)
importFrom(dplyr,arrange)
importFrom(dplyr,arrange_at)
importFrom(dplyr,between)
importFrom(dplyr,bind_rows)
importFrom(dplyr,case_when)
importFrom(dplyr,desc)
importFrom(dplyr,distinct)
importFrom(dplyr,everything)
importFrom(dplyr,filter)
importFrom(dplyr,filter_all)
importFrom(dplyr,filter_at)
importFrom(dplyr,funs)
importFrom(dplyr,group_by)
importFrom(dplyr,group_by_at)
importFrom(dplyr,group_vars)
importFrom(dplyr,if_else)
importFrom(dplyr,lag)
importFrom(dplyr,left_join)
importFrom(dplyr,mutate)
importFrom(dplyr,mutate_all)
importFrom(dplyr,mutate_at)
importFrom(dplyr,n)
importFrom(dplyr,n_distinct)
importFrom(dplyr,n_groups)
importFrom(dplyr,pull)
importFrom(dplyr,rename)
importFrom(dplyr,row_number)
importFrom(dplyr,select)
importFrom(dplyr,select_if)
importFrom(dplyr,slice)
importFrom(dplyr,summarise)
importFrom(dplyr,summarise_if)
importFrom(dplyr,tibble)
importFrom(dplyr,transmute)
importFrom(dplyr,ungroup)
importFrom(dplyr,vars)
importFrom(graphics,arrows)
importFrom(graphics,axis)
importFrom(graphics,barplot)
@ -377,12 +317,7 @@ importFrom(graphics,par) @@ -377,12 +317,7 @@ importFrom(graphics,par)
importFrom(graphics,plot)
importFrom(graphics,points)
importFrom(graphics,text)
importFrom(knitr,kable)
importFrom(microbenchmark,microbenchmark)
importFrom(pillar,pillar_shaft)
importFrom(rlang,as_label)
importFrom(rlang,enquos)
importFrom(rlang,eval_tidy)
importFrom(stats,complete.cases)
importFrom(stats,glm)
importFrom(stats,lm)
@ -393,10 +328,8 @@ importFrom(stats,qchisq) @@ -393,10 +328,8 @@ importFrom(stats,qchisq)
importFrom(stats,var)
importFrom(tidyr,pivot_longer)
importFrom(tidyr,pivot_wider)
importFrom(utils,adist)
importFrom(utils,browseURL)
importFrom(utils,menu)
importFrom(vctrs,vec_cast)
importFrom(vctrs,vec_cast.character)
importFrom(vctrs,vec_default_cast)
importFrom(vctrs,vec_ptype2.character)
importFrom(vctrs,vec_ptype_abbr)

14
NEWS.md

@ -1,10 +1,18 @@ @@ -1,10 +1,18 @@
# AMR 1.1.0.9003
## <small>Last updated: 01-May-2020</small>
# AMR 1.1.0.9004
## <small>Last updated: 16-May-2020</small>
### Breaking
* Removed previously deprecated function `p.symbol()` - it was replaced with `p_symbol()`
### Changed
* Small fix for some text input that could not be coerced as valid MIC values
* Better support for the tidyverse. The tidyverse now heavily relies on the `vctrs` package for data transformation and data joining. In newer versions of e.g. the `dplyr` package, a function like `bind_rows()` would not preserve the right class for microorganisms (class `mo`) and antibiotics (class `ab`). This is fixed in this version.
* Fix for cases where some functions of newer versions of the `dplyr` package (such as `bind_rows()`) would not preserve the right class for microorganisms (class `mo`) and antibiotics (class `ab`)
* Fixed interpretation of generic CLSI interpretation rules (thanks to Anthony Underwood)
* Added official drug names to verbose output of `eucast_rules()`
### Other
* Removed dependency on **all** packages that were needed for the `AMR` package to work properly: `crayon`, `data.table`, `dplyr`, `ggplot2`, `R6`, `rlang` and `tidyr`. This is a major code change, but will probably not be noticeable by users. Making this package independent on especially the tidyverse (packages `dplyr`, `ggplot2` and `tidyr`) tremendously increases sustainability on the long term, since tidyverse functions change quite often. Most of our functions are replaced with versions that only rely on base R, which keeps this package fully functional for many years to come, without requiring a lot of maintenance to keep up with other packages anymore. The only dependencies that remained are for extending methods of other packages, like `pillar` and `vctrs` for printing and working with tibbles using our classes `mo` and `ab`.
# AMR 1.1.0

253
R/aa_helper_functions.R

@ -19,6 +19,48 @@ @@ -19,6 +19,48 @@
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
# functions from dplyr, will perhaps become poorman
distinct <- function(.data, ..., .keep_all = FALSE) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
distinct.grouped_data(.data, ..., .keep_all = .keep_all)
} else {
distinct.default(.data, ..., .keep_all = .keep_all)
}
}
distinct.default <- function(.data, ..., .keep_all = FALSE) {
names <- rownames(.data)
rownames(.data) <- NULL
if (length(deparse_dots(...)) == 0) {
selected <- .data
} else {
selected <- select(.data, ...)
}
rows <- as.integer(rownames(unique(selected)))
if (isTRUE(.keep_all)) {
res <- .data[rows, , drop = FALSE]
} else {
res <- selected[rows, , drop = FALSE]
}
rownames(res) <- names[rows]
res
}
distinct.grouped_data <- function(.data, ..., .keep_all = FALSE) {
apply_grouped_function(.data, "distinct", ..., .keep_all = .keep_all)
}
filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
if (is.null(by)) {
by <- intersect(names(x), names(y))
join_message(by)
}
rows <- interaction(x[, by]) %in% interaction(y[, by])
if (type == "anti") rows <- !rows
res <- x[rows, , drop = FALSE]
rownames(res) <- NULL
res
}
# No export, no Rd
addin_insert_in <- function() {
rstudioapi::insertText(" %in% ")
@ -36,7 +78,7 @@ check_dataset_integrity <- function() { @@ -36,7 +78,7 @@ check_dataset_integrity <- function() {
"species", "subspecies", "rank",
"col_id", "species_id", "source",
"ref", "prevalence", "snomed") %in% colnames(microorganisms),
na.rm = TRUE) & NROW(microorganisms) == NROW(microorganismsDT)
na.rm = TRUE) & NROW(microorganisms) == NROW(MO_lookup)
check_antibiotics <- all(c("ab", "atc", "cid", "name", "group",
"atc_group1", "atc_group2", "abbreviations",
"synonyms", "oral_ddd", "oral_units",
@ -51,12 +93,11 @@ check_dataset_integrity <- function() { @@ -51,12 +93,11 @@ check_dataset_integrity <- function() {
invisible(TRUE)
}
#' @importFrom crayon blue bold red
#' @importFrom dplyr %>% pull
search_type_in_df <- function(x, type) {
# try to find columns based on type
found <- NULL
x <- as.data.frame(x, stringsAsFactors = FALSE)
colnames(x) <- trimws(colnames(x))
# -- mo
@ -89,14 +130,14 @@ search_type_in_df <- function(x, type) { @@ -89,14 +130,14 @@ search_type_in_df <- function(x, type) {
if (any(colnames(x) %like% "^(specimen date|specimen_date|spec_date)")) {
# WHONET support
found <- colnames(x)[colnames(x) %like% "^(specimen date|specimen_date|spec_date)"][1]
if (!any(class(x %>% pull(found)) %in% c("Date", "POSIXct"))) {
stop(red(paste0("ERROR: Found column `", bold(found), "` to be used as input for `col_", type,
if (!any(class(pull(x, found)) %in% c("Date", "POSIXct"))) {
stop(font_red(paste0("ERROR: Found column `", font_bold(found), "` to be used as input for `col_", type,
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
call. = FALSE)
}
} else {
for (i in seq_len(ncol(x))) {
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
if (any(class(pull(x, i)) %in% c("Date", "POSIXct"))) {
found <- colnames(x)[i]
break
}
@ -127,7 +168,7 @@ search_type_in_df <- function(x, type) { @@ -127,7 +168,7 @@ search_type_in_df <- function(x, type) {
if (!is.null(found)) {
# this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) {
message(red(paste0("NOTE: Column `", bold(found), "` found as input for `col_", type,
message(font_red(paste0("NOTE: Column `", font_bold(found), "` found as input for `col_", type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.")))
found <- NULL
}
@ -135,11 +176,11 @@ search_type_in_df <- function(x, type) { @@ -135,11 +176,11 @@ search_type_in_df <- function(x, type) {
}
if (!is.null(found)) {
msg <- paste0("NOTE: Using column `", bold(found), "` as input for `col_", type, "`.")
msg <- paste0("NOTE: Using column `", font_bold(found), "` as input for `col_", type, "`.")
if (type %in% c("keyantibiotics", "specimen")) {
msg <- paste(msg, "Use", bold(paste0("col_", type), "= FALSE"), "to prevent this.")
msg <- paste(msg, "Use", font_bold(paste0("col_", type), "= FALSE"), "to prevent this.")
}
message(blue(msg))
message(font_blue(msg))
}
found
}
@ -147,10 +188,11 @@ search_type_in_df <- function(x, type) { @@ -147,10 +188,11 @@ search_type_in_df <- function(x, type) {
stopifnot_installed_package <- function(package) {
# no "utils::installed.packages()" since it requires non-staged install since R 3.6.0
# https://developer.r-project.org/Blog/public/2019/02/14/staged-install/index.html
tryCatch(get(".packageName", envir = asNamespace(package)),
error = function(e) stop("package '", package, "' required but not installed",
' - try to install it with: install.packages("', package, '")',
call. = FALSE))
sapply(package, function(x)
tryCatch(get(".packageName", envir = asNamespace(x)),
error = function(e) stop("package '", x, "' required but not installed.",
"\nTry to install it with: install.packages(\"", x, "\")",
call. = FALSE)))
return(invisible())
}
@ -206,3 +248,184 @@ dataset_UTF8_to_ASCII <- function(df) { @@ -206,3 +248,184 @@ dataset_UTF8_to_ASCII <- function(df) {
}
df
}
# replace crayon::has_color
has_colour <- function() {
if (Sys.getenv("TERM") == "dumb") {
return(FALSE)
}
if (tolower(Sys.info()["sysname"]) == "windows") {
if (Sys.getenv("ConEmuANSI") == "ON" | Sys.getenv("CMDER_ROOT") != "") {
return(TRUE)
} else {
return(FALSE)
}
}
"COLORTERM" %in% names(Sys.getenv()) | grepl("^screen|^xterm|^vt100|color|ansi|cygwin|linux",
Sys.getenv("TERM"),
ignore.case = TRUE,
perl = TRUE)
}
# the crayon colours
try_colour <- function(..., before, after, collapse = " ") {
txt <- paste0(unlist(list(...)), collapse = collapse)
if (isTRUE(has_colour())) {
if (is.null(collapse)) {
paste0(before, txt, after, collapse = NULL)
} else {
paste0(before, txt, after, collapse = "")
}
} else {
txt
}
}
font_black <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;232m", after = "\033[39m", collapse = collapse)
}
font_blue <- function(..., collapse = " ") {
try_colour(..., before = "\033[34m", after = "\033[39m", collapse = collapse)
}
font_green <- function(..., collapse = " ") {
try_colour(..., before = "\033[32m", after = "\033[39m", collapse = collapse)
}
font_magenta <- function(..., collapse = " ") {
try_colour(..., before = "\033[35m", after = "\033[39m", collapse = collapse)
}
font_red <- function(..., collapse = " ") {
try_colour(..., before = "\033[31m", after = "\033[39m", collapse = collapse)
}
font_silver <- function(..., collapse = " ") {
try_colour(..., before = "\033[90m", after = "\033[39m", collapse = collapse)
}
font_white <- function(..., collapse = " ") {
try_colour(..., before = "\033[37m", after = "\033[39m", collapse = collapse)
}
font_yellow <- function(..., collapse = " ") {
try_colour(..., before = "\033[33m", after = "\033[39m", collapse = collapse)
}
font_subtle <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;246m", after = "\033[39m", collapse = collapse)
}
font_grey <- function(..., collapse = " ") {
try_colour(..., before = "\033[38;5;249m", after = "\033[39m", collapse = collapse)
}
font_green_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
}
font_red_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[41m", after = "\033[49m", collapse = collapse)
}
font_yellow_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[43m", after = "\033[49m", collapse = collapse)
}
font_bold <- function(..., collapse = " ") {
try_colour(..., before = "\033[1m", after = "\033[22m", collapse = collapse)
}
font_italic <- function(..., collapse = " ") {
try_colour(..., before = "\033[3m", after = "\033[23m", collapse = collapse)
}
font_underline <- function(..., collapse = " ") {
try_colour(..., before = "\033[4m", after = "\033[24m", collapse = collapse)
}
font_stripstyle <- function(x) {
# from crayon:::ansi_regex
gsub("(?:(?:\\x{001b}\\[)|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])|\\x{001b}[A-M]", "", x, perl = TRUE)
}
progress_estimated <- function(n = 1, n_min = 0, ...) {
# initiate with:
# progress <- progressbar(n)
# on.exit(close(progress))
#
# update with:
# progress$tick()
if (n >= n_min) {
pb <- utils::txtProgressBar(max = n, style = 3)
pb$tick <- function() {
pb$up(pb$getVal() + 1)
}
pb
} else {
pb <- list()
pb$tick <- function() {
invisible()
}
pb$kill <- function() {
invisible()
}
structure(pb, class = "txtProgressBar")
}
}
# works exactly like round(), but rounds `round(44.55, 1)` as 44.6 instead of 44.5
# and adds decimal zeroes until `digits` is reached when force_zero = TRUE
round2 <- function(x, digits = 0, force_zero = TRUE) {
x <- as.double(x)
# https://stackoverflow.com/a/12688836/4575331
val <- (trunc((abs(x) * 10 ^ digits) + 0.5) / 10 ^ digits) * sign(x)
if (digits > 0 & force_zero == TRUE) {
values_trans <- val[val != as.integer(val) & !is.na(val)]
val[val != as.integer(val) & !is.na(val)] <- paste0(values_trans,
strrep("0",
max(0,
digits - nchar(
format(
as.double(
gsub(".*[.](.*)$",
"\\1",
values_trans)),
scientific = FALSE)))))
}
as.double(val)
}
# percentage from our other package: 'cleaner'
percentage <- function(x, digits = NULL, ...) {
# getdecimalplaces() function
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (maximum < minimum) {
maximum <- minimum
}
if (minimum > maximum) {
minimum <- maximum
}
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
as.character(x * 100)), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
max(min(max_places,
maximum, na.rm = TRUE),
minimum, na.rm = TRUE)
}
# format_percentage() function
format_percentage <- function(x, digits = NULL, ...) {
if (is.null(digits)) {
digits <- getdecimalplaces(x)
}
# round right: percentage(0.4455) and format(as.percentage(0.4455), 1) should return "44.6%", not "44.5%"
x_formatted <- format(round2(as.double(x), digits = digits + 2) * 100,
scientific = FALSE,
digits = digits,
nsmall = digits,
...)
x_formatted <- paste0(x_formatted, "%")
x_formatted[!grepl(pattern = "^[0-9.,e-]+$", x = x)] <- NA_character_
x_formatted
}
# the actual working part
x <- as.double(x)
if (is.null(digits)) {
# max one digit if undefined
digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
}
format_percentage(structure(.Data = as.double(x),
class = c("percentage", "numeric")),
digits = digits, ...)
}

775
R/aa_helper_functions_dplyr.R

@ -0,0 +1,775 @@ @@ -0,0 +1,775 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Analysis #
# #
# SOURCE #
# https://gitlab.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2020 Berends MS, Luz CF et al. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
# Visit our website for more info: https://msberends.gitlab.io/AMR. #
# ==================================================================== #
# ------------------------------------------------
# THIS FILE WAS CREATED AUTOMATICALLY!
# Source file: data-raw/reproduction_of_poorman.R
# ------------------------------------------------
# Poorman: a package to replace all dplyr functions with base R so we can lose dependency on dplyr.
# These functions were downloaded from https://github.com/nathaneastwood/poorman,
# from this commit: https://github.com/nathaneastwood/poorman/tree/7d76d77f8f7bc663bf30fb5a161abb49801afa17
#
# All code below was released under MIT license, that permits 'free of charge, to any person obtaining a
# copy of the software and associated documentation files (the "Software"), to deal in the Software
# without restriction, including without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software
# is furnished to do so', given that a copyright notice is given in the software.
#
# Copyright notice as found on https://github.com/nathaneastwood/poorman/blob/master/LICENSE on 2 May 2020:
# YEAR: 2020
# COPYRIGHT HOLDER: Nathan Eastwood
arrange <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
arrange.grouped_data(.data, ...)
} else {
arrange.default(.data, ...)
}
}
arrange.default <- function(.data, ...) {
rows <- eval.parent(substitute(with(.data, order(...))))
.data[rows, , drop = FALSE]
}
arrange.grouped_data <- function(.data, ...) {
apply_grouped_function(.data, "arrange", ...)
}
between <- function(x, left, right) {
if (!is.null(attr(x, "class")) && !inherits(x, c("Date", "POSIXct"))) {
warning("`between()` called on numeric vector with S3 class")
}
if (!is.double(x)) x <- as.numeric(x)
x >= as.numeric(left) & x <= as.numeric(right)
}
count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) {
groups <- get_groups(x)
if (!missing(...)) x <- group_by(x, ..., .add = TRUE)
wt <- deparse_var(wt)
res <- do.call(tally, list(x, wt, sort, name))
if (length(groups) > 0L) res <- do.call(group_by, list(res, as.name(groups)))
res
}
tally <- function(x, wt = NULL, sort = FALSE, name = NULL) {
name <- check_name(x, name)
wt <- deparse_var(wt)
res <- do.call(summarise, set_names(list(x, as.name(tally_n(x, wt))), c(".data", name)))
res <- ungroup(res)
if (isTRUE(sort)) res <- do.call(arrange, list(res, call("desc", as.name(name))))
rownames(res) <- NULL
res
}
add_count <- function(x, ..., wt = NULL, sort = FALSE, name = NULL) {
name <- check_name(x, name)
row_names <- rownames(x)
wt <- deparse_var(wt)
if (!missing(...)) x <- group_by(x, ..., .add = TRUE)
res <- do.call(add_tally, list(x, wt, sort, name))
res[row_names, ]
}
add_tally <- function(x, wt = NULL, sort = FALSE, name = NULL) {
wt <- deparse_var(wt)
n <- tally_n(x, wt)
name <- check_name(x, name)
res <- do.call(mutate, set_names(list(x, as.name(n)), c(".data", name)))
if (isTRUE(sort)) {
do.call(arrange, list(res, call("desc", as.name(name))))
} else {
res
}
}
tally_n <- function(x, wt) {
if (is.null(wt) && "n" %in% colnames(x)) {
message("Using `n` as weighting variable")
wt <- "n"
}
context$.data <- x
on.exit(rm(list = ".data", envir = context))
if (is.null(wt)) {
"n()"
} else {
paste0("sum(", wt, ", na.rm = TRUE)")
}
}
check_name <- function(df, name) {
if (is.null(name)) {
if ("n" %in% colnames(df)) {
stop(
"Column 'n' is already present in output\n",
"* Use `name = \"new_name\"` to pick a new name"
)
}
return("n")
}
if (!is.character(name) || length(name) != 1) {
stop("`name` must be a single string")
}
name
}
desc <- function(x) -xtfrm(x)
select_env <- new.env()
peek_vars <- function() {
get(".col_names", envir = select_env)
}
context <- new.env()
n <- function() {
do.call(nrow, list(quote(.data)), envir = context)
}
filter <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
filter.grouped_data(.data, ...)
} else {
filter.default(.data, ...)
}
}
filter.default <- function(.data, ...) {
conditions <- paste(deparse_dots(...), collapse = " & ")
context$.data <- .data
on.exit(rm(.data, envir = context))
.data[do.call(with, list(.data, str2lang(unname(conditions)))), ]
}
filter.grouped_data <- function(.data, ...) {
rows <- rownames(.data)
res <- apply_grouped_function(.data, "filter", ...)
res[rows[rows %in% rownames(res)], ]
}
group_by <- function(.data, ..., .add = FALSE) {
check_is_dataframe(.data)
pre_groups <- get_groups(.data)
groups <- deparse_dots(...)
if (isTRUE(.add)) groups <- unique(c(pre_groups, groups))
unknown <- !(groups %in% colnames(.data))
if (any(unknown)) stop("Invalid groups: ", groups[unknown])
structure(.data, class = c("grouped_data", class(.data)), groups = groups)
}
ungroup <- function(x, ...) {
check_is_dataframe(x)
rm_groups <- deparse_dots(...)
groups <- attr(x, "groups")
if (length(rm_groups) == 0L) rm_groups <- groups
attr(x, "groups") <- groups[!(groups %in% rm_groups)]
if (length(attr(x, "groups")) == 0L) {
attr(x, "groups") <- NULL
class(x) <- class(x)[!(class(x) %in% "grouped_data")]
}
x
}
get_groups <- function(x) {
attr(x, "groups", exact = TRUE)
}
has_groups <- function(x) {
groups <- get_groups(x)
if (is.null(groups)) FALSE else TRUE
}
set_groups <- function(x, groups) {
attr(x, "groups") <- groups
x
}
apply_grouped_function <- function(.data, fn, ...) {
groups <- get_groups(.data)
grouped <- split_into_groups(.data, groups)
res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res))
attr(res, "groups") <- groups[groups %in% colnames(res)]
}
res
}
split_into_groups <- function(.data, groups) {
class(.data) <- "data.frame"
group_factors <- lapply(groups, function(x, .data) as.factor(.data[, x]), .data)
res <- split(x = .data, f = group_factors)
res
}
print.grouped_data <- function(x, ..., digits = NULL, quote = FALSE, right = TRUE, row.names = TRUE, max = NULL) {
class(x) <- "data.frame"
print(x, ..., digits = digits, quote = quote, right = right, row.names = row.names, max = max)
cat("\nGroups: ", paste(attr(x, "groups", exact = TRUE), collapse = ", "), "\n\n")
}
if_else <- function(condition, true, false, missing = NULL) {
if (!is.logical(condition)) stop("`condition` must be a logical vector.")
cls_true <- class(true)
cls_false <- class(false)
cls_missing <- class(missing)
if (!identical(cls_true, cls_false)) {
stop("The class of `true` <", class(true), "> is not the same as the class of `false` <", class(false), ">")
}
if (!is.null(missing) && !identical(cls_true, cls_missing)) {
stop("`missing` must be a ", cls_true, " vector, not a ", cls_missing, " vector.")
}
res <- ifelse(condition, true, false)
if (!is.null(missing)) res[is.na(res)] <- missing
attributes(res) <- attributes(true)
res
}
inner_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, sort = FALSE)
}
left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all.x = TRUE)
}
right_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all.y = TRUE)
}
full_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
join_worker(x = x, y = y, by = by, suffix = suffix, all = TRUE)
}
join_worker <- function(x, y, by = NULL, suffix = c(".x", ".y"), ...) {
x[, ".join_id"] <- seq_len(nrow(x))
if (is.null(by)) {
by <- intersect(names(x), names(y))
join_message(by)
merged <- merge(x = x, y = y, by = by, suffixes = suffix, ...)[, union(names(x), names(y))]
} else if (is.null(names(by))) {
merged <- merge(x = x, y = y, by = by, suffixes = suffix, ...)
} else {
merged <- merge(x = x, y = y, by.x = names(by), by.y = by, suffixes = suffix, ...)
}
merged <- merged[order(merged[, ".join_id"]), colnames(merged) != ".join_id"]
rownames(merged) <- NULL
merged
}
join_message <- function(by) {
if (length(by) > 1L) {
message("Joining, by = c(\"", paste0(by, collapse = "\", \""), "\")\n", sep = "")
} else {
message("Joining, by = \"", by, "\"\n", sep = "")
}
}
anti_join <- function(x, y, by = NULL) {
filter_join_worker(x, y, by, type = "anti")
}
semi_join <- function(x, y, by = NULL) {
filter_join_worker(x, y, by, type = "semi")
}
# filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
# type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
# if (is.null(by)) {
# by <- intersect(names(x), names(y))
# join_message(by)
# }
# rows <- interaction(x[, by]) %in% interaction(y[, by])
# if (type == "anti") rows <- !rows
# res <- x[rows, ]
# rownames(res) <- NULL
# res
# }
lag <- function (x, n = 1L, default = NA) {
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::lag()`?")
if (length(n) != 1L || !is.numeric(n) || n < 0L) stop("`n` must be a nonnegative integer scalar")
if (n == 0L) return(x)
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
stop("Cannot convert `default` <", typeof(default), "> to `x` <", typeof(x), ">")
}
)
xlen <- length(x)
n <- pmin(n, xlen)
res <- c(rep(default, n), x[seq_len(xlen - n)])
attributes(res) <- attributes(x)
res
}
lead <- function (x, n = 1L, default = NA) {
if (length(n) != 1L || !is.numeric(n) || n < 0L) stop("n must be a nonnegative integer scalar")
if (n == 0L) return(x)
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
stop("Cannot convert `default` <", typeof(default), "> to `x` <", typeof(x), ">")
}
)
xlen <- length(x)
n <- pmin(n, xlen)
res <- c(x[-seq_len(n)], rep(default, n))
attributes(res) <- attributes(x)
res
}
mutate <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
mutate.grouped_data(.data, ...)
} else {
mutate.default(.data, ...)
}
}
mutate.default <- function(.data, ...) {
conditions <- deparse_dots(...)
cond_names <- names(conditions)
unnamed <- which(nchar(cond_names) == 0L)
if (is.null(cond_names)) {
names(conditions) <- conditions
} else if (length(unnamed) > 0L) {
names(conditions)[unnamed] <- conditions[unnamed]
}
not_matched <- names(conditions)[!names(conditions) %in% names(.data)]
.data[, not_matched] <- NA
context$.data <- .data
on.exit(rm(.data, envir = context))
for (i in seq_along(conditions)) {
.data[, names(conditions)[i]] <- do.call(with, list(.data, str2lang(unname(conditions)[i])))
}
.data
}
mutate.grouped_data <- function(.data, ...) {
rows <- rownames(.data)
res <- apply_grouped_function(.data, "mutate", ...)
res[rows, ]
}
n_distinct <- function(..., na.rm = FALSE) {
res <- c(...)
if (is.list(res)) return(nrow(unique(as.data.frame(res, stringsAsFactors = FALSE))))
if (isTRUE(na.rm)) res <- res[!is.na(res)]
length(unique(res))
}
`%>%` <- function(lhs, rhs) {
lhs <- substitute(lhs)
rhs <- substitute(rhs)
eval(as.call(c(rhs[[1L]], lhs, as.list(rhs[-1L]))), envir = parent.frame())
}
pull <- function(.data, var = -1) {
var_deparse <- deparse_var(var)
col_names <- colnames(.data)
if (!(var_deparse %in% col_names) & grepl("^[[:digit:]]+L|[[:digit:]]", var_deparse)) {
var <- as.integer(gsub("L", "", var_deparse))
var <- if_else(var < 1L, rev(col_names)[abs(var)], col_names[var])
} else if (var_deparse %in% col_names) {
var <- var_deparse
}
.data[, var]
}
relocate <- function(.data, ..., .before = NULL, .after = NULL) {
check_is_dataframe(.data)
data_names <- colnames(.data)
col_pos <- select_positions(.data, ...)
.before <- deparse_var(.before)
.after <- deparse_var(.after)
has_before <- !is.null(.before)
has_after <- !is.null(.after)
if (has_before && has_after) {
stop("You must supply only one of `.before` and `.after`")
} else if (has_before) {
where <- min(match(.before, data_names))
col_pos <- c(setdiff(col_pos, where), where)
} else if (has_after) {
where <- max(match(.after, data_names))
col_pos <- c(where, setdiff(col_pos, where))
} else {
where <- 1L
col_pos <- union(col_pos, where)
}
lhs <- setdiff(seq(1L, where - 1L), col_pos)
rhs <- setdiff(seq(where + 1L, ncol(.data)), col_pos)
col_pos <- unique(c(lhs, col_pos, rhs))
col_pos <- col_pos[col_pos <= length(data_names)]
res <- .data[col_pos]
if (has_groups(.data)) res <- set_groups(res, get_groups(.data))
res
}
rename <- function(.data, ...) {
check_is_dataframe(.data)
new_names <- names(deparse_dots(...))
if (length(new_names) == 0L) {
warning("You didn't give any new names")
return(.data)
}
col_pos <- select_positions(.data, ...)
old_names <- colnames(.data)[col_pos]
new_names_zero <- nchar(new_names) == 0L
if (any(new_names_zero)) {
warning("You didn't provide new names for: ", paste0("`", old_names[new_names_zero], collapse = ", "), "`")
new_names[new_names_zero] <- old_names[new_names_zero]
}
colnames(.data)[col_pos] <- new_names
.data
}
rownames_to_column <- function(.data, var = "rowname") {
check_is_dataframe(.data)
col_names <- colnames(.data)
if (var %in% col_names) stop("Column `", var, "` already exists in `.data`")
.data[, var] <- rownames(.data)
rownames(.data) <- NULL
.data[, c(var, setdiff(col_names, var))]
}
select <- function(.data, ...) {
map <- names(deparse_dots(...))
col_pos <- select_positions(.data, ..., group_pos = TRUE)
res <- .data[, col_pos, drop = FALSE]
to_map <- nchar(map) > 0L
colnames(res)[to_map] <- map[to_map]
if (has_groups(.data)) res <- set_groups(res, get_groups(.data))
res
}
starts_with <- function(match, ignore.case = TRUE, vars = peek_vars()) {
grep(pattern = paste0("^", paste0(match, collapse = "|^")), x = vars, ignore.case = ignore.case)
}
ends_with <- function(match, ignore.case = TRUE, vars = peek_vars()) {
grep(pattern = paste0(paste0(match, collapse = "$|"), "$"), x = vars, ignore.case = ignore.case)
}
contains <- function(match, ignore.case = TRUE, vars = peek_vars()) {
matches <- lapply(
match,
function(x) {
if (isTRUE(ignore.case)) {
match_u <- toupper(x)
match_l <- tolower(x)
pos_u <- grep(pattern = match_u, x = toupper(vars), fixed = TRUE)
pos_l <- grep(pattern = match_l, x = tolower(vars), fixed = TRUE)
unique(c(pos_l, pos_u))
} else {
grep(pattern = x, x = vars, fixed = TRUE)
}
}
)
unique(matches)
}
matches <- function(match, ignore.case = TRUE, perl = FALSE, vars = peek_vars()) {
grep(pattern = match, x = vars, ignore.case = ignore.case, perl = perl)
}
num_range <- function(prefix, range, width = NULL, vars = peek_vars()) {
if (!is.null(width)) {
range <- sprintf(paste0("%0", width, "d"), range)
}
find <- paste0(prefix, range)
if (any(duplicated(vars))) {
stop("Column names must be unique")
} else {
x <- match(find, vars)
x[!is.na(x)]
}
}
all_of <- function(x, vars = peek_vars()) {
x_ <- !x %in% vars
if (any(x_)) {
which_x_ <- which(x_)
if (length(which_x_) == 1L) {
stop("The column ", x[which_x_], " does not exist.")
} else {
stop("The columns ", paste(x[which_x_], collapse = ", "), " do not exist.")
}
} else {
which(vars %in% x)
}
}
any_of <- function(x, vars = peek_vars()) {
which(vars %in% x)
}
everything <- function(vars = peek_vars()) {
seq_along(vars)
}
last_col <- function(offset = 0L, vars = peek_vars()) {
if (!is_wholenumber(offset)) stop("`offset` must be an integer")
n <- length(vars)
if (offset && n <= offset) {
stop("`offset` must be smaller than the number of `vars`")
} else if (n == 0) {
stop("Can't select last column when `vars` is empty")
} else {
n - offset
}
}
select_positions <- function(.data, ..., group_pos = FALSE) {
cols <- eval(substitute(alist(...)))
data_names <- colnames(.data)
select_env$.col_names <- data_names
on.exit(rm(list = ".col_names", envir = select_env))
exec_env <- parent.frame(2L)
pos <- unlist(lapply(cols, eval_expr, exec_env = exec_env))
if (isTRUE(group_pos)) {
groups <- get_groups(.data)
missing_groups <- !(groups %in% cols)
if (any(missing_groups)) {
message("Adding missing grouping variables: `", paste(groups[missing_groups], collapse = "`, `"), "`")
pos <- c(match(groups[missing_groups], data_names), pos)
}
}
unique(pos)
}
eval_expr <- function(x, exec_env) {
type <- typeof(x)
switch(
type,
"integer" = x,
"double" = as.integer(x),
"character" = select_char(x),
"symbol" = select_symbol(x, exec_env = exec_env),
"language" = eval_call(x),
stop("Expressions of type <", typeof(x), "> cannot be evaluated for use when subsetting.")
)
}
select_char <- function(expr) {
pos <- match(expr, select_env$.col_names)
if (is.na(pos)) stop("Column `", expr, "` does not exist")
pos
}
select_symbol <- function(expr, exec_env) {
res <- try(select_char(as.character(expr)), silent = TRUE)
if (inherits(res, "try-error")) {
res <- tryCatch(
select_char(eval(expr, envir = exec_env)),
error = function(e) stop("Column ", expr, " does not exist.")
)
}
res
}
eval_call <- function(x) {
type <- as.character(x[[1]])
switch(
type,
`:` = select_seq(x),
`!` = select_negate(x),
`-` = select_minus(x),
`c` = select_c(x),
`(` = select_bracket(x),
select_context(x)
)
}
select_seq <- function(expr) {
x <- eval_expr(expr[[2]])
y <- eval_expr(expr[[3]])
x:y
}
select_negate <- function(expr) {
x <- if (is_negated_colon(expr)) {
expr <- call(":", expr[[2]][[2]], expr[[2]][[3]][[2]])
eval_expr(expr)
} else {
eval_expr(expr[[2]])
}
x * -1L
}
is_negated_colon <- function(expr) {
expr[[1]] == "!" && length(expr[[2]]) > 1L && expr[[2]][[1]] == ":" && expr[[2]][[3]][[1]] == "!"
}
select_minus <- function(expr) {
x <- eval_expr(expr[[2]])
x * -1L
}
select_c <- function(expr) {
lst_expr <- as.list(expr)
lst_expr[[1]] <- NULL
unlist(lapply(lst_expr, eval_expr))
}
select_bracket <- function(expr) {
eval_expr(expr[[2]])
}
select_context <- function(expr) {
eval(expr, envir = context$.data)
}
slice <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
slice.grouped_data(.data, ...)
} else {
slice.default(.data, ...)
}
}
slice.default <- function(.data, ...) {
rows <- c(...)
stopifnot(is.numeric(rows) | is.integer(rows))
if (all(rows > 0L)) rows <- rows[rows <= nrow(.data)]
.data[rows, ]
}
slice.grouped_data <- function(.data, ...) {
apply_grouped_function(.data, "slice", ...)
}
summarise <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
summarise.grouped_data(.data, ...)
} else {
summarise.default(.data, ...)
}
}
summarise.default <- function(.data, ...) {
fns <- vapply(substitute(...()), deparse, NA_character_)
context$.data <- .data
on.exit(rm(.data, envir = context))
if (has_groups(.data)) {
group <- unique(.data[, get_groups(.data), drop = FALSE])
if (nrow(group) == 0L) return(NULL)
}
res <- lapply(fns, function(x) do.call(with, list(.data, str2lang(x))))
res <- as.data.frame(res)
fn_names <- names(fns)
colnames(res) <- if (is.null(fn_names)) fns else fn_names
if (has_groups(.data)) res <- cbind(group, res)
res
}
summarise.grouped_data <- function(.data, ...) {
groups <- get_groups(.data)
res <- apply_grouped_function(.data, "summarise", ...)
res <- res[do.call(order, lapply(groups, function(x) res[, x])), ]
rownames(res) <- NULL
res
}
summarize <- summarise
summarize.default <- summarise.default
summarize.grouped_data <- summarise.grouped_data
transmute <- function(.data, ...) {
check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
transmute.grouped_data(.data, ...)
} else {
transmute.default(.data, ...)
}
}
transmute.default <- function(.data, ...) {
conditions <- deparse_dots(...)
mutated <- mutate(.data, ...)
mutated[, names(conditions), drop = FALSE]
}
transmute.grouped_data <- function(.data, ...) {
rows <- rownames(.data)
res <- apply_grouped_function(.data, "transmute", ...)
res[rows, ]
}
deparse_dots <- function(...) {
vapply(substitute(...()), deparse, NA_character_)
}
deparse_var <- function(var) {
sub_var <- eval(substitute(substitute(var)), parent.frame())
if (is.symbol(sub_var)) var <-