Merge pull request #14 from KWB-R/clean

Clean again

R/analyse.R

@@ -22,13 +22,9 @@ analyse <- function(x, path = "")
   result[["path"]] <- path
 
   if (is.recursive(x)) {
-
-    result[["children"]] <- lapply(
-      X = seq_along(x), 
-      FUN = function(i) {
-        analyse(x[[i]], path = paste0(path, "/", i))
-      }
-    )
+    result[["children"]] <- lapply(seq_along(x), function(i) {
+      analyse(x[[i]], path = paste0(path, "/", i))
+    })
   }
 
   result  
@@ -40,7 +36,6 @@ type_info <- function(x, as_character = FALSE)
   shorten <- function(x) paste(substr(x, 1, 30), "...")
 
   text <- as.character(x)
-
   mode_x <- mode(x)
   class_x <- class(x)
 

R/duplicatesToFiles.R

@@ -50,9 +50,10 @@ duplicatesToFiles <- function
       extract_function_definition(function_name)
   })
 
-  target_dir <- file.path(target_root, "clean", function_name)
-  target_dir <- create_directory(target_dir, dbg = FALSE)
-
+  target_dir <- target_root %>% 
+    file.path("clean", function_name) %>% 
+    create_directory(dbg = FALSE)
+
   contents <- lapply(function_defs, function(x) deparse(x[[3L]]))
 
   # Write one file per function definition
@@ -75,17 +76,15 @@ duplicatesToFiles <- function
 # get_info_on_duplicated_function_names ----------------------------------------
 get_info_on_duplicated_function_names <- function(trees)
 {
-  function_info <- get_full_function_info(trees)
-  n_definitions <- selectColumns(function_info, "n.def")
-  function_info[n_definitions > 1L, ]
+  result <- get_full_function_info(trees)
+  result[selectColumns(result, "n.def") > 1L, ]
 }
 
 # extract_function_definition --------------------------------------------------
