Merge pull request #90 from lorenzwalthert/speedup

Speedup of nested styler functions by ~ 4x.

Author: lorenzwalthert

R/modify_pd.R

@@ -9,82 +9,32 @@ NULL
 
 #' @describeIn update_indention Inserts indetion based on round brackets.
 indent_round <- function(pd, indent_by) {
-  indention_needed <- needs_indention(pd, token = "'('")
-  if (indention_needed) {
-    opening <- which(pd$token == "'('")
-    start <- opening + 1
-    stop <- nrow(pd) - 1
-    if (start > stop) return(pd)
-
-    pd <- pd %>%
-      mutate(indent = indent + ifelse(seq_len(nrow(pd)) %in% start:stop,
-                                      indent_by, 0))
-  }
-
-  pd %>%
-    set_unindention_child(token = "')'", unindent_by = indent_by)
+  indent_indices <- compute_indent_indices(pd, token = "'('")
+  pd$indent[indent_indices] <- pd$indent[indent_indices] + indent_by
+  set_unindention_child(pd, token = "')'", unindent_by = indent_by)
 }
+
 #' @rdname update_indention
 indent_curly <- function(pd, indent_by) {
-  indention_needed <- needs_indention(pd, token = "'{'")
-  if (indention_needed) {
-    opening <- which(pd$token == "'{'")
-    start <- opening + 1
-    stop <- nrow(pd) - 1
-    if (start > stop) return(pd)
-
-    pd <- pd %>%
-      mutate(indent = indent + ifelse(seq_len(nrow(pd)) %in% start:stop,
-                                      indent_by, 0))
-  }
-  pd %>%
-    set_unindention_child(token = "'}'", unindent_by = indent_by)
-}
-
-#' Check whether indention is needed
-#'
-#' @param pd A parse table.
-#' @param token Which token the check should be based on.
-#' @return returns `TRUE` if indention is needed, `FALSE` otherwise. Indention
-#'   is needed:
-#'     * if `token` occurs in `pd`.
-#'     * if there is no child that starts on the same line as `token` and
-#'       "opens" indention without closing it on this line.
-#' @return `TRUE` if indention is needed, `FALSE` otherwise.
-needs_indention <- function(pd, token = "'('") {
-  opening <- which(pd$token %in% token)[1]
-  if (is.na(opening)) return(FALSE)
-  before_first_break <- which(pd$lag_newlines > 0)[1] - 1
-  if (is.na(before_first_break)) return(FALSE)
-  !any(pd$multi_line[opening:before_first_break])
+  indent_indices <- compute_indent_indices(pd, token = "'{'")
+  pd$indent[indent_indices] <- pd$indent[indent_indices] + indent_by
+  set_unindention_child(pd, token = "'}'", unindent_by = indent_by)
 }
 
 #' @rdname update_indention
 indent_op <- function(pd, indent_by, token = c(math_token,
                                                "SPECIAL-PIPE")) {
-  if (needs_indention(pd, token)) {
-    opening <- which(pd$token %in% token)
-    start <- opening[1] + 1
-    stop <- nrow(pd)
-    pd <- pd %>%
-      mutate(indent = indent + ifelse(seq_len(nrow(pd)) %in% start:stop,
-                                      indent_by, 0))
-  }
+  indent_indices <- compute_indent_indices(pd, token, indent_last = TRUE)
+  pd$indent[indent_indices] <- pd$indent[indent_indices] + indent_by
   pd
 }
 
 #' @describeIn update_indention Same as indent_op, but only indents one token
 #'   after `token`, not all remaining.
 indent_assign <- function(pd, indent_by, token = c("LEFT_ASSIGN", "
                                                    EQ_ASSIGN")) {
-  if (needs_indention(pd, token)) {
-    opening <- which(pd$token %in% token)
-    start <- opening + 1
-    stop <- start + 1
-    pd <- pd %>%
-      mutate(indent = indent + ifelse(seq_len(nrow(pd)) %in% start:stop,
-                                      indent_by, 0))
-  }
+  indent_indices <- compute_indent_indices(pd, token, indent_last = TRUE)
+  pd$indent[indent_indices] <- pd$indent[indent_indices] + indent_by
   pd
 }
 
@@ -98,15 +48,56 @@ indent_without_paren <- function(pd, indent_by = 2) {
   pd
 }
 
+#' Compute the indices that need indention
+#'
+#' Based on `token`, find the rows in `pd` that need to be indented.
+#' @param pd A parse table.
+#' @param token A character vector with tokens.
+#' @param indent_last Flag to indicate whether the last token in `pd` should
+#'   be indented or not. See 'Details'.
+#' @details
+#'  For example when `token` is a parenthesis, the closing parenthesis does not
+#'  need indention, but if token is something else, for example a plus (+), the
+#'  last token in `pd` needs indention.
+compute_indent_indices <- function(pd, token = "'('", indent_last = FALSE) {
+  npd <- nrow(pd)
+  opening <- which(pd$token %in% token)[1]
+  if (!needs_indention(pd, opening)) return(numeric(0))
+  start <- opening + 1
+  stop <- npd - ifelse(indent_last, 0, 1)
+  which(between(seq_len(npd), start, stop))
+}
+
+
+#' Check whether indention is needed
+#'
+#' @param pd A parse table.
+#' @param opening the index of the opening parse table. Since always computed
+#'   before this function is called, it is included as an argument so it does
+#'   not have to be recomputed.
+#' @return returns `TRUE` if indention is needed, `FALSE` otherwise. Indention
+#'   is needed if and only if:
+#'     * the opening token is not `NA`.
+#'     * if there is a multi-line token before the first line break.
+#' @return `TRUE` if indention is needed, `FALSE` otherwise.
+needs_indention <- function(pd, opening) {
+  if (is.na(opening)) return(FALSE)
+  before_first_break <- which(pd$lag_newlines > 0)[1] - 1
+  if (is.na(before_first_break)) return(FALSE)
+  !any(pd$multi_line[opening:before_first_break])
+}
+
+
+
 #' Set the multi-line column
 #'
 #' Sets the column `multi_line` in `pd` by checking row-wise whether any child
 #'   of a token is a multi-line token.
 #' @param pd A parse table.
 #' @importFrom purrr map_lgl
 set_multi_line <- function(pd) {
-  pd %>%
-    mutate(multi_line = map_lgl(child, token_is_multi_line))
+  pd$multi_line <- map_lgl(pd$child, token_is_multi_line)
+  pd
 }
 
 #' Check whether a parse table is a multi-line token
@@ -117,7 +108,7 @@ set_multi_line <- function(pd) {
 #' * it has at least one child that is a multi-line expression itself.
 #' @param pd A parse table.
 token_is_multi_line <- function(pd) {
-  any(pd$multi_line) | any(pd$lag_newlines)
+  any(pd$multi_line, pd$lag_newlines > 0)
 }
 
 
@@ -127,6 +118,7 @@ token_is_multi_line <- function(pd) {
 #' @param pd_flat A flat parse table.
 #' @return A nested parse table.
 strip_eol_spaces <- function(pd_flat) {
-  pd_flat %>%
-    mutate(spaces = spaces * (lead(lag_newlines, default = 0) == 0))
+  idx <- lead(pd_flat$lag_newlines, default = 0) != 0
+  pd_flat$spaces[idx] <- 0
+  pd_flat
 }

R/nested.R

@@ -29,10 +29,8 @@ compute_parse_data_nested <- function(text) {
     add_terminal_token_before() %>%
     add_terminal_token_after()
 
+  parse_data$child <- rep(list(NULL), length(parse_data$text))
   pd_nested <- parse_data %>%
-    mutate_(child = ~rep(list(NULL), length(text))) %>%
-    mutate_(short = ~substr(text, 1, 5)) %>%
-    select_(~short, ~everything()) %>%
     nest_parse_data() %>%
     flatten_operators()
 
@@ -48,6 +46,7 @@ tokenize <- function(text) {
   parsed <- parse(text = text, keep.source = TRUE)
   parse_data <- as_tibble(utils::getParseData(parsed, includeText = NA)) %>%
     enhance_mapping_special()
+  parse_data$short <- substr(parse_data$text, 1, 5)
   parse_data
 }
 
@@ -57,13 +56,13 @@ tokenize <- function(text) {
 #'   description.
 #' @param pd A parse table.
 enhance_mapping_special <- function(pd) {
-  pd %>%
-    mutate(token = case_when(
+  pd$token <- with(pd, case_when(
       token != "SPECIAL" ~ token,
       text == "%>%" ~ special_and("PIPE"),
       text == "%in%" ~ special_and("IN"),
       TRUE ~ special_and("OTHER")
     ))
+  pd
 }
 
 special_and <- function(text) {
@@ -98,19 +97,23 @@ NULL
 
 #' @rdname add_token_terminal
 add_terminal_token_after <- function(pd_flat) {
-  pd_flat %>%
+  terminals <- pd_flat %>%
     filter(terminal) %>%
-    arrange(line1, col1) %>%
-    transmute(id = id, token_after = lead(token, default = "")) %>%
+    arrange(line1, col1)
+
+  data_frame(id = terminals$id,
+             token_after = lead(terminals$token, default = "")) %>%
     left_join(pd_flat, ., by = "id")
 }
 
 #' @rdname add_token_terminal
 add_terminal_token_before <- function(pd_flat) {
-  pd_flat %>%
+  terminals <- pd_flat %>%
     filter(terminal) %>%
-    arrange(line1, col1) %>%
-    transmute(id = id, token_before = lag(token, default = "")) %>%
+    arrange(line1, col1)
+
+  data_frame(id = terminals$id,
+             token_before = lag(terminals$token, default = "")) %>%
     left_join(pd_flat, ., by = "id")
 }
 
@@ -146,24 +149,22 @@ set_spaces <- function(spaces_after_prefix, force_one) {
 #' @importFrom purrr map2
 nest_parse_data <- function(pd_flat) {
   if (all(pd_flat$parent <= 0)) return(pd_flat)
-  split <- pd_flat %>%
-    mutate_(internal = ~ (id %in% parent) | (parent <= 0)) %>%
-    nest_("data", names(pd_flat))
+  pd_flat$internal <- with(pd_flat, (id %in% parent) | (parent <= 0))
+  split_data <- split(pd_flat, pd_flat$internal)
 
-  child <- split$data[!split$internal][[1L]]
-  internal <- split$data[split$internal][[1L]]
+  child <- split_data$`FALSE`
+  internal <- split_data$`TRUE`
 
   internal <- rename_(internal, internal_child = ~child)
 
-  nested <-
+  child$parent_ <- child$parent
+  joined <-
     child %>%
-    mutate_(parent_ = ~parent) %>%
     nest_(., "child", setdiff(names(.), "parent_")) %>%
-    left_join(internal, ., by = c("id" = "parent_")) %>%
-    mutate_(child = ~map2(child, internal_child, combine_children)) %>%
-    select_(~-internal_child) %>%
-    select_(~short, ~everything(), ~-text, ~text)
-
+    left_join(internal, ., by = c("id" = "parent_"))
+  nested <- joined
+  nested$child <- map2(nested$child, nested$internal_child, combine_children)
+  nested <- nested[, setdiff(names(nested), "internal_child")]
   nest_parse_data(nested)
 }
 
@@ -179,7 +180,8 @@ nest_parse_data <- function(pd_flat) {
 combine_children <- function(child, internal_child) {
   bound <- bind_rows(child, internal_child)
   if (nrow(bound) == 0) return(NULL)
-  arrange_(bound, ~line1, ~col1)
+  bound[order(bound$line1, bound$col1), ]
+
 }
 
 #' Get the start right

R/parsed.R

@@ -44,9 +44,12 @@ enhance_parse_data <- function(parse_data) {
     parse_data_filtered %>%
     create_filler()
 
-  parse_data_comment_eol <-
-    parse_data_filled %>%
-    mutate_(text = ~if_else(token == "COMMENT", gsub(" +$", "", text), text))
+  parse_data_comment_eol <- parse_data_filled
+
+  parse_data_comment_eol$text <-
+    if_else(parse_data_comment_eol$token == "COMMENT",
+            gsub(" +$", "", parse_data_comment_eol$text),
+            parse_data_comment_eol$text)
 
   parse_data_comment_eol
 }
@@ -81,18 +84,17 @@ verify_roundtrip <- function(pd_flat, text) {
 #' @return A parse table with two three columns: lag_newlines, newlines and
 #'   spaces.
 create_filler <- function(pd_flat) {
-  ret <-
-    pd_flat %>%
-    mutate_(
-      line3 = ~lead(line1, default = tail(line2, 1)),
-      col3 = ~lead(col1, default = tail(col2, 1) + 1L),
-      newlines = ~line3 - line2,
-      lag_newlines = ~lag(newlines, default = 0),
-      col2_nl = ~if_else(newlines > 0L, 0L, col2),
-      spaces = ~col3 - col2_nl - 1L,
-      multi_line = ~ifelse(terminal, FALSE, NA)
-    ) %>%
-    select_(~-line3, ~-col3, ~-col2_nl)
+
+  pd_flat$line3 <- lead(pd_flat$line1, default = tail(pd_flat$line2, 1))
+  pd_flat$col3 <- lead(pd_flat$col1, default = tail(pd_flat$col2, 1) + 1L)
+  pd_flat$newlines <- pd_flat$line3 - pd_flat$line2
+  pd_flat$lag_newlines <- lag(pd_flat$newlines, default = 0)
+  pd_flat$col2_nl <- if_else(pd_flat$newlines > 0L, 0L, pd_flat$col2)
+  pd_flat$spaces <- pd_flat$col3 - pd_flat$col2_nl - 1L
+  pd_flat$multi_line <- ifelse(pd_flat$terminal, FALSE, NA)
+
+  ret <- pd_flat[, !(names(pd_flat) %in% c("line3", "col3", "col2_nl"))]
+
 
   if (!("indent" %in% names(ret))) {
     ret$indent <- 0

R/rules-replacement.R

@@ -8,7 +8,8 @@ force_assignment_op <- function(pd) {
 
 resolve_semicolon <- function(pd) {
   is_semicolon <- pd$token == "';'"
+  if (!any(is_semicolon)) return(pd)
   pd$lag_newlines[lag(is_semicolon)] <- 1L
-  pd <- pd[!is_semicolon,]
+  pd <- pd[!is_semicolon, ]
   pd
 }