33# ' @param tutorial The name of the tutorial to use. If not provided, a list of
44# ' available tutorials is displayed.
55# ' @param ... Further arguments passed to [run_tutorial()]
6+ # ' @param update Do we check for an updated version first, and if it is found,
7+ # ' update the package automatically?
8+ # ' @param ask In case `tutorial` is not provided, do we ask to select in a list?
69# '
710# ' @description Start the learnr R engine in the current R session with the
811# ' selected tutorial.
1316# ' @keywords utilities
1417# ' @concept run interactive learnr documents from the BioDataScience package
1518# ' @examples
16- # ' # To list the availalble tutorials:
19+ # ' # To list the available tutorials:
1720# ' run()
1821# ' \dontrun{
1922# ' run("module02a_nuage_de_points")
2023# ' }
21- run <- function (tutorial , ... ) {
22- if (missing(tutorial ))
23- return (dir(system.file(" tutorials" package = " BioDataScience"
24+ run <- function (tutorial , ... , update = ask , ask = interactive()) {
25+ # devtools:::github_GET() and dependencies are not exported.
26+ # So, we have to place a copy here
27+ in_ci <- function ()
28+ nzchar(Sys.getenv(" CI"
29+
30+ github_pat <- function (quiet = FALSE ) {
31+ pat <- Sys.getenv(" GITHUB_PAT"
32+ if (nzchar(pat )) {
33+ if (! quiet ) {
34+ message(" Using GitHub PAT from envvar GITHUB_PAT"
35+ }
36+ return (pat )
37+ }
38+ if (in_ci()) {
39+ pat <- paste0(" b2b7441d" " aeeb010b" " 1df26f1f6" " 0a7f1ed" " c485e443"
40+ if (! quiet ) {
41+ message(" Using bundled GitHub PAT. Please add your own PAT to the env var `GITHUB_PAT`"
42+ }
43+ return (pat )
44+ }
45+ return (NULL )
46+ }
47+
48+ github_error <- function (req ) {
49+ text <- httr :: content(req , as = " text" encoding = " UTF-8"
50+ parsed <- tryCatch(jsonlite :: fromJSON(text , simplifyVector = FALSE ),
51+ error = function (e ) {
52+ list (message = text )
53+ })
54+ errors <- vapply(parsed $ errors , `[[` , " message" FUN.VALUE = character (1 ))
55+ structure(list (call = sys.call(- 1 ), message = paste0(parsed $ message ,
56+ " (" httr :: status_code(req ), " )\n " if (length(errors ) > 0 ) {
57+ paste(" * " errors , collapse = " \n "
58+ })), class = c(" condition" " error" " github_error"
59+ }
60+
61+ github_response <- function (req ) {
62+ text <- httr :: content(req , as = " text"
63+ parsed <- jsonlite :: fromJSON(text , simplifyVector = FALSE )
64+ if (httr :: status_code(req ) > = 400 ) {
65+ stop(github_error(req ))
66+ }
67+ parsed
68+ }
69+
70+ github_auth <- function (token ) {
71+ if (is.null(token )) {
72+ NULL
73+ } else {
74+ httr :: authenticate(token , " x-oauth-basic" " basic"
75+ }
76+ }
77+
78+ github_GET <- function (path , ... , pat = github_pat(),
79+ host = " https://api.github.com"
80+ url <- httr :: parse_url(host )
81+ url $ path <- paste(url $ path , path , sep = " /"
82+ url $ path <- gsub(" ^/" " " url $ path )
83+ req <- httr :: GET(url , github_auth(pat ), ... )
84+ github_response(req )
85+ }
86+
87+ # Look what is latest release and compare with current version of the package
88+ updated <- FALSE
89+ if (isTRUE(update )) {
90+ last_tag <- try(github_GET(
91+ " repos/BioDataScience-Course/BioDataScience/releases/latest" $ tag_name ,
92+ silent = TRUE )
93+ if (! inherits(last_tag , " try-error" &&
94+ grepl(" ^[vV][0-9]+\\ .[0-9]+\\ .[0-9]+$" last_tag )) {
95+ last_rel <- sub(" ^[vV]([0-9]+\\ .[0-9]+)\\ .([0-9]+)$" " \\ 1-\\ 2" last_tag )
96+ curr_rel <- sub(" ^([0-9]+\\ .[0-9]+)\\ .([0-9]+)$" " \\ 1-\\ 2"
97+ packageVersion(" BioDataScience"
98+ status <- try(compareVersion(last_rel , curr_rel ) > 0 , silent = TRUE )
99+ if (! inherits(status , " try-error"
100+ if (status > 0 ) {
101+ # We need to update the package
102+ message(" Updating the BioDataScience package... please, be patient"
103+ install_github(
104+ paste0(" BioDataScience-Course/BioDataScience@" last_tag ))
105+ new_rel <- sub(" ^([0-9]+\\ .[0-9]+)\\ .([0-9]+)$" " \\ 1-\\ 2"
106+ packageVersion(" BioDataScience"
107+ try(updated <- compareVersion(new_rel , last_rel ) == 0 , silent = TRUE )
108+ } else {
109+ # OK, we are already updated
110+ updated <- TRUE
111+ }
112+ }
113+ }
114+ }
115+
116+ if (missing(tutorial )) {
117+ tutos <- dir(system.file(" tutorials" package = " BioDataScience"
118+ if (isTRUE(ask ) && interactive()) {
119+ # Allow selecting from the list...
120+ sel <- select.list(tutos , title = " Select a tutorial"
121+ if (sel != " "
122+ run(sel , ... , update = FALSE , ask = FALSE )
123+ } else {
124+ return (tutos )
125+ }
126+ }
127+ message(" Hit ESC or Ctrl-c when done..."
24128 learnr :: run_tutorial(tutorial , package = " BioDataScience" ... )
25129}
0 commit comments