jasptools: Helps preview and debug JASP analyses

# lintAnalysis <- function(analysis) {
#
#   nLint <- length(analysis)
#   output <- vector("list", nLint)
#   prog <- dplyr::progress_estimated(nLint)
#     # lintr checks the parent environment for function definitions (i.e.)
#   env <- new.env()
#   if (.isModule())
#     .sourceDir(getPkgOption("module.dir"), env)
#   else
#     .sourceDir(getPkgOption("common.r.dir"), env)
#
#   for (i in seq_len(nLint)) {
#
#     analysis[i] <- try(.validateAnalysis(analysis[i]), silent = FALSE)
#     if (.isModule())
#       filename <- file.path(getPkgOption("module.dir"), "R", paste0(analysis[i], ".R"))
#     else
#       filename <- file.path(getPkgOption("common.r.dir"), paste0(analysis[i], ".R"))
#     output[[i]] <- if (!inherits("try-error", analysis[i])) {
#       lintr::lint(
#         filename = filename,
#         linters = list(
#           absolute_paths_linter          = lintr::absolute_path_linter,
#           no_tab_linter                  = lintr::no_tab_linter,
#           assignment_linter              = lintr::assignment_linter,
#           line_length_linter             = lintr::line_length_linter(120L),
#           trailing_whitespace_linter     = lintr::trailing_whitespace_linter,
#           spaces_inside_linter           = lintr::spaces_inside_linter,
#           open_curly_linter              = lintr::open_curly_linter,
#           object_name_linter             = lintr::object_name_linter,
#           commas_linter                  = lintr::commas_linter,
#           infix_spaces_linter            = lintr::infix_spaces_linter,
#           T_and_F_symbol_linter          = lintr::T_and_F_symbol_linter,
#           object_usage_linter            = object_usage_linter_custom(env),
#           object_length_linter           = lintr::object_length_linter,
#           undesirable_operator_linter    = lintr::undesirable_operator_linter,
#           unneeded_concatenation_linter  = lintr::unneeded_concatenation_linter,
#           spaces_left_parentheses_linter = lintr::spaces_left_parentheses_linter,
#           undesirable_function_linter    = lintr::undesirable_function_linter
#         )
#       )
#     } else {
#       analysis[i]
#     }
#     prog$tick()$print()
#   }
#   class(output) <- "jaspLint"
#   return(output)
# }
#
# lintAll <- function() {
#
#   env <- new.env()
#   if (.isModule()) {
#     .sourceDir(getPkgOption("module.dir"), env)
#     files <- list.files(file.path(getPkgOption("module.dir"), "R"), "\\.[RrSsQq]$")
#   } else {
#     .sourceDir(getPkgOption("common.r.dir"), env)
#     files <- list.files(getPkgOption("common.r.dir"), "\\.[RrSsQq]$")
#   }
#   output <- vector("list", length(files))
#   names(output) <- files
#
#   prog <- dplyr::progress_estimated(length(files))
#   for (f in files) {
#     if (.isModule())
#       filename <- file.path(getPkgOption("module.dir"), "R", f)
#     else
#       filename <- file.path(getPkgOption("common.r.dir"), f)
#     output[[f]] <- lintr::lint(
#       filename = filename,
#       linters = list(
#         absolute_paths_linter          = lintr::absolute_path_linter,
#         no_tab_linter                  = lintr::no_tab_linter,
#         assignment_linter              = lintr::assignment_linter,
#         line_length_linter             = lintr::line_length_linter(120L),
#         trailing_whitespace_linter     = lintr::trailing_whitespace_linter,
#         spaces_inside_linter           = lintr::spaces_inside_linter,
#         open_curly_linter              = lintr::open_curly_linter,
#         object_name_linter             = lintr::object_name_linter,
#         commas_linter                  = lintr::commas_linter,
#         infix_spaces_linter            = lintr::infix_spaces_linter,
#         T_and_F_symbol_linter          = lintr::T_and_F_symbol_linter,
#         object_usage_linter            = object_usage_linter_custom(env),
#         object_length_linter           = lintr::object_length_linter,
#         undesirable_operator_linter    = lintr::undesirable_operator_linter,
#         unneeded_concatenation_linter  = lintr::unneeded_concatenation_linter,
#         spaces_left_parentheses_linter = lintr::spaces_left_parentheses_linter,
#         undesirable_function_linter    = lintr::undesirable_function_linter
#       )
#     )
#     prog$tick()$print()
#   }
#   class(output) <- "jaspLint"
#   return(output)
# }
#
# testLint <- function(lintObj = NULL) {
#
#   if (is.null(lintObj))
#     lintObj <- lintAll()
#
#
# }
#
# styleAnalysis <- function(analysis, silent = FALSE, safetyCopy = tempfile(fileext = ".R")) {
#
#   if (inherits(analysis, "lints")) {
#     obj <- analysis
#     fullname <- names(analysis)[1]
#     filename <- basename(fullname)
#   } else {
#     filename <- paste0(.validateAnalysis(analysis), ".R")
#     if (.isModule())
#       fullname <- file.path(getPkgOption("module.dir"), "R", filename)
#     else
#       fullname <- file.path(getPkgOption("common.r.dir"), filename)
#     obj <- lintAnalysis(analysis)
#   }
#
#   if (!file.copy(from = fullname, to = safetyCopy, overwrite = FALSE))
#     stop("Could not create safety copy. Aborting styling.")
#   if (!silent)
#     message(sprintf("A safety-copy is available at %s", safetyCopy))
#
#   if (silent) {
#     utils::capture.output(
#       {
#         obj <- styler::style_file(
#           path                          = fullname,
#           scope                         = "tokens",
#           strict                        = FALSE,
#           start_comments_with_one_space = TRUE
#         )
#       }
#     )
#   } else {
#     obj <- styler::style_file(
#       path                          = fullname,
#       scope                         = "tokens",
#       strict                        = FALSE,
#       start_comments_with_one_space = TRUE
#     )
#   }
#   return(invisible(obj))
# }
#
# # custom lintr checks go here ----
# object_usage_linter_custom <- function(parent_env = NULL) {
#
#   function(source_file) {
#     if (is.null(parent_env)) {
#       pkg_name <- pkg_name(lintr:::find_package(dirname(source_file$filename)))
#       if (!is.null(pkg_name)) {
#         parent_env <- lintr:::try_silently(getNamespace(pkg_name))
#       }
#       if (is.null(pkg_name) || inherits(parent_env, "try-error")) {
#         parent_env <- globalenv()
#       }
#     }
#     env <- new.env(parent = parent_env)
#
#     globals <- mget(".__global__", parent_env, ifnotfound = list(NULL))$.__global__
#     mapply(assign, globals, MoreArgs = list(value = function(...) NULL,
#                                             envir = env))
#     lintr:::try_silently(eval(source_file$parsed_content, envir = env))
#     all_globals <- unique(lintr:::recursive_ls(env))
#     # lapply(lintr:::ids_with_token(source_file, rex::rex(start, "FUNCTION"), fun = rex::re_matches),
#     lapply(lintr:::ids_with_token(source_file, "^FUNCTION", fun = rex::re_matches),
#            function(loc) {
#              id <- source_file$parsed_content$id[loc]
#              parent_ids <- lintr:::parents(source_file$parsed_content, id,
#                                            simplify = FALSE)
#              if (length(parent_ids) > 3L) {
#                return(NULL)
#              }
#              fun <- lintr:::try_silently(eval(parse(text = source_file$content,
#                                                     keep.source = TRUE), envir = env))
#              if (inherits(fun, "try-error")) {
#                return()
#              }
#              res <- lintr:::parse_check_usage(fun)
#              locals <- codetools::findFuncLocals(formals(fun), body(fun))
#              both <- c(locals, names(formals(fun)), all_globals)
#              lapply(which(!is.na(res$message)), function(row_num) {
#                row <- res[row_num, ]
#                if (rex::re_matches(row$message, rex::rex("no visible"))) {
#                  suggestion <- lintr:::try_silently(both[stringdist::amatch(row$name,
#                                                                             both, maxDist = 2)])
#                  if (!inherits(suggestion, "try-error") && !is.na(suggestion)) {
#                    row$message <- paste0(row$message, ", Did you mean '",
#                                          suggestion, "'?")
#                  }
#                }
#                org_line_num <- as.integer(row$line_number) + as.integer(names(source_file$lines)[1]) -
#                  1L
#                line <- source_file$lines[as.character(org_line_num)]
#                row$name <- rex::re_substitutes(row$name, rex::rex("<-"), "")
#                location <- rex::re_matches(line, rex::rex(row$name), locations = TRUE)
#                lintr:::Lint(filename = source_file$filename, line_number = org_line_num,
#                             column_number = location$start, type = "warning",
#                             message = row$message, line = line, ranges = list(c(location$start,
#                                                                                 location$end)), linter = "object_usage_linter")
#              })
#            })
#   }
# }
#
# .sourceDir <- function(paths, envir, fileNames=NULL) {
#   for (i in 1:length(paths)) {
#     rFilePaths <- list.files(paths[i], pattern = "\\.[RrSsQq]$", recursive=TRUE)
#     for (rFilePath in rFilePaths) {
#       rFileName <- tools::file_path_sans_ext(basename(rFilePath))
#       if (! is.null(fileNames) && ! rFileName %in% fileNames)
#         next
#       source(file.path(paths[i], rFilePath), local=envir)
#     }
#   }
# }

