1## Do not edit this file manually. 2## It has been automatically generated from *.org sources. 3 4# TODO: krapka! 5.patch_latex <- function(txt){ # print(bibentry,"latex") inserts \bsl macros. 6 gsub("\\bsl{}", "", txt, fixed=TRUE) 7} 8 9## maybe add to package `gbutils'? 10## 11## if `wd' is a subdirectory of `string' return the path upto and including `string', 12## otherwise return NULL. 13## If not NULL, it is guaranteed that basename(wd) == string 14## NOTE: currently doesn't expand `./', etc.. 15in_subdirectory <- function(string, wd = getwd()){ 16 if(grepl(string, wd)){ 17 packpat <- paste0(string, "$") 18 while(!grepl(packpat, wd)){ 19 wd <- dirname(wd) 20 if(!grepl(string, wd)) 21 return(NULL) 22 } 23 if(basename(wd) == string) 24 wd 25 else 26 ## the found directory has `string' as a suffix, eg. xxxRdpack, not Rdpack 27 NULL 28 }else 29 NULL 30} 31 32get_bibentries <- function(..., package = NULL, bibfile = "REFERENCES.bib", 33 url_only = FALSE, stop_on_error = TRUE){ 34 if(is.null(package)){ 35 fn <- file.path(..., bibfile) 36 ## check for existence of fn (and length(fn) == 1)? (but see below) 37 }else{ 38 ## first check for development mode in "devtools" 39 40 ## if the current directory is under `package', first look for the file there 41 devdir <- in_subdirectory(package) 42 if(is.null(devdir)) 43 fn <- "" 44 else{ 45 ## if in development dir of `package', get it from there 46 fn <- file.path(devdir, "inst", ..., bibfile) 47 if(length(fn) > 1){ 48 warning("More than one file found, using the first one only.") 49 fn <- fn[1] 50 } 51 if(!file.exists(fn)) 52 fn <- "" 53 } 54 55 if(fn == "") 56 ## if the above didn't succeed, try system.file(). In principle, this should work 57 ## also in development mode under devtools, at least for REFERENCES.bib, 58 ## but currently devtools' system.file() doesn't handle it. 59 fn <- system.file(..., bibfile, package = package) 60 61 if(fn == "") 62 ## if the above didn't succeed try system.file() with subdir "inst". 63 ## This is really for the case when system.file() is the one from devtools, 64 ## see the note above. TODO: check if this is the case? 65 fn <- system.file("inst", ..., bibfile, package = package) 66 67 ## 2020-09-27 removing this functionality since package 'bibtex' ca no longer be 68 ## relied upon and was dropped from the dependencies. 69 ## 70 ## if(length(fn) == 1 && fn == "") 71 ## ## if system.file() didn't find the bib file, check if file package.bib is 72 ## ## provided by package "bibtex" (it is for core R packages, such as "base") 73 ## fn <- system.file("bib", sprintf("%s.bib", package), package = "bibtex") 74 } 75 76 if(length(fn) > 1){ 77 warning("More than one file found, using the first one only.") 78 fn <- fn[1] 79 }else if(length(fn) == 1 && fn == ""){ 80 msg <- paste0("Couldn't find file ", file.path(..., bibfile), 81 if(!is.null(package)) paste0(" in package `", package, "'")) 82 if(stop_on_error) 83 stop(msg) 84 else{ 85 warning(msg) 86 ## return an empty bibentryRd object 87 res <- bibentry() 88 class(res) <- c("bibentryRd", class(res)) 89 return(res) 90 } 91 } 92 93 ## 2018-10-03 94 ## use package's encoding if specified. 95 ## TODO: maybe this function should have argument 'encoding' 96 ## TODO: in principle the Rd file may have its own encoding, 97 ## but my current understanding is that parse_Rd() first converts it to UTF-8. 98 ## BUT what is the encoding of the strings in the object returned by read.bib? 99 encoding <- if(!is.null(package) && !is.null(utils::packageDescription(package)$Encoding)) 100 utils::packageDescription(package)$Encoding 101 else 102 "UTF-8" 103 104 ## 2020-09-22 switching to 'rbibutils 105 ## res <- read.bib(file = fn, encoding = encoding) 106 ## current: res <- readBib(file = fn, encoding = encoding) 107 ## test: 108 res <- if(packageVersion("rbibutils") > '2.2.4') 109 ## issue #7 in rbibutils 110 readBib(file = fn, encoding = encoding, direct = TRUE, texChars = "Rdpack") 111 else if(packageVersion("rbibutils") >= '2.1.2') 112 readBib(file = fn, encoding = encoding, direct = TRUE) 113 else 114 readBib(file = fn, encoding = encoding) 115 116 # 2018-03-10 commenting out 117 # since bibtex v. >= 0.4.0 has been required for a long time in DESCRIPTION 118 # 119 # ## 2016-07-26 Now do this only for versions of bibtex < '0.4.0'. 120 # ## From bibtex '0.4.0' read.bib() sets the names. 121 # if(packageVersion("bibtex") < '0.4.0'){ 122 # names(res) <- sapply(1:length(res), function(x) bibentry_key(res[[x]][[1]])) 123 # } 124 125 ## 2020-10-02 commenting out since taken care (hopefully) by readBib 126 ## 127 # for(nam in names(res)){ 128 # ## unconditionaly recode %'s in filed URL 129 # if(!is.null(res[nam]$url)) { 130 # res[nam]$url <- gsub("([^\\])%", "\\1\\\\%", res[nam]$url) 131 # } 132 # 133 # if(url_only){ # process also other fields 134 # ## TODO: currently all unescaped %'s in all fields are recoded; 135 # ## Maybe do it more selectively, e.g. only for %'s inside \url{}, 136 # ## or matching something like http(s):// 137 # fields <- names(unclass(res[nam])[[1]]) 138 # 139 # unclassed <- unclass(res[nam]) 140 # flag <- FALSE 141 # for(field in fields){ 142 # wrk <- unclass(res[nam])[[1]][[field]] 143 # if(is.character(wrk) && any(grepl("([^\\])%", wrk))){ 144 # flag <- TRUE 145 # unclassed[[1]][[field]] <- gsub("([^\\])%", "\\1\\\\%", wrk) 146 # } 147 # } 148 # if(flag){ 149 # class(unclassed) <- class(res[nam]) 150 # res[nam] <- unclassed 151 # } 152 # } 153 # } 154 155 ## new 2020-10-02 - allow \% in url's and doi's in the bib file 156 for(nam in names(res)){ # print(res[nam], style = "R") 157 ## unconditionaly recode %'s in filed URL 158 if(!is.null(res[nam]$doi)) { 159 res[nam]$doi <- gsub("([^\\\\])[\\\\]%", "\\1%", res[nam]$doi) 160 } 161 162 if(!is.null(res[nam]$url)) { 163 res[nam]$url <- gsub("([^\\\\])[\\\\]%", "\\1%", res[nam]$url) 164 } 165 166 # if(url_only){ # process also other fields 167 # ## TODO: currently all unescaped %'s in all fields are recoded; 168 # ## Maybe do it more selectively, e.g. only for %'s inside \url{}, 169 # ## or matching something like http(s):// 170 # fields <- names(unclass(res[nam])[[1]]) 171 # 172 # unclassed <- unclass(res[nam]) 173 # flag <- FALSE 174 # for(field in fields){ 175 # wrk <- unclass(res[nam])[[1]][[field]] 176 # if(is.character(wrk) && any(grepl("([^\\])%", wrk))){ 177 # flag <- TRUE 178 # unclassed[[1]][[field]] <- gsub("([^\\])%", "\\1\\\\%", wrk) 179 # } 180 # } 181 # if(flag){ 182 # class(unclassed) <- class(res[nam]) 183 # res[nam] <- unclassed 184 # } 185 # } 186 } 187 188 ## 2018-03-03 new: 189 class(res) <- c("bibentryRd", class(res)) 190 191 res 192} 193 194print.bibentryRd <- function (x, style = "text", ...){ 195 class(x) <- class(x)[-1] 196 ## TODO: It would be better to modify the entries and then call 197 ## print(), rather than vice versa as now. 198 res <- capture.output(print(x, style = style, ...)) 199 res <- switch(tolower(style), 200 r = gsub("\\\\\\\\%", "%", res), 201 citation = , 202 bibtex = gsub("\\\\%", "%", res), 203 204 res 205 ) 206 cat(res, sep = "\n") 207} 208 209rebib <- function(infile, outfile, ...){ # 2013-03-29 210 rdo <- permissive_parse_Rd(infile) ## 2017-11-25 TODO: argument for RdMacros! 211 212 if(missing(outfile)) 213 outfile <- basename(infile) 214 else if(identical(outfile, "")) # 2013-10-23 else clause is new 215 outfile <- infile 216 217 rdo <- inspect_Rdbib(rdo, ...) 218 219 Rdo2Rdf(rdo, file=outfile, srcfile=infile) 220 221 rdo 222} 223 224inspect_Rdbib <- function(rdo, force = FALSE, ...){ # 2013-03-29 225 # 2013-12-08 was: pos <- Rdo_locate_predefined_section(rdo, "\\references") 226 pos <- Rdo_which_tag_eq(rdo, "\\references") 227 228 if(length(pos) > 1) 229 stop(paste("Found", length(pos), "sections `references'.\n", 230 "There should be only one." 231 )) 232 else if(length(pos) == 0) # no section "references". 233 return(rdo) 234 235 bibs <- get_bibentries(...) 236 237 fkey <- function(x){ 238 m <- gregexpr("[ ]+", x) 239 rm <- regmatches(x, m, invert = TRUE)[[1]] 240 if(length(rm) >= 2 && rm[2] != "bibentry:") 241 rm[2] # e.g. bibentry:all 242 else if(length(rm) < 3) # % bibentry: xxx_key_xxx 243 "" # NA_character_ 244 else 245 rm[3] 246 } 247 248 fbib <- function(x) grepl("[ ]+bibentry:", x) 249 posbibs <- Rdo_locate(rdo[[pos]], f = fbib, pos_only = fkey) 250 poskeys <- sapply(posbibs, function(x) x$value) 251 252 print(posbibs) 253 254 fendkey <- function(x){ 255 m <- gregexpr("[ ]+", x) 256 rm <- regmatches(x, m, invert = TRUE)[[1]] 257 if(length(rm) >= 2 && rm[2] != "end:bibentry:") 258 rm[2] # e.g. end:bibentry:all 259 else if(length(rm) < 3) # % end:bibentry: xxx_key_xxx 260 "" # NA_character_ 261 else 262 rm[3] 263 } 264 265 fendbib <- function(x) grepl("end:bibentry:", x) 266 posendbibs <- Rdo_locate(rdo[[pos]], f = fendbib, pos_only = fendkey) 267 posendkeys <- sapply(posendbibs, function(x) x$value) 268 269 toomit <- which(poskeys %in% posendkeys) # note: en@bibkeys:all is different! todo: 270 if(length(toomit) > 0 && !force){ 271 poskeys <- poskeys[-toomit] 272 posbibs <- posbibs[-toomit] 273 } 274 275 if(length(poskeys)==0) 276 "nothing to do." 277 else if(any(poskeys == "bibentry:all")){ 278 poskey <- posbibs[[ which(poskeys == "bibentry:all") ]]$pos 279 280 ## 2021-04-29 TODO: the following line(s) needs to be replaced with 281 ## .toRd_styled(bibs[poskeys[i], ???) 282 ## For testing use REFERENCES.bib in rbibutils 283 ## (the doi's are currently rendered horribly) 284 ## DONE! was: 285 # bibstxt <- capture.output(print(bibs, "latex")) 286 # 287 # bibstxt <- .patch_latex(bibstxt) # TODO: krapka! 288 ## TODO: the bibstyles used beloww should probably be arguments 289 bibs <- sort(bibs, .bibstyle = "JSSRd") 290 bibstxt <- .toRd_styled(bibs, "Rdpack") 291 # bibstxt <- paste0(bibstxt, collapse = "\\cr\\cr ") 292 bibstxt <- paste0(bibstxt, collapse = "\n\n ") 293 294 bibstxt <- paste(c("", bibstxt), "\n", sep="") 295 endbibline <- Rdo_comment("% end:bibentry:all") 296 297 keyflag <- "end:bibentry:all" %in% posendkeys 298 if(keyflag && force){ #todo: more careful! 299 endposkey <- posendbibs[[ which(posendkeys == "end:bibentry:all") ]]$pos 300 rdo[[pos]] <- Rdo_flatremove(rdo[[pos]], poskey+1, endposkey) 301 } 302 303 if(!keyflag || force){ 304 rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], list(endbibline), poskey, 305 before = FALSE) 306 rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], bibstxt, poskey, 307 before = FALSE) 308 } 309 }else{ 310 for(i in length(poskeys):1){ 311 bibkey <- posbibs[[i]]$value 312 poskey <- posbibs[[i]]$pos 313 314 ## 2021-04-29 TODO: the following line(s) needs to be replaced with 315 ## .toRd_styled(bibs[poskeys[i], ???) 316 ## For testing use REFERENCES.bib in rbibutils 317 ## (the doi's are currently rendered horribly) 318 ## DONE! was: 319 # bibstxt <- capture.output(print(bibs[poskeys[i]],"latex")) 320 # 321 # bibstxt <- .patch_latex(bibstxt) # TODO: krapka! 322 bibstxt <- .toRd_styled(bibs[poskeys[i]], "Rdpack") 323 324 bibstxt <- list( paste( c("", bibstxt), "\n", sep="") ) 325 endbibline <- Rdo_comment(paste("% end:bibentry: ", bibkey)) 326 327 keyflag <- bibkey %in% posendkeys 328 if(keyflag && force){ #todo: more careful! 329 endposkey <- posendbibs[[ which(posendkeys == bibkey) ]]$pos 330 rdo[[pos]] <- Rdo_flatremove(rdo[[pos]], poskey+1, endposkey) 331 } 332 333 if(!keyflag || force){ # this is always TRUE here but is left for common look 334 # with "all". todo: needs consolidation 335 rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], list(endbibline), poskey, 336 before = FALSE) 337 rdo[[pos]] <- Rdo_flatinsert(rdo[[pos]], bibstxt, poskey, 338 before = FALSE) 339 } 340 } 341 } 342 343 rdo 344} 345 346Rdo_flatremove <- function(rdo, from, to){ # 2013-03-30 todo: more careful! 347 res <- rdo[-(from:to)] 348 attributes(res) <- attributes(rdo) # todo: more guarded copying of attributes? 349 res 350} 351 352 # todo: move to another file later 353Rdo_flatinsert <- function(rdo, val, pos, before = TRUE){ # 2013-03-29 354 depth <- length(pos) 355 if(depth > 1){ 356 rdo[[pos]] <- Recall(rdo[[ pos[-depth] ]], val, pos[-depth]) 357 # todo: dali zapazva attributite na rdo? 358 return(rdo) 359 } 360 361 n <- length(rdo) 362 if(!before) 363 pos <- pos + 1 364 365 res <- if(pos==1) c(val, rdo) 366 else if(pos==n+1) c(rdo, val) 367 else c( rdo[1:(pos-1)], val, rdo[pos:n]) 368 attributes(res) <- attributes(rdo) # todo: more guarded copying of attributes? 369 res 370} 371 372## 2020-11-01: use local() 373.bibs_cache <- local({ 374 ## initialise the cache 375 ## TODO: remove refsmat, it is not needed here, maybe 376 refsmat <- matrix(character(0), nrow = 0, ncol = 2) 377 allbibs <- list() 378 ## TODO: time stamp for auto clearing 379 380 .get_bibs0 <- function(package, ..., cached_env) { 381 if(is.null(package)) 382 stop("argument 'package' must be provided") 383 384 bibs <- allbibs[[package]] 385 if(is.null(bibs)){ 386 ## message(" bibs is NULL") 387 388 bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE) 389 allbibs[[package]] <<- bibs 390 } ## else 391 ## message(" bibs is nonNULL") 392 393 bibs 394 } 395 396 .get_all_bibs <- function(){ 397 allbibs 398 } 399 400 list(.get_bibs0 = .get_bibs0, .get_all_bibs = .get_all_bibs) 401}) 402 403## TODO: auto-deduce 'package'? 404## 2020-09-30: changing to cache bib as \insertCite does (new arg. cached_env, etc) 405insert_ref <- function(key, package = NULL, ..., cached_env = NULL) { 406 407 # 2020-09-30: replaced by a single call 408 # if(is.null(package)) 409 # stop("argument 'package' must be provided") 410 # 411 # bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE) 412 # 413 414 # TODO: this is for testing only! 415 # message("\nkey is ", key) 416 417 # if(is.null(cached_env)) 418 # message(" cached_env is NULL") 419 # else 420 # message(" cached_env is nonNULL") 421 422 bibs <- .bibs_cache$.get_bibs0(package, ..., cached_env = cached_env) 423 424 if(length(bibs) == 0){ 425 note <- paste0("\"Failed to insert reference with key = ", key, 426 " from package = '", package, "'.", 427 " Possible cause --- missing REFERENCES.bib in package '", 428 package, "' or '", package, "' not installed.\"" 429 ) 430 note <- paste0("\\Sexpr[results=rd,stage=install]{{warning(", note, ");", note, "}} ") 431 item <- bibentry( 432 bibtype = "Misc", 433 title = "Not avalable", 434 author = person("A", "Adummy"), 435 year = format(Sys.time(), "%Y"), 436 note = note, 437 key = key 438 ) 439 .toRd_styled(item, package) 440 }else if(length(key) == 1){ 441 item <- tryCatch(bibs[[key]], 442 warning = function(c) { 443 if(grepl("subscript out of bounds", c$message)){ 444 ## tell the user the offending key. 445 s <- paste0("possibly non-existing key '", key, "'") 446 c$message <- paste0(c$message, " (", s, ")") 447 } 448 warning(c) 449 # res <- paste0("\nWARNING: failed to insert reference '", key, 450 # "' from package '", package, "' - ", 451 # s, ".\n") 452 # return(res) 453 ## setup a dummy entry 454 bibentry( 455 bibtype = "Misc", 456 title = "Not avalable", 457 author = person("A", "Adummy"), 458 year = format(Sys.time(), "%Y"), 459 note = paste0("Failed to insert reference with key = ", key, 460 " from package = '", package, "'.", 461 " Possible cause --- missing or misspelled key." 462 ), 463 key = key 464 ) 465 }) 466 467 # # 2018-03-01 Bug: Unexpected END_OF_INPUT error (URL parsing?) #3 468 # # I don't know why toRd() doesn't do this... 469 # # 470 # # escape percents that are not preceded by backslash 471 # # (`if' is because in case of error above, item will be simply a string) 472 # 473 # Commenting out since get_bibentries() does it. 474 # if(inherits(item, "bibentry") && !is.null(item$url)) 475 # item$url <- gsub("([^\\])%", "\\1\\\\%", item$url) 476 477 # if(interactive()) browser() 478 479 # wrk <- .toRd_styled(item, package) # TODO: add styles? (doesn't seem feasible here) 480 # fn <- tempfile() 481 # cat(wrk, file = fn) 482 # res <- permissive_parse_Rd(fn) ## tools::parse_Rd(fn) 483 # tools::toRd(res) 484 # 485 # wrk <- .toRd_styled(item, package) 486 # Encoding(wrk) <- "bytes" 487 # wrk 488 # 489 .toRd_styled(item, package) 490 }else{ 491 ## key is documented to be of length one, nevertheless handle it too 492 kiki <- FALSE 493 items <- withCallingHandlers(bibs[[key]], warning = function(w) {kiki <<- TRUE}) 494 ## TODO: deal with URL's as above 495 txt <- .toRd_styled(items, package) 496 497 if(kiki){ # warning(s) in bibs[[key]] 498 s <- paste0("WARNING: failed to insert ", 499 "one or more of the following keys in REFERENCES.bib:\n", 500 paste(key, collapse = ", \n"), ".") 501 warning(s) 502 txt <- c(txt, s) 503 } 504 paste0(paste(txt, collapse = "\n\n"), "\n") 505 } 506} 507 508## 2017-11-25 new 509## see utils:::print.help_files_with_topic() 510viewRd <- function(infile, type = getOption("help_type"), stages = NULL){ 511 infile <- normalizePath(infile) 512 513 if(is.null(type)) 514 type <- "text" 515 else if(!is.character(type) || length(type) != 1) 516 stop("'type' should be 'html' or 'text'") 517 518 if(is.null(stages)) 519 # stages <- c("install", "render") 520 stages <- c("build", "install", "render") 521 # stages <- c("build", "render") 522 else if(!is.character(stages) || !all(stages %in% c("build", "install", "render"))) 523 stop('stages must be a character vector containing one or more of the strings "build", "install", and "render"') 524 525 pkgname <- basename(dirname(dirname(infile))) 526 outfile <- tempfile(fileext = paste0(".", type)) 527 ## 2020-05-19: added pkgdir to read also current package macros, see below 528 pkgdir <- dirname(dirname(infile)) 529 530 ## here we need to expand the Rd macros, so don't use permissive_parse_Rd() 531 ## 2020-05-19: read also the macros from pkgdir, 532 ## load those from Rdpack anyway, in case Rdpack is not in 'DESCRIPTION' yet 533 ## TODO: could issue warning here but this could be intrusive here since 534 ## the user may not need Rdpack for the current package. 535 e <- tools::loadPkgRdMacros(system.file(package = "Rdpack")) 536 e <- tools::loadPkgRdMacros(pkgdir, macros = e) 537 ## finally load the Rd system macros (though I haven't noticed errors without this step). 538 e <- tools::loadRdMacros(file.path(R.home("share"), "Rd", "macros", "system.Rd"), 539 macros = e) 540 541 ## check if mathjaxr is needed 542 descpath <- file.path(pkgdir, "DESCRIPTION") 543 need_mathjaxr <- 544 if(file.exists(descpath)){ 545 ## rdmac is NA if there is no RDMacros field in DESCRIPTION 546 rdmac <- as.character(read.dcf(descpath, fields = "RdMacros")) 547 grepl("mathjaxr", as.character(rdmac)) 548 }else{ 549 ## try installed package 550 pkgdesc <- packageDescription(pkgname) 551 !is.null(pkgdesc$RdMacros) && grepl("mathjaxr",pkgdesc$RdMacros) 552 } 553 ## this loads mathjax from CDN, so internet connection needed 554 if(need_mathjaxr){ 555 ## code borrowed from package "mathjaxr" 556 mjcdn <- Sys.getenv("MATHJAXR_USECDN") 557 on.exit(Sys.setenv(MATHJAXR_USECDN = mjcdn)) 558 Sys.setenv(MATHJAXR_USECDN = "TRUE") 559 } 560 561 ## Rdo <- parse_Rd(infile, macros = e) 562 563 ## can't do this (the file may be deleted before the browser opens it): 564 ## on.exit(unlink(outfile)) 565 switch(type, 566 text = { 567 temp <- tools::Rd2txt(infile, # was: Rdo, 568 out = outfile, package = pkgname, stages = stages 569 , macros = e) 570 file.show(temp, delete.file = TRUE) # text file is deleted 571 }, 572 html = { 573 temp <- tools::Rd2HTML(infile, # was: Rdo, 574 out = outfile, package = pkgname, 575 stages = stages 576 , macros = e) 577 browseURL(temp) 578 ## html file is not deleted 579 }, 580 stop("'type' should be one of 'text' or 'html'") 581 ) 582} 583 584## temporary; not exported 585vigbib <- function(package, verbose = TRUE, ..., vig = NULL){ 586 if(!is.null(vig)) 587 return(makeVignetteReference(package, vig, ...)) 588 589 vigs <- vignette(package = package) 590 if(nrow(vigs$results) == 0){ 591 if(verbose) 592 cat("No vignettes found in package ", package, "\n") 593 return(bibentry()) 594 } 595 wrk <- lapply(seq_len(nrow(vigs$results)), 596 function(x) makeVignetteReference(package = package, vig = x, 597 verbose = FALSE, ...) 598 ) 599 res <- do.call("c", wrk) 600 if(verbose) 601 print(res, style = "Bibtex") 602 invisible(res) 603} 604 605makeVignetteReference <- function(package, vig = 1, verbose = TRUE, 606 title, author, type = "pdf", 607 bibtype = "Article", key = NULL 608 ){ 609 publisher <- NULL # todo: turn this into an argument some day ... 610 611 if(missing(package)) 612 stop("argument 'package' is missing with no default") 613 614 cranname <- "CRAN" 615 cran <- "https://CRAN.R-Project.org" 616 cranpack <- paste0(cran, "/package=", package) 617 618 ## todo: for now only cran 619 if(is.null(publisher)){ 620 publisher <- cran 621 publishername <- cranname 622 publisherpack <- cranpack 623 } 624 625 desc <- packageDescription(package) 626 vigs <- vignette(package = package) 627 628 if(is.character(vig)){ 629 vig <- pmatch(vig, vigs$results[ , "Item"]) 630 if(length(vig) == 1 && !is.na(vig)){ 631 wrk <- vigs$results[vig, "Title"] 632 }else 633 stop(paste0( 634 "'vig' must (partially) match one of:\n", 635 paste0("\t", 1:nrow(vigs$results), " ", vigs$results[ , "Item"], "\n", 636 collapse = "\n"), 637 "Alternatively, 'vig' can be the index printed in front of the name above.")) 638 }else if(1 <= vig && vig <= nrow(vigs$results)){ 639 wrk <- vigs$results[vig, "Title"] 640 }else{ 641 stop("not ready yet, should return all vigs in the package.") 642 } 643 644 if(missing(author)) 645 author <- desc$Author 646 647 title <- gsub(" \\([^)]*\\)$", "", wrk) # drop ' (source, pdf)' 648 item <- vigs$results[vig, "Item"] 649 vigfile <- paste0(item, ".", type) 650 651 journal <- paste0("URL ", publisherpack, ".", 652 " Vignette included in R package ", package, 653 ", version ", desc$Version 654 ) 655 656 if(is.null(desc$Date)){ # built-in packages do not have field "year" 657 if(grepl("^Part of R", desc$License[1])){ 658 ## title <- paste0(title, "(", desc$License, ")") 659 publisherpack <- cran ## do not add package=... to https in this case 660 journal <- paste0("URL ", publisherpack, ".", 661 " Vignette included in R package ", package, 662 " (", desc$License, ")" 663 ) 664 } 665 year <- R.version$year 666 }else 667 year <- substring(desc$Date, 1, 4) 668 669 # stop(paste0("argument 'vig' must be a charater string or an integer\n", 670 # "between 1 and the number of vignettes in the package")) 671 672 if(is.null(key)) 673 key <- paste0("vig", package, ":", vigs$results[vig, "Item"]) 674 675 res <- bibentry( 676 key = key, 677 bibtype = bibtype, 678 title = title, 679 author = author, 680 journal = journal, 681 year = year, 682 ## note = "R package version 1.3-4", 683 publisher = publishername, 684 url = publisherpack 685 ) 686 687 if(verbose){ 688 print(res, style = "Bibtex") 689 cat("\n") 690 } 691 res 692} 693 694## 2018-03-13 new 695insert_citeOnly <- function(keys, package = NULL, before = NULL, after = NULL, 696 bibpunct = NULL, ..., 697 cached_env = NULL, cite_only = FALSE, dont_cite = FALSE) { 698 if(!is.null(cached_env)){ 699 if(is.null(cached_env$refsmat)) 700 cached_env$refsmat <- matrix(character(0), nrow = 0, ncol = 2) 701 ## if(is.null(cached_env$allbibs)) 702 ## cached_env$allbibs <- list() 703 } 704 705 if(is.null(package)) 706 stop("argument 'package' must be provided") 707 708 if(length(keys) > 1) 709 stop("`keys' must be a character string") 710 711 if(!cite_only) 712 cached_env$refsmat <- rbind(cached_env$refsmat, c(keys, package)) 713 714 if(dont_cite) 715 return(character(0)) 716 717 718 textual <- grepl(";textual$", keys) 719 if(textual) 720 keys <- gsub(";textual$", "", keys) 721 722 if(grepl("[^a-zA-Z.0-9]", package)){ 723 delims <- gsub("[a-zA-Z.0-9]", "", package) 724 ch <- substr(delims, 1, 1) 725 wrk <- strsplit(package, ch, fixed = TRUE)[[1]] # note: [[1]] 726 package <- wrk[1] 727 if(length(wrk) > 1){ 728 if(nchar(wrk[2]) > 1 || nchar(wrk[2]) == 1 && wrk[2] != " ") 729 before <- wrk[2] 730 if(length(wrk) > 2 && (nchar(wrk[3]) > 1 || nchar(wrk[3]) == 1 && wrk[3] != " ")) 731 after <- wrk[3] 732 } 733 } 734 735 # 2020-11-05 was: 736 # 737 # if(is.null(cached_env)){ 738 # bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE) 739 # }else{ 740 # bibs <- cached_env$allbibs[[package]] 741 # if(is.null(bibs)){ 742 # bibs <- get_bibentries(package = package, ..., stop_on_error = FALSE) 743 # cached_env$allbibs[[package]] <- bibs 744 # } 745 # } 746 # 747 bibs <- .bibs_cache$.get_bibs0(package, ..., cached_env = cached_env) 748 749 # This wouldn't work since roxygen2 will change it to citation 750 # TODO: check 751 # if(substr(keys, 1, 1) == "["){ # rmarkdown syntax (actually roxygen2?) 752 # keys <- substr(keys, 2, nchar(keys) - 1) # drop "[" and the closing "]" 753 # splitkeys <- strsplit(keys, ";", fixed = TRUE)[[1]] # note: [[1]] 754 # 755 # 756 # 757 # } 758 759 refch <- "@" 760 refchpat <- paste0("^[", refch, "]") 761 if(grepl(refchpat, keys)){ 762 ch <- substr(keys, 1, 1) # 'ch' is not used currently 763 keys <- substr(keys, 2, nchar(keys)) # drop refch 764 ## TODO: check if there are still @'s at this point 765 766 refpat <- paste0("(", refch, "[^;,()[:space:]]+)") # "(@[^;,[:space:]]+)" 767 if(textual){ 768 wrkkeys <- strsplit(keys, "@")[[1]] # note [[1]] !!! 769 770 ## the last key is special, since there is none after it 771 nk <- length(wrkkeys) 772 wrkkeys[nk] <- if(grepl("[;,]$", wrkkeys[nk])) 773 sub("([;,])$", ")\\1", wrkkeys[nk]) 774 else 775 paste0(wrkkeys[nk], ")") 776 777 ## the 2nd element contains the first key even if the string starts with '@' 778 ## (if that is the case the first string is "") 779 if(nk > 2){ 780 for(i in 2:(nk - 1)){ 781 wrkkeys[i] <- if(grepl("([;,][^;,]*)$", wrkkeys[i])) 782 sub("([;,][^;,]*)$", ")\\1" , wrkkeys[i]) 783 else 784 sub("^([^;,()[:space:]]+)", "\\1)" , wrkkeys[i]) 785 } 786 } 787 keys <- paste0(wrkkeys, collapse = refch) 788 } 789 790 m <- gregexpr(refpat, keys) 791 allkeys <- regmatches(keys, m)[[1]] # note: [[1]] 792 allkeys <- gsub(refch, "", allkeys) 793 794 if(textual){ 795 bibpunct0 = c("(", ")", ";", "a", "", ",") 796 if(!is.null(bibpunct)){ 797 if(length(bibpunct) < length(bibpunct0)) 798 bibpunct <- c(bibpunct, bibpunct0[-seq_len(length(bibpunct))]) 799 ind <- which(is.na(bibpunct)) 800 if(length(ind) > 0) 801 bibpunct[ind] <- bibpunct0[ind] 802 }else 803 bibpunct <- bibpunct0 804 }else{ 805 ## for now ignore bibpunct in this case 806 bibpunct <- c("", "", ";", "a", "", ",") 807 } 808 809 refs <- sapply(allkeys, 810 function(key) 811 safe_cite(key, bibs, textual = textual, bibpunct = bibpunct, 812 from.package = package) 813 ) 814 if(textual){ 815 ## drop ")" - strong assumption that that is the last char 816 refs <- sapply(refs, function(s) substr(s, 1, nchar(s) - 1)) 817 } 818 819 ## replace keys with citations 820 text <- keys 821 regmatches(text, m) <- list(refs) 822 823 if(!textual) # 2018-03-28 don't put patentheses in textual mode 824 text <- paste0("(", text, ")") 825 }else{ 826 if(is.null(bibpunct)) 827 text <- safe_cite(keys, bibs, textual = textual, before = before, after = after 828 , from.package = package) 829 else{ 830 bibpunct0 = c("(", ")", ";", "a", "", ",") 831 if(length(bibpunct) < length(bibpunct0)) 832 bibpunct <- c(bibpunct, bibpunct0[-seq_len(length(bibpunct))]) 833 ind <- which(is.na(bibpunct)) 834 if(length(ind) > 0) 835 bibpunct[ind] <- bibpunct0[ind] 836 837 text <- safe_cite(keys, bibs, textual = textual, before = before, after = after, 838 bibpunct = bibpunct, from.package = package) 839 } 840 } 841 842 toRd(text) 843} 844 845safe_cite <- function(keys, bib, ..., from.package = NULL){ 846 wrk.keys <- unlist(strsplit(keys, ",")) 847 if(!all(wrk.keys %in% names(bib))){ 848 ok <- wrk.keys %in% names(bib) 849 miss.keys <- wrk.keys[!ok] 850 warning("possibly non-existing or duplicated key(s)", 851 if(!is.null(from.package)) 852 paste0(" in bib file from package '", from.package, "'"), 853 ":\n ", paste(miss.keys, sep = ", "), "\n") 854 855 keys <- wrk.keys[ok] 856 } 857 858 # 2018-06-02 was: cite(keys = keys, bib = bib, ...) 859 cite(keys = keys, bib = bib, longnamesfirst = FALSE, ...) 860} 861 862insert_all_ref <- function(refs, style = ""){ 863 if(is.environment(refs)){ 864 refsmat <- refs$refsmat 865 allbibs <- .bibs_cache$.get_all_bibs() # 2020-11-05 was: refs$allbibs 866 if(is.null(allbibs)) ## TODO: this can be removed, since .get_all_bibs() 867 allbibs <- list() ## returns an initialised list() 868 }else{ 869 refsmat <- refs 870 allbibs <- list() 871 } 872 873 if(is.null(refs) || is.null(refsmat) || nrow(refsmat) == 0) 874 ## Returning the empty string is probably preferable but 'R CMD check' does not see 875 ## that the references are empty in this case (although the help system see this and 876 ## drops the section "references". To avoid confusing the user, print some 877 ## informative text. 878 return("There are no references for Rd macro \\verb{\\insertAllCites} on this help page.") 879 880 all.keys <- list() 881 for(i in 1:nrow(refsmat)){ 882 keys <- refsmat[i, 1] 883 884 textual <- grepl(";textual$", keys) 885 if(any(textual)) 886 keys <- gsub(";textual", "", keys) 887 888 refch <- "@" 889 refchpat <- paste0("^[", refch, "]") 890 if(grepl(refchpat, keys)){ 891 ch <- substr(keys, 1, 1) 892 keys <- substr(keys, 2, nchar(keys)) # drop refch 893 894 refpat <- paste0("(", refch, "[^;,[:space:]]+)") # "(@[^;,[:space:]]+)" 895 m <- gregexpr(refpat, keys) 896 keys <- regmatches(keys, m)[[1]] # note: [[1]] 897 keys <- gsub("@", "", keys) 898 }else{ 899 keys <- unlist(strsplit(keys, ",")) 900 } 901 902 package <- refsmat[i, 2] 903 904 if(is.null(all.keys[[package]])) 905 all.keys[[package]] <- keys 906 else 907 all.keys[[package]] <- c(all.keys[[package]], keys) 908 } 909 bibs <- NULL 910 for(package in names(all.keys)){ 911 cur <- unique(all.keys[[package]]) 912 913 be <- allbibs[[package]] 914 if(is.null(be)) 915 be <- get_bibentries(package = package, stop_on_error = FALSE) 916 917 if(length(be) == 0){ 918 be <- bibentry( 919 bibtype = "Misc", 920 title = "Not avalable", 921 author = person("A", "Adummy"), 922 year = format(Sys.time(), "%Y"), 923 note = paste0("Failed to insert reference with keys = \n ", 924 paste0(cur, collapse = " "), "\n", 925 "from package = '", package, "'.", 926 " Possible cause --- missing REFERENCES.bib in package '", 927 package, "' or '", package, "' not installed." 928 ), 929 key = paste0(cur, collapse = ":") 930 ) 931 }else if(all(cur != "*")){ 932 be <- tryCatch( 933 be[cur], 934 warning = function(c) { 935 if(grepl("subscript out of bounds", c$message)){ 936 ## tell the user the offending keys. 937 c$message <- paste0(c$message, " (", 938 paste(cur, collapse = " "), 939 "' from package '", package, "'", ")" 940 ) 941 } 942 warning(c) 943 ## setup a dummy entry 944 dummy <- bibentry( 945 bibtype = "Misc", 946 title = paste0("Some keys from package ", package, 947 " are not avalable"), 948 author = person("A", "Adummy"), 949 year = format(Sys.time(), "%Y"), 950 note = paste0("Failed to insert reference with keys:\n ", 951 paste0(cur, collapse = ", "), "\n", 952 "from package = '", package, "'.", 953 " Possible cause - missing REFERENCES.bib in package '", 954 package, "' or '", package, "' not installed." 955 ), 956 key = paste0(cur, collapse = ":") 957 ) 958 959 c(be[cur], dummy) 960 }) 961 } 962 963 if(is.null(bibs)) 964 bibs <- be 965 else 966 bibs <- c(bibs, be) # TODO: duplicate keys in different packages? 967 } 968 969 bibs <- sort(bibs, .bibstyle = "JSSRd") # 2021-04-24 was: sort(bibs) 970 971 pkgs <- names(all.keys) 972 # \Sexpr[stage=build,results=hide]{requireNamespace("cvar")} 973 974 # 2016-06-02 was: 975 # if(length(pkgs) > 0){ 976 # pkg <- pkgs[1] ## TODO: for now should do 977 # if(!isNamespaceLoaded(pkg) && !requireNamespace(pkg) ) 978 # sty <- NULL 979 # else{ 980 # sty <- Rdpack_bibstyles(pkg) 981 # } 982 # }else 983 # sty <- NULL 984 # 985 # if(!is.null(sty)) 986 # res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames")) 987 # else { 988 # if(style == "") 989 # res <- sapply(bibs, function(x) tools::toRd(x)) 990 # else{ 991 # res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames")) 992 # } 993 # } 994 pkg <- if(length(pkgs) > 0) ## TODO: for now should do 995 pkgs[1] 996 else character(0) 997 998 res <- .toRd_styled(bibs, pkg) 999 # 2018-10-01 use \par since pkgdown ignores the empty lines 1000 # TODO: needs further thought 1001 # was: 1002 # (for now restoring the old one, to check if pkgdown would consider this as a bug) 1003 1004 # paste0(res, collapse = "\n\n") 1005 paste0(res, collapse = "\\cr\\cr ") 1006} 1007 1008deparseLatexToRd <- function(x, dropBraces = FALSE) 1009{ 1010 result <- character() 1011 lastTag <- "TEXT" 1012 for (i in seq_along(x)) { 1013 a <- x[[i]] 1014 tag <- attr(a, "latex_tag") 1015 if (is.null(tag)) tag <- "NULL" 1016 switch(tag, 1017 VERB = , 1018 TEXT = , 1019 MACRO = , 1020 COMMENT = result <- c(result, a), 1021 BLOCK = result <- c(result, if (dropBraces && lastTag == "TEXT") Recall(a) else c("{", Recall(a), "}")), 1022 ENVIRONMENT = result <- c(result, 1023 "\\begin{", a[[1L]], "}", 1024 Recall(a[[2L]]), 1025 "\\end{", a[[1L]], "}"), 1026 ## MATH = result <- c(result, "$", Recall(a), "$"), 1027 MATH = result <- c(result, "\\eqn{", Recall(a), "}"), 1028 NULL = stop("Internal error, no tag", domain = NA) 1029 ) 1030 lastTag <- tag 1031 } 1032 paste(result, collapse="") 1033} 1034 1035Rdpack_bibstyles <- local({ 1036 styles <- list() 1037 function(package, authors){ 1038 if((n <- nargs()) > 1){ 1039 styles[[package]] <<- authors 1040 1041 }else if(n == 1) 1042 styles[[package]] 1043 else 1044 styles 1045 } 1046}) 1047 1048.toRd_styled <- function(bibs, package, style = ""){ 1049 sty <- if(length(package) == 0) 1050 NULL 1051 else if(!isNamespaceLoaded(package) && !requireNamespace(package) ) 1052 NULL 1053 else 1054 Rdpack_bibstyles(package) 1055 1056 # if(!is.null(sty)) 1057 # res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames")) 1058 # else { # check style 1059 # if(style == ""){ 1060 # if(!("JSSRd" %in% tools::getBibstyle(all = TRUE))) 1061 # ## bibstyle_JSSRd() 1062 # set_Rdpack_bibstyle("JSSRd") 1063 # res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSRd")) 1064 # }else{ 1065 # res <- sapply(bibs, function(x) tools::toRd(x, style = "JSSLongNames")) 1066 # } 1067 # } 1068 1069 sty <- if(is.null(sty) && style == ""){ 1070 if(!("JSSRd" %in% tools::getBibstyle(all = TRUE))) 1071 set_Rdpack_bibstyle("JSSRd") 1072 "JSSRd" 1073 }else 1074 "JSSLongNames" 1075 1076 f <- function(x){ 1077 if(!is.null(x$doi) && !is.null(x$url) && 1078 grepl(paste0("https?://doi.org/", x$doi), x$url)) 1079 x$url <- NULL 1080 1081 ## (2021-10-13) TODO: regarding issue #7 in rbibutils 1082 ## to fix temporarilly, add here processing of author and editor fields 1083 ## to change \'i to \'\i, if any, see 1084 ## https://github.com/GeoBosh/rbibutils/issues/7#issuecomment-939852743 1085 ## 1086 ## But 'author' fields are of class "person", so the following will not work: 1087 ## 1088 ## if(!is.null(x$author) && grepl("\\\\'i", x$author)) 1089 ## x$author <- gsub("\\\\'i", "\\\\'\\\\i", x$author), 1090 ## 1091 ## Processing the person field in each reference is not appealing. 1092 ## Maybe rbibutils should get texChars = "Rdpack" option and do whatever specific 1093 ## for Rdpack is needed. 1094 1095 tools::toRd(x, style = sty) 1096 } 1097 1098 ## TODO: check if these 'sapply()' preserves encodings, if set. 1099 res <- sapply(bibs, f) 1100 1101 ## 2018-10-08 1102 1103 ## TODO: this is risky but read.bib, bibentry, toRd and similar seem to work 1104 ## internally with UTF-8 1105 ## 1106 ## if(!all(Encoding(res) == "UTF-8")){ 1107 ## # warning(paste("encoding is: ", paste0(Encoding(res), collapse = ", "), "\n")) 1108 ## Encoding(res) <- "UTF-8" 1109 ## } 1110 1111 res 1112} 1113 1114set_Rdpack_bibstyle <- local({ 1115 ## from /tools/R/bibstyle.R makeJSS() 1116 collapse <- function(strings) 1117 paste(strings, collapse="\n") 1118 emph <- function(s) 1119 if (length(s)) paste0("\\emph{", collapse(s), "}") 1120 authorList <- function (paper) { 1121 names <- sapply(paper$author, shortName) 1122 if (length(names) > 1L) 1123 result <- paste(names, collapse = ", ") 1124 else result <- names 1125 result 1126 } 1127 editorList <- function (paper) { 1128 names <- sapply(paper$editor, shortName) 1129 if (length(names) > 1L) 1130 result <- paste(paste(names, collapse = ", "), "(eds.)") 1131 else if (length(names)) 1132 result <- paste(names, "(ed.)") 1133 else result <- NULL 1134 result 1135 } 1136 shortName <- function (person) { 1137 if (length(person$family)) { 1138 result <- cleanupLatex(person$family) 1139 if (length(person$given)) 1140 paste(result, paste(substr(sapply(person$given, cleanupLatex), 1141 1, 1), collapse = "")) 1142 else result 1143 } 1144 else paste(cleanupLatex(person$given), collapse = " ") 1145 } 1146 ## Clean up LaTeX accents and braces 1147 ## this is a copy of unexported tools:::cleanupLatex by Duncan Murdoch. 1148 cleanupLatex <- function(x) { 1149 if (!length(x)) 1150 return(x) 1151 latex <- tryCatch(tools::parseLatex(x), error = function(e)e) 1152 if (inherits(latex, "error")) { 1153 x 1154 } else { 1155 deparseLatexToRd(latexToUtf8(latex), dropBraces=TRUE) 1156 } 1157 } 1158 1159 ## modified from tools::makeJSS() 1160 ## TODO: report on R-devel?. 1161 bookVolume <- function(book) { 1162 result <- "" 1163 if (length(book$volume)){ 1164 result <- paste("volume", collapse(book$volume)) 1165 if (length(book$number)) 1166 result <- paste0(result, "(", collapse(book$number), ")") 1167 if (length(book$series)) 1168 result <- paste(result, "of", emph(collapse(book$series))) 1169 }else if (length(book$number)){ 1170 ## todo: in JSS style and others the title end with '.' and 1171 ## 'number' is 'Number', but don't want to fiddle with this now. 1172 result <- paste(result, "number", collapse(book$number)) 1173 if (length(book$series)) 1174 result <- paste(result, "in", collapse(book$series)) 1175 }else if (length(book$series)) 1176 result <- paste(result, collapse(book$series)) 1177 if (nzchar(result)) result 1178 } 1179 1180 ## new 2021-04-23 1181 sortKeys <- function (bib) { 1182 result <- character(length(bib)) 1183 for (i in seq_along(bib)) { 1184 authors <- authorList(bib[[i]]) 1185 if (!length(authors)) 1186 authors <- editorList(bib[[i]]) 1187 if (!length(authors)) 1188 authors <- "" 1189 year <- collapse(bib[[i]]$year) 1190 authyear <- if(authors != "" ) 1191 paste0(authors, ", ", year) 1192 else 1193 year 1194 result[i] <- authyear 1195 } 1196 result 1197 } 1198 1199 function(bibstyle = "JSSRd"){ 1200 switch(bibstyle, 1201 "JSSRd" = 1202 tools::bibstyle("JSSRd", .init = TRUE, .default = FALSE, 1203 cleanupLatex = cleanupLatex, 1204 bookVolume = bookVolume, 1205 sortKeys = sortKeys 1206 ), 1207 1208 "JSSLongNames" = 1209 tools::bibstyle("JSSLongNames", .init = TRUE, .default = FALSE, 1210 cleanupLatex = cleanupLatex, 1211 bookVolume = bookVolume, 1212 sortKeys = sortKeys, 1213 1214 shortName = function(person) { 1215 paste(paste(cleanupLatex(person$given), collapse=" "), 1216 cleanupLatex(person$family), sep = " ") 1217 } 1218 ), 1219 ## default 1220 stop("Unknown bibstyle ", bibstyle) 1221 ) 1222 } 1223}) 1224 1225.onLoad <- function(lib, pkg){ 1226 ## define the styles but not set any of them as default 1227 set_Rdpack_bibstyle("JSSRd") 1228 set_Rdpack_bibstyle("JSSLongNames") 1229 1230 ## set "LongNames" style for this package (Rdpack) 1231 Rdpack_bibstyles(package = pkg, authors = "LongNames") 1232 invisible(NULL) 1233} 1234