R/deploy_all.R

In rstudio/testShinyExamples: Test Shiny Examples

#' Default Library path
#'
#' @export
default_libpath <- function() {
  file.path(tempdir(), paste0("test-shiny-examples-lib-", paste0(sample(letters, 8), collapse = "")))
  "_shiny-examples-lib"
}

# clear_deploy_libpath <- function(libpath = default_libpath()) {
#   unlink(libpath, recursive = TRUE)
# }


#' Deploy apps to a server
#'
#' Run this in the terminal (not RStudio IDE) as it has issues when installing some packages.
#'
#' @param account,server args supplied to `[rsconnect::deployApp]`
#' @param apps A vector of three digit character values or `TRUE` to deploy all apps
#' @param libpath library location. (Creates the path if it does not exist.)
#' @param cores number of cores to use when deploying
#' @param testing_repo Location of the testShinyExamples R pkg
#' @param examples_repo Location of the shiny examples repo
#' @importFrom utils install.packages packageVersion
#' @export
deploy_apps <- function(
  account = "testing-apps",
  server = "shinyapps.io",
  apps = TRUE,
  libpath = default_libpath(),
  cores = 1,
  testing_repo = "rstudio/testShinyExamples",
  examples_repo = "rstudio/shiny-examples"
) {

  message_with_arr("Using libpath", libpath)

  is_missing <- list(
    account = missing(account),
    server = missing(server),
    apps = missing(apps),
    libpath = missing(libpath),
    cores = missing(cores)
  )

  accts <- rsconnect::accounts()
  accts_found <- sum(
    (account %in% accts$name) &
    (server %in% accts$server)
  )
  if (accts_found == 0) {
    stop("please set an account with `rsconnect::setAccountInfo()` to match directly to `rsconnect::accounts()` information")
  } else if (accts_found > 1) {
    stop("more than one account matches `rsconnect::accounts()`. Fix it?")
  }

  cores <- as.numeric(cores)
  if (is.na(cores)) {
    stop("number of cores should be a numeric value")
  }

  if (!dir.exists(libpath)) {
    dir.create(libpath, recursive = TRUE)
  }
  libpath <- normalizePath(libpath)

  apps_folder <- shiny_examples_dir(examples_repo)
  apps_dirs <- apps_folder %>%
    list.dirs(recursive = FALSE) %>%
    basename() %>%
    pipe_grep("^\\d\\d\\d", value = TRUE)
  apps_dirs <- file.path(apps_folder, apps_dirs)

  if (isTRUE(apps)) {
    # accept all apps
  } else {
    # filter apps
    app_num <- grep("^\\d\\d\\d", basename(apps_dirs), value = TRUE) %>%
      pipe_sub("-.*", "")
    apps_dirs <- apps_dirs[app_num %in% apps]
  }


  withr::with_libpaths(new = libpath, {

    message_with_arr("Library Paths", .libPaths())

    install_testing_deps(examples_repo)

    pb <- progress::progress_bar$new(
      total = ceiling(length(apps_dirs) / cores),
      format = "Testing :name [:bar] :current/:total eta::eta\n",
      show_after = 0
    )
    deploy_apps_ <- function(app_dir) {
      pb$tick(tokens = list(name = basename(app_dir)))
      deployment_worked <- try({
        rsconnect::deployApp(
          appDir = app_dir,
          appName = basename(app_dir),
          account = account,
          server = server,
          # logLevel = 'verbose',
          launch.browser = FALSE,
          forceUpdate = TRUE
        )
      })
      if (inherits(deployment_worked, 'try-error')) {
        return(1)
      } else {
        return(as.numeric(!deployment_worked))
      }
    }

    deploy_res <-
      if (cores > 1) {
        parallel::mclapply(apps_dirs, deploy_apps_, mc.cores = cores)
      } else {
        lapply(apps_dirs, deploy_apps_)
      }
    deploy_res <- unlist(deploy_res)
    pb$terminate() # make sure it goes away

    deploy_warnings <- warnings()
    if (length(deploy_warnings) != 0) {
      cat("\n")
      print(deploy_warnings)
    }

    if (any(deploy_res != 0)) {
      dput_arg <- function(x) {
        f <- file()
        on.exit({
          close(f)
        })
        dput(x, f)
        ret <- paste0(readLines(f), collapse = "\n")
        ret
      }
      error_apps <-
        grep("^\\d\\d\\d", basename(apps_dirs[deploy_res != 0]), value = TRUE) %>%
        pipe_sub("-.*", "")
      args <- c(
        if (!is_missing$account) paste0("account = ", dput_arg(account)),
        if (!is_missing$server) paste0("server = ", dput_arg(server)),
        paste0("apps = ", dput_arg(error_apps)),
        if (!is_missing$libpath) paste0("libpath = ", dput_arg(libpath)),
        if (!is_missing$cores) paste0("cores = ", dput_arg(cores))
      )
      fn <- paste0(
        "deploy_apps(", paste0(args, collapse = ", "),")"
      )
      message(
        "\nError deploying apps:\n",
        fn,
        "\n"
      )
    } else {
      message("No errors found when deploying apps")
    }

  })


}



install_testing_deps <- function(
  examples_repo = "rstudio/shiny-examples"
) {
  is_installed <- function (pkg) {
    system.file(package = pkg) != ""
  }

  libpath <- .libPaths()[1]

   # Install a package or packages if not already installed.
  install_if_needed <- function(pkgs) {
    installed_idx <- vapply(pkgs, is_installed, TRUE)
    needed <- pkgs[!installed_idx]
    if (length(needed) > 0) {
      message_with_arr("Installing packages from CRAN", needed)
      remotes::install_cran(needed, lib = libpath)
    }
  }
  install_github <- function(repo, ...) {
    # message("Installing github: ", repo)
    remotes::install_github(repo, ..., upgrade = TRUE, lib = libpath)
  }

  # install pkgs used in this function
  install_if_needed(c("remotes", "progress"))

  # install all remotes and extra pkgs
  message_with_arr("Installing remotes for testing", unlist(testing_remotes))
  lapply(testing_remotes, install_github)

  # install app pkgs
  install_if_needed(testing_pkgs) # known pkgs
  app_deps <- app_dependencies(examples_repo)
  install_if_needed(app_deps) # packrat pkgs
  # make sure everything is the latest, as some packages may have already been installed
  remotes::update_packages(app_deps, upgrade = TRUE, lib = libpath)

  # make sure remotes and pkgs are the last remaining ones
  message_with_arr("Re-installing remotes for testing", unlist(testing_remotes))
  lapply(testing_remotes, install_github)

  invisible(TRUE)
}




pipe_grep <- function(x, ...) {
  grep(x = x, ...)
}
pipe_sub <- function(x, ...) {
  sub(x = x, ...)
}

message_with_arr <- function(msg, arr) {
  message("\n", msg, ": \n\t", paste0(arr, collapse = "\n\t"))
}