|
| 1 | + |
| 2 | +stopIfInvalidDate <- function(snapshotDate){ |
| 3 | + if(missing(snapshotDate) || is.null(snapshotDate)) |
| 4 | + stop("You have to specify a snapshotDate", call. = FALSE) |
| 5 | + if(!grepl("^\\d{4}-\\d{2}-\\d{2}$", snapshotDate)) |
| 6 | + stop("snapshotDate must be a valid date using format YYYY-MM-DD", call. = FALSE) |
| 7 | + if(as.Date(snapshotDate) < as.Date("2014-09-17")) |
| 8 | + stop("Snapshots are only available after 2014-09-17", call. = FALSE) |
| 9 | + if(as.Date(snapshotDate) > Sys.Date()) |
| 10 | + stop("snapshotDate can not be in the future!", call. = FALSE) |
| 11 | + |
| 12 | +} |
| 13 | + |
| 14 | +testHttps <- function(https){ |
| 15 | + tf = tempfile() |
| 16 | + dir.create(tf) |
| 17 | + on.exit(unlink(tf)) |
| 18 | + testpkg = "memoise" |
| 19 | + repos <- paste0(https, "snapshot/2014-09-12/") |
| 20 | + tryCatch(utils::install.packages(testpkg, lib = tf, |
| 21 | + repos = repos , |
| 22 | + dependencies = FALSE, |
| 23 | + type = "source", |
| 24 | + quiet = TRUE)) |
| 25 | + if(testpkg %in% names(installed.packages(lib.loc = tf)[, "Package"])) { |
| 26 | + TRUE |
| 27 | + } else { |
| 28 | + FALSE |
| 29 | + } |
| 30 | +} |
| 31 | + |
| 32 | +mranUrlDefault <- function(){ |
| 33 | + http = "http://mran.revolutionanalytics.com/" |
| 34 | + https = gsub("http://", replacement = "https://", http) |
| 35 | + if(getRversion() >= "3.2.0") { |
| 36 | + if(testHttps(https)) https else http |
| 37 | + } else { |
| 38 | + http |
| 39 | + } |
| 40 | +} |
| 41 | + |
| 42 | +getDownloadOption <- function(){ |
| 43 | + getOption("download.file.method") |
| 44 | +} |
| 45 | + |
| 46 | + |
| 47 | +isHttpsUrl <- function(url){ |
| 48 | + grepl("^https://", url) |
| 49 | +} |
| 50 | + |
| 51 | +setDownloadOption <- function(mranUrl){ |
| 52 | + |
| 53 | +# is.recent = getRversion() >= "3.2.2" |
| 54 | +# is.unix = .Platform$OS.type == "unix" |
| 55 | + is.os.x = length(grep(pattern = "darwin", R.version$os)) > 0 |
| 56 | +# is.win = .Platform$OS.type == "windows" |
| 57 | + |
| 58 | + method <- if(isHttpsUrl(mranUrl)){ |
| 59 | + switch(.Platform$OS.type, |
| 60 | + windows = "wininet", |
| 61 | + unix = if(capabilities("libcurl")) "libcurl" else "wget" |
| 62 | + ) |
| 63 | + } else { |
| 64 | + switch(.Platform$OS.type, |
| 65 | + windows = {utils::setInternet2(TRUE); "wininet"}, |
| 66 | + unix = if(is.os.x) "curl" else "wget" |
| 67 | + ) |
| 68 | + } |
| 69 | + |
| 70 | + options(download.file.method = method, url.method = method) |
| 71 | +} |
| 72 | + |
| 73 | +resetDownloadOption <- function(opts){ |
| 74 | + options(opts) |
| 75 | +} |
| 76 | + |
| 77 | + |
| 78 | +# ------------------------------------------------------------------------ |
| 79 | + |
| 80 | +mranUrl <- function(){ |
| 81 | + url <- getOption("checkpoint.mranUrl") |
| 82 | + url <- if(is.null(url)) mranUrlDefault() else url |
| 83 | + url <- gsub("snapshot/*$", "", url) |
| 84 | + if(substring(url, nchar(url)) != "/") url <- paste0(url, "/") |
| 85 | + |
| 86 | + paste0(url, "snapshot/") |
| 87 | +} |
| 88 | + |
| 89 | + |
| 90 | + |
| 91 | +setCheckpointUrl <- function(url){ |
| 92 | + options("checkpoint.mranUrl" = url) |
| 93 | +} |
| 94 | + |
| 95 | + |
| 96 | +# ------------------------------------------------------------------------ |
| 97 | + |
| 98 | + |
| 99 | + |
| 100 | +#' Read list of available snapshot dates from MRAN url. |
| 101 | +#' |
| 102 | +#' @param mranRootUrl URL of MRAN root, e.g. \code{"http://mran.revolutionanalytics.com/snapshot/"} |
| 103 | +#' |
| 104 | +#' @importFrom xml2 read_xml xml_find_all xml_text |
| 105 | +#' @export |
| 106 | +getValidSnapshots <- function(mranRootUrl = mranUrl()){ |
| 107 | + opts <- setDownloadOption(mranRootUrl) |
| 108 | + on.exit(resetDownloadOption(opts)) |
| 109 | + text <- tryCatch(suppressWarnings(read_xml(mranRootUrl, as_html = TRUE)), error=function(e)e) |
| 110 | + if(inherits(text, "error")) { |
| 111 | + stop(sprintf("Unable to download from MRAN: %s", text$message)) |
| 112 | + } |
| 113 | + links <- xml_find_all(text, "//a") |
| 114 | + dates <- xml_text(links) |
| 115 | + idx <- grep("\\d{4}-\\d{2}-\\d{2}/", dates) |
| 116 | + gsub("/$", "", dates[idx]) |
| 117 | +} |
| 118 | + |
| 119 | + |
| 120 | +# ------------------------------------------------------------------------ |
| 121 | + |
| 122 | +getSnapshotUrl <- function(snapshotDate, mranRootUrl = mranUrl()){ |
| 123 | + |
| 124 | + opts <- setDownloadOption(mranRootUrl) |
| 125 | + on.exit(resetDownloadOption(opts)) |
| 126 | + mran.root = url(mranRootUrl) |
| 127 | + snapshot.url = paste(gsub("/$", "", mranRootUrl), snapshotDate, sep = "/") |
| 128 | + on.exit(close(mran.root)) |
| 129 | + res <- tryCatch( |
| 130 | + suppressWarnings(readLines(mran.root)), |
| 131 | + error = function(e) e |
| 132 | + ) |
| 133 | + if(inherits(res, "error")) { |
| 134 | + warning("Unable to reach MRAN root at ", mranRootUrl, call. = FALSE) |
| 135 | + return(snapshot.url) |
| 136 | + } |
| 137 | + |
| 138 | + con = url(snapshot.url) |
| 139 | + on.exit(close(con), add = TRUE) |
| 140 | + res <- tryCatch( |
| 141 | + suppressWarnings(readLines(con)), |
| 142 | + error = function(e) e |
| 143 | + ) |
| 144 | + if(inherits(res, "error")) { |
| 145 | + warning("Unable to find snapshot on MRAN at ", snapshot.url, call. = FALSE) |
| 146 | + return(snapshot.url) |
| 147 | + } |
| 148 | + snapshot.url |
| 149 | +} |
| 150 | + |
0 commit comments