forked from r-lib/usethis
/
browse.R
153 lines (132 loc) · 4.36 KB
/
browse.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
#' Quickly browse to important package webpages
#'
#' These functions take you to various webpages associated with a package and
#' return the target URL invisibly. Some URLs are formed from first principles
#' and there is no guarantee there will be content at the destination.
#' @details
#'
#' * `browse_github()`: Looks for a GitHub URL in the URL field of
#' `DESCRIPTION`.
#' * `browse_github_issues()`: Visits the GitHub Issues index or one specific
#' issue.
#' * `browse_github_pulls()`: Visits the GitHub Pull Request index or one
#' specific pull request.
#' * `browse_travis()`: Visits the package's page on [Travis
#' CI](https://travis-ci.org).
#' * `browse_cran()`: Visits the package on CRAN, via the canonical URL.
#'
#' @param package Name of package; leave as `NULL` to use current package
#' @param number For GitHub issues and pull requests. Can be a number or
#' `"new"`.
#' @examples
#' browse_github("gh")
#' browse_github_issues("backports")
#' browse_github_issues("backports", 1)
#' browse_github_pulls("rprojroot")
#' browse_github_pulls("rprojroot", 3)
#' browse_travis("usethis")
#' browse_cran("MASS")
#' @name browse-this
NULL
#' @export
#' @rdname browse-this
browse_github <- function(package = NULL) {
view_url(github_link(package))
}
#' @export
#' @rdname browse-this
browse_github_issues <- function(package = NULL, number = NULL) {
view_url(github_home(package), "issues", number)
}
#' @export
#' @rdname browse-this
browse_github_pulls <- function(package = NULL, number = NULL) {
pull <- if (is.null(number)) "pulls" else "pull"
view_url(github_home(package), pull, number)
}
#' @export
#' @rdname browse-this
#' @param ext Version of travis to use.
browse_travis <- function(package = NULL, ext = c("org", "com")) {
gh <- github_home(package)
ext <- rlang::arg_match(ext)
travis_url <- glue::glue("travis-ci.{ext}")
view_url(sub("github.com", travis_url, gh))
}
#' @export
#' @rdname browse-this
browse_cran <- function(package = NULL) {
view_url(cran_home(package))
}
## gets at most one GitHub link from the URL field of DESCRIPTION
## strips any trailing slash
## respects the URL given by maintainer, e.g.
## "https://github.com/simsem/semTools/wiki" <-- note the "wiki" part
## "https://github.com/r-lib/gh#readme" <-- note trailing "#readme"
github_link <- function(package = NULL) {
if (is.null(package)) {
desc <- desc::desc(proj_get())
} else {
desc <- desc::desc(package = package)
}
urls <- desc$get_urls()
gh_links <- grep("^https?://github.com/", urls, value = TRUE)
if (length(gh_links) == 0) {
ui_warn("
Package does not provide a GitHub URL.
Falling back to GitHub CRAN mirror")
return(glue("https://github.com/cran/{package}"))
}
gsub("/$", "", gh_links[[1]])
}
cran_home <- function(package = NULL) {
package <- package %||% project_name()
glue("https://cran.r-project.org/package={package}")
}
github_url_rx <- function() {
paste0(
"^",
"(?:https?://github.com/)",
"(?<owner>[^/]+)/",
"(?<repo>[^/#]+)",
"/?",
"(?<fragment>.*)",
"$"
)
}
## takes URL return by github_link() and strips it down to support
## appending path parts for issues or pull requests
## input: "https://github.com/simsem/semTools/wiki"
## output: "https://github.com/simsem/semTools"
## input: "https://github.com/r-lib/gh#readme"
## output: "https://github.com/r-lib/gh"
github_home <- function(package = NULL) {
gh_link <- github_link(package)
df <- re_match_inline(gh_link, github_url_rx())
glue("https://github.com/{df$owner}/{df$repo}")
}
## inline a simplified version of rematch2::re_match()
re_match_inline <- function(text, pattern) {
match <- regexpr(pattern, text, perl = TRUE)
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")
res
}