First commit

.Rbuildignore

@@ -0,0 +1,2 @@
+^.*\.Rproj$
+^\.Rproj\.user$

DESCRIPTION

@@ -0,0 +1,21 @@
+Package: shiny.performance
+Title: Compare performance of several versions of a shiny app
+Version: 0.1.0
+Authors@R:
+  c(
+    person(given = "Douglas", family = "Azevedo", email = "douglas@appsilon.com", role = "aut"),
+    person(given = "Pedro", family = "Silva", email = "pedro@appsilon.com", role = "aut"),
+    person("Developers", "Appsilon", email = "support+opensource@appsilon.com", role = "cre"),
+    person(family = "Appsilon Sp. z o.o.", role = "cph")
+  )
+Description: Compare performance of several versions of a shiny app based on commit hashs
+License: LGPL-3 + file LICENSE
+URL: https://github.com/Appsilon/shiny.performance
+SystemRequirements: yarn 1.22.17 or higher, cypress 9.4.1 or higher, xvfb
+Encoding: UTF-8
+LazyData: true
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.1.2
+VignetteBuilder: knitr
+Depends:
+  R (>= 3.1.0)

NAMESPACE

@@ -0,0 +1,8 @@
+# Generated by roxygen2: do not edit by hand
+
+export(performance_tests)
+export(run_performance_test)
+importFrom(git2r,checkout)
+importFrom(glue,glue)
+importFrom(jsonlite,write_json)
+importFrom(stringr,str_trim)

R/performance_tests.R

@@ -0,0 +1,91 @@
+#' @title Execute performance tests for a list of commits
+#'
+#' @param commit_list A list of commit hash codes, branches' names or anything else you can use with git checkout [...]
+#' @param cypress_file The path to the .js file containing cypress tests to be recorded
+#' @param app_dir The path to the application root
+#' @param port Port to run the app
+#' @param debug Logical. TRUE to display all the system messages on runtime
+#'
+#' @importFrom git2r checkout
+#'
+#' @export
+performance_tests <- function(commit_list, cypress_file, app_dir = getwd(), port = 3333, debug = FALSE) {
+  # getting the current branch
+  current_branch <- get_commit_hash()
+
+  # creating the structure
+  project_path <- create_tests_structure(app_dir = app_dir, port = port, debug = debug)
+
+  # copy the cypress test file from the current location and store it
+  cypress_file_cp <- file.path(project_path, "cypress_tests.js")
+  file.copy(from = cypress_file, to = cypress_file_cp)
+
+  # apply the tests for each branch/commit
+  perf_list <- tryCatch(
+    expr = {
+      lapply(
+        X = commit_list,
+        FUN = run_performance_test,
+        project_path = project_path,
+        cypress_file = cypress_file_cp,
+        debug = debug
+      )
+    },
+    error = function(e) {
+      message(e)
+    },
+    finally = {
+      checkout(branch = current_branch)
+      message(glue("Switched back to {current_branch}"))
+
+      # Cleaning the temporary directory
+      unlink(
+        x = c(
+          file.path(project_path, "node"),
+          file.path(project_path, "tests")
+        ),
+        recursive = TRUE
+      )
+    }
+  )
+
+  return(perf_list)
+}
+
+#' @title Run the performance test based on a single commit
+#'
+#' @param commit A commit hash code or a branch's name
+#' @param project_path The path to the project with all needed packages installed
+#' @param cypress_file The path to the .js file conteining cypress tests to be recorded
+#' @param txt_file The path to the file where it is aimed to save the times
+#' @param debug Logical. TRUE to display all the system messages on runtime
+#'
+#' @export
+run_performance_test <- function(commit, project_path, cypress_file, txt_file, debug) {
+  files <- create_cypress_tests(project_path = project_path, cypress_file = cypress_file)
+  js_file <- files$js_file
+  txt_file <- files$txt_file
+
+  # checkout to the desired commit
+  checkout(branch = commit)
+  date <- get_commit_date(branch = commit)
+  message(glue("Switched to {commit}"))
+
+  # run tests there
+  command <- glue("cd {project_path}; set -eu; exec yarn --cwd node performance-test")
+  system(command, ignore.stdout = !debug, ignore.stderr = !debug)
+
+  # read the file saved by cypress
+  perf_file <- read.table(file = txt_file, header = FALSE, sep = ";")
+  perf_file <- cbind.data.frame(date = date, perf_file)
+  colnames(perf_file) <- c("date", "test_name", "duration_ms")
+
+  # removing temp files
+  unlink(x = c(js_file, txt_file))
+
+  # removing anything new in the github repo
+  checkout_files()
+
+  # return times
+  return(perf_file)
+}

