1#' @include globals.R 2#' @include map.R 3NULL 4 5#' Make a random number generator repeatable 6#' 7#' Given a function that generates random data, returns a wrapped version of 8#' that function that always uses the same seed when called. The seed to use can 9#' be passed in explicitly if desired; otherwise, a random number is used. 10#' 11#' @param rngfunc The function that is affected by the R session's seed. 12#' @param seed The seed to set every time the resulting function is called. 13#' @return A repeatable version of the function that was passed in. 14#' 15#' @note When called, the returned function attempts to preserve the R session's 16#' current seed by snapshotting and restoring 17#' [base::.Random.seed()]. 18#' 19#' @examples 20#' rnormA <- repeatable(rnorm) 21#' rnormB <- repeatable(rnorm) 22#' rnormA(3) # [1] 1.8285879 -0.7468041 -0.4639111 23#' rnormA(3) # [1] 1.8285879 -0.7468041 -0.4639111 24#' rnormA(5) # [1] 1.8285879 -0.7468041 -0.4639111 -1.6510126 -1.4686924 25#' rnormB(5) # [1] -0.7946034 0.2568374 -0.6567597 1.2451387 -0.8375699 26#' @export 27repeatable <- function(rngfunc, seed = stats::runif(1, 0, .Machine$integer.max)) { 28 force(seed) 29 30 function(...) { 31 # When we exit, restore the seed to its original state 32 if (exists('.Random.seed', where=globalenv())) { 33 currentSeed <- get('.Random.seed', pos=globalenv()) 34 on.exit(assign('.Random.seed', currentSeed, pos=globalenv())) 35 } 36 else { 37 on.exit(rm('.Random.seed', pos=globalenv())) 38 } 39 40 set.seed(seed) 41 42 rngfunc(...) 43 } 44} 45 46.globals$ownSeed <- NULL 47# Evaluate an expression using Shiny's own private stream of 48# randomness (not affected by set.seed). 49withPrivateSeed <- function(expr) { 50 # Save the old seed if present. 51 if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) { 52 hasOrigSeed <- TRUE 53 origSeed <- .GlobalEnv$.Random.seed 54 } else { 55 hasOrigSeed <- FALSE 56 } 57 58 # Swap in the private seed. 59 if (is.null(.globals$ownSeed)) { 60 if (hasOrigSeed) { 61 # Move old seed out of the way if present. 62 rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE) 63 } 64 } else { 65 .GlobalEnv$.Random.seed <- .globals$ownSeed 66 } 67 68 # On exit, save the modified private seed, and put the old seed back. 69 on.exit({ 70 .globals$ownSeed <- .GlobalEnv$.Random.seed 71 72 if (hasOrigSeed) { 73 .GlobalEnv$.Random.seed <- origSeed 74 } else { 75 rm(.Random.seed, envir = .GlobalEnv, inherits = FALSE) 76 } 77 # Need to call this to make sure that the value of .Random.seed gets put 78 # into R's internal RNG state. (Issue #1763) 79 httpuv::getRNGState() 80 }) 81 82 expr 83} 84 85# Version of runif that runs with private seed 86p_runif <- function(...) { 87 withPrivateSeed(stats::runif(...)) 88} 89 90# Version of sample that runs with private seed 91p_sample <- function(...) { 92 withPrivateSeed(sample(...)) 93} 94 95# Return a random integral value in the range [min, max). 96# If only one argument is passed, then min=0 and max=argument. 97randomInt <- function(min, max) { 98 if (missing(max)) { 99 max <- min 100 min <- 0 101 } 102 if (min < 0 || max <= min) 103 stop("Invalid min/max values") 104 105 min + sample(max-min, 1)-1 106} 107 108p_randomInt <- function(...) { 109 withPrivateSeed(randomInt(...)) 110} 111 112isWholeNum <- function(x, tol = .Machine$double.eps^0.5) { 113 abs(x - round(x)) < tol 114} 115 116# Given a vector or list, drop all the NULL items in it 117dropNulls <- function(x) { 118 x[!vapply(x, is.null, FUN.VALUE=logical(1))] 119} 120 121nullOrEmpty <- function(x) { 122 is.null(x) || length(x) == 0 123} 124# Given a vector or list, drop all the NULL items in it 125dropNullsOrEmpty <- function(x) { 126 x[!vapply(x, nullOrEmpty, FUN.VALUE=logical(1))] 127} 128 129# Given a vector/list, return TRUE if any elements are named, FALSE otherwise. 130anyNamed <- function(x) { 131 # Zero-length vector 132 if (length(x) == 0) return(FALSE) 133 134 nms <- names(x) 135 136 # List with no name attribute 137 if (is.null(nms)) return(FALSE) 138 139 # List with name attribute; check for any "" 140 any(nzchar(nms)) 141} 142 143# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise. 144anyUnnamed <- function(x) { 145 # Zero-length vector 146 if (length(x) == 0) return(FALSE) 147 148 nms <- names(x) 149 150 # List with no name attribute 151 if (is.null(nms)) return(TRUE) 152 153 # List with name attribute; check for any "" 154 any(!nzchar(nms)) 155} 156 157 158# Given a vector/list, returns a named vector/list (the labels will be blank). 159asNamed <- function(x) { 160 if (is.null(names(x))) { 161 names(x) <- character(length(x)) 162 } 163 164 x 165} 166 167empty_named_list <- function() { 168 list(a = 1)[0] 169} 170 171# Given two named vectors, join them together, and keep only the last element 172# with a given name in the resulting vector. If b has any elements with the same 173# name as elements in a, the element in a is dropped. Also, if there are any 174# duplicated names in a or b, only the last one with that name is kept. 175mergeVectors <- function(a, b) { 176 if (anyUnnamed(a) || anyUnnamed(b)) { 177 stop("Vectors must be either NULL or have names for all elements") 178 } 179 180 x <- c(a, b) 181 drop_idx <- duplicated(names(x), fromLast = TRUE) 182 x[!drop_idx] 183} 184 185# Sort a vector by the names of items. If there are multiple items with the 186# same name, preserve the original order of those items. For empty 187# vectors/lists/NULL, return the original value. 188sortByName <- function(x) { 189 if (anyUnnamed(x)) 190 stop("All items must be named") 191 192 # Special case for empty vectors/lists, and NULL 193 if (length(x) == 0) 194 return(x) 195 196 x[order(names(x))] 197} 198 199# Sort a vector. If a character vector, sort using C locale, which is consistent 200# across platforms. Note that radix sort uses C locale according to ?sort. 201sort_c <- function(x, ...) { 202 # Use UTF-8 encoding, because if encoding is "unknown" for non-ASCII 203 # characters, the sort() will throw an error. 204 if (is.character(x)) 205 x <- enc2utf8(x) 206 sort(x, method = "radix", ...) 207} 208 209 210# Wrapper around list2env with a NULL check. In R <3.2.0, if an empty unnamed 211# list is passed to list2env(), it errors. But an empty named list is OK. For 212# R >=3.2.0, this wrapper is not necessary. 213list2env2 <- function(x, ...) { 214 # Ensure that zero-length lists have a name attribute 215 if (length(x) == 0) 216 attr(x, "names") <- character(0) 217 218 list2env(x, ...) 219} 220 221# Combine dir and (file)name into a file path. If a file already exists with a 222# name differing only by case, then use it instead. 223file.path.ci <- function(...) { 224 result <- find.file.ci(...) 225 if (!is.null(result)) 226 return(result) 227 228 # If not found, return the file path that was given to us. 229 return(file.path(...)) 230} 231 232# Does a particular file exist? Case-insensitive for filename, case-sensitive 233# for path (on platforms with case-sensitive file system). 234file.exists.ci <- function(...) { 235 !is.null(find.file.ci(...)) 236} 237 238# Look for a file, case-insensitive for filename, case-sensitive for path (on 239# platforms with case-sensitive filesystem). If found, return the path to the 240# file, with the correct case. If not found, return NULL. 241find.file.ci <- function(...) { 242 default <- file.path(...) 243 if (length(default) > 1) 244 stop("find.file.ci can only check for one file at a time.") 245 if (file.exists(default)) 246 return(default) 247 248 dir <- dirname(default) 249 name <- basename(default) 250 251 # If we got here, then we'll check for a directory with the exact case, and a 252 # name with any case. 253 all_files <- list.files(dir, all.files=TRUE, full.names=TRUE, 254 include.dirs=TRUE) 255 match_idx <- tolower(name) == tolower(basename(all_files)) 256 matches <- all_files[match_idx] 257 if (length(matches) == 0) 258 return(NULL) 259 260 return(matches[1]) 261} 262 263# The function base::dir.exists was added in R 3.2.0, but for backward 264# compatibility we need to add this function 265dirExists <- function(paths) { 266 file.exists(paths) & file.info(paths)$isdir 267} 268 269# Removes empty directory (vectorized). This is needed because file.remove() 270# on Unix will remove empty directories, but on Windows, it will not. On 271# Windows, you would need to use unlink(recursive=TRUE), which is not very 272# safe. This function does it safely on Unix and Windows. 273dirRemove <- function(path) { 274 for (p in path) { 275 if (!dirExists(p)) { 276 stop("Cannot remove non-existent directory ", p, ".") 277 } 278 if (length(dir(p, all.files = TRUE, no.. = TRUE)) != 0) { 279 stop("Cannot remove non-empty directory ", p, ".") 280 } 281 result <- unlink(p, recursive = TRUE) 282 if (result == 1) { 283 stop("Error removing directory ", p, ".") 284 } 285 } 286} 287 288# Attempt to join a path and relative path, and turn the result into a 289# (normalized) absolute path. The result will only be returned if it is an 290# existing file/directory and is a descendant of dir. 291# 292# Example: 293# resolve("/Users/jcheng", "shiny") # "/Users/jcheng/shiny" 294# resolve("/Users/jcheng", "./shiny") # "/Users/jcheng/shiny" 295# resolve("/Users/jcheng", "shiny/../shiny/") # "/Users/jcheng/shiny" 296# resolve("/Users/jcheng", ".") # NULL 297# resolve("/Users/jcheng", "..") # NULL 298# resolve("/Users/jcheng", "shiny/..") # NULL 299resolve <- function(dir, relpath) { 300 abs.path <- file.path(dir, relpath) 301 if (!file.exists(abs.path)) 302 return(NULL) 303 abs.path <- normalizePath(abs.path, winslash='/', mustWork=TRUE) 304 dir <- normalizePath(dir, winslash='/', mustWork=TRUE) 305 # trim the possible trailing slash under Windows (#306) 306 if (isWindows()) dir <- sub('/$', '', dir) 307 if (nchar(abs.path) <= nchar(dir) + 1) 308 return(NULL) 309 if (substr(abs.path, 1, nchar(dir)) != dir || 310 substr(abs.path, nchar(dir)+1, nchar(dir)+1) != '/') { 311 return(NULL) 312 } 313 return(abs.path) 314} 315 316# Given a string, make sure it has a trailing slash. 317ensure_trailing_slash <- function(path) { 318 if (!grepl("/$", path)) { 319 path <- paste0(path, "/") 320 } 321 path 322} 323 324 325isWindows <- function() .Platform$OS.type == 'windows' 326 327# This is a wrapper for download.file and has the same interface. 328# The only difference is that, if the protocol is https, it changes the 329# download settings, depending on platform. 330download <- function(url, ...) { 331 # First, check protocol. If http or https, check platform: 332 if (grepl('^https?://', url)) { 333 334 # Check whether we are running R 3.2 335 isR32 <- getRversion() >= "3.2" 336 337 # Windows 338 if (.Platform$OS.type == "windows") { 339 340 if (isR32) { 341 method <- "wininet" 342 } else { 343 344 # If we directly use setInternet2, R CMD CHECK gives a Note on Mac/Linux 345 seti2 <- `::`(utils, 'setInternet2') 346 347 # Check whether we are already using internet2 for internal 348 internet2_start <- seti2(NA) 349 350 # If not then temporarily set it 351 if (!internet2_start) { 352 # Store initial settings, and restore on exit 353 on.exit(suppressWarnings(seti2(internet2_start))) 354 355 # Needed for https. Will get warning if setInternet2(FALSE) already run 356 # and internet routines are used. But the warnings don't seem to matter. 357 suppressWarnings(seti2(TRUE)) 358 } 359 360 method <- "internal" 361 } 362 363 # download.file will complain about file size with something like: 364 # Warning message: 365 # In download.file(url, ...) : downloaded length 19457 != reported length 200 366 # because apparently it compares the length with the status code returned (?) 367 # so we supress that 368 suppressWarnings(utils::download.file(url, method = method, ...)) 369 370 } else { 371 # If non-Windows, check for libcurl/curl/wget/lynx, then call download.file with 372 # appropriate method. 373 374 if (isR32 && capabilities("libcurl")) { 375 method <- "libcurl" 376 } else if (nzchar(Sys.which("wget")[1])) { 377 method <- "wget" 378 } else if (nzchar(Sys.which("curl")[1])) { 379 method <- "curl" 380 381 # curl needs to add a -L option to follow redirects. 382 # Save the original options and restore when we exit. 383 orig_extra_options <- getOption("download.file.extra") 384 on.exit(options(download.file.extra = orig_extra_options)) 385 386 options(download.file.extra = paste("-L", orig_extra_options)) 387 388 } else if (nzchar(Sys.which("lynx")[1])) { 389 method <- "lynx" 390 } else { 391 stop("no download method found") 392 } 393 394 utils::download.file(url, method = method, ...) 395 } 396 397 } else { 398 utils::download.file(url, ...) 399 } 400} 401 402getContentType <- function(file, defaultType = 'application/octet-stream') { 403 subtype <- ifelse(grepl('[.]html?$', file), 'charset=UTF-8', '') 404 mime::guess_type(file, unknown = defaultType, subtype = subtype) 405} 406 407#' Parse a GET query string from a URL 408#' 409#' Returns a named list of key-value pairs. 410#' 411#' @noMd 412#' @param str The query string. It can have a leading \code{"?"} or not. 413#' @param nested Whether to parse the query string of as a nested list when it 414#' contains pairs of square brackets \code{[]}. For example, the query 415#' \samp{a[i1][j1]=x&b[i1][j1]=y&b[i2][j1]=z} will be parsed as \code{list(a = 416#' list(i1 = list(j1 = 'x')), b = list(i1 = list(j1 = 'y'), i2 = list(j1 = 417#' 'z')))} when \code{nested = TRUE}, and \code{list(`a[i1][j1]` = 'x', 418#' `b[i1][j1]` = 'y', `b[i2][j1]` = 'z')} when \code{nested = FALSE}. 419#' @export 420#' @examples 421#' parseQueryString("?foo=1&bar=b%20a%20r") 422#' 423#' \dontrun{ 424#' # Example of usage within a Shiny app 425#' function(input, output, session) { 426#' 427#' output$queryText <- renderText({ 428#' query <- parseQueryString(session$clientData$url_search) 429#' 430#' # Ways of accessing the values 431#' if (as.numeric(query$foo) == 1) { 432#' # Do something 433#' } 434#' if (query[["bar"]] == "targetstring") { 435#' # Do something else 436#' } 437#' 438#' # Return a string with key-value pairs 439#' paste(names(query), query, sep = "=", collapse=", ") 440#' }) 441#' } 442#' } 443#' 444parseQueryString <- function(str, nested = FALSE) { 445 if (is.null(str) || nchar(str) == 0) 446 return(list()) 447 448 # Remove leading ? 449 if (substr(str, 1, 1) == '?') 450 str <- substr(str, 2, nchar(str)) 451 452 pairs <- strsplit(str, '&', fixed = TRUE)[[1]] 453 # Drop any empty items (if there's leading/trailing/consecutive '&' chars) 454 pairs <- pairs[pairs != ""] 455 pairs <- strsplit(pairs, '=', fixed = TRUE) 456 457 keys <- vapply(pairs, function(x) x[1], FUN.VALUE = character(1)) 458 values <- vapply(pairs, function(x) x[2], FUN.VALUE = character(1)) 459 # Replace NA with '', so they don't get converted to 'NA' by URLdecode 460 values[is.na(values)] <- '' 461 462 # Convert "+" to " ", since URLdecode doesn't do it 463 keys <- gsub('+', ' ', keys, fixed = TRUE) 464 values <- gsub('+', ' ', values, fixed = TRUE) 465 466 keys <- URLdecode(keys) 467 values <- URLdecode(values) 468 469 res <- stats::setNames(as.list(values), keys) 470 if (!nested) return(res) 471 472 # Make a nested list from a query of the form ?a[1][1]=x11&a[1][2]=x12&... 473 for (i in grep('\\[.+\\]', keys)) { 474 k <- strsplit(keys[i], '[][]')[[1L]] # split by [ or ] 475 res <- assignNestedList(res, k[k != ''], values[i]) 476 res[[keys[i]]] <- NULL # remove res[['a[1][1]']] 477 } 478 res 479} 480 481# Assign value to the bottom element of the list x using recursive indices idx 482assignNestedList <- function(x = list(), idx, value) { 483 for (i in seq_along(idx)) { 484 sub <- idx[seq_len(i)] 485 if (is.null(x[[sub]])) x[[sub]] <- list() 486 } 487 x[[idx]] <- value 488 x 489} 490 491# decide what to do in case of errors; it is customizable using the shiny.error 492# option (e.g. we can set options(shiny.error = recover)) 493#' @include conditions.R 494shinyCallingHandlers <- function(expr) { 495 withCallingHandlers(captureStackTraces(expr), 496 error = function(e) { 497 # Don't intercept shiny.silent.error (i.e. validation errors) 498 if (inherits(e, "shiny.silent.error")) 499 return() 500 501 handle <- getOption('shiny.error') 502 if (is.function(handle)) handle() 503 } 504 ) 505} 506 507 508#' Register a function with the debugger (if one is active). 509#' 510#' Call this function after exprToFunction to give any active debugger a hook 511#' to set and clear breakpoints in the function. A debugger may implement 512#' registerShinyDebugHook to receive callbacks when Shiny functions are 513#' instantiated at runtime. 514#' 515#' @param name Name of the field or object containing the function. 516#' @param where The reference object or environment containing the function. 517#' @param label A label to display on the function in the debugger. 518#' @noRd 519registerDebugHook <- function(name, where, label) { 520 if (exists("registerShinyDebugHook", mode = "function")) { 521 registerShinyDebugHook <- get("registerShinyDebugHook", mode = "function") 522 params <- new.env(parent = emptyenv()) 523 params$name <- name 524 params$where <- where 525 params$label <- label 526 registerShinyDebugHook(params) 527 } 528} 529 530Callbacks <- R6Class( 531 'Callbacks', 532 portable = FALSE, 533 class = FALSE, 534 public = list( 535 .nextId = integer(0), 536 .callbacks = 'Map', 537 538 initialize = function() { 539 # NOTE: we avoid using '.Machine$integer.max' directly 540 # as R 3.3.0's 'radixsort' could segfault when sorting 541 # an integer vector containing this value 542 .nextId <<- as.integer(.Machine$integer.max - 1L) 543 .callbacks <<- Map$new() 544 }, 545 register = function(callback) { 546 if (!is.function(callback)) { 547 stop("callback must be a function") 548 } 549 id <- as.character(.nextId) 550 .nextId <<- .nextId - 1L 551 .callbacks$set(id, callback) 552 return(function() { 553 .callbacks$remove(id) 554 }) 555 }, 556 invoke = function(..., onError=NULL, ..stacktraceon = FALSE) { 557 # Ensure that calls are invoked in the order that they were registered 558 keys <- as.character(sort(as.integer(.callbacks$keys()), decreasing = TRUE)) 559 callbacks <- .callbacks$mget(keys) 560 561 for (callback in callbacks) { 562 if (is.null(onError)) { 563 if (..stacktraceon) { 564 ..stacktraceon..(callback(...)) 565 } else { 566 callback(...) 567 } 568 } else { 569 tryCatch( 570 captureStackTraces( 571 if (..stacktraceon) 572 ..stacktraceon..(callback(...)) 573 else 574 callback(...) 575 ), 576 error = onError 577 ) 578 } 579 } 580 }, 581 count = function() { 582 .callbacks$size() 583 } 584 ) 585) 586 587# convert a data frame to JSON as required by DataTables request 588dataTablesJSON <- function(data, req) { 589 n <- nrow(data) 590 # DataTables requests were sent via POST 591 params <- URLdecode(rawToChar(req$rook.input$read())) 592 q <- parseQueryString(params, nested = TRUE) 593 ci <- q$search[['caseInsensitive']] == 'true' 594 595 # data may have been replaced/updated in the new table while the Ajax request 596 # from the previous table is still on its way, so it is possible that the old 597 # request asks for more columns than the current data, in which case we should 598 # discard this request and return empty data; the next Ajax request from the 599 # new table will retrieve the correct number of columns of data 600 if (length(q$columns) != ncol(data)) { 601 res <- toJSON(list( 602 draw = as.integer(q$draw), 603 recordsTotal = n, 604 recordsFiltered = 0, 605 data = NULL 606 )) 607 return(httpResponse(200, 'application/json', enc2utf8(res))) 608 } 609 610 # global searching 611 i <- seq_len(n) 612 if (length(q$search[['value']]) && q$search[['value']] != '') { 613 i0 <- apply(data, 2, function(x) { 614 grep2(q$search[['value']], as.character(x), 615 fixed = q$search[['regex']] == 'false', ignore.case = ci) 616 }) 617 i <- intersect(i, unique(unlist(i0))) 618 } 619 620 # search by columns 621 if (length(i)) for (j in names(q$columns)) { 622 col <- q$columns[[j]] 623 # if the j-th column is not searchable or the search string is "", skip it 624 if (col[['searchable']] != 'true') next 625 if ((k <- col[['search']][['value']]) == '') next 626 j <- as.integer(j) 627 dj <- data[, j + 1] 628 r <- commaToRange(k) 629 ij <- if (length(r) == 2 && is.numeric(dj)) { 630 which(dj >= r[1] & dj <= r[2]) 631 } else { 632 grep2(k, as.character(dj), fixed = col[['search']][['regex']] == 'false', 633 ignore.case = ci) 634 } 635 i <- intersect(ij, i) 636 if (length(i) == 0) break 637 } 638 if (length(i) != n) data <- data[i, , drop = FALSE] 639 640 # sorting 641 oList <- list() 642 for (ord in q$order) { 643 k <- ord[['column']] # which column to sort 644 d <- ord[['dir']] # direction asc/desc 645 if (q$columns[[k]][['orderable']] != 'true') next 646 col <- data[, as.integer(k) + 1] 647 oList[[length(oList) + 1]] <- (if (d == 'asc') identity else `-`)( 648 if (is.numeric(col)) col else xtfrm(col) 649 ) 650 } 651 if (length(oList)) { 652 i <- do.call(order, oList) 653 data <- data[i, , drop = FALSE] 654 } 655 # paging 656 if (q$length != '-1') { 657 i <- seq(as.integer(q$start) + 1L, length.out = as.integer(q$length)) 658 i <- i[i <= nrow(data)] 659 fdata <- data[i, , drop = FALSE] # filtered data 660 } else fdata <- data 661 662 fdata <- unname(as.matrix(fdata)) 663 if (is.character(fdata) && q$escape != 'false') { 664 if (q$escape == 'true') { 665 # fdata must be a matrix at this point, and we need to preserve 666 # dimensions. Note that it could be a 1xn matrix. 667 dims <- dim(fdata) 668 fdata <- htmlEscape(fdata) 669 dim(fdata) <- dims 670 671 } else { 672 k <- as.integer(strsplit(q$escape, ',')[[1]]) 673 # use seq_len() in case escape = negative indices, e.g. c(-1, -5) 674 for (j in seq_len(ncol(fdata))[k]) fdata[, j] <- htmlEscape(fdata[, j]) 675 } 676 } 677 678 res <- toJSON(list( 679 draw = as.integer(q$draw), 680 recordsTotal = n, 681 recordsFiltered = nrow(data), 682 data = fdata 683 )) 684 httpResponse(200, 'application/json', enc2utf8(res)) 685} 686 687# when both ignore.case and fixed are TRUE, we use grep(ignore.case = FALSE, 688# fixed = TRUE) to do lower-case matching of pattern on x 689grep2 <- function(pattern, x, ignore.case = FALSE, fixed = FALSE, ...) { 690 if (fixed && ignore.case) { 691 pattern <- tolower(pattern) 692 x <- tolower(x) 693 ignore.case <- FALSE 694 } 695 # when the user types in the search box, the regular expression may not be 696 # complete before it is sent to the server, in which case we do not search 697 if (!fixed && inherits(try(grep(pattern, ''), silent = TRUE), 'try-error')) 698 return(seq_along(x)) 699 grep(pattern, x, ignore.case = ignore.case, fixed = fixed, ...) 700} 701 702getExists <- function(x, mode, envir = parent.frame()) { 703 if (exists(x, envir = envir, mode = mode, inherits = FALSE)) 704 get(x, envir = envir, mode = mode, inherits = FALSE) 705} 706 707# convert a string of the form "lower,upper" to c(lower, upper) 708commaToRange <- function(string) { 709 if (!grepl(',', string)) return() 710 r <- strsplit(string, ',')[[1]] 711 if (length(r) > 2) return() 712 if (length(r) == 1) r <- c(r, '') # lower, 713 r <- as.numeric(r) 714 if (is.na(r[1])) r[1] <- -Inf 715 if (is.na(r[2])) r[2] <- Inf 716 r 717} 718 719# for options passed to DataTables/Selectize/..., the options of the class AsIs 720# will be evaluated as literal JavaScript code 721checkAsIs <- function(options) { 722 evalOptions <- if (length(options)) { 723 nms <- names(options) 724 if (length(nms) == 0L || any(nms == '')) stop("'options' must be a named list") 725 i <- unlist(lapply(options, function(x) { 726 is.character(x) && inherits(x, 'AsIs') 727 })) 728 if (any(i)) { 729 # must convert to character, otherwise toJSON() turns it to an array [] 730 options[i] <- lapply(options[i], paste, collapse = '\n') 731 nms[i] # options of these names will be evaluated in JS 732 } 733 } 734 list(options = options, eval = evalOptions) 735} 736 737srcrefFromShinyCall <- function(expr) { 738 srcrefs <- attr(expr, "srcref") 739 num_exprs <- length(srcrefs) 740 if (num_exprs < 1) 741 return(NULL) 742 c(srcrefs[[1]][1], srcrefs[[1]][2], 743 srcrefs[[num_exprs]][3], srcrefs[[num_exprs]][4], 744 srcrefs[[1]][5], srcrefs[[num_exprs]][6]) 745} 746 747# Indicates whether the given querystring should cause the associated request 748# to be handled in showcase mode. Returns the showcase mode if set, or NULL 749# if no showcase mode is set. 750showcaseModeOfQuerystring <- function(querystring) { 751 if (nchar(querystring) > 0) { 752 qs <- parseQueryString(querystring) 753 if (exists("showcase", where = qs)) { 754 return(as.numeric(qs$showcase)) 755 } 756 } 757 return(NULL) 758} 759 760showcaseModeOfReq <- function(req) { 761 showcaseModeOfQuerystring(req$QUERY_STRING) 762} 763 764# Returns (just) the filename containing the given source reference, or an 765# empty string if the source reference doesn't include file information. 766srcFileOfRef <- function(srcref) { 767 fileEnv <- attr(srcref, "srcfile") 768 # The 'srcfile' attribute should be a non-null environment containing the 769 # variable 'filename', which gives the full path to the source file. 770 if (!is.null(fileEnv) && 771 is.environment(fileEnv) && 772 exists("filename", where = fileEnv)) 773 basename(fileEnv[["filename"]]) 774 else 775 "" 776} 777 778# Format a number without sci notation, and keep as many digits as possible (do 779# we really need to go beyond 15 digits?) 780formatNoSci <- function(x) { 781 if (is.null(x)) return(NULL) 782 format(x, scientific = FALSE, digits = 15) 783} 784 785# Returns a function that calls the given func and caches the result for 786# subsequent calls, unless the given file's mtime changes. 787cachedFuncWithFile <- function(dir, file, func, case.sensitive = FALSE) { 788 dir <- normalizePath(dir, mustWork=TRUE) 789 mtime <- NA 790 value <- NULL 791 function(...) { 792 fname <- if (case.sensitive) 793 file.path(dir, file) 794 else 795 file.path.ci(dir, file) 796 797 now <- file.info(fname)$mtime 798 if (!identical(mtime, now)) { 799 value <<- func(fname, ...) 800 mtime <<- now 801 } 802 value 803 } 804} 805 806# turn column-based data to row-based data (mainly for JSON), e.g. data.frame(x 807# = 1:10, y = 10:1) ==> list(list(x = 1, y = 10), list(x = 2, y = 9), ...) 808columnToRowData <- function(data) { 809 do.call( 810 mapply, c( 811 list(FUN = function(...) list(...), SIMPLIFY = FALSE, USE.NAMES = FALSE), 812 as.list(data) 813 ) 814 ) 815} 816 817#' Declare an error safe for the user to see 818#' 819#' This should be used when you want to let the user see an error 820#' message even if the default is to sanitize all errors. If you have an 821#' error `e` and call `stop(safeError(e))`, then Shiny will 822#' ignore the value of `getOption("shiny.sanitize.errors")` and always 823#' display the error in the app itself. 824#' 825#' @param error Either an "error" object or a "character" object (string). 826#' In the latter case, the string will become the message of the error 827#' returned by `safeError`. 828#' 829#' @return An "error" object 830#' 831#' @details An error generated by `safeError` has priority over all 832#' other Shiny errors. This can be dangerous. For example, if you have set 833#' `options(shiny.sanitize.errors = TRUE)`, then by default all error 834#' messages are omitted in the app, and replaced by a generic error message. 835#' However, this does not apply to `safeError`: whatever you pass 836#' through `error` will be displayed to the user. So, this should only 837#' be used when you are sure that your error message does not contain any 838#' sensitive information. In those situations, `safeError` can make 839#' your users' lives much easier by giving them a hint as to where the 840#' error occurred. 841#' 842#' @seealso [shiny-options()] 843#' 844#' @examples 845#' ## Only run examples in interactive R sessions 846#' if (interactive()) { 847#' 848#' # uncomment the desired line to experiment with shiny.sanitize.errors 849#' # options(shiny.sanitize.errors = TRUE) 850#' # options(shiny.sanitize.errors = FALSE) 851#' 852#' # Define UI 853#' ui <- fluidPage( 854#' textInput('number', 'Enter your favorite number from 1 to 10', '5'), 855#' textOutput('normalError'), 856#' textOutput('safeError') 857#' ) 858#' 859#' # Server logic 860#' server <- function(input, output) { 861#' output$normalError <- renderText({ 862#' number <- input$number 863#' if (number %in% 1:10) { 864#' return(paste('You chose', number, '!')) 865#' } else { 866#' stop( 867#' paste(number, 'is not a number between 1 and 10') 868#' ) 869#' } 870#' }) 871#' output$safeError <- renderText({ 872#' number <- input$number 873#' if (number %in% 1:10) { 874#' return(paste('You chose', number, '!')) 875#' } else { 876#' stop(safeError( 877#' paste(number, 'is not a number between 1 and 10') 878#' )) 879#' } 880#' }) 881#' } 882#' 883#' # Complete app with UI and server components 884#' shinyApp(ui, server) 885#' } 886#' @export 887safeError <- function(error) { 888 if (inherits(error, "character")) { 889 error <- simpleError(error) 890 } 891 if (!inherits(error, "error")) { 892 stop("The class of the `error` parameter must be either 'error' or 'character'") 893 } 894 class(error) <- c("shiny.custom.error", class(error)) 895 error 896} 897 898#***********************************************************************# 899#**** Keep this function internal for now, may chnage in the future ****# 900#***********************************************************************# 901# #' Propagate an error through Shiny, but catch it before it throws 902# #' 903# #' Throws a type of exception that is caught by observers. When such an 904# #' exception is triggered, all reactive links are broken. So, essentially, 905# #' \code{reactiveStop()} behaves just like \code{stop()}, except that 906# #' instead of ending the session, it is silently swalowed by Shiny. 907# #' 908# #' This function should be used when you want to disrupt the reactive 909# #' links in a reactive chain, but do not want to end the session. For 910# #' example, this enables you to disallow certain inputs, but get back 911# #' to business as usual when valid inputs are re-entered. 912# #' \code{reactiveStop} is also called internally by Shiny to create 913# #' special errors, such as the ones generated by \code{\link{validate}()}, 914# #' \code{\link{req}()} and \code{\link{cancelOutput}()}. 915# #' 916# #' @param message An optional error message. 917# #' @param class An optional class to add to the error. 918# #' @export 919# #' @examples 920# #' ## Note: the breaking of the reactive chain that happens in the app 921# #' ## below (when input$txt = 'bad' and input$allowBad = 'FALSE') is 922# #' ## easily visualized with `reactlogShow()` 923# #' 924# #' ## Only run examples in interactive R sessions 925# #' if (interactive()) { 926# #' 927# #' ui <- fluidPage( 928# #' textInput('txt', 'Enter some text...'), 929# #' selectInput('allowBad', 'Allow the string \'bad\'?', 930# #' c('TRUE', 'FALSE'), selected = 'FALSE') 931# #' ) 932# #' 933# #' server <- function(input, output) { 934# #' val <- reactive({ 935# #' if (!(as.logical(input$allowBad))) { 936# #' if (identical(input$txt, "bad")) { 937# #' reactiveStop() 938# #' } 939# #' } 940## ' }) 941# #' 942# #' observe({ 943# #' val() 944# #' }) 945# #' } 946# #' 947# #' shinyApp(ui, server) 948# #' } 949# #' @export 950reactiveStop <- function(message = "", class = NULL) { 951 stopWithCondition(c("shiny.silent.error", class), message) 952} 953 954#' Validate input values and other conditions 955#' 956#' @description 957#' `validate()` provides convenient mechanism for validating that an output 958#' has all the inputs necessary for successful rendering. It takes any number 959#' of (unnamed) arguments, each representing a condition to test. If any 960#' of condition fails (i.e. is not ["truthy"][isTruthy]), a special type of 961#' error is signaled to stop execution. If this error is not handled by 962#' application-specific code, it is displayed to the user by Shiny. 963#' 964#' If you use `validate()` in a [reactive()] validation failures will 965#' automatically propagate to outputs that use the reactive. 966#' 967#' @section `need()`: 968#' An easy way to provide arguments to `validate()` is to use `need()`, which 969#' takes an expression and a string. If the expression is not 970#' ["truthy"][isTruthy] then the string will be used as the error message. 971#' 972#' If "truthiness" is flexible for your use case, you'll need to explicitly 973#' generate a logical values. For example, if you want allow `NA` but not 974#' `NULL`, you can `!is.null(input$foo)`. 975#' 976#' If you need validation logic that differs significantly from `need()`, you 977#' can create your own validation test functions. A passing test should return 978#' `NULL`. A failing test should return either a string providing the error 979#' to display to the user, or if the failure should happen silently, `FALSE`. 980#' 981#' Alternatively you can use `validate()` within an `if` statement, which is 982#' particularly useful for more complex conditions: 983#' 984#' ``` 985#' if (input$x < 0 && input$choice == "positive") { 986#' validate("If choice is positive then x must be greater than 0") 987#' } 988#' ``` 989#' 990#' @param ... A list of tests. Each test should equal `NULL` for success, 991#' `FALSE` for silent failure, or a string for failure with an error 992#' message. 993#' @param errorClass A CSS class to apply. The actual CSS string will have 994#' `shiny-output-error-` prepended to this value. 995#' @export 996#' @examples 997#' ## Only run examples in interactive R sessions 998#' if (interactive()) { 999#' options(device.ask.default = FALSE) 1000#' 1001#' ui <- fluidPage( 1002#' checkboxGroupInput('in1', 'Check some letters', choices = head(LETTERS)), 1003#' selectizeInput('in2', 'Select a state', choices = c("", state.name)), 1004#' plotOutput('plot') 1005#' ) 1006#' 1007#' server <- function(input, output) { 1008#' output$plot <- renderPlot({ 1009#' validate( 1010#' need(input$in1, 'Check at least one letter!'), 1011#' need(input$in2 != '', 'Please choose a state.') 1012#' ) 1013#' plot(1:10, main = paste(c(input$in1, input$in2), collapse = ', ')) 1014#' }) 1015#' } 1016#' 1017#' shinyApp(ui, server) 1018#' 1019#' } 1020validate <- function(..., errorClass = character(0)) { 1021 results <- sapply(list2(...), function(x) { 1022 # Detect NULL or NA 1023 if (is.null(x)) 1024 return(NA_character_) 1025 else if (identical(x, FALSE)) 1026 return("") 1027 else if (is.character(x)) 1028 return(paste(as.character(x), collapse = "\n")) 1029 else 1030 stop("Unexpected validation result: ", as.character(x)) 1031 }) 1032 1033 results <- stats::na.omit(results) 1034 if (length(results) == 0) 1035 return(invisible()) 1036 1037 # There may be empty strings remaining; these are message-less failures that 1038 # started as FALSE 1039 results <- results[nzchar(results)] 1040 reactiveStop(paste(results, collapse="\n"), c(errorClass, "validation")) 1041} 1042 1043#' @param expr An expression to test. The condition will pass if the expression 1044#' meets the conditions spelled out in Details. 1045#' @param message A message to convey to the user if the validation condition is 1046#' not met. If no message is provided, one will be created using `label`. 1047#' To fail with no message, use `FALSE` for the message. 1048#' @param label A human-readable name for the field that may be missing. This 1049#' parameter is not needed if `message` is provided, but must be provided 1050#' otherwise. 1051#' @export 1052#' @rdname validate 1053need <- function(expr, message = paste(label, "must be provided"), label) { 1054 1055 force(message) # Fail fast on message/label both being missing 1056 1057 if (!isTruthy(expr)) 1058 return(message) 1059 else 1060 return(invisible(NULL)) 1061} 1062 1063#' Check for required values 1064#' 1065#' Ensure that values are available (["truthy"][isTruthy]) before proceeding 1066#' with a calculation or action. If any of the given values is not truthy, the 1067#' operation is stopped by raising a "silent" exception (not logged by Shiny, 1068#' nor displayed in the Shiny app's UI). 1069#' 1070#' The `req` function was designed to be used in one of two ways. The first 1071#' is to call it like a statement (ignoring its return value) before attempting 1072#' operations using the required values: 1073#' 1074#' ``` 1075#' rv <- reactiveValues(state = FALSE) 1076#' r <- reactive({ 1077#' req(input$a, input$b, rv$state) 1078#' # Code that uses input$a, input$b, and/or rv$state... 1079#' }) 1080#' ``` 1081#' 1082#' In this example, if `r()` is called and any of `input$a`, 1083#' `input$b`, and `rv$state` are `NULL`, `FALSE`, `""`, 1084#' etc., then the `req` call will trigger an error that propagates all the 1085#' way up to whatever render block or observer is executing. 1086#' 1087#' The second is to use it to wrap an expression that must be truthy: 1088#' 1089#' ``` 1090#' output$plot <- renderPlot({ 1091#' if (req(input$plotType) == "histogram") { 1092#' hist(dataset()) 1093#' } else if (input$plotType == "scatter") { 1094#' qplot(dataset(), aes(x = x, y = y)) 1095#' } 1096#' }) 1097#' ``` 1098#' 1099#' In this example, `req(input$plotType)` first checks that 1100#' `input$plotType` is truthy, and if so, returns it. This is a convenient 1101#' way to check for a value "inline" with its first use. 1102#' 1103#' @section Using `req(FALSE)`: 1104#' 1105#' You can use `req(FALSE)` (i.e. no condition) if you've already performed 1106#' all the checks you needed to by that point and just want to stop the reactive 1107#' chain now. There is no advantange to this, except perhaps ease of readibility 1108#' if you have a complicated condition to check for (or perhaps if you'd like to 1109#' divide your condition into nested `if` statements). 1110#' 1111#' @section Using `cancelOutput = TRUE`: 1112#' 1113#' When `req(..., cancelOutput = TRUE)` is used, the "silent" exception is 1114#' also raised, but it is treated slightly differently if one or more outputs are 1115#' currently being evaluated. In those cases, the reactive chain does not proceed 1116#' or update, but the output(s) are left is whatever state they happen to be in 1117#' (whatever was their last valid state). 1118#' 1119#' Note that this is always going to be the case if 1120#' this is used inside an output context (e.g. `output$txt <- ...`). It may 1121#' or may not be the case if it is used inside a non-output context (e.g. 1122#' [reactive()], [observe()] or [observeEvent()]) 1123#' --- depending on whether or not there is an `output$...` that is triggered 1124#' as a result of those calls. See the examples below for concrete scenarios. 1125#' 1126#' @param ... Values to check for truthiness. 1127#' @param cancelOutput If `TRUE` and an output is being evaluated, stop 1128#' processing as usual but instead of clearing the output, leave it in 1129#' whatever state it happens to be in. 1130#' @return The first value that was passed in. 1131#' @export 1132#' @examples 1133#' ## Only run examples in interactive R sessions 1134#' if (interactive()) { 1135#' ui <- fluidPage( 1136#' textInput('data', 'Enter a dataset from the "datasets" package', 'cars'), 1137#' p('(E.g. "cars", "mtcars", "pressure", "faithful")'), hr(), 1138#' tableOutput('tbl') 1139#' ) 1140#' 1141#' server <- function(input, output) { 1142#' output$tbl <- renderTable({ 1143#' 1144#' ## to require that the user types something, use: `req(input$data)` 1145#' ## but better: require that input$data is valid and leave the last 1146#' ## valid table up 1147#' req(exists(input$data, "package:datasets", inherits = FALSE), 1148#' cancelOutput = TRUE) 1149#' 1150#' head(get(input$data, "package:datasets", inherits = FALSE)) 1151#' }) 1152#' } 1153#' 1154#' shinyApp(ui, server) 1155#' } 1156req <- function(..., cancelOutput = FALSE) { 1157 dotloop(function(item) { 1158 if (!isTruthy(item)) { 1159 if (isTRUE(cancelOutput)) { 1160 cancelOutput() 1161 } else { 1162 reactiveStop(class = "validation") 1163 } 1164 } 1165 }, ...) 1166 1167 if (!missing(..1)) 1168 ..1 1169 else 1170 invisible() 1171} 1172 1173#***********************************************************************# 1174#**** Keep this function internal for now, may chnage in the future ****# 1175#***********************************************************************# 1176# #' Cancel processing of the current output 1177# #' 1178# #' Signals an error that Shiny treats specially if an output is currently being 1179# #' evaluated. Execution will stop, but rather than clearing the output (as 1180# #' \code{\link{req}} does) or showing an error message (as \code{\link{stop}} 1181# #' does), the output simply remains unchanged. 1182# #' 1183# #' If \code{cancelOutput} is called in any non-output context (like in an 1184# #' \code{\link{observe}} or \code{\link{observeEvent}}), the effect is the same 1185# #' as \code{\link{req}(FALSE)}. 1186# #' @export 1187# #' @examples 1188# #' ## Only run examples in interactive R sessions 1189# #' if (interactive()) { 1190# #' 1191# #' # uncomment the desired line to experiment with cancelOutput() vs. req() 1192# #' 1193# #' ui <- fluidPage( 1194# #' textInput('txt', 'Enter text'), 1195# #' textOutput('check') 1196# #' ) 1197# #' 1198# #' server <- function(input, output) { 1199# #' output$check <- renderText({ 1200# #' # req(input$txt) 1201# #' if (input$txt == 'hi') return('hi') 1202# #' else if (input$txt == 'bye') return('bye') 1203# #' # else cancelOutput() 1204# #' }) 1205# #' } 1206# #' 1207# #' shinyApp(ui, server) 1208# #' } 1209cancelOutput <- function() { 1210 reactiveStop(class = "shiny.output.cancel") 1211} 1212 1213# Execute a function against each element of ..., but only evaluate each element 1214# after the previous element has been passed to fun_. The return value of fun_ 1215# is discarded, and only invisible() is returned from dotloop. 1216# 1217# Can be used to facilitate short-circuit eval on dots. 1218dotloop <- function(fun_, ...) { 1219 for (i in seq_len(nargs() - 1)) { 1220 fun_(eval(as.symbol(paste0("..", i)))) 1221 } 1222 invisible() 1223} 1224 1225#' Truthy and falsy values 1226#' 1227#' The terms "truthy" and "falsy" generally indicate whether a value, when 1228#' coerced to a [base::logical()], is `TRUE` or `FALSE`. We use 1229#' the term a little loosely here; our usage tries to match the intuitive 1230#' notions of "Is this value missing or available?", or "Has the user provided 1231#' an answer?", or in the case of action buttons, "Has the button been 1232#' clicked?". 1233#' 1234#' For example, a `textInput` that has not been filled out by the user has 1235#' a value of `""`, so that is considered a falsy value. 1236#' 1237#' To be precise, a value is truthy *unless* it is one of: 1238#' 1239#' * `FALSE` 1240#' * `NULL` 1241#' * `""` 1242#' * An empty atomic vector 1243#' * An atomic vector that contains only missing values 1244#' * A logical vector that contains all `FALSE` or missing values 1245#' * An object of class `"try-error"` 1246#' * A value that represents an unclicked [actionButton()] 1247#' 1248#' Note in particular that the value `0` is considered truthy, even though 1249#' `as.logical(0)` is `FALSE`. 1250#' 1251#' @param x An expression whose truthiness value we want to determine 1252#' @export 1253isTruthy <- function(x) { 1254 if (inherits(x, 'try-error')) 1255 return(FALSE) 1256 1257 if (!is.atomic(x)) 1258 return(TRUE) 1259 1260 if (is.null(x)) 1261 return(FALSE) 1262 if (length(x) == 0) 1263 return(FALSE) 1264 if (all(is.na(x))) 1265 return(FALSE) 1266 if (is.character(x) && !any(nzchar(stats::na.omit(x)))) 1267 return(FALSE) 1268 if (inherits(x, 'shinyActionButtonValue') && x == 0) 1269 return(FALSE) 1270 if (is.logical(x) && !any(stats::na.omit(x))) 1271 return(FALSE) 1272 1273 return(TRUE) 1274} 1275 1276# add class(es) to the error condition, which will be used as names of CSS 1277# classes, e.g. shiny-output-error shiny-output-error-validation 1278stopWithCondition <- function(class, message) { 1279 cond <- structure( 1280 list(message = message), 1281 class = c(class, 'error', 'condition') 1282 ) 1283 stop(cond) 1284} 1285 1286#' Collect information about the Shiny Server environment 1287#' 1288#' This function returns the information about the current Shiny Server, such as 1289#' its version, and whether it is the open source edition or professional 1290#' edition. If the app is not served through the Shiny Server, this function 1291#' just returns `list(shinyServer = FALSE)`. 1292#' 1293#' This function will only return meaningful data when using Shiny Server 1294#' version 1.2.2 or later. 1295#' @export 1296#' @return A list of the Shiny Server information. 1297serverInfo <- function() { 1298 .globals$serverInfo 1299} 1300.globals$serverInfo <- list(shinyServer = FALSE) 1301 1302setServerInfo <- function(...) { 1303 infoOld <- serverInfo() 1304 infoNew <- list(...) 1305 infoOld[names(infoNew)] <- infoNew 1306 .globals$serverInfo <- infoOld 1307} 1308 1309# assume file is encoded in UTF-8, but warn against BOM 1310checkEncoding <- function(file) { 1311 # skip *nix because its locale is normally UTF-8 based (e.g. en_US.UTF-8), and 1312 # *nix users have to make a conscious effort to save a file with an encoding 1313 # that is not UTF-8; if they choose to do so, we cannot do much about it 1314 # except sitting back and seeing them punished after they choose to escape a 1315 # world of consistency (falling back to getOption('encoding') will not help 1316 # because native.enc is also normally UTF-8 based on *nix) 1317 if (!isWindows()) return('UTF-8') 1318 size <- file.info(file)[, 'size'] 1319 if (is.na(size)) stop('Cannot access the file ', file) 1320 # BOM is 3 bytes, so if the file contains BOM, it must be at least 3 bytes 1321 if (size < 3L) return('UTF-8') 1322 1323 # check if there is a BOM character: this is also skipped on *nix, because R 1324 # on *nix simply ignores this meaningless character if present, but it hurts 1325 # on Windows 1326 if (identical(charToRaw(readChar(file, 3L, TRUE)), charToRaw('\UFEFF'))) { 1327 warning('You should not include the Byte Order Mark (BOM) in ', file, '. ', 1328 'Please re-save it in UTF-8 without BOM. See ', 1329 'https://shiny.rstudio.com/articles/unicode.html for more info.') 1330 return('UTF-8-BOM') 1331 } 1332 x <- readChar(file, size, useBytes = TRUE) 1333 if (is.na(iconv(x, 'UTF-8', 'UTF-8'))) { 1334 warning('The input file ', file, ' does not seem to be encoded in UTF8') 1335 } 1336 'UTF-8' 1337} 1338 1339# read a file using UTF-8 and (on Windows) convert to native encoding if possible 1340readUTF8 <- function(file) { 1341 enc <- checkEncoding(file) 1342 file <- base::file(file, encoding = enc) 1343 on.exit(close(file), add = TRUE) 1344 x <- enc2utf8(readLines(file, warn = FALSE)) 1345 tryNativeEncoding(x) 1346} 1347 1348# if the UTF-8 string can be represented in the native encoding, use native encoding 1349tryNativeEncoding <- function(string) { 1350 if (!isWindows()) return(string) 1351 string2 <- enc2native(string) 1352 if (identical(enc2utf8(string2), string)) string2 else string 1353} 1354 1355# similarly, try to source() a file with UTF-8 1356sourceUTF8 <- function(file, envir = globalenv()) { 1357 lines <- readUTF8(file) 1358 enc <- if (any(Encoding(lines) == 'UTF-8')) 'UTF-8' else 'unknown' 1359 src <- srcfilecopy(file, lines, isFile = TRUE) # source reference info 1360 # oddly, parse(file) does not work when file contains multibyte chars that 1361 # **can** be encoded natively on Windows (might be a bug in base R); we 1362 # rewrite the source code in a natively encoded temp file and parse it in this 1363 # case (the source reference is still pointed to the original file, though) 1364 if (isWindows() && enc == 'unknown') { 1365 file <- tempfile(); on.exit(unlink(file), add = TRUE) 1366 writeLines(lines, file) 1367 } 1368 exprs <- try(parse(file, keep.source = FALSE, srcfile = src, encoding = enc)) 1369 if (inherits(exprs, "try-error")) { 1370 diagnoseCode(file) 1371 stop("Error sourcing ", file) 1372 } 1373 1374 # Wrap the exprs in first `{`, then ..stacktraceon..(). It's only really the 1375 # ..stacktraceon..() that we care about, but the `{` is needed to make that 1376 # possible. 1377 exprs <- makeCall(`{`, exprs) 1378 # Need to wrap exprs in a list because we want it treated as a single argument 1379 exprs <- makeCall(..stacktraceon.., list(exprs)) 1380 1381 eval(exprs, envir) 1382} 1383 1384# @param func Name of function, in unquoted form 1385# @param args An evaluated list of unevaluated argument expressions 1386makeCall <- function(func, args) { 1387 as.call(c(list(substitute(func)), args)) 1388} 1389 1390# a workaround for https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16264 1391srcfilecopy <- function(filename, lines, ...) { 1392 if (getRversion() > '3.2.2') return(base::srcfilecopy(filename, lines, ...)) 1393 src <- base::srcfilecopy(filename, lines = '', ...) 1394 src$lines <- lines 1395 src 1396} 1397 1398# write text as UTF-8 1399writeUTF8 <- function(text, ...) { 1400 text <- enc2utf8(text) 1401 writeLines(text, ..., useBytes = TRUE) 1402} 1403 1404URLdecode <- function(value) { 1405 decodeURIComponent(value) 1406} 1407 1408URLencode <- function(value, reserved = FALSE) { 1409 value <- enc2utf8(value) 1410 if (reserved) encodeURIComponent(value) else encodeURI(value) 1411} 1412 1413# Make sure user-supplied dates are either NULL or can be coerced to a 1414# yyyy-mm-dd formatted string. If a date is specified, this function returns a 1415# string for consistency across locales. Also, `as.Date()` is used to coerce 1416# strings to date objects so that strings like "2016-08-9" are expanded to 1417# "2016-08-09". If any of the values result in error or NA, then the input 1418# `date` is returned unchanged. 1419dateYMD <- function(date = NULL, argName = "value") { 1420 if (!length(date)) return(NULL) 1421 tryCatch({ 1422 res <- format(as.Date(date), "%Y-%m-%d") 1423 if (any(is.na(res))) stop() 1424 date <- res 1425 }, 1426 error = function(e) { 1427 warning( 1428 "Couldn't coerce the `", argName, 1429 "` argument to a date string with format yyyy-mm-dd", 1430 call. = FALSE 1431 ) 1432 } 1433 ) 1434 date 1435} 1436 1437# This function takes a name and function, and it wraps that function in a new 1438# function which calls the original function using the specified name. This can 1439# be helpful for profiling, because the specified name will show up on the stack 1440# trace. 1441wrapFunctionLabel <- function(func, name, ..stacktraceon = FALSE, dots = TRUE) { 1442 if (name == "name" || name == "func" || name == "relabelWrapper") { 1443 stop("Invalid name for wrapFunctionLabel: ", name) 1444 } 1445 assign(name, func, environment()) 1446 registerDebugHook(name, environment(), name) 1447 1448 if (isTRUE(dots)) { 1449 if (..stacktraceon) { 1450 # We need to wrap the `...` in `!!quote(...)` so that R CMD check won't 1451 # complain about "... may be used in an incorrect context" 1452 body <- expr({ ..stacktraceon..((!!name)(!!quote(...))) }) 1453 } else { 1454 body <- expr({ (!!name)(!!quote(...)) }) 1455 } 1456 relabelWrapper <- new_function(pairlist2(... =), body, environment()) 1457 } else { 1458 # Same logic as when `dots = TRUE`, but without the `...` 1459 if (..stacktraceon) { 1460 body <- expr({ ..stacktraceon..((!!name)()) }) 1461 } else { 1462 body <- expr({ (!!name)() }) 1463 } 1464 relabelWrapper <- new_function(list(), body, environment()) 1465 } 1466 1467 # Preserve the original function that was passed in; is used for caching. 1468 attr(relabelWrapper, "wrappedFunc") <- func 1469 relabelWrapper 1470} 1471 1472 1473# This is a very simple mutable object which only stores one value 1474# (which we can set and get). Using this class is sometimes useful 1475# when communicating persistent changes across functions. 1476Mutable <- R6Class("Mutable", 1477 private = list( 1478 value = NULL 1479 ), 1480 public = list( 1481 set = function(value) { private$value <- value }, 1482 get = function() { private$value } 1483 ) 1484) 1485 1486# More convenient way of chaining together promises than then/catch/finally, 1487# without the performance impact of %...>%. 1488promise_chain <- function(promise, ..., catch = NULL, finally = NULL, 1489 domain = NULL, replace = FALSE) { 1490 1491 do <- function() { 1492 p <- Reduce(function(memo, func) { 1493 promises::then(memo, func) 1494 }, list(...), promise) 1495 1496 if (!is.null(catch)) { 1497 p <- promises::catch(p, catch) 1498 } 1499 1500 if (!is.null(finally)) { 1501 p <- promises::finally(p, finally) 1502 } 1503 1504 p 1505 } 1506 1507 if (!is.null(domain)) { 1508 promises::with_promise_domain(domain, do(), replace = replace) 1509 } else { 1510 do() 1511 } 1512} 1513 1514# Like promise_chain, but if `expr` returns a non-promise, then `...`, `catch`, 1515# and `finally` are all executed synchronously 1516hybrid_chain <- function(expr, ..., catch = NULL, finally = NULL, 1517 domain = NULL, replace = FALSE) { 1518 1519 do <- function() { 1520 runFinally <- TRUE 1521 tryCatch( 1522 { 1523 captureStackTraces({ 1524 result <- withVisible(force(expr)) 1525 if (promises::is.promising(result$value)) { 1526 # Purposefully NOT including domain (nor replace), as we're already in 1527 # the domain at this point 1528 p <- promise_chain(valueWithVisible(result), ..., catch = catch, finally = finally) 1529 runFinally <- FALSE 1530 p 1531 } else { 1532 result <- Reduce( 1533 function(v, func) { 1534 if (v$visible) { 1535 withVisible(func(v$value)) 1536 } else { 1537 withVisible(func(invisible(v$value))) 1538 } 1539 }, 1540 list(...), 1541 result 1542 ) 1543 1544 valueWithVisible(result) 1545 } 1546 }) 1547 }, 1548 error = function(e) { 1549 if (!is.null(catch)) 1550 catch(e) 1551 else 1552 stop(e) 1553 }, 1554 finally = if (runFinally && !is.null(finally)) finally() 1555 ) 1556 } 1557 1558 if (!is.null(domain)) { 1559 promises::with_promise_domain(domain, do(), replace = replace) 1560 } else { 1561 do() 1562 } 1563} 1564 1565# Given a list with items named `value` and `visible`, return `x$value` either 1566# visibly, or invisibly, depending on the value of `x$visible`. 1567valueWithVisible <- function(x) { 1568 if (x$visible) x$value else invisible(x$value) 1569} 1570 1571 1572createVarPromiseDomain <- function(env, name, value) { 1573 force(env) 1574 force(name) 1575 force(value) 1576 1577 promises::new_promise_domain( 1578 wrapOnFulfilled = function(onFulfilled) { 1579 function(...) { 1580 orig <- env[[name]] 1581 env[[name]] <- value 1582 on.exit(env[[name]] <- orig) 1583 1584 onFulfilled(...) 1585 } 1586 }, 1587 wrapOnRejected = function(onRejected) { 1588 function(...) { 1589 orig <- env[[name]] 1590 env[[name]] <- value 1591 on.exit(env[[name]] <- orig) 1592 1593 onRejected(...) 1594 } 1595 }, 1596 wrapSync = function(expr) { 1597 orig <- env[[name]] 1598 env[[name]] <- value 1599 on.exit(env[[name]] <- orig) 1600 1601 force(expr) 1602 } 1603 ) 1604} 1605 1606getSliderType <- function(min, max, value) { 1607 vals <- dropNulls(list(value, min, max)) 1608 if (length(vals) == 0) return("") 1609 type <- unique(lapply(vals, function(x) { 1610 if (inherits(x, "Date")) "date" 1611 else if (inherits(x, "POSIXt")) "datetime" 1612 else "number" 1613 })) 1614 if (length(type) > 1) { 1615 rlang::abort(c( 1616 "Type mismatch for `min`, `max`, and `value`.", 1617 "All values must either be numeric, Date, or POSIXt." 1618 )) 1619 } 1620 type[[1]] 1621} 1622 1623# Reads the `shiny.sharedSecret` global option, and returns a function that can 1624# be used to test header values for a match. 1625loadSharedSecret <- function() { 1626 normalizeToRaw <- function(value, label = "value") { 1627 if (is.null(value)) { 1628 raw() 1629 } else if (is.character(value)) { 1630 charToRaw(paste(value, collapse = "\n")) 1631 } else if (is.raw(value)) { 1632 value 1633 } else { 1634 stop("Wrong type for ", label, "; character or raw expected") 1635 } 1636 } 1637 1638 sharedSecret <- normalizeToRaw(getOption("shiny.sharedSecret")) 1639 if (is.null(sharedSecret)) { 1640 function(x) TRUE 1641 } else { 1642 # We compare the digest of the two values so that their lengths are equalized 1643 function(x) { 1644 x <- normalizeToRaw(x) 1645 # Constant time comparison to avoid timing attacks 1646 constantTimeEquals(sharedSecret, x) 1647 } 1648 } 1649} 1650 1651# Compares two raw vectors of equal length for equality, in constant time 1652constantTimeEquals <- function(raw1, raw2) { 1653 stopifnot(is.raw(raw1)) 1654 stopifnot(is.raw(raw2)) 1655 if (length(raw1) != length(raw2)) { 1656 return(FALSE) 1657 } 1658 1659 sum(as.integer(xor(raw1, raw2))) == 0 1660} 1661 1662cat_line <- function(...) { 1663 cat(paste(..., "\n", collapse = "")) 1664} 1665 1666select_menu <- function(choices, title = NULL, msg = "Enter one or more numbers (with spaces), or an empty line to exit: \n") 1667{ 1668 if (!is.null(title)) { 1669 cat(title, "\n", sep = "") 1670 } 1671 nc <- length(choices) 1672 op <- paste0(format(seq_len(nc)), ": ", choices) 1673 fop <- format(op) 1674 cat("", fop, "", sep = "\n") 1675 repeat { 1676 answer <- readline(msg) 1677 answer <- strsplit(answer, "[ ,]+")[[1]] 1678 if (all(answer %in% seq_along(choices))) { 1679 return(choices[as.integer(answer)]) 1680 } 1681 } 1682} 1683 1684#' @noRd 1685isAppDir <- function(path) { 1686 1687 if (file.exists(file.path.ci(path, "app.R"))) 1688 return(TRUE) 1689 1690 if (file.exists(file.path.ci(path, "server.R")) 1691 && file.exists(file.path.ci(path, "ui.R"))) 1692 return(TRUE) 1693 1694 FALSE 1695} 1696 1697# Borrowed from rprojroot which borrowed from devtools 1698#' @noRd 1699is_root <- function(path) { 1700 identical( 1701 normalizePath(path, winslash = "/"), 1702 normalizePath(dirname(path), winslash = "/") 1703 ) 1704} 1705 1706#' @noRd 1707findEnclosingApp <- function(path = ".") { 1708 orig_path <- path 1709 path <- normalizePath(path, winslash = "/", mustWork = TRUE) 1710 repeat { 1711 if (isAppDir(path)) 1712 return(path) 1713 if (is_root(path)) 1714 stop("Shiny app not found at ", orig_path, " or in any parent directory.") 1715 path <- dirname(path) 1716 } 1717} 1718 1719# Check if a package is installed, and if version is specified, 1720# that we have at least that version 1721is_available <- function(package, version = NULL) { 1722 installed <- nzchar(system.file(package = package)) 1723 if (is.null(version)) { 1724 return(installed) 1725 } 1726 installed && isTRUE(utils::packageVersion(package) >= version) 1727} 1728 1729 1730# cached version of utils::packageVersion("shiny") 1731shinyPackageVersion <- local({ 1732 version <- NULL 1733 function() { 1734 if (is.null(version)) { 1735 version <<- utils::packageVersion("shiny") 1736 } 1737 version 1738 } 1739}) 1740