-extract_function_definition <- function(tree, function_name) {
-
-  tree <- tree[sapply(tree, is_function_assignment)]
-
-  fnames <- sapply(tree, function(x) split_function_assignment(x)$functionName)
+extract_function_definition <- function(tree, function_name)
+{
+  fnames <- tree[sapply(tree, is_function_assignment)] %>% 
+    sapply(function(x) split_function_assignment(x)$functionName)
 
   index <- which(fnames == function_name)
 

R/extract_from_parse_tree.R

@@ -18,16 +18,16 @@
 #' @param index for internal use
 #' @return vector of character or \code{NULL}
 extract_from_parse_tree <- function(
-  x, 
-  matches = matches_function, 
-  dbg = FALSE, 
-  path = integer(), 
-  parent = NULL, 
-  index = -1
+    x, 
+    matches = matches_function, 
+    dbg = FALSE, 
+    path = integer(), 
+    parent = NULL, 
+    index = -1
 )
 {
   if (is.null(matches) || ! is.function(matches)) {
-    stop(call. = FALSE, "Please give a function in argument 'matches'")
+    stop_formatted("Please give a function in argument 'matches'")
   }
 
   # If this function is called with a list of parse trees, call the function for 
@@ -44,46 +44,45 @@ extract_from_parse_tree <- function(
       index = index
     ))
   }
-    
+
   cat_if(dbg, sprintf(
     "[[%s]]: %s\n", 
     comma_collapsed(path), 
     utils::capture.output(utils::str(x))
   ))
-
+  
   # Is the current element wanted? If yes, store this element
   element <- if (wanted <- matches(x, parent, index)) {
     get_attribute(wanted, "name")
   } # else NULL implicitly
-
-  # Do we have to climb further branches up?  
-  if (is.expression(x) || is.list(x) || length(x) > 1L) {
-
-    c(element, unlist(
-      lapply(
-        X = seq_along(x), 
-        FUN = function(i) {
-          extract_from_parse_tree(
-            x = x[[i]], 
-            matches = matches, 
-            dbg = dbg, 
-            path = c(path, i), 
-            parent = x, 
-            index = i
-          )
-        }
-      )
-    ))
-
-  } else {
-
-    element
+
+  # Do we have to climb further branches up?
+  is_recursive <- is.expression(x) || is.list(x) || length(x) > 1L
+
+  if (!is_recursive) {
+    return(element)
   }
+
+  # Call this function recursively
+  more_elements <- seq_along(x) %>% 
+    lapply(function(i) {
+      extract_from_parse_tree(
+        x = x[[i]], 
+        matches = matches, 
+        dbg = dbg, 
+        path = c(path, i), 
+        parent = x, 
+        index = i
+      )
+    }) %>% 
+    unlist()
+
+  c(element, more_elements)
 }
 
 # matches_function -------------------------------------------------------------
 matches_function <- function(
-  x, parent = NULL, index, exclude = base_functions()
+    x, parent = NULL, index, exclude = base_functions()
 )
 {
   if (!is.call(x) || (is.call(parent) && index == 1L)) {
@@ -95,19 +94,17 @@ matches_function <- function(
   n <- length(name)
 
   if (!(n == 1L || n == 3L)) {
-
     message_formatted(
       "Not expected: n = %d, str(x) = %s", 
       n, utils::capture.output(utils::str(x))
     )
-
     return(FALSE)
   }
 
   if (n == 3L) {
     name <- paste(name[c(2L, 1L, 3L)], collapse = "")
   }
-
+  
   if (name %in% exclude) {
     return(FALSE)
   } 

R/filter_scripts.R

@@ -1,13 +1,14 @@
 # filter_scripts ---------------------------------------------------------------
 filter_scripts <- function(scriptInfo, fun.min = 5, epf.min = 10)
 {
-  keep_row <- matches_criteria(
+  keep <- matches_criteria(
     Data = scriptInfo, 
     criteria = c(
       paste("fun >=", fun.min), 
       paste("epf >=", epf.min)
     )
   )
 
-  remove_empty_columns(scriptInfo[keep_row, ])
+  scriptInfo[keep, ] %>% 
+    remove_empty_columns()
 }

R/find_string_constants.R

@@ -1,12 +1,10 @@
 #' Show String Constants Used in R Scripts
 #'
-#' @param root path from which to look recursively for R scripts
+#' @param root path from which to look recursively for R scripts. Default: "./R"
 #' @export
 find_string_constants <- function(root = "./R")
 {
-  get_string_constants_in_scripts(
-    root = root, 
-    FUN = fetch_string_constants_2
-  ) %>%
+  root %>% 
+    get_string_constants_in_scripts(FUN = fetch_string_constants_2) %>%
     kwb.file::add_file_info()
 }

R/find_weaknesses_in_scripts.R

@@ -66,9 +66,11 @@ find_weaknesses_in_scripts <- function(
   )
 
   strings <- find_code_snippets(x, is.character, "check for duplicated strings")
+
+  nchars <- nchar(as.character(strings$expression))
 
   is_relevant <- 
-    nchar(as.character(strings$expression)) >= min_duplicate_string_length & 
+    nchars >= min_duplicate_string_length & 
     strings$frequency >= min_duplicate_frequency
 
   if (any(is_relevant)) {
@@ -124,120 +126,6 @@ to_matches_function <- function(check_function, type = "self", max_chars = 50L)
 
 }
 
-# is_logical_constant_false ----------------------------------------------------
-is_logical_constant_false <- function(x, type = "short")
-{
-  is_logical_constant(x, type, logicals = FALSE)
-}
-
-# is_logical_constant_true -----------------------------------------------------
-is_logical_constant_true <- function(x, type = "short")
-{
-  is_logical_constant(x, type, logicals = TRUE)
-}
-
-# is_logical_constant ----------------------------------------------------------
-is_logical_constant <- function(x, type = "short", logicals = c(FALSE, TRUE))
-{
-  if (!is.symbol(x)) {
-    return(FALSE)
-  }
-
-  deparse(x) %in% deparsed_logical_values(type, logicals)
-}
-
-# deparsed_logical_values ------------------------------------------------------
-deparsed_logical_values <- function(
-    type = c("short", "long", "either")[3L],
-    logicals = c(FALSE, TRUE)
-)
-{
-  values <- c("F", "T", "FALSE", "TRUE")
-  use_false_true <- c(FALSE %in% logicals, TRUE %in% logicals)
-
-  if (type == "short") {
-    values[1:2][use_false_true]
-  } else if (type == "long") {
-    values[3:4][use_false_true]
-  } else if (type == "either") {
-    values[rep(use_false_true, 2L)]
-  } else {
-    stop("Unknown type: ", type)
-  }
-}
-
-# is_colon_seq_1_to_length -----------------------------------------------------
-is_colon_seq_1_to_length <- function(x)
-{
-  is_colon_seq_1_to_any(x) &&
-    mode(x[[3]]) == "call" &&
-    identical(deparse(x[[3]][[1]]), "length")
-}
-
-# is_colon_seq_1_to_variable ---------------------------------------------------
-is_colon_seq_1_to_variable <- function(x)
-{
-  is_colon_seq_1_to_any(x) &&
-    !is.numeric(x[[3]]) &&
-    mode(x[[3]]) != "call"
-}
-
-# is_colon_seq_1_to_any --------------------------------------------------------
-is_colon_seq_1_to_any <- function(x)
-{
-  is_colon_seq(x) && identical(x[[2]], 1)
-}
-
-# is_colon_seq -----------------------------------------------------------------
-is_colon_seq <- function(x)
-{
-  is.language(x) && 
-    length(x) == 3L && 
-    is.symbol(x[[1L]]) &&
-    identical(as.character(x[[1]]), ":")
-}
-
-# is_bad_function_name ---------------------------------------------------------
-is_bad_function_name <- function(x)
-{
-  if (!is_function_assignment(x)) {
-    return(FALSE)
-  }
-
-  function_name <- split_assignment(x)$leftSide
-
-  is.name(function_name) && 
-    grepl("\\.", deparse(function_name))
-}
-
-
-# is_comparison_with_false -----------------------------------------------------
-is_comparison_with_false <- function(x)
-{
-  is_comparison_with_logical(x, logicals = FALSE)
-}
-
-# is_comparison_with_true ------------------------------------------------------
-is_comparison_with_true <- function(x)
-{
-  is_comparison_with_logical(x, logicals = TRUE)
-}
-
-# is_comparison_with_logical ---------------------------------------------------
-is_comparison_with_logical <- function(x, logicals = c(FALSE, TRUE))
-{
-  if (!is.call(x)) {
-    return(FALSE)
-  }
-
-  operator <- deparse(x[[1]])
-
-  operator %in% c("==", "!=") && (
-    is_logical_constant(x[[2]], type = "either", logicals) ||
-      is_logical_constant(x[[3]], type = "either", logicals)
-  )
-}
-
 # summarise_extracted_matches --------------------------------------------------
 summarise_extracted_matches <- function(x)
 {

R/get_function_assignments.R

@@ -4,10 +4,11 @@
 #' 
 #' @param file path to R script from which function definitions are to be 
 #'   extracted
+#' @param \dots further arguments passed to \code{\link{parse}}
 #' @return named list of expressions. The names of the list elements represent 
 #'   the names of the functions that are defined by the expressions in the list.
 #' @export
-get_function_assignments <- function(file)
+get_function_assignments <- function(file, ...)
 {
   # code <- as.list(parse(file))
   #
@@ -22,7 +23,7 @@ get_function_assignments <- function(file)
   #
   # assignments <- code[is_function_assignment]
 
-  assignments <- parse(file) %>%
+  assignments <- parse(file, ...) %>%
     get_functions() %>%
     as.list()
 

R/helpers.R

@@ -0,0 +1,19 @@
+# deparsed_logical_values ------------------------------------------------------
+deparsed_logical_values <- function(
+    type = c("short", "long", "either")[3L],
+    logicals = c(FALSE, TRUE)
+)
+{
+  values <- c("F", "T", "FALSE", "TRUE")
+  use_false_true <- c(FALSE %in% logicals, TRUE %in% logicals)
+
+  if (type == "short") {
+    values[1:2][use_false_true]
+  } else if (type == "long") {
+    values[3:4][use_false_true]
+  } else if (type == "either") {
+    values[rep(use_false_true, 2L)]
+  } else {
+    stop("Unknown type: ", type)
+  }
+}