Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Select needs matching functions #158

Closed
hadley opened this issue Dec 6, 2013 · 3 comments
Closed

Select needs matching functions #158

hadley opened this issue Dec 6, 2013 · 3 comments
Milestone

Comments

@hadley
Copy link
Member

@hadley hadley commented Dec 6, 2013

So you could do e.g.

select(df, starts_with("xyz_"))
select(df, contains("xyz_"))
select(df, ends_with("xyz_"))
select(df, matches("xyz.*"))
@hadley
Copy link
Member Author

@hadley hadley commented Jan 20, 2014

Initial implementation below. It's ok but not wonderful. Would be nice to have natural composition

starts_with <- function(match, ignore.case = TRUE) {
  stopifnot(is.string(match), !is.na(match))

  if (ignore.case) match <- tolower(match)
  n <- nchar(match)

  function(x) {
    if (ignore.case) x <- tolower(x)
    substr(x, 1, n) == match
  }
}

ends_with <- function(match, ignore.case = TRUE) {
  stopifnot(is.string(match), !is.na(match))

  if (ignore.case) match <- tolower(match)
  n <- nchar(match)

  function(x) {
    if (ignore.case) x <- tolower(x)
    length <- nchar(x)

    substr(x, pmax(1, length - n + 1), length) == match
  }
}

contains <- function(match, ignore.case = TRUE) {
  stopifnot(is.string(match))
  function(x) {
    grepl(match, x, ignore.case = ignore.case)
  }
}

matches <- function(match, ignore.case = TRUE) {
  stopifnot(is.string(match))
  function(x) {
    grepl(match, x, ignore.case = ignore.case)
  }
}

select <- function(tbl, ..., env = parent.frame()) {
  dots <- dots(...)

  nm <- tbl_vars(tbl)
  nms_list <- as.list(setNames(seq_along(nm), nm))

  idx <- lapply(dots, eval, nms_list, env)

  # Execute any functions passing names as first arg
  funs <- vapply(idx, is.function, logical(1))
  idx[funs] <- lapply(idx[funs], function(f) f(nm))

  # Convert any logical to numeric
  log <- vapply(idx, is.logical, logical(1))
  idx[log] <- lapply(idx[log], function(x) seq_along(nm)[x])

  # Check all numeric
  num <- vapply(idx, is.numeric, logical(1))
  if (any(!num)) {
    stop("Non-numeric outputs in positions ", 
      paste(which(num), collapse = ", "), call. = FALSE)
  }

  new <- nm[unique(unlist(idx))]
  tbl[new]
} 


select(iris, starts_with("Petal"))
select(iris, ends_with("Width"))
select(iris, contains("etal"))
select(iris, matches(".t."))

Loading

@hadley
Copy link
Member Author

@hadley hadley commented Jan 22, 2014

And one more from Bob Muenchen: select(df, num_range(x1:xN)

Loading

@hadley
Copy link
Member Author

@hadley hadley commented Feb 3, 2014

Better implementation in 8ccdb07

Loading

hadley added a commit that referenced this issue Feb 4, 2014
@hadley hadley closed this in d948c6e Feb 4, 2014
@hadley hadley added this to the v0.1.2 milestone Feb 17, 2014
@hadley hadley removed this from the v0.2 milestone Feb 17, 2014
krlmlr pushed a commit to krlmlr/dplyr that referenced this issue Mar 2, 2016
@lock lock bot locked as resolved and limited conversation to collaborators Jun 10, 2018
Sign up for free to subscribe to this conversation on GitHub. Already have an account? Sign in.
Labels
None yet
Projects
None yet
Linked pull requests

Successfully merging a pull request may close this issue.

None yet
1 participant