tests/testthat/helper_lint.R

In mlrCPO: Composable Preprocessing Operators and Pipelines for Machine Learning

# check if lintr version is sufficient
# if `error.if.not` is TRUE an error is thrown with a meaningful message.
isLintrVersionOk = function(error.if.not = FALSE) {
  lintr.ver = try(packageVersion("lintr"), silent = TRUE)
  lintr.required = "1.0.2.9000"
  if (inherits(lintr.ver, "try-error")) {
    msg = sprintf("lintr is not installed: %s", BBmisc::printToChar(lintr.ver))
  } else {
    if (package_version(lintr.ver) >= package_version(lintr.required)) {
      return(TRUE)
    }
    msg = sprintf("lintr is version %s, but version %s is required.", lintr.ver, lintr.required)
  }
  if (error.if.not) {
    stopf(paste("%s\nInstalling the github version of lintr will probably solve this issue. For that, please run",
        "> devtools::install_github(\"jimhester/lintr\")", sep = "\n"), msg)
  }
  return(FALSE)
}

if (isLintrVersionOk() && require("lintr", quietly = TRUE) && require("rex", quietly = TRUE)) {


  # The following functions are adaptions of the corresponding functions in the `lintr` packages
  # The lintr package, and the original versions of these functions, can be found at https://github.com/jimhester/lintr
  # Copyright notice of original functions:
  # Copyright (c) 2014-2016, James Hester
  #
  # Permission is hereby granted, free of charge, to any person obtaining
  # a copy of this 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, subject to
  # the following conditions:
  #
  # The above copyright notice and this permission notice shall be
  # included in all copies or substantial portions of the Software.
  #
  # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  # LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  # OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  # WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  #
  # End copyright notice.
  # All modifications are licensed as the rest of mlr.

  # linters that differ from the default linters
  # this is necessary because mlr's style is weird.

  # prohibit <-
  left.assign.linter = function(source_file) {
    lapply(lintr:::ids_with_token(source_file, "LEFT_ASSIGN"), function(id) {
        parsed = lintr:::with_id(source_file, id)
        Lint(filename = source_file$filename, line_number = parsed$line1,
          column_number = parsed$col1, type = "style", message = "Use =, not <-, for assignment.",
          line = source_file$lines[as.character(parsed$line1)],
          linter = "assignment_linter")
    })
  }

  # prohibit ->
  right.assign.linter = function(source_file) {
    lapply(lintr:::ids_with_token(source_file, "RIGHT_ASSIGN"), function(id) {
        parsed = lintr:::with_id(source_file, id)
        Lint(filename = source_file$filename, line_number = parsed$line1,
          column_number = parsed$col1, type = "style", message = "Use =, not ->, for assignment.",
          line = source_file$lines[as.character(parsed$line1)],
          linter = "assignment_linter")
    })
  }

  `%!=%` = lintr:::`%!=%`
  `%==%` = lintr:::`%==%`

  spaces.left.parentheses.linter = function(source_file) {
        lapply(lintr:::ids_with_token(source_file, "'('"), function(id) {
          parsed = source_file$parsed_content[id, ]
          terminal.before = source_file$parsed_content[source_file$parsed_content$line1 ==
              parsed$line1 & source_file$parsed_content$col1 <
              parsed$col1 & source_file$parsed_content$terminal, ]
          last.before = tail(terminal.before, n = 1)
          last.type = last.before$token
          is.function = length(last.type) %!=% 0L && (last.type %in%
              c("SYMBOL_FUNCTION_CALL", "FUNCTION", "'}'", "')'",
                  "']'"))
          is.unary.minus = last.type == "'-'" && sum(source_file$parsed_content$parent == last.before$parent) == 2
          if (!is.function && !is.unary.minus) {
              line = source_file$lines[as.character(parsed$line1)]
              before.operator = substr(line, parsed$col1 - 1L,
                  parsed$col1 - 1L)
              non.space.before = re_matches(before.operator, rex(non_space))
              not.exception = !(before.operator %in% c("!", ":",
                  "[", "("))
              if (non.space.before && not.exception) {
                  Lint(filename = source_file$filename, line_number = parsed$line1,
                    column_number = parsed$col1, type = "style",
                    message = "Place a space before left parenthesis, except in a function call.",
                    line = line, linter = "spaces.left.parentheses.linter")
              }
          }
      })
  }

  function.left.parentheses.linter = function(source_file) {
    lapply(lintr:::ids_with_token(source_file, "'('"),
      function(id) {

        parsed = source_file$parsed_content[id, ]
        ttb = which(source_file$parsed_content$line1 == parsed$line1 &
                    source_file$parsed_content$col1 < parsed$col1 &
                    source_file$parsed_content$terminal)
        ttb = tail(ttb, n = 1)
        last.type = source_file$parsed_content$token[ttb]

        is.function = length(last.type) %!=% 0L &&
          (last.type %in% c("SYMBOL_FUNCTION_CALL", "FUNCTION", "'}'", "')'", "']'"))
        # check whether this is a lambda expression; we want to allow e.g. function(x) (x - 1)^2
        if (is.function && last.type == "')'") {
          # parenvec: 1 for every '(', -1 for every ')', 0 otherwise
          parenvec = c(1, -1, 0)[match(source_file$parsed_content$token, c("'('", "')'"), 3)]
          parenlevel = cumsum(parenvec)
          parenlevelcut = parenlevel[seq_len(ttb - 1)]
          opening.paren.pos = max(which(parenlevelcut == parenlevel[ttb])) + 1
          opparsed = source_file$parsed_content[opening.paren.pos, ]

          opttb = which(source_file$parsed_content$line1 == opparsed$line1 &
                        source_file$parsed_content$col1 < opparsed$col1 &
                        source_file$parsed_content$terminal)
          opttb = tail(opttb, n = 1)
          before.op.type = source_file$parsed_content$token[opttb]
          if (length(before.op.type) %!=% 0L && before.op.type == "FUNCTION") {
            is.function = FALSE
          }
        }
        if (is.function) {

          line = source_file$lines[as.character(parsed$line1)]

          before.operator = substr(line, parsed$col1 - 1L, parsed$col1 - 1L)

          space.before = re_matches(before.operator, rex(space))

          if (space.before) {
            Lint(
              filename = source_file$filename,
              line_number = parsed$line1,
              column_number = parsed$col1,
              type = "style",
              message = "Remove spaces before the left parenthesis in a function call.",
              line = line,
              linter = "function_left_parentheses"
              )
          }
        }

      })
  }

  infix.spaces.linter = function(source_file) {
      lapply(lintr:::ids_with_token(source_file, lintr:::infix_tokens, fun = `%in%`),
          function(id) {
              parsed = lintr:::with_id(source_file, id)
              line = source_file$lines[as.character(parsed$line1)]
              if (substr(line, parsed$col1, parsed$col2) == "^") {
                return(NULL)
              }
              around.operator = substr(line, parsed$col1 - 1L,
                  parsed$col2 + 1L)
              non.space.before = re_matches(around.operator, rex(start,
                  non_space))
              newline.after = unname(nchar(line)) %==% parsed$col2
              non.space.after = re_matches(around.operator, rex(non_space,
                  end))
              if (non.space.before || (!newline.after && non.space.after)) {
                  is.infix = length(lintr:::siblings(source_file$parsed_content,
                    parsed$id, 1)) > 1L
                  start = end = parsed$col1
                  if (is.infix) {
                    if (non.space.before) {
                      start = parsed$col1 - 1L
                    }
                    if (non.space.after) {
                      end = parsed$col2 + 1L
                    }
                    Lint(filename = source_file$filename, line_number = parsed$line1,
                      column_number = parsed$col1, type = "style",
                      message = "Put spaces around all infix operators (except exponentiation).",
                      line = line, ranges = list(c(start, end)),
                      linter = "infix.spaces.linter")
                  }
              }
          })
  }


  loweralnum = rex::rex(one_of(lower, digit))
  upperalnum = rex::rex(one_of(upper, digit))

  style.regexes = list(
    "UpperCamelCase" = rex::rex(start, upper, zero_or_more(alnum), end),
    "lowerCamelCase" = rex::rex(start, lower, zero_or_more(alnum), end),
    "snake_case"     = rex::rex(start, one_or_more(loweralnum), zero_or_more("_", one_or_more(loweralnum)), end),
    "dotted.case"    = rex::rex(start, one_or_more(loweralnum), zero_or_more(dot, one_or_more(loweralnum)), end),
    "alllowercase"   = rex::rex(start, one_or_more(loweralnum), end),
    "ALLUPPERCASE"   = rex::rex(start, one_or_more(upperalnum), end),
    "functionCamel.case" = rex::rex(start, lower, zero_or_more(alnum), zero_or_more(dot, one_or_more(alnum)), end)
  )

  # incorporate our own camelCase.withDots style.
  matchesStyles = function(name, styles=names(style.regexes)) {
    invalids = paste(styles[!styles %in% names(style.regexes)], collapse = ", ")
    if (nzchar(invalids)) {
      valids = paste(names(style.regexes), collapse = ", ")
      stop(sprintf("Invalid style(s) requested: %s\nValid styles are: %s\n", invalids, valids))
    }
    name = re_substitutes(name, rex(start, one_or_more(dot)), "")  # remove leading dots
    vapply(
      style.regexes[styles],
      re_matches,
      logical(1L),
      data = name
    )
  }

  object.naming.linter = lintr:::make_object_linter(function(source_file, token) {
    sp = source_file$parsed_content
    if (tail(c("", sp$token[sp$terminal & sp$id < token$id]), n = 1) == "'$'") {
      # ignore list member names
      return(NULL)
    }
    sp = head(sp[sp$terminal & sp$id > token$id, ], n = 2)
    if (!sp$token[1] %in% c("LEFT_ASSIGN", "EQ_ASSIGN")) {
      # ignore if not an assignment.
      # we check for LEFT_ASSIGN and EQ_ASSIGN since here we are LEFT_ASSIGN tolerant
      return(NULL)
    }
    style = ifelse(sp$token[2] == "FUNCTION", "functionCamel.case", "dotted.case")
    name = lintr:::unquote(token[["text"]])
    if (nchar(name) <= 1) {
      # allow single uppercase letter
      return(NULL)
    }
    if (!matchesStyles(name, style)) {
      lintr:::object_lint(source_file, token, sprintf("Variable or function name should be %s.",
        style), "object_name_linter")
    }
  })


  # note that this must be a *named* list (bug in lintr)
  linters = tryCatch(list(
    commas = lintr::commas_linter,
  #  open.curly = open_curly_linter(),
  #  closed.curly = closed_curly_linter(),
    spaces.left.parentheses = spaces.left.parentheses.linter,
    function.left.parentheses = function.left.parentheses.linter,
    single.quotes = lintr::single_quotes_linter,
    left.assign = left.assign.linter,
    right.assign = right.assign.linter,
    no.tab = lintr::no_tab_linter,
    T.and.F.symbol = lintr::T_and_F_symbol_linter,
    semicolon.terminator = lintr::semicolon_terminator_linter,
    seq = lintr::seq_linter,
    unneeded.concatenation = lintr::unneeded_concatenation_linter,
    trailing.whitespace = lintr::trailing_whitespace_linter,
    #todo.comment = lintr::todo_comment_linter(todo = "todo"), # is case-insensitive
    spaces.inside = lintr::spaces_inside_linter,
    infix.spaces = infix.spaces.linter,
    object.naming = object.naming.linter),
    error = function(e) {
      list(error = "linter creation failed even though lintr announced the right version")
    })
} else {
  # everything that uses `linters` should check `isLintrVersionOk` first, so the
  # following should never be used. Make sure that it is an error if it IS used.
  linters = list(error = "lintr package could not be loaded")
}