R/R6-Repository.R

In PaRe: A Way to Perform Code Review or QA on Other Packages

# Copyright 2024 DARWIN EU®
#
# This file is part of PaRe
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' @title
#' R6 Repository class.
#'
#' @description
#' Class representing the Repository
#'
#' @export
#'
#' @family
#' Representations
#'
#' @examples
#' fetchedRepo <- tryCatch(
#'   {
#'     # Set dir to clone repository to.
#'     tempDir <- tempdir()
#'     pathToRepo <- file.path(tempDir, "glue")
#'
#'     # Clone repo
#'     git2r::clone(
#'       url = "https://github.com/tidyverse/glue.git",
#'       local_path = pathToRepo
#'     )
#'
#'     # Create instance of Repository object.
#'     repo <- PaRe::Repository$new(path = pathToRepo)
#'
#'     # Set fetchedRepo to TRUE if all goes well.
#'     TRUE
#'   },
#'   error = function(e) {
#'     # Set fetchedRepo to FALSE if an error is encountered.
#'     FALSE
#'   },
#'   warning = function(w) {
#'     # Set fetchedRepo to FALSE if a warning is encountered.
#'     FALSE
#'   }
#' )
#'
#' if (fetchedRepo) {
#'   repo
#' }
Repository <- R6::R6Class(
  classname = "Repository",
  # Public ----
  public = list(
    #' @description
    #' Initializer for Repository class
    #'
    #' @param path (\link[base]{character})\cr
    #' Path to R package project
    #'
    #' @return `invisible(self)`
    initialize = function(path) {
      private$path <- normalizePath(path)
      private$name <- basename(private$path)
      private$git <- git2r::in_repository(private$path)
      private$description <- desc::description$new(private$path)
      private$functionUse <- NULL
      private$gitIgnore <- private$setupGitIgnore()
      private$validate()

      private$fetchRFiles()
      private$fetchCppFiles()
      private$fetchJavaFiles()
      private$fetchSqlFiles()
      return(invisible(self))
    },

    #' @description
    #' Get method for name.
    #'
    #' @return (\link[base]{character})\cr
    #' Repository name
    getName = function() {
      return(private$name)
    },

    #' @description
    #' Get method fro path
    #'
    #' @return (\link[base]{character})\cr
    #' Path to Repository folder
    getPath = function() {
      return(private$path)
    },

    #' @description
    #' Get method to get a list of \link[PaRe]{File} objects.
    #'
    #' @return (\link[base]{list})\cr
    #' List of \link[PaRe]{File} objects.
    getFiles = function() {
      files <- list(
        R = private$rFiles,
        cpp = private$cppFiles,
        o = private$oFiles,
        h = private$hFiles,
        java = private$javaFiles,
        sql = private$sqlFiles
      )
      return(files)
    },

    #' @description
    #' Get method to get only R-files.
    #'
    #' @return (\link[base]{list})\cr
    #' List of \link[PaRe]{File} objects.
    getRFiles = function() {
      return(private$rFiles)
    },

    #' @description
    #' Get method to get the description of the package. See: \link[desc]{description}.
    #'
    #' @return (\link[desc]{description})\cr
    #' Description object.
    getDescription = function() {
      return(private$description)
    },

    #' @description
    #' Get method for functionUse, will check if functionUse has already been
    #' fetched or not.
    #'
    #' @return (\link[base]{data.frame})\cr
    #' See \link[PaRe]{getFunctionUse}.
    getFunctionUse = function() {
      if (is.null(private$functionUse)) {
        private$functionUse <- getFunctionUse(self, verbose = TRUE)
      }
      return(private$functionUse)
    },

    #' @description
    #' Method to run 'git checkout <branch/commit hash>'
    #'
    #' @param branch (\link[base]{character})\cr
    #' Name of branch or a hash referencing a specific commit.
    #' @param ...
    #' Further parameters for \link[git2r]{checkout}.
    #'
    #' @return `invisible(self)`
    gitCheckout = function(branch, ...) {
      tryCatch(
        {
          git2r::checkout(object = private$path, branch = branch, ...)
          message(glue::glue("Switched to: {branch}"))
          message("Re-initializing")
          self$initialize(path = private$path)
        },
        error = function(e) {
          message(glue::glue("Availible branches: {paste(names(git2r::branches(private$path)), collapse = ', ')}"))
          stop(glue::glue("Branches: '{branch}' not found"))
        }
      )
      return(invisible(self))
    },

    #' @description
    #' Method to run 'git pull'
    #'
    #' @param ...
    #' Further parameters for \link[git2r]{pull}.
    #'
    #' @return `invisible(self)`
    gitPull = function(...) {
      message("Pulling latest")
      git2r::pull(repo = private$path, ...)
      message("Re-initializing")
      self$initialize(path = private$path)
      return(invisible(self))
    },

    #' @description
    #' Method to fetch data generated by 'git blame'.
    #'
    #' @return (\link[dplyr]{tibble})
    #' |     column |              data type |
    #' | ---------- | ---------------------- |
    #' | repository | \link[base]{character} |
    #' |     author | \link[base]{character} |
    #' |       file | \link[base]{character} |
    #' |       date | \link[base]{character} |
    #' |      lines |   \link[base]{integer} |
    gitBlame = function() {
      files <- unlist(self$getFiles())

      dplyr::bind_rows(lapply(files, function(file) {
        file$getBlameTable()
      }))
    }
  ),
  # Private ----
  private = list(
    name = "name",
    path = "",
    rFiles = NULL,
    cppFiles = NULL,
    oFiles = NULL,
    hFiles = NULL,
    sqlFiles = NULL,
    javaFiles = NULL,
    git = NULL,
    description = NULL,
    functionUse = NULL,
    gitIgnore = c(),
    validate = function() {
      errorMessages <- checkmate::makeAssertCollection()
      # .rproj file
      rproj <- list.files(file.path(private$path), pattern = "*.Rproj", full.names = TRUE)
      if (length(rproj) == 0) {
        rproj <- ".Rproj"
      }
      checkmate::assertFileExists(rproj, add = errorMessages)
      checkmate::reportAssertions(collection = errorMessages)

      status <- git2r::status(repo = private$path)
      if (length(status$staged) > 0) {
        warning(glue::glue("Staged chagned not committed, unexpected behaviour expected."))
      }
      return(invisible(self))
    },
    setupGitIgnore = function() {
      ignorePath <- file.path(private$path, ".gitignore")
      if (file.exists(ignorePath)) {
        gitIgnore <- readLines(ignorePath, warn = FALSE)
        gitIgnore <- gitIgnore[!startsWith(x = gitIgnore, prefix = "#")]
        gitIgnore <- gitIgnore[!gitIgnore == ""]
        gitIgnore <- stringr::str_replace_all(string = gitIgnore, pattern = "\\*", replacement = ".")
        private$gitIgnore <- gitIgnore
      }
    },
    filterIgnored = function(paths) {
      for (pat in private$gitIgnore) {
        paths <- paths[!grepl(pattern = pat, x = paths)]
      }
      return(paths)
    },
    fetchRFiles = function() {
      paths <- list.files(file.path(private$path, "R"), recursive = TRUE, pattern = "\\.[Rr]$") %>%
        private$filterIgnored()

      private$rFiles <- unlist(lapply(paths, function(path) {
        File$new(repoPath = private$path, filePath = file.path("R", path))
      }))
      return(invisible(self))
    },
    fetchCppFiles = function() {
      paths <- list.files(
        path = private$path,
        pattern = "\\.(cpp|O|h)$",
        recursive = TRUE
      ) %>%
        private$filterIgnored()

      cpp <- paths[endsWith(paths, ".cpp")]
      o <- paths[endsWith(paths, ".o")]
      h <- paths[endsWith(paths, ".h")]

      private$cppFiles <- lapply(cpp, function(path) {
        File$new(repoPath = private$path, filePath = path)
      })

      private$oFiles <- lapply(o, function(path) {
        File$new(repoPath = private$path, filePath = path)
      })

      private$hFiles <- lapply(h, function(path) {
        File$new(repoPath = private$path, filePath = path)
      })
    },
    fetchJavaFiles = function() {
      paths <- list.files(path = private$path, pattern = "\\.java$", recursive = TRUE)
      paths <- paths[endsWith(paths, ".java")] %>%
        private$filterIgnored()

      private$javaFiles <- lapply(paths, function(path) {
        File$new(repoPath = private$path, filePath = path)
      })
    },
    fetchSqlFiles = function() {
      paths <- list.files(
        path = private$path,
        pattern = "\\.sql$",
        recursive = TRUE
      ) %>%
        private$filterIgnored()

      private$sqlFiles <- lapply(paths, function(path) {
        File$new(repoPath = private$path, filePath = path)
      })
    }
  )
)