R/utils.R

@@ -0,0 +1,211 @@
+#' @title Create a temporary directory to store everything needed by Cypress
+#'
+#' @param app_dir The path to the application root
+#' @param port Port to run the app
+#' @param debug Logical. TRUE to display all the system messages on runtime
+#'
+#' @importFrom jsonlite write_json
+create_tests_structure <- function(app_dir, port, debug) {
+  # temp dir to run the tests
+  dir_cypress <- tempdir()
+
+  # node path
+  node_path <- file.path(dir_cypress, "node")
+  root_path <- file.path(node_path, "root")
+
+  # test path
+  tests_path <- file.path(dir_cypress, "tests")
+  cypress_path <- file.path(tests_path, "cypress")
+  integration_path <- file.path(cypress_path, "integration")
+  plugins_path <- file.path(cypress_path, "plugins")
+
+  # creating paths
+  dir.create(path = node_path, showWarnings = FALSE)
+  dir.create(path = tests_path, showWarnings = FALSE)
+  dir.create(path = cypress_path, showWarnings = FALSE)
+  dir.create(path = integration_path, showWarnings = FALSE)
+  dir.create(path = plugins_path, showWarnings = FALSE)
+
+  # create a path root linked to the main directory app
+  symlink_cmd <- glue("cd {dir_cypress}; ln -s {app_dir} {root_path}")
+  system(symlink_cmd)
+
+  # create the packages.json file
+  json_txt <- create_node_list(tests_path = tests_path, port = port)
+  json_file <- file.path(node_path, "package.json")
+  write_json(x = json_txt, path = json_file, pretty = TRUE, auto_unbox = TRUE)
+
+  # install everything that is needed
+  install_deps <- glue("yarn --cwd {node_path}")
+  system(install_deps, ignore.stdout = !debug, ignore.stderr = !debug)
+
+  # creating cypress plugin file
+  js_txt <- create_cypress_plugins()
+  js_file <- file.path(plugins_path, "index.js")
+  writeLines(text = js_txt, con = js_file)
+
+  # creating cypress.json
+  json_txt <- create_cypress_list(plugins_file = js_file, port = port)
+  json_file <- file.path(tests_path, "cypress.json")
+  write_json(x = json_txt, path = json_file, pretty = TRUE, auto_unbox = TRUE)
+
+  # returning the project folder
+  message(glue("Structure created at {dir_cypress}"))
+
+  return(dir_cypress)
+}
+
+#' @title Create the list of needed libraries
+#'
+#' @param tests_path The path to project
+create_node_list <- function(tests_path, port) {
+  json_list <- list(
+    private = TRUE,
+    scripts = list(
+      "performance-test" = glue("start-server-and-test run-app http://localhost:{port} run-cypress"),
+      "run-app" = glue("cd root && Rscript -e 'shiny::runApp(port = {port})'"),
+      "run-cypress" = glue("cypress run --project {tests_path}")
+    ),
+    "devDependencies" = list(
+      "cypress" = "^7.6.0",
+      "start-server-and-test" = "^1.12.6"
+    )
+  )
+
+  return(json_list)
+}
+
+#' @title Create the cypress configuration list
+#'
+#' @param plugins_file The path to the Cypress plugins
+create_cypress_list <- function(plugins_file, port) {
+  json_list <- list(
+    baseUrl = glue("http://localhost:{port}"),
+    pluginsFile = plugins_file,
+    supportFile = FALSE
+  )
+
+  return(json_list)
+}
+
+#' @title Create the JS code to track execution time
+create_cypress_plugins <- function() {
+  js_txt <- "
+  const fs = require('fs')
+  module.exports = (on, config) => {
+    on('task', {
+      performanceTimes (attributes) {
+        fs.writeFile(attributes.fileOut, `${ attributes.title }; ${ attributes.duration }\n`, { flag: 'a' })
+        return null
+      }
+    })
+  }"
+
+  return(js_txt)
+}
+
+#' @title Create the cypress files under project directory
+#'
+#' @param project_path The path to the project with all needed packages installed
+#' @param cypress_file The path to the .js file conteining cypress tests to be recorded
+create_cypress_tests <- function(project_path, cypress_file) {
+  # creating a copy to be able to edit the js file
+  js_file <- file.path(project_path, "tests", "cypress", "integration", "app.spec.js")
+  file.copy(from = cypress_file, to = js_file, overwrite = TRUE)
+
+  # file to store the times
+  txt_file <- file.path(project_path, "tests", "cypress", "performance.txt")
+  add_sendtime2js(js_file = js_file, txt_file = txt_file)
+
+  # returning the file location
+  return(list(js_file = js_file, txt_file = txt_file))
+}
+
+#' @title Add the sendTime function to the .js file
+#'
+#' @param js_file Path to the .js file to add code
+#' @param txt_file Path to the file to record the execution times
+add_sendtime2js <- function(js_file, txt_file) {
+  lines_to_add <- glue(
+    "
+  // Returning the time for each test
+  // https://www.cypress.io/blog/2020/05/22/where-does-the-test-spend-its-time/
+  let commands = []
+  let performanceAttrs
+  Cypress.on('test:before:run', () => {
+    commands.length = 0
+  })
+  Cypress.on('test:after:run', (attributes) => {
+    performanceAttrs = {
+      title: attributes.title,
+      duration: attributes.duration,
+      commands: Cypress._.cloneDeep(commands),
+    }
+  })
+  const sendTestTimings = () => {
+    if (!performanceAttrs) {
+      return
+    }
+    const attr = performanceAttrs
+    attr.fileOut = '{{txt_file}}'
+    performanceAttrs = null
+    cy.task('performanceTimes', attr)
+  }
+  // Calling the sendTestTimings function
+  beforeEach(sendTestTimings)
+  after(sendTestTimings)
+  ",
+    .open = "{{", .close = "}}"
+  )
+
+  write(x = lines_to_add, file = js_file, append = TRUE)
+}
+
+#' @title Get the commit date in POSIXct format
+#'
+#' @param branch Commit hash code or branch name
+#' @importFrom glue glue
+get_commit_date <- function(branch) {
+  date <- system(
+    glue("git show -s --format=%ci {branch}"),
+    intern = TRUE
+  )
+  date <- as.POSIXct(date[1])
+
+  return(date)
+}
+
+#' @title Find the hash code of the current commit
+#' @importFrom glue glue
+#' @importFrom stringr str_trim
+get_commit_hash <- function() {
+  hash <- system("git show -s --format=%H", intern = TRUE)[1]
+  branch <- system(
+    glue("git branch --contains {hash}"),
+    intern = TRUE
+  )
+
+  branch <- str_trim(
+    string = gsub(x = branch[length(branch)], pattern = "\\*\\s", replacement = ""),
+    side = "both"
+  )
+
+  hash_head <- system(
+    glue("git rev-parse {branch}"),
+    intern = TRUE
+  )
+
+  is_head <- hash == hash_head
+
+  if (is_head) hash <- branch
+
+  return(hash)
+}
+
+#' @title Checkout GitHub files
+#'
+#' @description checkout anything created by the app. It prevents errors when
+#' changing branches
+checkout_files <- function() {
+  system("git checkout .")
+}