1+ # Acknowledgment
2+ # This function is based on the source code of the webshot2 package.
3+ # We would like to acknowledge and express our gratitude to the authors
4+ # and contributors of webshot2 for their valuable work in developing tools
5+ # for web content capture.
6+ #
7+ # In this implementation, we have adapted and modified parts of the original
8+ # webshot2 code to address an issue where PNG files were being generated as
9+ # empty images when used on Windows systems. Our modifications aim to improve
10+ # compatibility and ensure reliable output across different platforms.
11+ #
12+ # Reference:
13+ # webshot2 package: https://github.com/rstudio/webshot2
14+
15+ biblioShot <- function (
16+ url = NULL ,
17+ file = " biblioShot.png"
18+ vwidth = 992 ,
19+ vheight = 744 ,
20+ selector = NULL ,
21+ cliprect = NULL ,
22+ expand = NULL ,
23+ delay = 0.2 ,
24+ zoom = 1 ,
25+ useragent = NULL ,
26+ max_concurrent = getOption(" biblioShot.concurrent" default = 6 ),
27+ verbose = FALSE
28+ ) {
29+
30+ if (length(url ) == 0 ) {
31+ stop(" Need url."
32+ }
33+
34+ url <- vapply(url ,
35+ function (x ) {
36+ if (! is_url(x )) {
37+ file_url(x )
38+ } else {
39+ x
40+ }
41+ },
42+ character (1 )
43+ )
44+
45+ if (! is.null(cliprect ) && ! is.list(cliprect )) cliprect <- list (cliprect )
46+ if (! is.null(selector ) && ! is.list(selector )) selector <- list (selector )
47+ if (! is.null(expand ) && ! is.list(expand )) expand <- list (expand )
48+
49+ if (is.null(selector )) {
50+ selector <- " html"
51+ }
52+
53+ if (length(url ) > 1 && length(file ) == 1 ) {
54+ file <- vapply(1 : length(url ), FUN.VALUE = character (1 ), function (i ) {
55+ replacement <- sprintf(" %03d.\\ 1" i )
56+ gsub(" \\ .(.{3,4})$" replacement , file )
57+ })
58+ }
59+
60+ args_all <- list (
61+ url = url ,
62+ file = file ,
63+ vwidth = vwidth ,
64+ vheight = vheight ,
65+ selector = selector ,
66+ cliprect = cliprect ,
67+ expand = expand ,
68+ delay = delay ,
69+ zoom = zoom ,
70+ useragent = useragent ,
71+ verbose = verbose
72+ )
73+
74+ n_urls <- length(url )
75+ args_all <- mapply(args_all , names(args_all ),
76+ FUN = function (arg , name ) {
77+ if (length(arg ) == 0 ) {
78+ return (vector(mode = " list" n_urls ))
79+ } else if (length(arg ) == 1 ) {
80+ return (rep(arg , n_urls ))
81+ } else if (length(arg ) == n_urls ) {
82+ return (arg )
83+ } else {
84+ stop(" Argument `" name , " ` should be NULL, length 1, or same length as `url`."
85+ }
86+ },
87+ SIMPLIFY = FALSE
88+ )
89+
90+ args_all <- long_to_wide(args_all )
91+
92+ cm <- default_chromote_object()
93+
94+ # A list of promises for the screenshots
95+ res <- lapply(args_all ,
96+ function (args ) {
97+ new_session_screenshot(cm ,
98+ args $ url , args $ file , args $ vwidth , args $ vheight , args $ selector ,
99+ args $ cliprect , args $ expand , args $ delay , args $ zoom , args $ useragent ,
100+ verbose
101+ )
102+ }
103+ )
104+
105+ p <- promises :: promise_all(.list = res )
106+ res <- cm $ wait_for(p )
107+ res <- structure(unlist(res ), class = " webshot"
108+ res
109+ }
110+
111+
112+ new_session_screenshot <- function (
113+ chromote ,
114+ url ,
115+ file ,
116+ vwidth ,
117+ vheight ,
118+ selector ,
119+ cliprect ,
120+ expand ,
121+ delay ,
122+ zoom ,
123+ useragent ,
124+ verbose = FALSE
125+ ) {
126+
127+ filetype <- tolower(tools :: file_ext(file ))
128+ if (filetype != " png" && filetype != " pdf"
129+ stop(" File extension must be 'png' or 'pdf'"
130+ }
131+
132+ if (is.null(selector )) {
133+ selector <- " html"
134+ }
135+
136+ if (is.character(cliprect )) {
137+ if (cliprect == " viewport"
138+ cliprect <- c(0 , 0 , vwidth , vheight )
139+ } else {
140+ stop(" Invalid value for cliprect: " cliprect )
141+ }
142+ } else {
143+ if (! is.null(cliprect ) && ! (is.numeric(cliprect ) && length(cliprect ) == 4 )) {
144+ stop(" `cliprect` must be a vector with four numbers, or a list of such vectors"
145+ }
146+ }
147+
148+ s <- NULL
149+
150+ p <- chromote $ new_session(wait_ = FALSE ,
151+ width = vwidth ,
152+ height = vheight
153+ )$
154+ then(function (session ) {
155+ s <<- session
156+
157+ if (! is.null(useragent )) {
158+ s $ Network $ setUserAgentOverride(userAgent = useragent )
159+ }
160+ res <- s $ Page $ loadEventFired(wait_ = FALSE )
161+ s $ Page $ navigate(url , wait_ = FALSE )
162+ res
163+ })$
164+ then(function (value ) {
165+ if (delay > 0 ) {
166+ promises :: promise(function (resolve , reject ) {
167+ later :: later(
168+ function () {
169+ resolve(value )
170+ },
171+ delay
172+ )
173+ })
174+ } else {
175+ value
176+ }
177+ })$
178+ then(function (value ) {
179+ if (filetype == " png"
180+ s $ screenshot(
181+ filename = file , selector = selector , cliprect = cliprect ,
182+ expand = expand , scale = zoom ,
183+ show = FALSE , wait_ = FALSE
184+ )
185+
186+ } else if (filetype == " pdf"
187+ s $ screenshot_pdf(filename = file , wait_ = FALSE )
188+ }
189+ })$
190+ then(function (value ) {
191+ if (verbose ) message(url , " screenshot completed"
192+ normalizePath(value )
193+ })$
194+ finally(function () {
195+ s $ close()
196+ })
197+
198+ p
199+ }
200+
201+ is_url <- function (x ) {
202+ grepl(" ^[a-zA-Z]+://" x )
203+ }
204+
205+ # Given the path to a file, return a file:// URL.
206+ file_url <- function (filename ) {
207+ if (is_windows()) {
208+ paste0(" file://" filename , mustWork = TRUE ))
209+ } else {
210+ enc2utf8(paste0(" file:///" filename , winslash = " /" mustWork = TRUE )))
211+ }
212+ }
213+
214+ is_windows <- function () .Platform $ OS.type == " windows"
215+
216+ is_mac <- function () Sys.info()[[" sysname" == " Darwin"
217+
218+ is_linux <- function () Sys.info()[[" sysname" == " Linux"
219+
220+ long_to_wide <- function (x ) {
221+ if (length(x ) == 0 )
222+ return (x )
223+
224+ lapply(seq_along(x [[1 ]]), function (n ) {
225+ lapply(stats :: setNames(names(x ), names(x )), function (name ) {
226+ x [[name ]][[n ]]
227+ })
228+ })
229+ }
0 commit comments