# errorCol   <- crayon::combine_styles("red", "bold")
# warningCol <- crayon::make_style(rgb(5/7, 2/7, 0), bg = FALSE)
# goodCol    <- crayon::green
#
# print.jaspLint <- function(x, showmax = 3, ...) {
#
#   errorList <- vector("list", length(x))
#   shouldBeFixed <- FALSE
#   for (i in seq_along(x)) {
#
#     current <- x[[i]]
#     errors <- list()
#
#     name <- basename(current[[1]]$filename)
#     cat(paste0(
#       strrep("=", nchar(name)), "\n",
#       name, "\n",
#       strrep("=", nchar(name)), "\n",
#       collapse = ""
#     ))
#     for (j in seq_along(current)) {
#       errorType <- current[[j]][["message"]]
#
#       idx <- match(errorType, names(errors), nomatch = NA)
#       if (!is.na(idx)) {
#         errors[[idx]] <- c(errors[[idx]], current[[j]]$line_number)
#       } else {
#         idx <- length(errors) + 1L
#         errors[[idx]] <- current[[j]]$line_number
#         names(errors)[idx] <- errorType
#       }
#     }
#     if (length(errors) > 0) {
#
#       nms <- names(errors)
#       nms <- substr(nms, 1, nchar(nms) - 1L) # cut off trailing .
#
#       # show errors first then warnings. Sort each alphabetically
#       o <- order(nms)
#       idx <- nms[o] %in% .listOfFatalStylesErrors
#       order4loop <- c(o[idx], o[!idx])
#
#       for (j in order4loop) {
#
#         toShow  <- errors[[j]]
#         toShow  <- toShow[1:min(length(toShow), showmax)]
#         andMore <- length(errors[[j]]) - length(toShow)
#
#         line1 <- if (length(toShow) > 1) "lines" else "line"
#         line2 <- if (andMore > 1) "lines" else "line"
#
#         if (andMore > 0) {
#           string <- sprintf("%s on %s: %s, and %d more %s.\n",
#                             nms[j], line1, paste(toShow, collapse = ", "), andMore, line2)
#         } else {
#           string <- sprintf("%s on %s: %s.\n",
#                             nms[j], line1, paste(toShow, collapse = ", "))
#         }
#
#         if (nms[j] %in% .listOfFatalStylesErrors) {
#           shouldBeFixed <- TRUE
#           cat(errorCol(string))
#         } else {
#           cat(warningCol(string))
#         }
#       }
#     } else {
#       cat(goodCol("Perfect!"))
#     }
#     cat("\n")
#     errorList[[i]] <- errors
#   }
#   return(invisible(list(errorList = errorList, shouldBeFixed = shouldBeFixed)))
# }
#
# .listOfFatalStylesErrors <- c(
#   "Commas should always have a space after",
#   "Commas should never have a space before",
#   "Do not place spaces around code in parentheses or square brackets",
#   "Place a space before left parenthesis, except in a function call",
#   "Put spaces around all infix operators", "Unneded concatenation of a constant. Remove the \"c\" call",
#   "Unneded concatenation without arguments. Replace the \"c\" call by NULL or vector()",
#   "Use <-, not =, for assignment", "Use spaces to indent, not tabs",
#   "Use FALSE instead of the symbol F"
# )