install.R

In ttraboue/FrissSwitch:

function(...) {
  
  ## This is the code of the package, put in here by brew
  
  
  bioc_version <- function() {
    bver <- get(
      ".BioC_version_associated_with_R_version",
      envir = asNamespace("tools"),
      inherits = FALSE
    )
    
    if (is.function(bver)) bver() else bver
  }
  
  ## This is mostly from https://bioconductor.org/biocLite.R
  
  #' Deduce the URLs of the BioConductor repositories
  #'
  #' @return A named character vector of the URLs of the
  #' BioConductor repositories, appropriate for the current
  #' R version.
  #'
  #' @export
  
  bioc_install_repos <- function() {
    
    vers <- getRversion()
    biocVers <- bioc_version()
    
    a <- NULL
    
    p <- file.path(Sys.getenv("HOME"), ".R", "repositories")
    if (file.exists(p)) {
      a <- ("tools" %:::% ".read_repositories")(p)
      if (!"BioCsoft" %in% rownames(a)) a <- NULL
    }
    
    if (is.null(a)) {
      p <- file.path(R.home("etc"), "repositories")
      a <- ("tools" %:::% ".read_repositories")(p)
    }
    
    ## add a conditional for Bioc releases occuring WITHIN
    ## a single R minor version. This is so that a user with a
    ## version of R (whose etc/repositories file references the
    ## no-longer-latest URL) and without BiocInstaller
    ## will be pointed to the most recent repository suitable
    ## for their version of R
    if (vers >= "3.2.2" && vers < "3.3.0") {
      ## transitioning to https support; check availability
      con <- file(fl <- tempfile(), "w")
      sink(con, type = "message")
      tryCatch(
        { xx <- close(file("https://bioconductor.org")) },
        error = function(e) { message(conditionMessage(e)) }
      )
      sink(type = "message")
      close(con)
      
      if (!length(readLines(fl))) {
        a[, "URL"] <- sub("^http:", "https:", a[, "URL"])
      }
    }
    if (vers >= "3.5") {
      "3.6"
    } else if (vers >= "3.4") {
      a[, "URL"] <- sub(as.character(biocVers), "3.5", a[, "URL"])
      
    } else if (vers >= "3.3.0") {
      a[, "URL"] <- sub(as.character(biocVers), "3.4", a[, "URL"])
      
    } else if (vers >= "3.2") {
      a[, "URL"] <- sub(as.character(biocVers), "3.2", a[, "URL"])
      
    } else if (vers == "3.1.1") {
      ## R-3.1.1's etc/repositories file at the time of the release
      ## of Bioc 3.0 pointed to the 2.14 repository, but we want
      ## new installations to access the 3.0 repository
      a[, "URL"] <- sub(as.character(biocVers), "3.0", a[, "URL"])
      
    } else if (vers == "3.1.0") {
      ## R-devel points to 2.14 repository
      a[, "URL"] <- sub(as.character(biocVers), "2.14", a[, "URL"])
      
    } else if (vers >= "2.15" && vers < "2.16") {
      a[, "URL"] <- sub(as.character(biocVers), "2.11", a[, "URL"])
      biocVers <- numeric_version("2.11")
    }
    
    repos <- intersect(
      rownames(a),
      c("BioCsoft", "BioCann", "BioCexp", "BioCextra")
    )
    
    structure(a[repos, "URL"], names = repos)
  }
  
  ## A environment to hold which packages are being installed so packages
  ## with circular dependencies can be skipped the second time.
  
  installing <- new.env(parent = emptyenv())
  
  is_root_install <- function() is.null(installing$packages)
  
  exit_from_root_install <- function() installing$packages <- NULL
  
  check_for_circular_dependencies <- function(pkgdir, quiet) {
    pkgdir <- normalizePath(pkgdir)
    pkg <- get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package")
    
    if (pkg %in% installing$packages) {
      if (!quiet) message("Skipping ", pkg, ", it is already being installed")
      TRUE
      
    } else {
      installing$packages <- c(installing$packages, pkg)
      FALSE
    }
  }
  
  available_packages <- function(repos, type) {
    suppressWarnings(utils::available.packages(utils::contrib.url(repos, type), type = type))
  }
  read_dcf <- function(path) {
    fields <- colnames(read.dcf(path))
    as.list(read.dcf(path, keep.white = fields)[1, ])
  }
  
  write_dcf <- function(path, desc) {
    write.dcf(
      rbind(unlist(desc)),
      file = path,
      keep.white = names(desc),
      indent = 0
    )
  }
  
  get_desc_field <- function(path, field) {
    dcf <- read_dcf(path)
    dcf[[field]]
  }
  # Decompress pkg, if needed
  source_pkg <- function(path, subdir = NULL, before_install = NULL) {
    if (!file.info(path)$isdir) {
      bundle <- path
      outdir <- tempfile(pattern = "remotes")
      dir.create(outdir)
      
      path <- decompress(path, outdir)
    } else {
      bundle <- NULL
    }
    
    pkg_path <- if (is.null(subdir)) path else file.path(path, subdir)
    
    # Check it's an R package
    if (!file.exists(file.path(pkg_path, "DESCRIPTION"))) {
      stop("Does not appear to be an R package (no DESCRIPTION)", call. = FALSE)
    }
    
    # Check configure is executable if present
    config_path <- file.path(pkg_path, "configure")
    if (file.exists(config_path)) {
      Sys.chmod(config_path, "777")
    }
    
    # Call before_install for bundles (if provided)
    if (!is.null(bundle) && !is.null(before_install))
      before_install(bundle, pkg_path)
    
    pkg_path
  }
  
  
  decompress <- function(src, target) {
    stopifnot(file.exists(src))
    
    if (grepl("\\.zip$", src)) {
      my_unzip(src, target)
      outdir <- getrootdir(as.vector(utils::unzip(src, list = TRUE)$Name))
      
    } else if (grepl("\\.tar$", src)) {
      untar(src, exdir = target)
      outdir <- getrootdir(untar(src, list = TRUE))
      
    } else if (grepl("\\.(tar\\.gz|tgz)$", src)) {
      untar(src, exdir = target, compressed = "gzip")
      outdir <- getrootdir(untar(src, compressed = "gzip", list = TRUE))
      
    } else if (grepl("\\.(tar\\.bz2|tbz)$", src)) {
      untar(src, exdir = target, compressed = "bzip2")
      outdir <- getrootdir(untar(src, compressed = "bzip2", list = TRUE))
      
    } else {
      ext <- gsub("^[^.]*\\.", "", src)
      stop("Don't know how to decompress files with extension ", ext,
           call. = FALSE)
    }
    
    file.path(target, outdir)
  }
  
  
  # Returns everything before the last slash in a filename
  # getdir("path/to/file") returns "path/to"
  # getdir("path/to/dir/") returns "path/to/dir"
  getdir <- function(path)  sub("/[^/]*$", "", path)
  
  # Given a list of files, returns the root (the topmost folder)
  # getrootdir(c("path/to/file", "path/to/other/thing")) returns "path/to"
  getrootdir <- function(file_list) {
    slashes <- nchar(gsub("[^/]", "", file_list))
    if (min(slashes) == 0) return("")
    
    getdir(file_list[which.min(slashes)])
  }
  
  my_unzip <- function(src, target, unzip = getOption("unzip")) {
    if (unzip %in% c("internal", "")) {
      return(utils::unzip(src, exdir = target))
    }
    
    args <- paste(
      "-oq", shQuote(src),
      "-d", shQuote(target)
    )
    
    system_check(unzip, args)
  }
  
  #' Find all dependencies of a CRAN or dev package.
  #'
  #' Find all the dependencies of a package and determine whether they are ahead
  #' or behind CRAN. A \code{print()} method identifies mismatches (if any)
  #' between local and CRAN versions of each dependent package; an
  #' \code{update()} method installs outdated or missing packages from CRAN.
  #'
  #' @param packages A character vector of package names.
  #' @param pkgdir path to a package directory, or to a package tarball.
  #' @param dependencies Which dependencies do you want to check?
  #'   Can be a character vector (selecting from "Depends", "Imports",
  #'    "LinkingTo", "Suggests", or "Enhances"), or a logical vector.
  #'
  #'   \code{TRUE} is shorthand for "Depends", "Imports", "LinkingTo" and
  #'   "Suggests". \code{NA} is shorthand for "Depends", "Imports" and "LinkingTo"
  #'   and is the default. \code{FALSE} is shorthand for no dependencies (i.e.
  #'   just check this package, not its dependencies).
  #' @param quiet If \code{TRUE}, suppress output.
  #' @param upgrade If \code{TRUE}, also upgrade any of out date dependencies.
  #' @param repos A character vector giving repositories to use.
  #' @param type Type of package to \code{update}.  If "both", will switch
  #'   automatically to "binary" to avoid interactive prompts during package
  #'   installation.
  #'
  #' @param object A \code{package_deps} object.
  #' @param ... Additional arguments passed to \code{install_packages}.
  #'
  #' @return
  #'
  #' A \code{data.frame} with columns:
  #'
  #' \tabular{ll}{
  #' \code{package} \tab The dependent package's name,\cr
  #' \code{installed} \tab The currently installed version,\cr
  #' \code{available} \tab The version available on CRAN,\cr
  #' \code{diff} \tab An integer denoting whether the locally installed version
  #'   of the package is newer (1), the same (0) or older (-1) than the version
  #'   currently available on CRAN.\cr
  #' }
  #'
  #' @export
  #' @examples
  #' \dontrun{
  #' package_deps("devtools")
  #' # Use update to update any out-of-date dependencies
  #' update(package_deps("devtools"))
  #' }
  
  package_deps <- function(packages, dependencies = NA,
                           repos = getOption("repos"),
                           type = getOption("pkgType")) {
    
    if (identical(type, "both")) {
      type <- "binary"
    }
    
    repos <- fix_repositories(repos)
    cran <- available_packages(repos, type)
    
    deps <- sort(find_deps(packages, cran, top_dep = dependencies))
    
    # Remove base packages
    inst <- utils::installed.packages()
    base <- unname(inst[inst[, "Priority"] %in% c("base", "recommended"), "Package"])
    deps <- setdiff(deps, base)
    
    inst_ver <- unname(inst[, "Version"][match(deps, rownames(inst))])
    cran_ver <- unname(cran[, "Version"][match(deps, rownames(cran))])
    diff <- compare_versions(inst_ver, cran_ver)
    
    structure(
      data.frame(
        package = deps,
        installed = inst_ver,
        available = cran_ver,
        diff = diff,
        stringsAsFactors = FALSE
      ),
      class = c("package_deps", "data.frame"),
      repos = repos,
      type = type
    )
  }
  
  #' \code{local_package_deps} extracts dependencies from a
  #' local DESCRIPTION file.
  #'
  #' @export
  #' @rdname package_deps
  
  local_package_deps <- function(pkgdir = ".", dependencies = NA) {
    pkg <- load_pkg_description(pkgdir)
    
    dependencies <- tolower(standardise_dep(dependencies))
    dependencies <- intersect(dependencies, names(pkg))
    
    parsed <- lapply(pkg[tolower(dependencies)], parse_deps)
    unlist(lapply(parsed, `[[`, "name"), use.names = FALSE)
  }
  
  #' \code{dev_package_deps} lists the status of the dependencies
  #' of a local package.
  #'
  #' @export
  #' @rdname package_deps
  
  dev_package_deps <- function(pkgdir = ".", dependencies = NA,
                               repos = getOption("repos"),
                               type = getOption("pkgType")) {
    
    pkg <- load_pkg_description(pkgdir)
    install_dev_remotes(pkgdir)
    repos <- c(repos, parse_additional_repositories(pkg))
    
    deps <- local_package_deps(pkgdir = pkgdir, dependencies = dependencies)
    
    if (is_bioconductor(pkg)) {
      bioc_repos <- bioc_install_repos()
      
      missing_repos <- setdiff(names(bioc_repos), names(repos))
      
      if (length(missing_repos) > 0)
        repos[missing_repos] <- bioc_repos[missing_repos]
    }
    
    package_deps(deps, repos = repos, type = type)
  }
  
  ## -2 = not installed, but available on CRAN
  ## -1 = installed, but out of date
  ##  0 = installed, most recent version
  ##  1 = installed, version ahead of CRAN
  ##  2 = package not on CRAN
  
  compare_versions <- function(installed, cran) {
    stopifnot(length(installed) == length(cran))
    
    compare_var <- function(i, c) {
      if (is.na(c)) return(c(notcran = 2L))
      if (is.na(i)) return(c(notinst = -2L))
      
      i <- package_version(i)
      c <- package_version(c)
      
      if (i < c) {
        c(outofdate = -1L)
      } else if (i > c) {
        c(aheadofcran = 1L)
      } else {
        c(equal = 0L)
      }
    }
    
    vapply(
      seq_along(installed),
      function(i) compare_var(installed[[i]], cran[[i]]),
      integer(1)
    )
  }
  
  install_dev_remotes <- function(pkgdir = ".", ...) {
    
    pkg <- load_pkg_description(pkgdir)
    if (!has_dev_remotes(pkg)) {
      return()
    }
    
    types <- dev_remote_type(pkg[["remotes"]])
    
    lapply(types, function(type) type$fun(type$repository, ...))
  }
  
  # Parse the remotes field split into pieces and get install_ functions for each
  # remote type
  dev_remote_type <- function(remotes = "") {
    
    if (!nchar(remotes)) {
      return()
    }
    
    dev_packages <- trim_ws(unlist(strsplit(remotes, ",[[:space:]]*")))
    
    parse_one <- function(x) {
      pieces <- strsplit(x, "::", fixed = TRUE)[[1]]
      
      if (length(pieces) == 1) {
        type <- "github"
        repo <- pieces
      } else if (length(pieces) == 2) {
        type <- pieces[1]
        repo <- pieces[2]
      } else {
        stop("Malformed remote specification '", x, "'", call. = FALSE)
      }
      tryCatch(
        fun <- get(x = paste0("install_", tolower(type)), mode = "function"),
        error = function(e) {
          stop(
            "Malformed remote specification '", x, "'",
            ", error: ", conditionMessage(e),
            call. = FALSE
          )
        })
      list(repository = repo, type = type, fun = fun)
    }
    
    lapply(dev_packages, parse_one)
  }
  
  has_dev_remotes <- function(pkg) {
    !is.null(pkg[["remotes"]])
  }
  
  #' @export
  print.package_deps <- function(x, show_ok = FALSE, ...) {
    class(x) <- "data.frame"
    
    ahead <- x$diff > 0L
    behind <- x$diff < 0L
    same_ver <- x$diff == 0L
    
    x$diff <- NULL
    x[] <- lapply(x, format)
    
    if (any(behind)) {
      cat("Needs update -----------------------------\n")
      print(x[behind, , drop = FALSE], row.names = FALSE, right = FALSE)
    }
    
    if (any(ahead)) {
      cat("Not on CRAN ----------------------------\n")
      print(x[ahead, , drop = FALSE], row.names = FALSE, right = FALSE)
    }
    
    if (show_ok && any(same_ver)) {
      cat("OK ---------------------------------------\n")
      print(x[same_ver, , drop = FALSE], row.names = FALSE, right = FALSE)
    }
  }
  
  ## -2 = not installed, but available on CRAN
  ## -1 = installed, but out of date
  ##  0 = installed, most recent version
  ##  1 = installed, version ahead of CRAN
  ##  2 = package not on CRAN
  
  #' @export
  #' @rdname package_deps
  #' @importFrom stats update
  
  update.package_deps <- function(object, ..., quiet = FALSE, upgrade = TRUE) {
    ahead <- object$package[object$diff == 2L]
    if (length(ahead) > 0 && !quiet) {
      message("Skipping ", length(ahead), " packages not available: ",
              paste(ahead, collapse = ", "))
    }
    
    missing <- object$package[object$diff == 1L]
    if (length(missing) > 0 && !quiet) {
      message("Skipping ", length(missing), " packages ahead of CRAN: ",
              paste(missing, collapse = ", "))
    }
    
    if (upgrade) {
      behind <- object$package[object$diff < 0L]
    } else {
      behind <- object$package[is.na(object$installed)]
    }
    if (length(behind) > 0L) {
      install_packages(behind, repos = attr(object, "repos"),
                       type = attr(object, "type"), ...)
    }
    
  }
  
  install_packages <- function(packages, repos = getOption("repos"),
                               type = getOption("pkgType"), ...,
                               dependencies = FALSE, quiet = NULL) {
    if (identical(type, "both"))
      type <- "binary"
    if (is.null(quiet))
      quiet <- !identical(type, "source")
    
    message("Installing ", length(packages), " packages: ",
            paste(packages, collapse = ", "))
    
    safe_install_packages(
      packages,
      repos = repos,
      type = type,
      ...,
      dependencies = dependencies,
      quiet = quiet
    )
  }
  
  find_deps <- function(packages, available = utils::available.packages(),
                        top_dep = TRUE, rec_dep = NA, include_pkgs = TRUE) {
    if (length(packages) == 0 || identical(top_dep, FALSE))
      return(character())
    
    top_dep <- standardise_dep(top_dep)
    rec_dep <- standardise_dep(rec_dep)
    
    top <- tools::package_dependencies(packages, db = available, which = top_dep)
    top_flat <- unlist(top, use.names = FALSE)
    
    if (length(rec_dep) != 0 && length(top_flat) > 0) {
      rec <- tools::package_dependencies(top_flat, db = available, which = rec_dep,
                                         recursive = TRUE)
      rec_flat <- unlist(rec, use.names = FALSE)
    } else {
      rec_flat <- character()
    }
    
    unique(c(if (include_pkgs) packages, top_flat, rec_flat))
  }
  
  standardise_dep <- function(x) {
    if (identical(x, NA)) {
      c("Depends", "Imports", "LinkingTo")
    } else if (isTRUE(x)) {
      c("Depends", "Imports", "LinkingTo", "Suggests")
    } else if (identical(x, FALSE)) {
      character(0)
    } else if (is.character(x)) {
      x
    } else {
      stop("Dependencies must be a boolean or a character vector", call. = FALSE)
    }
  }
  
  #' Update packages that are missing or out-of-date.
  #'
  #' Works similarly to \code{\link[utils]{install.packages}} but doesn't install packages
  #' that are already installed, and also upgrades out dated dependencies.
  #'
  #' @param packages Character vector of packages to update.
  #' @inheritParams package_deps
  #' @seealso \code{\link{package_deps}} to see which packages are out of date/
  #'   missing.
  #' @export
  #' @examples
  #' \dontrun{
  #' update_packages("ggplot2")
  #' update_packages(c("plyr", "ggplot2"))
  #' }
  
  update_packages <- function(packages, dependencies = NA,
                              repos = getOption("repos"),
                              type = getOption("pkgType")) {
    pkgs <- package_deps(packages, repos = repos, type = type)
    update(pkgs)
  }
  
  has_additional_repositories <- function(pkg) {
    "additional_repositories" %in% names(pkg)
  }
  
  parse_additional_repositories <- function(pkg) {
    if (has_additional_repositories(pkg)) {
      strsplit(pkg[["additional_repositories"]], "[,[:space:]]+")[[1]]
    }
  }
  
  fix_repositories <- function(repos) {
    if (length(repos) == 0)
      repos <- character()
    
    # Override any existing default values with the cloud mirror
    # Reason: A "@CRAN@" value would open a GUI for choosing a mirror
    repos[repos == "@CRAN@"] <- "http://cloud.r-project.org"
    repos
  }
  
  has_devel <- function() {
    tryCatch(
      has_devel2(),
      error = function(e) FALSE
    )
  }
  
  ## This is similar to devtools:::has_devel(), with some
  ## very minor differences.
  
  has_devel2 <- function() {
    foo_path <- file.path(tempfile(fileext = ".c"))
    
    cat("void foo(int *bar) { *bar=1; }\n", file = foo_path)
    on.exit(unlink(foo_path))
    
    R(c("CMD", "SHLIB", basename(foo_path)), dirname(foo_path))
    dylib <- sub("\\.c$", .Platform$dynlib.ext, foo_path)
    on.exit(unlink(dylib), add = TRUE)
    
    dll <- dyn.load(dylib)
    on.exit(dyn.unload(dylib), add = TRUE)
    
    stopifnot(.C(dll$foo, 0L)[[1]] == 1L)
    TRUE
  }
  
  missing_devel_warning <- function(pkgdir) {
    pkgname <- tryCatch(
      get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package"),
      error = function(e) NULL
    ) %||% "<unknown>"
    
    sys <- sys_type()
    
    warning(
      "Package ",
      pkgname,
      " has compiled code, but no suitable ",
      "compiler(s) were found. Installation will likely fail.\n  ",
      if (sys == "windows") "Install Rtools and make sure it is in the PATH.",
      if (sys == "macos") "Install XCode and make sure it works.",
      if (sys == "linux") "Install compilers via your Linux package manager."
    )
  }
  
  R <- function(args, path = tempdir()) {
    
    r <- file.path(R.home("bin"), "R")
    
    args <- c(
      "--no-site-file", "--no-environ", "--no-save",
      "--no-restore", "--quiet",
      args
    )
    
    system_check(r, args, path = path)
  }
  
  #' @importFrom utils compareVersion
  
  download <- function(path, url, auth_token = NULL, basic_auth = NULL,
                       quiet = TRUE) {
    
    real_url <- url
    
    if (!is.null(basic_auth)) {
      str <- paste0("://", basic_auth$user, ":", basic_auth$password, "@")
      real_url <- sub("://", str, url)
    }
    
    if (!is.null(auth_token)) {
      sep <- if (grepl("?", url, fixed = TRUE)) "&" else "?"
      real_url <- paste0(url, sep, "access_token=", auth_token)
    }
    
    if (compareVersion(get_r_version(), "3.2.0") == -1) {
      curl_download(real_url, path, quiet)
      
    } else {
      
      base_download(real_url, path, quiet)
    }
    
    path
  }
  
  base_download <- function(url, path, quiet) {
    
    suppressWarnings(
      status <- utils::download.file(
        url,
        path,
        method = download_method(),
        quiet = quiet,
        mode = "wb"
      )
    )
    
    if (status != 0)  stop("Cannot download file from ", url, call. = FALSE)
    
    path
  }
  
  download_method <- function() {
    
    # R versions newer than 3.3.0 have correct default methods
    if (compareVersion(get_r_version(), "3.3") == -1) {
      
      if (os_type() == "windows") {
        "wininet"
        
      } else if (isTRUE(unname(capabilities("libcurl")))) {
        "libcurl"
        
      } else {
        "auto"
      }
      
    } else {
      "auto"
    }
  }
  
  curl_download <- function(url, path, quiet) {
    
    if (!pkg_installed("curl")) {
      stop("The 'curl' package is required if R is older than 3.2.0")
    }
    
    curl::curl_download(url, path, quiet = quiet, mode = "wb")
  }
  
  # Extract the commit hash from a git archive. Git archives include the SHA1
  # hash as the comment field of the zip central directory record
  # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html)
  # Since we know it's 40 characters long we seek that many bytes minus 2
  # (to confirm the comment is exactly 40 bytes long)
  git_extract_sha1 <- function(bundle) {
    
    # open the bundle for reading
    conn <- file(bundle, open = "rb", raw = TRUE)
    on.exit(close(conn))
    
    # seek to where the comment length field should be recorded
    seek(conn, where = -0x2a, origin = "end")
    
    # verify the comment is length 0x28
    len <- readBin(conn, "raw", n = 2)
    if (len[1] == 0x28 && len[2] == 0x00) {
      # read and return the SHA1
      rawToChar(readBin(conn, "raw", n = 0x28))
    } else {
      NULL
    }
  }
  
  git <- function(args, quiet = TRUE, path = ".") {
    full <- paste0(shQuote(check_git_path()), " ", paste(args, collapse = ""))
    if (!quiet) {
      message(full)
    }
    
    result <- in_dir(path, system(full, intern = TRUE, ignore.stderr = quiet))
    
    status <- attr(result, "status") %||% 0
    if (!identical(as.character(status), "0")) {
      stop("Command failed (", status, ")", call. = FALSE)
    }
    
    result
  }
  
  # Retrieve the current running path of the git binary.
  # @param git_binary_name The name of the binary depending on the OS.
  git_path <- function(git_binary_name = NULL) {
    # Use user supplied path
    if (!is.null(git_binary_name)) {
      if (!file.exists(git_binary_name)) {
        stop("Path ", git_binary_name, " does not exist", .call = FALSE)
      }
      return(git_binary_name)
    }
    
    # Look on path
    git_path <- Sys.which("git")[[1]]
    if (git_path != "") return(git_path)
    
    # On Windows, look in common locations
    if (os_type() == "windows") {
      look_in <- c(
        "C:/Program Files/Git/bin/git.exe",
        "C:/Program Files (x86)/Git/bin/git.exe"
      )
      found <- file.exists(look_in)
      if (any(found)) return(look_in[found][1])
    }
    
    NULL
  }
  
  check_git_path <- function(git_binary_name = NULL) {
    
    path <- git_path(git_binary_name)
    
    if (is.null(path)) {
      stop("Git does not seem to be installed on your system.", call. = FALSE)
    }
    
    path
  }
  
  github_GET <- function(path, ..., pat = github_pat()) {
    
    url <- paste0("https://api.github.com/", path)
    
    tmp <- tempfile()
    download(tmp, url, auth_token = pat)
    
    fromJSONFile(tmp)
  }
  
  github_commit <- function(username, repo, ref = "master") {
    
    url <- file.path("https://api.github.com",
                     "repos", username, repo, "commits", ref)
    
    tmp <- tempfile()
    download(tmp, url, auth_token = github_pat())
    
    fromJSONFile(tmp)
  }
  
  #' Retrieve Github personal access token.
  #'
  #' A github personal access token
  #' Looks in env var \code{GITHUB_PAT}
  #'
  #' @keywords internal
  #' @noRd
  github_pat <- function() {
    pat <- Sys.getenv('GITHUB_PAT')
    if (identical(pat, "")) return(NULL)
    
    message("Using github PAT from envvar GITHUB_PAT")
    pat
  }
  
  #' Install a package directly from bitbucket
  #'
  #' This function is vectorised so you can install multiple packages in
  #' a single command.
  #'
  #' @inheritParams install_github
  #' @param auth_user your account username if you're attempting to install
  #'   a package hosted in a private repository (and your username is different
  #'   to \code{username})
  #' @param password your password
  #' @param ref Desired git reference; could be a commit, tag, or branch name.
  #'   Defaults to master.
  #' @seealso Bitbucket API docs:
  #'   \url{https://confluence.atlassian.com/bitbucket/use-the-bitbucket-cloud-rest-apis-222724129.html}
  #'
  #' @export
  #' @examples
  #' \dontrun{
  #' install_bitbucket("sulab/mygene.r@@default")
  #' install_bitbucket("dannavarro/lsr-package")
  #' }
  install_bitbucket <- function(repo, ref = "master", subdir = NULL,
                                auth_user = NULL, password = NULL, ...) {
    
    remotes <- lapply(repo, bitbucket_remote, ref = ref,
                      subdir = subdir, auth_user = auth_user, password = password)
    
    install_remotes(remotes, ...)
  }
  
  bitbucket_remote <- function(repo, ref = NULL, subdir = NULL,
                               auth_user = NULL, password = NULL, sha = NULL) {
    
    meta <- parse_git_repo(repo)
    
    remote("bitbucket",
           repo = meta$repo,
           subdir = meta$subdir %||% subdir,
           username = meta$username,
           ref = meta$ref %||% ref,
           sha = sha,
           auth_user = auth_user,
           password = password
    )
  }
  
  #' @export
  remote_download.bitbucket_remote <- function(x, quiet = FALSE) {
    if (!quiet) {
      message("Downloading bitbucket repo ", x$username, "/", x$repo, "@", x$ref)
    }
    
    dest <- tempfile(fileext = paste0(".zip"))
    src <- paste("https://bitbucket.org/", x$username, "/", tolower(x$repo), "/get/",
                 x$ref, ".zip", sep = "")
    
    if (!is.null(x$password)) {
      auth <- list(
        user = x$auth_user %||% x$username,
        password = x$password
      )
    } else {
      auth <- NULL
    }
    
    download(dest, src, basic_auth = auth)
  }
  
  #' @export
  remote_metadata.bitbucket_remote <- function(x, bundle = NULL, source = NULL) {
    # Determine sha as efficiently as possible
    if (!is.null(x$sha)) {
      # Might be cached already (because re-installing)
      sha <- x$sha
    } else if (!is.null(bundle)) {
      # Might be able to get from zip archive
      sha <- git_extract_sha1(bundle)
    } else {
      # Don't know
      sha <- NULL
    }
    
    list(
      RemoteType = "bitbucket",
      RemoteRepo = x$repo,
      RemoteUsername = x$username,
      RemoteRef = x$ref,
      RemoteSha = sha,
      RemoteSubdir = x$subdir
    )
  }
  
  #' Install a package from a git repository
  #'
  #' It is vectorised so you can install multiple packages with
  #' a single command. You do not need to have the \code{git2r} package,
  #' or an external git client installed.
  #'
  #' @param url Location of package. The url should point to a public or
  #'   private repository.
  #' @param branch Name of branch or tag to use, if not master.
  #' @param subdir A sub-directory within a git repository that may
  #'   contain the package we are interested in installing.
  #' @param git Whether to use the \code{git2r} package, or an external
  #'   git client via system. Default is \code{git2r} if it is installed,
  #'   otherwise an external git installation.
  #' @param ... passed on to \code{\link[utils]{install.packages}}
  #' @export
  #' @examples
  #' \dontrun{
  #' install_git("git://github.com/hadley/stringr.git")
  #' install_git("git://github.com/hadley/stringr.git", branch = "stringr-0.2")
  #'}
  install_git <- function(url, subdir = NULL, branch = NULL,
                          git = c("auto", "git2r", "external"), ...) {
    
    git_remote <- select_git_remote(match.arg(git))
    remotes <- lapply(url, git_remote, subdir = subdir, branch = branch)
    install_remotes(remotes, ...)
  }
  
  
  select_git_remote <- function(git) {
    if (git == "auto") {
      git <- if (pkg_installed("git2r")) "git2r" else "external"
    }
    
    list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]]
  }
  
  
  git_remote_git2r <- function(url, subdir = NULL, branch = NULL) {
    remote("git2r",
           url = url,
           subdir = subdir,
           branch = branch
    )
  }
  
  
  git_remote_xgit <- function(url, subdir = NULL, branch = NULL) {
    remote("xgit",
           url = url,
           subdir = subdir,
           branch = branch
    )
  }
  
  #' @export
  remote_download.git2r_remote <- function(x, quiet = FALSE) {
    if (!quiet) {
      message("Downloading git repo ", x$url)
    }
    
    bundle <- tempfile()
    git2r::clone(x$url, bundle, progress = FALSE)
    
    if (!is.null(x$branch)) {
      r <- git2r::repository(bundle)
      git2r::checkout(r, x$branch)
    }
    
    bundle
  }
  
  #' @export
  remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL) {
    if (!is.null(bundle)) {
      r <- git2r::repository(bundle)
      sha <- git2r::commits(r)[[1]]@sha
    } else {
      sha <- NULL
    }
    
    list(
      RemoteType = "git",
      RemoteUrl = x$url,
      RemoteSubdir = x$subdir,
      RemoteRef = x$ref,
      RemoteSha = sha
    )
  }
  
  
  #' @export
  remote_download.xgit_remote <- function(x, quiet = FALSE) {
    if (!quiet) {
      message("Downloading git repo ", x$url)
    }
    
    bundle <- tempfile()
    
    args <- c('clone', '--depth', '1', '--no-hardlinks')
    if (!is.null(x$branch)) args <- c(args, "--branch", x$branch)
    args <- c(args, x$args, x$url, bundle)
    git(paste0(args, collapse = " "), quiet = quiet)
    
    bundle
  }
  
  #' @export
  remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL) {
    list(
      RemoteType = "git",
      RemoteUrl = x$url,
      RemoteSubdir = x$subdir,
      RemoteRef = x$ref,
      RemoteSha = xgit_remote_sha1(x$url),
      RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
    )
  }
  
  #' @importFrom utils read.delim
  
  xgit_remote_sha1 <- function(url, ref = "master") {
    refs <- git(paste("ls-remote", url, ref))
    
    refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t",
                          header = FALSE)
    names(refs_df) <- c("sha", "ref")
    
    refs_df$sha[1]
  }
  #' Attempts to install a package directly from GitHub.
  #'
  #' This function is vectorised on \code{repo} so you can install multiple
  #' packages in a single command.
  #'
  #' @param repo Repository address in the format
  #'   \code{username/repo[/subdir][@@ref|#pull]}. Alternatively, you can
  #'   specify \code{subdir} and/or \code{ref} using the respective parameters
  #'   (see below); if both is specified, the values in \code{repo} take
  #'   precedence.
  #' @param username User name. Deprecated: please include username in the
  #'   \code{repo}
  #' @param ref Desired git reference. Could be a commit, tag, or branch
  #'   name, or a call to \code{\link{github_pull}}. Defaults to \code{"master"}.
  #' @param subdir subdirectory within repo that contains the R package.
  #' @param auth_token To install from a private repo, generate a personal
  #'   access token (PAT) in \url{https://github.com/settings/applications} and
  #'   supply to this argument. This is safer than using a password because
  #'   you can easily delete a PAT without affecting any others. Defaults to
  #'   the \code{GITHUB_PAT} environment variable.
  #' @param host GitHub API host to use. Override with your GitHub enterprise
  #'   hostname, for example, \code{"github.hostname.com/api/v3"}.
  #' @param ... Other arguments passed on to \code{\link[utils]{install.packages}}.
  #' @details
  #' Attempting to install from a source repository that uses submodules
  #' raises a warning. Because the zipped sources provided by GitHub do not
  #' include submodules, this may lead to unexpected behaviour or compilation
  #' failure in source packages. In this case, cloning the repository manually
  #' may yield better results.
  #' @export
  #' @seealso \code{\link{github_pull}}
  #' @examples
  #' \dontrun{
  #' install_github("klutometis/roxygen")
  #' install_github("wch/ggplot2")
  #' install_github(c("rstudio/httpuv", "rstudio/shiny"))
  #' install_github(c("hadley/httr@@v0.4", "klutometis/roxygen#142",
  #'   "mfrasca/r-logging/pkg"))
  #'
  #' # To install from a private repo, use auth_token with a token
  #' # from https://github.com/settings/applications. You only need the
  #' # repo scope. Best practice is to save your PAT in env var called
  #' # GITHUB_PAT.
  #' install_github("hadley/private", auth_token = "abc")
  #'
  #' }
  install_github <- function(repo, username = NULL,
                             ref = "master", subdir = NULL,
                             auth_token = github_pat(),
                             host = "api.github.com", ...) {
    
    remotes <- lapply(repo, github_remote, username = username, ref = ref,
                      subdir = subdir, auth_token = auth_token, host = host)
    
    install_remotes(remotes, ...)
  }
  
  github_remote <- function(repo, username = NULL, ref = NULL, subdir = NULL,
                            auth_token = github_pat(), sha = NULL,
                            host = "api.github.com") {
    
    meta <- parse_git_repo(repo)
    meta <- github_resolve_ref(meta$ref %||% ref, meta)
    
    if (is.null(meta$username)) {
      meta$username <- username %||% getOption("github.user") %||%
        stop("Unknown username.")
      warning("Username parameter is deprecated. Please use ",
              username, "/", repo, call. = FALSE)
    }
    
    remote("github",
           host = host,
           repo = meta$repo,
           subdir = meta$subdir %||% subdir,
           username = meta$username,
           ref = meta$ref,
           sha = sha,
           auth_token = auth_token
    )
  }
  
  #' @export
  remote_download.github_remote <- function(x, quiet = FALSE) {
    if (!quiet) {
      message("Downloading GitHub repo ", x$username, "/", x$repo, "@", x$ref)
    }
    
    dest <- tempfile(fileext = paste0(".zip"))
    src_root <- paste0("https://", x$host, "/repos/", x$username, "/", x$repo)
    src <- paste0(src_root, "/zipball/", utils::URLencode(x$ref, reserved = TRUE))
    
    if (github_has_submodules(x)) {
      warning("GitHub repo contains submodules, may not function as expected!",
              call. = FALSE)
    }
    
    download(dest, src, auth_token = x$auth_token)
  }
  
  github_has_submodules <- function(x) {
    src_root <- paste0("https://", x$host, "/repos/", x$username, "/", x$repo)
    src_submodules <- paste0(src_root, "/contents/.gitmodules?ref=", x$ref)
    
    tmp <- tempfile()
    res <- tryCatch(
      download(tmp, src_submodules, auth_token = x$auth_token),
      error = function(e) e
    )
    if (methods::is(res, "error")) return(FALSE)
    
    ## download() sometimes just downloads the error page, because
    ## the libcurl backend in download.file() is broken
    ## If the request was successful (=submodules exist), then it has an
    ## 'sha' field.
    sha <- tryCatch(
      fromJSONFile(tmp)$sha,
      error = function(e) e
    )
    ! methods::is(sha, "error") && ! is.null(sha)
  }
  
  #' @export
  remote_metadata.github_remote <- function(x, bundle = NULL, source = NULL) {
    # Determine sha as efficiently as possible
    if (!is.null(x$sha)) {
      # Might be cached already (because re-installing)
      sha <- x$sha
    } else if (!is.null(bundle)) {
      # Might be able to get from zip archive
      sha <- git_extract_sha1(bundle)
    } else {
      # Otherwise can use github api
      sha <- github_commit(x$username, x$repo, x$ref)$sha
    }
    
    list(
      RemoteType = "github",
      RemoteHost = x$host,
      RemoteRepo = x$repo,
      RemoteUsername = x$username,
      RemoteRef = x$ref,
      RemoteSha = sha,
      RemoteSubdir = x$subdir,
      # Backward compatibility for packrat etc.
      GithubRepo = x$repo,
      GithubUsername = x$username,
      GithubRef = x$ref,
      GithubSHA1 = sha,
      GithubSubdir = x$subdir
    )
  }
  
  #' GitHub references
  #'
  #' Use as \code{ref} parameter to \code{\link{install_github}}.
  #' Allows installing a specific pull request or the latest release.
  #'
  #' @param pull The pull request to install
  #' @seealso \code{\link{install_github}}
  #' @rdname github_refs
  #' @export
  github_pull <- function(pull) structure(pull, class = "github_pull")
  
  #' @rdname github_refs
  #' @export
  github_release <- function() structure(NA_integer_, class = "github_release")
  
  github_resolve_ref <- function(x, params) UseMethod("github_resolve_ref")
  
  #' @export
  github_resolve_ref.default <- function(x, params) {
    params$ref <- x
    params
  }
  
  #' @export
  github_resolve_ref.NULL <- function(x, params) {
    params$ref <- "master"
    params
  }
  
  #' @export
  github_resolve_ref.github_pull <- function(x, params) {
    # GET /repos/:user/:repo/pulls/:number
    path <- file.path("repos", params$username, params$repo, "pulls", x)
    response <- tryCatch(
      github_GET(path),
      error = function(e) e
    )
    
    ## Just because libcurl might download the error page...
    if (methods::is(response, "error") || is.null(response$head)) {
      stop("Cannot find GitHub pull request ", params$username, "/",
           params$repo, "#", x)
    }
    
    params$username <- response$head$user$login
    params$ref <- response$head$ref
    params
  }
  
  # Retrieve the ref for the latest release
  #' @export
  github_resolve_ref.github_release <- function(x, params) {
    # GET /repos/:user/:repo/releases
    path <- paste("repos", params$username, params$repo, "releases", sep = "/")
    response <- tryCatch(
      github_GET(path),
      error = function(e) e
    )
    
    if (methods::is(response, "error") || !is.null(response$message)) {
      stop("Cannot find repo ", params$username, "/", params$repo, ".")
    }
    
    if (length(response) == 0L)
      stop("No releases found for repo ", params$username, "/", params$repo, ".")
    
    params$ref <- response[[1L]]$tag_name
    params
  }
  
  #' Parse a remote git repo specification
  #'
  #' A remote repo can be specified in two ways:
  #' \describe{
  #' \item{as a URL}{\code{parse_github_url()} handles HTTPS and SSH remote URLs
  #' and various GitHub browser URLs}
  #' \item{via a shorthand}{\code{parse_repo_spec()} handles this concise form:
  #' \code{[username/]repo[/subdir][#pull|@ref|@*release]}}
  #' }
  #'
  #' @param repo Character scalar, the repo specification.
  #' @return List with members: \code{username}, \code{repo}, \code{subdir}
  #'   \code{ref}, \code{pull}, \code{release}, some which will be empty.
  #'
  #' @name parse-git-repo
  #' @examples
  #' parse_repo_spec("metacran/crandb")
  #' parse_repo_spec("jimhester/covr#47")        ## pull request
  #' parse_repo_spec("jeroen/curl@v0.9.3")       ## specific tag
  #' parse_repo_spec("tidyverse/dplyr@*release") ## shorthand for latest release
  #' parse_repo_spec("r-lib/remotes@550a3c7d3f9e1493a2ba") ## commit SHA
  #'
  #' parse_github_url("https://github.com/jeroen/curl.git")
  #' parse_github_url("git@github.com:metacran/crandb.git")
  #' parse_github_url("https://github.com/jimhester/covr")
  #' parse_github_url("https://github.example.com/user/repo.git")
  #' parse_github_url("git@github.example.com:user/repo.git")
  #'
  #' parse_github_url("https://github.com/r-lib/remotes/pull/108")
  #' parse_github_url("https://github.com/r-lib/remotes/tree/name-of-branch")
  #' parse_github_url("https://github.com/r-lib/remotes/commit/1234567")
  #' parse_github_url("https://github.com/r-lib/remotes/releases/latest")
  #' parse_github_url("https://github.com/r-lib/remotes/releases/tag/1.0.0")
  NULL
  
  #' @export
  #' @rdname parse-git-repo
  parse_repo_spec <- function(repo) {
    username_rx <- "(?:(?<username>[^/]+)/)?"
    repo_rx     <- "(?<repo>[^/@#]+)"
    subdir_rx   <- "(?:/(?<subdir>[^@#]*[^@#/])/?)?"
    ref_rx      <- "(?:@(?<ref>[^*].*))"
    pull_rx     <- "(?:#(?<pull>[0-9]+))"
    release_rx  <- "(?:@(?<release>[*]release))"
    ref_or_pull_or_release_rx <- sprintf(
      "(?:%s|%s|%s)?", ref_rx, pull_rx, release_rx
    )
    spec_rx  <- sprintf(
      "^%s%s%s%s$", username_rx, repo_rx, subdir_rx, ref_or_pull_or_release_rx
    )
    params <- as.list(re_match(text = repo, pattern = spec_rx))
    
    if (is.na(params$.match)) {
      stop(sprintf("Invalid git repo specification: '%s'", repo))
    }
    
    params[grepl("^[^\\.]", names(params))]
  }
  
  #' @export
  #' @rdname parse-git-repo
  parse_github_repo_spec <- parse_repo_spec
  
  #' @export
  #' @rdname parse-git-repo
  parse_github_url <- function(repo) {
    prefix_rx <- "(?:github[^/:]+[/:])"
    username_rx <- "(?:(?<username>[^/]+)/)"
    repo_rx     <- "(?<repo>[^/@#]+)"
    ref_rx <- "(?:(?:tree|commit|releases/tag)/(?<ref>.+$))"
    pull_rx <- "(?:pull/(?<pull>.+$))"
    release_rx <- "(?:releases/)(?<release>.+$)"
    ref_or_pull_or_release_rx <- sprintf(
      "(?:/(%s|%s|%s))?", ref_rx, pull_rx, release_rx
    )
    url_rx  <- sprintf(
      "%s%s%s%s",
      prefix_rx, username_rx, repo_rx, ref_or_pull_or_release_rx
    )
    params <- as.list(re_match(text = repo, pattern = url_rx))
    
    if (is.na(params$.match)) {
      stop(sprintf("Invalid GitHub URL: '%s'", repo))
    }
    if (params$ref == "" && params$pull == "" && params$release == "") {
      params$repo <- gsub("\\.git$", "", params$repo)
    }
    if (params$release == "latest") {
      params$release <- "*release"
    }
    
    params[grepl("^[^\\.]", names(params))]
  }
  
  parse_git_repo <- function(repo) {
    
    if (grepl("^https://github|^git@github", repo)) {
      params <- parse_github_url(repo)
    } else {
      params <- parse_repo_spec(repo)
    }
    params <- params[viapply(params, nchar) > 0]
    
    if (!is.null(params$pull)) {
      params$ref <- github_pull(params$pull)
      params$pull <- NULL
    }
    
    if (!is.null(params$release)) {
      params$ref <- github_release()
      params$release <- NULL
    }
    
    params
  }
  
  #' Install a package from a local file
  #'
  #' This function is vectorised so you can install multiple packages in
  #' a single command.
  #'
  #' @param path path to local directory, or compressed file (tar, zip, tar.gz
  #'   tar.bz2, tgz2 or tbz)
  #' @inheritParams install_url
  #' @export
  #' @examples
  #' \dontrun{
  #' dir <- tempfile()
  #' dir.create(dir)
  #' pkg <- download.packages("testthat", dir, type = "source")
  #' install_local(pkg[, 2])
  #' }
  
  install_local <- function(path, subdir = NULL, ...) {
    remotes <- lapply(path, local_remote, subdir = subdir)
    install_remotes(remotes, ...)
  }
  
  local_remote <- function(path, subdir = NULL, branch = NULL, args = character(0)) {
    remote("local",
           path = normalizePath(path),
           subdir = subdir
    )
  }
  
  #' @export
  remote_download.local_remote <- function(x, quiet = FALSE) {
    # Already downloaded - just need to copy to tempdir()
    bundle <- tempfile()
    dir.create(bundle)
    file.copy(x$path, bundle, recursive = TRUE)
    
    # file.copy() creates directory inside of bundle
    dir(bundle, full.names = TRUE)[1]
  }
  
  #' @export
  remote_metadata.local_remote <- function(x, bundle = NULL, source = NULL) {
    list(
      RemoteType = "local",
      RemoteUrl = x$path,
      RemoteSubdir = x$subdir
    )
  }
  #' Install a remote package.
  #'
  #' This:
  #' \enumerate{
  #'   \item downloads source bundle
  #'   \item decompresses & checks that it's a package
  #'   \item adds metadata to DESCRIPTION
  #'   \item calls install
  #' }
  #' @noRd
  install_remote <- function(remote, ..., quiet = FALSE) {
    stopifnot(is.remote(remote))
    
    bundle <- remote_download(remote, quiet = quiet)
    on.exit(unlink(bundle), add = TRUE)
    
    source <- source_pkg(bundle, subdir = remote$subdir)
    on.exit(unlink(source, recursive = TRUE), add = TRUE)
    
    add_metadata(source, remote_metadata(remote, bundle, source))
    
    # Because we've modified DESCRIPTION, its original MD5 value is wrong
    clear_description_md5(source)
    
    install(source, ..., quiet = quiet)
  }
  
  install_remotes <- function(remotes, ...) {
    invisible(vapply(remotes, install_remote, ..., FUN.VALUE = logical(1)))
  }
  
  # Add metadata
  add_metadata <- function(pkg_path, meta) {
    path <- file.path(pkg_path, "DESCRIPTION")
    desc <- read_dcf(path)
    
    desc <- utils::modifyList(desc, meta)
    
    write_dcf(path, desc)
  }
  
  # Modify the MD5 file - remove the line for DESCRIPTION
  clear_description_md5 <- function(pkg_path) {
    path <- file.path(pkg_path, "MD5")
    
    if (file.exists(path)) {
      text <- readLines(path)
      text <- text[!grepl(".*\\*DESCRIPTION$", text)]
      
      writeLines(text, path)
    }
  }
  
  remote <- function(type, ...) {
    structure(list(...), class = c(paste0(type, "_remote"), "remote"))
  }
  is.remote <- function(x) inherits(x, "remote")
  
  remote_download <- function(x, quiet = FALSE) UseMethod("remote_download")
  remote_metadata <- function(x, bundle = NULL, source = NULL) UseMethod("remote_metadata")
  
  #' Install a package from a SVN repository
  #'
  #' This function requires \command{svn} to be installed on your system in order to
  #' be used.
  #'
  #' It is vectorised so you can install multiple packages with
  #' a single command.
  #'
  #' @inheritParams install_git
  #' @param subdir A sub-directory withing a svn repository that contains the
  #'   package we are interested in installing.
  #' @param args A character vector providing extra options to pass on to
  #'   \command{svn}.
  #' @param revision svn revision, if omitted updates to latest
  #' @param ... Other arguments passed on to \code{\link[utils]{install.packages}}.
  #' @export
  #'
  #' @examples
  #' \dontrun{
  #' install_svn("svn://github.com/hadley/stringr/trunk")
  #' install_svn("svn://github.com/hadley/httr/branches/oauth")
  #'}
  install_svn <- function(url, subdir = NULL, args = character(0),
                          ..., revision = NULL) {
    
    remotes <- lapply(url, svn_remote, svn_subdir = subdir,
                      revision = revision, args = args)
    
    install_remotes(remotes, ...)
  }
  
  svn_remote <- function(url, svn_subdir = NULL, revision = revision,
                         args = character(0)) {
    remote("svn",
           url = url,
           svn_subdir = svn_subdir,
           revision = revision,
           args = args
    )
  }
  
  #' @export
  remote_download.svn_remote <- function(x, quiet = FALSE) {
    if (!quiet) {
      message("Downloading svn repo ", x$url)
    }
    
    bundle <- tempfile()
    svn_binary_path <- svn_path()
    url <- x$url
    args <- "export"
    if (!is.null(x$revision))
      args <- paste("-r", x$revision, args)
    if (!is.null(x$svn_subdir)) {
      url <- file.path(url, x$svn_subdir);
    }
    args <- c(x$args, args, url, bundle)
    
    message(shQuote(svn_binary_path), " ", paste0(args, collapse = " "))
    request <- system2(svn_binary_path, args, stdout = FALSE, stderr = FALSE)
    
    # This is only looking for an error code above 0-success
    if (request > 0) {
      stop("There seems to be a problem retrieving this SVN-URL.", call. = FALSE)
    }
    
    bundle
  }
  
  #' @export
  remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL) {
    list(
      RemoteType = "svn",
      RemoteUrl = x$url,
      RemoteSubdir = x$subdir,
      RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ")
    )
  }
  
  svn_path <- function(svn_binary_name = NULL) {
    # Use user supplied path
    if (!is.null(svn_binary_name)) {
      if (!file.exists(svn_binary_name)) {
        stop("Path ", svn_binary_name, " does not exist", .call = FALSE)
      }
      return(svn_binary_name)
    }
    
    # Look on path
    svn_path <- Sys.which("svn")[[1]]
    if (svn_path != "") return(svn_path)
    
    # On Windows, look in common locations
    if (os_type() == "windows") {
      look_in <- c(
        "C:/Program Files/Svn/bin/svn.exe",
        "C:/Program Files (x86)/Svn/bin/svn.exe"
      )
      found <- file.exists(look_in)
      if (any(found)) return(look_in[found][1])
    }
    
    stop("SVN does not seem to be installed on your system.", call. = FALSE)
  }
  
  #' Install a package from a url
  #'
  #' This function is vectorised so you can install multiple packages in
  #' a single command.
  #'
  #' @param url location of package on internet. The url should point to a
  #'   zip file, a tar file or a bzipped/gzipped tar file.
  #' @param subdir subdirectory within url bundle that contains the R package.
  #' @param ... Other arguments passed on to \code{\link[utils]{install.packages}}.
  #' @export
  #'
  #' @examples
  #' \dontrun{
  #' install_url("https://github.com/hadley/stringr/archive/master.zip")
  #' }
  
  install_url <- function(url, subdir = NULL, ...) {
    remotes <- lapply(url, url_remote, subdir = subdir)
    install_remotes(remotes, ...)
  }
  
  url_remote <- function(url, subdir = NULL) {
    remote("url",
           url = url,
           subdir = subdir
    )
  }
  
  #' @importFrom tools file_ext
  #' @export
  remote_download.url_remote <- function(x, quiet = FALSE) {
    if (!quiet) {
      message("Downloading package from url: ", x$url)
    }
    
    ext <- if (grepl("\\.tar\\.gz$", x$url)) "tar.gz" else file_ext(x$url)
    
    bundle <- tempfile(fileext = paste0(".", ext))
    download(bundle, x$url)
  }
  
  #' @export
  remote_metadata.url_remote <- function(x, bundle = NULL, source = NULL) {
    list(
      RemoteType = "url",
      RemoteUrl = x$url,
      RemoteSubdir = x$subdir
    )
  }
  
  #' Install specified version of a CRAN package.
  #'
  #' If you are installing an package that contains compiled code, you will
  #' need to have an R development environment installed.  You can check
  #' if you do by running \code{devtools::has_devel} (you need the
  #' \code{devtools} package for this).
  #'
  #' @export
  #' @family package installation
  #' @param package package name
  #' @param version If the specified version is NULL or the same as the most
  #'   recent version of the package, this function simply calls
  #'   \code{\link[utils]{install.packages}}. Otherwise, it looks at the list of
  #'   archived source tarballs and tries to install an older version instead.
  #' @param ... Other arguments passed on to \code{\link[utils]{install.packages}}.
  #' @inheritParams utils::install.packages
  #' @author Jeremy Stephens
  #' @importFrom utils available.packages contrib.url install.packages
  
  install_version <- function(package, version = NULL, repos = getOption("repos"), type = getOption("pkgType"), ...) {
    
    url <- download_version_url(package, version, repos, type)
    install_url(url, ...)
  }
  
  package_find_repo <- function(package, repos) {
    for (repo in repos) {
      if (length(repos) > 1)
        message("Trying ", repo)
      
      archive <-
        tryCatch({
          con <- gzcon(url(sprintf("%s/src/contrib/Meta/archive.rds", repo), "rb"))
          on.exit(close(con))
          readRDS(con)
        },
        warning = function(e) list(),
        error = function(e) list())
      
      info <- archive[[package]]
      if (!is.null(info)) {
        info$repo <- repo
        return(info)
      }
    }
    
    stop(sprintf("couldn't find package '%s'", package))
  }
  
  
  #' Download a specified version of a CRAN package
  #'
  #' It downloads the package to a temporary file, and
  #' returns the name of the file.
  #'
  #' @inheritParams install_version
  #' @return Name of the downloaded file.
  #'
  #' @export
  
  download_version <- function(package, version = NULL,
                               repos = getOption("repos"),
                               type = getOption("pkgType"), ...) {
    
    url <- download_version_url(package, version, repos, type)
    download(path = tempfile(), url = url)
  }
  
  download_version_url <- function(package, version, repos, type) {
    
    contriburl <- contrib.url(repos, type)
    available <- available.packages(contriburl)
    
    if (package %in% row.names(available)) {
      current.version <- available[package, 'Version']
      if (is.null(version) || version == current.version) {
        row <- available[which(rownames(available) == package)[1], ]
        return(paste0(
          row[["Repository"]],
          "/",
          row[["Package"]],
          "_",
          row[["Version"]],
          ".tar.gz"
        ))
      }
    }
    
    info <- package_find_repo(package, repos)
    
    if (is.null(version)) {
      # Grab the latest one: only happens if pulled from CRAN
      package.path <- row.names(info)[nrow(info)]
    } else {
      package.path <- paste(package, "/", package, "_", version, ".tar.gz",
                            sep = "")
      if (!(package.path %in% row.names(info))) {
        stop(sprintf("version '%s' is invalid for package '%s'", version,
                     package))
      }
    }
    
    paste(info$repo[1L], "/src/contrib/Archive/", package.path, sep = "")
  }
  
  install <- function(pkgdir = ".", dependencies = NA, quiet = TRUE, ...) {
    
    if (file.exists(file.path(pkgdir, "src")) && ! has_devel()) {
      missing_devel_warning(pkgdir)
    }
    
    ## Check for circular dependencies. We need to know about the root
    ## of the install process.
    if (is_root_install()) on.exit(exit_from_root_install(), add = TRUE)
    if (check_for_circular_dependencies(pkgdir, quiet)) {
      return(invisible(FALSE))
    }
    
    install_deps(pkgdir, dependencies = dependencies, quiet = quiet, ...)
    
    safe_install_packages(
      pkgdir,
      repos = NULL,
      quiet = quiet,
      type = "source",
      ...
    )
    
    invisible(TRUE)
  }
  
  safe_install_packages <- function(...) {
    
    lib <- paste(.libPaths(), collapse = ":")
    
    if (has_package("crancache") && has_package("callr")) {
      i.p <- "crancache" %::% "install_packages"
    } else {
      i.p <- utils::install.packages
    }
    
    with_envvar(
      c(R_LIBS = lib,
        R_LIBS_USER = lib,
        R_LIBS_SITE = lib,
        R_PROFILE_USER = tempfile()),
      i.p(...)
    )
  }
  
  #' Install package dependencies if needed.
  #'
  #' @inheritParams package_deps
  #' @param threads Number of threads to start, passed to
  #'   \code{\link[utils]{install.packages}} as \code{Ncpus}.
  #' @param ... additional arguments passed to \code{\link[utils]{install.packages}}.
  #' @export
  #' @examples
  #' \dontrun{install_deps(".")}
  
  install_deps <- function(pkgdir = ".", dependencies = NA,
                           threads = getOption("Ncpus", 1),
                           repos = getOption("repos"),
                           type = getOption("pkgType"),
                           ...,
                           upgrade = TRUE,
                           quiet = FALSE) {
    
    packages <- dev_package_deps(
      pkgdir,
      repos = repos,
      dependencies = dependencies,
      type = type
    )
    
    dep_deps <- if (isTRUE(dependencies)) NA else dependencies
    
    update(
      packages,
      dependencies = dep_deps,
      ...,
      Ncpus = threads,
      quiet = quiet,
      upgrade = upgrade
    )
  }
  
  tokenize_json <- function(text) {
    text <- paste(text, collapse = "\n")
    
    ESCAPE <- '(\\\\[^u[:cntrl:]]|\\\\u[0-9a-fA-F]{4})'
    CHAR <- '[^[:cntrl:]"\\\\]'
    
    STRING <- paste0('"', CHAR, '*(', ESCAPE, CHAR, '*)*"')
    NUMBER <- "-?(0|[1-9][0-9]*)([.][0-9]*)?([eE][+-]?[0-9]*)?"
    KEYWORD <- 'null|false|true'
    SPACE <- '[[:space:]]+'
    
    match <- gregexpr(
      pattern = paste0(
        STRING, "|", NUMBER, "|", KEYWORD, "|", SPACE, "|", "."
      ),
      text = text,
      perl = TRUE
    )
    
    grep("^\\s+$", regmatches(text, match)[[1]], value = TRUE, invert = TRUE)
  }
  
  throw <- function(...) {
    stop("JSON: ", ..., call. = FALSE)
  }
  
  fromJSONFile <- function(filename) {
    fromJSON(readLines(filename, warn = FALSE))
  }
  
  fromJSON <- function(text) {
    
    tokens <- tokenize_json(text)
    token <- NULL
    ptr <- 1
    
    read_token <- function() {
      if (ptr <= length(tokens)) {
        token <<- tokens[ptr]
        ptr <<- ptr + 1
      } else {
        token <<- 'EOF'
      }
    }
    
    parse_value <- function(name = "") {
      if (token == "{") {
        parse_object()
      } else if (token == "[") {
        parse_array()
      } else if (token == "EOF" || (nchar(token) == 1 && ! token %in% 0:9)) {
        throw("EXPECTED value GOT ", token)
      } else {
        j2r(token)
      }
    }
    
    parse_object <- function() {
      res <- structure(list(), names = character())
      
      read_token()
      
      ## Invariant: we are at the beginning of an element
      while (token != "}") {
        
        ## "key"
        if (grepl('^".*"$', token)) {
          key <- j2r(token)
        } else {
          throw("EXPECTED string GOT ", token)
        }
        
        ## :
        read_token()
        if (token != ":") { throw("EXPECTED : GOT ", token) }
        
        ## value
        read_token()
        res[key] <- list(parse_value())
        
        ## } or ,
        read_token()
        if (token == "}") {
          break
        } else if (token != ",") {
          throw("EXPECTED , or } GOT ", token)
        }
        read_token()
      }
      
      res
    }
    
    parse_array <- function() {
      res <- list()
      
      read_token()
      
      ## Invariant: we are at the beginning of an element
      while (token != "]") {
        ## value
        res <- c(res, list(parse_value()))
        
        ## ] or ,
        read_token()
        if (token == "]") {
          break
        } else if (token != ",") {
          throw("EXPECTED , GOT ", token)
        }
        read_token()
      }
      
      res
    }
    
    read_token()
    parse_value(tokens)
  }
  
  j2r <- function(token) {
    if (token == "null") {
      NULL
    } else if (token == "true") {
      TRUE
    } else if (token == "false") {
      FALSE
    } else if (grepl('^".*"$', token)) {
      trimq(token)
    } else {
      as.numeric(token)
    }
  }
  
  trimq <- function(x) {
    sub('^"(.*)"$', "\\1", x)
  }
  
  parse_deps <- function(string) {
    if (is.null(string)) return()
    stopifnot(is.character(string), length(string) == 1)
    if (grepl("^\\s*$", string)) return()
    
    pieces <- strsplit(string, ",")[[1]]
    
    # Get the names
    names <- gsub("\\s*\\(.*?\\)", "", pieces)
    names <- gsub("^\\s+|\\s+$", "", names)
    
    # Get the versions and comparison operators
    versions_str <- pieces
    have_version <- grepl("\\(.*\\)", versions_str)
    versions_str[!have_version] <- NA
    
    compare  <- sub(".*\\((\\S+)\\s+.*\\)", "\\1", versions_str)
    versions <- sub(".*\\(\\S+\\s+(.*)\\)", "\\1", versions_str)
    
    # Check that non-NA comparison operators are valid
    compare_nna   <- compare[!is.na(compare)]
    compare_valid <- compare_nna %in% c(">", ">=", "==", "<=", "<")
    if(!all(compare_valid)) {
      stop("Invalid comparison operator in dependency: ",
           paste(compare_nna[!compare_valid], collapse = ", "))
    }
    
    deps <- data.frame(name = names, compare = compare,
                       version = versions, stringsAsFactors = FALSE)
    
    # Remove R dependency
    deps[names != "R", ]
  }
  
  load_pkg_description <- function(path) {
    
    path <- normalizePath(path)
    
    if (!is_dir(path)) {
      dir <- tempfile()
      path_desc <- untar_description(path, dir = dir)
      on.exit(unlink(dir, recursive = TRUE))
      
    } else {
      path_desc <- file.path(path, "DESCRIPTION")
    }
    
    desc <- read_dcf(path_desc)
    names(desc) <- tolower(names(desc))
    desc$path <- path
    
    desc
  }
  
  system_check <- function(command, args = character(), quiet = TRUE,
                           error = TRUE, path = ".") {
    
    out <- tempfile()
    err <- tempfile()
    on.exit(unlink(out), add = TRUE)
    on.exit(unlink(err), add = TRUE)
    
    ## We suppress warnings, they are given if the command
    ## exits with a non-zero status
    res <- in_dir(
      path,
      suppressWarnings(
        system2(command, args = args, stdout = out, stderr = err)
      )
    )
    
    res <- list(
      stdout = tryCatch(
        suppressWarnings(win2unix(read_char(out))),
        error = function(e) ""
      ),
      stderr = tryCatch(
        suppressWarnings(win2unix(read_char(err))),
        error = function(e) ""
      ),
      status = res
    )
    
    if (error && res$status != 0) {
      stop("Command ", command, " failed ", res$stderr)
    }
    
    if (! quiet) {
      if (! identical(res$stdout, NA_character_)) cat(res$stdout)
      if (! identical(res$stderr, NA_character_)) cat(res$stderr)
    }
    
    res
  }
  
  win2unix <- function(str) {
    gsub("\r\n", "\n", str, fixed = TRUE)
  }
  
  read_char <- function(path, ...) {
    readChar(path, nchars = file.info(path)$size, ...)
  }
  
  `%||%` <- function (a, b) if (!is.null(a)) a else b
  
  `%:::%` <- function (p, f) get(f, envir = asNamespace(p))
  
  `%::%` <- function (p, f) get(f, envir = asNamespace(p))
  
  viapply <- function(X, FUN, ..., USE.NAMES = TRUE) {
    vapply(X, FUN, integer(1L), ..., USE.NAMES = USE.NAMES)
  }
  
  is_bioconductor <- function(x) {
    !is.null(x$biocviews)
  }
  
  trim_ws <- function(x) {
    gsub("^[[:space:]]+|[[:space:]]+$", "", x)
  }
  
  set_envvar <- function(envs) {
    if (length(envs) == 0) return()
    
    stopifnot(is.named(envs))
    
    old <- Sys.getenv(names(envs), names = TRUE, unset = NA)
    set <- !is.na(envs)
    
    both_set <- set & !is.na(old)
    
    if (any(set))  do.call("Sys.setenv", as.list(envs[set]))
    if (any(!set)) Sys.unsetenv(names(envs)[!set])
    
    invisible(old)
  }
  
  with_envvar <- function(new, code) {
    old <- set_envvar(new)
    on.exit(set_envvar(old))
    force(code)
  }
  
  is.named <- function(x) {
    !is.null(names(x)) && all(names(x) != "")
  }
  
  pkg_installed <- function(pkg) {
    
    if (pkg %in% loadedNamespaces()) {
      TRUE
    } else if (requireNamespace(pkg, quietly = TRUE)) {
      try(unloadNamespace(pkg))
      TRUE
    } else {
      FALSE
    }
  }
  
  has_package <- function(pkg) {
    if (pkg %in% loadedNamespaces()) {
      TRUE
    } else {
      requireNamespace(pkg, quietly = TRUE)
    }
  }
  
  with_something <- function(set, reset = set) {
    function(new, code) {
      old <- set(new)
      on.exit(reset(old))
      force(code)
    }
  }
  
  in_dir <- with_something(setwd)
  
  get_r_version <- function() {
    paste(R.version$major, sep = ".", R.version$minor)
  }
  
  set_libpaths <- function(paths) {
    old <- .libPaths()
    .libPaths(paths)
    invisible(old)
  }
  
  with_libpaths <- with_something(set_libpaths, .libPaths)
  
  ## There are two kinds of tar on windows, one needs --force-local
  ## not to interpret : characters, the other does not. We try both ways.
  
  untar <- function(tarfile, ...) {
    if (os_type() == "windows") {
      tryCatch(
        utils::untar(tarfile, extras = "--force-local", ...),
        error = function(e) utils::untar(tarfile, ...)
      )
      
    } else {
      utils::untar(tarfile, ...)
    }
  }
  
  os_type <- function() {
    .Platform$OS.type
  }
  
  sys_type <- function() {
    if (.Platform$OS.type == "windows") {
      "windows"
    } else if (Sys.info()["sysname"] == "Darwin") {
      "macos"
    } else if (Sys.info()["sysname"] == "Linux") {
      "linux"
    } else if (.Platform$OS.type == "unix") {
      "unix"
    } else {
      stop("Unknown OS")
    }
  }
  
  is_dir <- function(path) {
    file.info(path)$isdir
  }
  
  untar_description <- function(tarball, dir = tempfile()) {
    files <- untar(tarball, list = TRUE)
    desc <- grep("^[^/]+/DESCRIPTION$", files, value = TRUE)
    if (length(desc) < 1) stop("No 'DESCRIPTION' file in package")
    untar(tarball, desc, exdir = dir)
    file.path(dir, desc)
  }
  
  ## copied from rematch2@180fb61
  re_match <- function(text, pattern, perl = TRUE, ...) {
    
    stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern))
    text <- as.character(text)
    
    match <- regexpr(pattern, text, perl = perl, ...)
    
    start  <- as.vector(match)
    length <- attr(match, "match.length")
    end    <- start + length - 1L
    
    matchstr <- substring(text, start, end)
    matchstr[ start == -1 ] <- NA_character_
    
    res <- data.frame(
      stringsAsFactors = FALSE,
      .text = text,
      .match = matchstr
    )
    
    if (!is.null(attr(match, "capture.start"))) {
      
      gstart  <- attr(match, "capture.start")
      glength <- attr(match, "capture.length")
      gend    <- gstart + glength - 1L
      
      groupstr <- substring(text, gstart, gend)
      groupstr[ gstart == -1 ] <- NA_character_
      dim(groupstr) <- dim(gstart)
      
      res <- cbind(groupstr, res, stringsAsFactors = FALSE)
    }
    
    names(res) <- c(attr(match, "capture.names"), ".text", ".match")
    class(res) <- c("tbl_df", "tbl", class(res))
    res
  }
  
  
  install_github(...)
  
}