R/reactives.R

In YTLogos/shiny: Web Application Framework for R

#' @include utils.R
NULL

Dependents <- R6Class(
  'Dependents',
  portable = FALSE,
  class = FALSE,
  public = list(
    .dependents = 'Map',

    initialize = function() {
      .dependents <<- Map$new()
    },
    register = function(depId=NULL, depLabel=NULL) {
      ctx <- .getReactiveEnvironment()$currentContext()
      if (!.dependents$containsKey(ctx$id)) {
        .dependents$set(ctx$id, ctx)
        ctx$onInvalidate(function() {
          .dependents$remove(ctx$id)
        })

        if (!is.null(depId) && nchar(depId) > 0)
          .graphDependsOnId(ctx$id, depId)
        if (!is.null(depLabel))
          .graphDependsOn(ctx$id, depLabel)
      }
    },
    invalidate = function() {
      lapply(
        .dependents$values(),
        function(ctx) {
          ctx$invalidate()
          NULL
        }
      )
    }
  )
)


# ReactiveVal ---------------------------------------------------------------

ReactiveVal <- R6Class(
  'ReactiveVal',
  portable = FALSE,
  private = list(
    value = NULL,
    label = NULL,
    frozen = FALSE,
    dependents = NULL
  ),
  public = list(
    initialize = function(value, label = NULL) {
      private$value <- value
      private$label <- label
      private$dependents <- Dependents$new()
      .graphValueChange(private$label, value)
    },
    get = function() {
      private$dependents$register(depLabel = private$label)

      if (private$frozen)
        reactiveStop()

      private$value
    },
    set = function(value) {
      if (identical(private$value, value)) {
        return(invisible(FALSE))
      }
      private$value <- value
      .graphValueChange(private$label, value)
      private$dependents$invalidate()
      invisible(TRUE)
    },
    freeze = function(session = getDefaultReactiveDomain()) {
      if (is.null(session)) {
        stop("Can't freeze a reactiveVal without a reactive domain")
      }
      session$onFlushed(function() {
        self$thaw()
      })
      private$frozen <- TRUE
    },
    thaw = function() {
      private$frozen <- FALSE
    },
    isFrozen = function() {
      private$frozen
    },
    format = function(...) {
      # capture.output(print()) is necessary because format() doesn't
      # necessarily return a character vector, e.g. data.frame.
      label <- capture.output(print(base::format(private$value, ...)))
      if (length(label) == 1) {
        paste0("reactiveVal: ", label)
      } else {
        c("reactiveVal:", label)
      }
    }
  )
)

#' Create a (single) reactive value
#'
#' The \code{reactiveVal} function is used to construct a "reactive value"
#' object. This is an object used for reading and writing a value, like a
#' variable, but with special capabilities for reactive programming. When you
#' read the value out of a reactiveVal object, the calling reactive expression
#' takes a dependency, and when you change the value, it notifies any reactives
#' that previously depended on that value.
#'
#' \code{reactiveVal} is very similar to \code{\link{reactiveValues}}, except
#' that the former is for a single reactive value (like a variable), whereas the
#' latter lets you conveniently use multiple reactive values by name (like a
#' named list of variables). For a one-off reactive value, it's more natural to
#' use \code{reactiveVal}. See the Examples section for an illustration.
#'
#' @param value An optional initial value.
#' @param label An optional label, for debugging purposes (see
#'   \code{\link{showReactLog}}). If missing, a label will be automatically
#'   created.
#'
#' @return A function. Call the function with no arguments to (reactively) read
#'   the value; call the function with a single argument to set the value.
#'
#' @examples
#'
#' \dontrun{
#'
#' # Create the object by calling reactiveVal
#' r <- reactiveVal()
#'
#' # Set the value by calling with an argument
#' r(10)
#'
#' # Read the value by calling without arguments
#' r()
#'
#' }
#'
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#'   actionButton("minus", "-1"),
#'   actionButton("plus", "+1"),
#'   br(),
#'   textOutput("value")
#' )
#'
#' # The comments below show the equivalent logic using reactiveValues()
#' server <- function(input, output, session) {
#'   value <- reactiveVal(0)       # rv <- reactiveValues(value = 0)
#'
#'   observeEvent(input$minus, {
#'     newValue <- value() - 1     # newValue <- rv$value - 1
#'     value(newValue)             # rv$value <- newValue
#'   })
#'
#'   observeEvent(input$plus, {
#'     newValue <- value() + 1     # newValue <- rv$value + 1
#'     value(newValue)             # rv$value <- newValue
#'   })
#'
#'   output$value <- renderText({
#'     value()                     # rv$value
#'   })
#' }
#'
#' shinyApp(ui, server)
#'
#' }
#'
#' @export
reactiveVal <- function(value = NULL, label = NULL) {
  if (missing(label)) {
    call <- sys.call()
    label <- rvalSrcrefToLabel(attr(call, "srcref", exact = TRUE))
  }

  rv <- ReactiveVal$new(value, label)
  structure(
    function(x) {
      if (missing(x)) {
        rv$get()
      } else {
        force(x)
        rv$set(x)
      }
    },
    class = c("reactiveVal", "reactive"),
    label = label,
    .impl = rv
  )
}

#' @rdname freezeReactiveValue
#' @export
freezeReactiveVal <- function(x) {
  domain <- getDefaultReactiveDomain()
  if (is.null(domain)) {
    stop("freezeReactiveVal() must be called when a default reactive domain is active.")
  }
  if (!inherits(x, "reactiveVal")) {
    stop("x must be a reactiveVal object")
  }

  attr(x, ".impl", exact = TRUE)$freeze(domain)
  invisible()
}

#' @export
format.reactiveVal <- function(x, ...) {
  attr(x, ".impl", exact = TRUE)$format(...)
}

# Attempts to extract the variable name that the reactiveVal object is being
# assigned to (e.g. for `a <- reactiveVal()`, the result should be "a"). This
# is a fragile, error-prone operation, so we default to a random label if
# necessary.
rvalSrcrefToLabel <- function(srcref,
  defaultLabel = paste0("reactiveVal", createUniqueId(4))) {

  if (is.null(srcref))
    return(defaultLabel)

  srcfile <- attr(srcref, "srcfile", exact = TRUE)
  if (is.null(srcfile))
    return(defaultLabel)

  if (is.null(srcfile$lines))
    return(defaultLabel)

  lines <- srcfile$lines
  # When pasting at the Console, srcfile$lines is not split
  if (length(lines) == 1) {
    lines <- strsplit(lines, "\n")[[1]]
  }

  if (length(lines) < srcref[1]) {
    return(defaultLabel)
  }

  firstLine <- substring(lines[srcref[1]], srcref[2] - 1)

  m <- regexec("\\s*([^[:space:]]+)\\s*(<-|=)\\s*reactiveVal\\b", firstLine)
  if (m[[1]][1] == -1) {
    return(defaultLabel)
  }

  sym <- regmatches(firstLine, m)[[1]][2]
  res <- try(parse(text = sym), silent = TRUE)
  if (inherits(res, "try-error"))
    return(defaultLabel)

  if (length(res) != 1)
    return(defaultLabel)

  return(as.character(res))
}


# ReactiveValues ------------------------------------------------------------

ReactiveValues <- R6Class(
  'ReactiveValues',
  portable = FALSE,
  public = list(
    # For debug purposes
    .label = character(0),
    .values = 'environment',
    .metadata = 'environment',
    .dependents = 'environment',
    # Dependents for the list of all names, including hidden
    .namesDeps = 'Dependents',
    # Dependents for all values, including hidden
    .allValuesDeps = 'Dependents',
    # Dependents for all values
    .valuesDeps = 'Dependents',

    initialize = function() {
      .label <<- paste('reactiveValues',
                       p_randomInt(1000, 10000),
                       sep="")
      .values <<- new.env(parent=emptyenv())
      .metadata <<- new.env(parent=emptyenv())
      .dependents <<- new.env(parent=emptyenv())
      .namesDeps <<- Dependents$new()
      .allValuesDeps <<- Dependents$new()
      .valuesDeps <<- Dependents$new()
    },

    get = function(key) {
      # Register the "downstream" reactive which is accessing this value, so
      # that we know to invalidate them when this value changes.
      ctx <- .getReactiveEnvironment()$currentContext()
      dep.key <- paste(key, ':', ctx$id, sep='')
      if (!exists(dep.key, envir=.dependents, inherits=FALSE)) {
        .graphDependsOn(ctx$id, sprintf('%s$%s', .label, key))
        .dependents[[dep.key]] <- ctx
        ctx$onInvalidate(function() {
          rm(list=dep.key, envir=.dependents, inherits=FALSE)
        })
      }

      if (isFrozen(key))
        reactiveStop()

      if (!exists(key, envir=.values, inherits=FALSE))
        NULL
      else
        .values[[key]]
    },

    set = function(key, value) {
      hidden <- substr(key, 1, 1) == "."

      if (exists(key, envir=.values, inherits=FALSE)) {
        if (identical(.values[[key]], value)) {
          return(invisible())
        }
      }
      else {
        .namesDeps$invalidate()
      }

      if (hidden)
        .allValuesDeps$invalidate()
      else
        .valuesDeps$invalidate()

      .values[[key]] <- value

      .graphValueChange(sprintf('names(%s)', .label), ls(.values, all.names=TRUE))
      .graphValueChange(sprintf('%s (all)', .label), as.list(.values))
      .graphValueChange(sprintf('%s$%s', .label, key), value)

      dep.keys <- objects(
        envir=.dependents,
        pattern=paste('^\\Q', key, ':', '\\E', '\\d+$', sep=''),
        all.names=TRUE
      )
      lapply(
        mget(dep.keys, envir=.dependents),
        function(ctx) {
          ctx$invalidate()
          NULL
        }
      )
      invisible()
    },

    mset = function(lst) {
      lapply(base::names(lst),
             function(name) {
               self$set(name, lst[[name]])
             })
    },

    names = function() {
      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                      sprintf('names(%s)', .label))
      .namesDeps$register()
      return(ls(.values, all.names=TRUE))
    },

    # Get a metadata value. Does not trigger reactivity.
    getMeta = function(key, metaKey) {
      # Make sure to use named (not numeric) indexing into list.
      metaKey <- as.character(metaKey)
      .metadata[[key]][[metaKey]]
    },

    # Set a metadata value. Does not trigger reactivity.
    setMeta = function(key, metaKey, value) {
      # Make sure to use named (not numeric) indexing into list.
      metaKey <- as.character(metaKey)

      if (!exists(key, envir = .metadata, inherits = FALSE)) {
        .metadata[[key]] <<- list()
      }

      .metadata[[key]][[metaKey]] <<- value
    },

    # Mark a value as frozen If accessed while frozen, a shiny.silent.error will
    # be thrown.
    freeze = function(key) {
      setMeta(key, "frozen", TRUE)
    },

    thaw = function(key) {
      setMeta(key, "frozen", NULL)
    },

    isFrozen = function(key) {
      isTRUE(getMeta(key, "frozen"))
    },

    toList = function(all.names=FALSE) {
      .graphDependsOn(.getReactiveEnvironment()$currentContext()$id,
                      sprintf('%s (all)', .label))
      if (all.names)
        .allValuesDeps$register()

      .valuesDeps$register()

      return(as.list(.values, all.names=all.names))
    },

    .setLabel = function(label) {
      .label <<- label
    }
  )
)


# reactivevalues ------------------------------------------------------------
# S3 wrapper class for ReactiveValues reference class

#' Create an object for storing reactive values
#'
#' This function returns an object for storing reactive values. It is similar to
#' a list, but with special capabilities for reactive programming. When you read
#' a value from it, the calling reactive expression takes a reactive dependency
#' on that value, and when you write to it, it notifies any reactive functions
#' that depend on that value. Note that values taken from the reactiveValues
#' object are reactive, but the reactiveValues object itself is not.
#'
#' @examples
#' # Create the object with no values
#' values <- reactiveValues()
#'
#' # Assign values to 'a' and 'b'
#' values$a <- 3
#' values[['b']] <- 4
#'
#' \dontrun{
#' # From within a reactive context, you can access values with:
#' values$a
#' values[['a']]
#' }
#'
#' # If not in a reactive context (e.g., at the console), you can use isolate()
#' # to retrieve the value:
#' isolate(values$a)
#' isolate(values[['a']])
#'
#' # Set values upon creation
#' values <- reactiveValues(a = 1, b = 2)
#' isolate(values$a)
#'
#' @param ... Objects that will be added to the reactivevalues object. All of
#'   these objects must be named.
#'
#' @seealso \code{\link{isolate}} and \code{\link{is.reactivevalues}}.
#' @export
reactiveValues <- function(...) {
  args <- list(...)
  if ((length(args) > 0) && (is.null(names(args)) || any(names(args) == "")))
    stop("All arguments passed to reactiveValues() must be named.")

  values <- .createReactiveValues(ReactiveValues$new())

  # Use .subset2() instead of [[, to avoid method dispatch
  .subset2(values, 'impl')$mset(args)
  values
}

checkName <- function(x) {
  if (!is.character(x) || length(x) != 1) {
    stop("Must use single string to index into reactivevalues")
  }
}

# Create a reactivevalues object
#
# @param values A ReactiveValues object
# @param readonly Should this object be read-only?
# @param ns A namespace function (either `identity` or `NS(namespace)`)
.createReactiveValues <- function(values = NULL, readonly = FALSE,
  ns = identity) {

  structure(
    list(
      impl = values,
      readonly = readonly,
      ns = ns
    ),
    class='reactivevalues'
  )
}

#' Checks whether an object is a reactivevalues object
#'
#' Checks whether its argument is a reactivevalues object.
#'
#' @param x The object to test.
#' @seealso \code{\link{reactiveValues}}.
#' @export
is.reactivevalues <- function(x) inherits(x, 'reactivevalues')

#' @export
`$.reactivevalues` <- function(x, name) {
  checkName(name)
  .subset2(x, 'impl')$get(.subset2(x, 'ns')(name))
}

#' @export
`[[.reactivevalues` <- `$.reactivevalues`

#' @export
`$<-.reactivevalues` <- function(x, name, value) {
  if (.subset2(x, 'readonly')) {
    stop("Attempted to assign value to a read-only reactivevalues object")
  }
  checkName(name)
  .subset2(x, 'impl')$set(.subset2(x, 'ns')(name), value)
  x
}

#' @export
`[[<-.reactivevalues` <- `$<-.reactivevalues`

#' @export
`[.reactivevalues` <- function(values, name) {
  stop("Single-bracket indexing of reactivevalues object is not allowed.")
}

#' @export
`[<-.reactivevalues` <- function(values, name, value) {
  stop("Single-bracket indexing of reactivevalues object is not allowed.")
}

#' @export
names.reactivevalues <- function(x) {
  prefix <- .subset2(x, 'ns')("")
  results <- .subset2(x, 'impl')$names()
  if (nzchar(prefix)) {
    results <- results[substring(results, 1, nchar(prefix)) == prefix]
    results <- substring(results, nchar(prefix) + 1)
  }
  results
}

#' @export
`names<-.reactivevalues` <- function(x, value) {
  stop("Can't assign names to reactivevalues object")
}

#' @export
as.list.reactivevalues <- function(x, all.names=FALSE, ...) {
  shinyDeprecated("reactiveValuesToList",
    msg = paste("'as.list.reactivevalues' is deprecated. ",
      "Use reactiveValuesToList instead.",
      "\nPlease see ?reactiveValuesToList for more information.",
      sep = ""))

  reactiveValuesToList(x, all.names)
}

# For debug purposes
.setLabel <- function(x, label) {
  .subset2(x, 'impl')$.setLabel(label)
}

#' Convert a reactivevalues object to a list
#'
#' This function does something similar to what you might \code{\link[base]{as.list}}
#' to do. The difference is that the calling context will take dependencies on
#' every object in the reactivevalues object. To avoid taking dependencies on
#' all the objects, you can wrap the call with \code{\link{isolate}()}.
#'
#' @param x A reactivevalues object.
#' @param all.names If \code{TRUE}, include objects with a leading dot. If
#'   \code{FALSE} (the default) don't include those objects.
#' @examples
#' values <- reactiveValues(a = 1)
#' \dontrun{
#' reactiveValuesToList(values)
#' }
#'
#' # To get the objects without taking dependencies on them, use isolate().
#' # isolate() can also be used when calling from outside a reactive context (e.g.
#' # at the console)
#' isolate(reactiveValuesToList(values))
#' @export
reactiveValuesToList <- function(x, all.names=FALSE) {
  # Default case
  res <- .subset2(x, 'impl')$toList(all.names)

  prefix <- .subset2(x, 'ns')("")
  # Special handling for namespaces
  if (nzchar(prefix)) {
    fullNames <- names(res)

    # Filter out items that match namespace
    fullNames <- fullNames[substring(fullNames, 1, nchar(prefix)) == prefix]
    res <- res[fullNames]

    # Remove namespace prefix
    names(res) <- substring(fullNames, nchar(prefix) + 1)
  }

  res
}

# This function is needed because str() on a reactivevalues object will call
# [[.reactivevalues(), which will give an error when it tries to access
# x[['impl']].
#' @export
str.reactivevalues <- function(object, indent.str = " ", ...) {
  utils::str(unclass(object), indent.str = indent.str, ...)
  # Need to manually print out the class field,
  cat(indent.str, '- attr(*, "class")=', sep = "")
  utils::str(class(object))
}


#' Freeze a reactive value
#'
#' These functions freeze a \code{\link{reactiveVal}}, or an element of a
#' \code{\link{reactiveValues}}. If the value is accessed while frozen, a
#' "silent" exception is raised and the operation is stopped. This is the same
#' thing that happens if \code{req(FALSE)} is called. The value is thawed
#' (un-frozen; accessing it will no longer raise an exception) when the current
#' reactive domain is flushed. In a Shiny application, this occurs after all of
#' the observers are executed.
#'
#' @param x For \code{freezeReactiveValue}, a \code{\link{reactiveValues}}
#'   object (like \code{input}); for \code{freezeReactiveVal}, a
#'   \code{\link{reactiveVal}} object.
#' @param name The name of a value in the \code{\link{reactiveValues}} object.
#'
#' @seealso \code{\link{req}}
#' @examples
#' ## Only run this examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#'   selectInput("data", "Data Set", c("mtcars", "pressure")),
#'   checkboxGroupInput("cols", "Columns (select 2)", character(0)),
#'   plotOutput("plot")
#' )
#'
#' server <- function(input, output, session) {
#'   observe({
#'     data <- get(input$data)
#'     # Sets a flag on input$cols to essentially do req(FALSE) if input$cols
#'     # is accessed. Without this, an error will momentarily show whenever a
#'     # new data set is selected.
#'     freezeReactiveValue(input, "cols")
#'     updateCheckboxGroupInput(session, "cols", choices = names(data))
#'   })
#'
#'   output$plot <- renderPlot({
#'     # When a new data set is selected, input$cols will have been invalidated
#'     # above, and this will essentially do the same as req(FALSE), causing
#'     # this observer to stop and raise a silent exception.
#'     cols <- input$cols
#'     data <- get(input$data)
#'
#'     if (length(cols) == 2) {
#'       plot(data[[ cols[1] ]], data[[ cols[2] ]])
#'     }
#'   })
#' }
#'
#' shinyApp(ui, server)
#' }
#' @export
freezeReactiveValue <- function(x, name) {
  domain <- getDefaultReactiveDomain()
  if (is.null(domain)) {
    stop("freezeReactiveValue() must be called when a default reactive domain is active.")
  }

  domain$freezeValue(x, name)
  invisible()
}


# Observable ----------------------------------------------------------------

Observable <- R6Class(
  'Observable',
  portable = FALSE,
  public = list(
    .origFunc = 'function',
    .func = 'function',
    .label = character(0),
    .domain = NULL,
    .dependents = 'Dependents',
    .invalidated = logical(0),
    .running = logical(0),
    .value = NULL,
    .error = FALSE,
    .visible = logical(0),
    .execCount = integer(0),
    .mostRecentCtxId = character(0),

    initialize = function(func, label = deparse(substitute(func)),
                          domain = getDefaultReactiveDomain(),
                          ..stacktraceon = TRUE) {
      if (length(formals(func)) > 0)
        stop("Can't make a reactive expression from a function that takes one ",
             "or more parameters; only functions without parameters can be ",
             "reactive.")

      # This is to make sure that the function labels that show in the profiler
      # and in stack traces doesn't contain whitespace. See
      # https://github.com/rstudio/profvis/issues/58
      if (grepl("\\s", label, perl = TRUE)) {
        funcLabel <- "<reactive>"
      } else {
        funcLabel <- paste0("<reactive:", label, ">")
      }

      .origFunc <<- func
      .func <<- wrapFunctionLabel(func, funcLabel,
        ..stacktraceon = ..stacktraceon)
      .label <<- label
      .domain <<- domain
      .dependents <<- Dependents$new()
      .invalidated <<- TRUE
      .running <<- FALSE
      .execCount <<- 0L
      .mostRecentCtxId <<- ""
    },
    getValue = function() {
      .dependents$register()

      if (.invalidated || .running) {
        ..stacktraceoff..(
          self$.updateValue()
        )
      }

      .graphDependsOnId(getCurrentContext()$id, .mostRecentCtxId)

      if (.error) {
        stop(.value)
      }

      if (.visible)
        .value
      else
        invisible(.value)
    },
    format = function() {
      label <- sprintf('reactive(%s)', paste(deparse(body(.origFunc)), collapse='\n'))
      strsplit(label, "\n")[[1]]
    },
    .updateValue = function() {
      ctx <- Context$new(.domain, .label, type = 'observable',
                         prevId = .mostRecentCtxId)
      .mostRecentCtxId <<- ctx$id
      ctx$onInvalidate(function() {
        .invalidated <<- TRUE
        .value <<- NULL # Value can be GC'd, it won't be read once invalidated
        .dependents$invalidate()
      })
      .execCount <<- .execCount + 1L

      .invalidated <<- FALSE

      wasRunning <- .running
      .running <<- TRUE
      on.exit(.running <<- wasRunning)

      ctx$run(function() {
        result <- withCallingHandlers(

          {
            .error <<- FALSE
            withVisible(.func())
          },

          error = function(cond) {
            # If an error occurs, we want to propagate the error, but we also
            # want to save a copy of it, so future callers of this reactive will
            # get the same error (i.e. the error is cached).

            # We stripStackTrace in the next line, just in case someone
            # downstream of us (i.e. deeper into the call stack) used
            # captureStackTraces; otherwise the entire stack would always be the
            # same (i.e. you'd always see the whole stack trace of the *first*
            # time the code was run and the condition raised; there'd be no way
            # to see the stack trace of the call site that caused the cached
            # exception to be re-raised, and you need that information to figure
            # out what's triggering the re-raise).
            #
            # We use try(stop()) as an easy way to generate a try-error object
            # out of this condition.
            .value <<- cond
            .error <<- TRUE
            .visible <<- FALSE
          }
        )
        .value <<- result$value
        .visible <<- result$visible
      })
    }
  )
)

#' Create a reactive expression
#'
#' Wraps a normal expression to create a reactive expression. Conceptually, a
#' reactive expression is a expression whose result will change over time.
#'
#' Reactive expressions are expressions that can read reactive values and call
#' other reactive expressions. Whenever a reactive value changes, any reactive
#' expressions that depended on it are marked as "invalidated" and will
#' automatically re-execute if necessary. If a reactive expression is marked as
#' invalidated, any other reactive expressions that recently called it are also
#' marked as invalidated. In this way, invalidations ripple through the
#' expressions that depend on each other.
#'
#' See the \href{http://rstudio.github.com/shiny/tutorial/}{Shiny tutorial} for
#' more information about reactive expressions.
#'
#' @param x For \code{reactive}, an expression (quoted or unquoted). For
#'   \code{is.reactive}, an object to test.
#' @param env The parent environment for the reactive expression. By default,
#'   this is the calling environment, the same as when defining an ordinary
#'   non-reactive expression.
#' @param quoted Is the expression quoted? By default, this is \code{FALSE}.
#'   This is useful when you want to use an expression that is stored in a
#'   variable; to do so, it must be quoted with \code{quote()}.
#' @param label A label for the reactive expression, useful for debugging.
#' @param domain See \link{domains}.
#' @param ..stacktraceon Advanced use only. For stack manipulation purposes; see
#'   \code{\link{stacktrace}}.
#' @return a function, wrapped in a S3 class "reactive"
#'
#' @examples
#' values <- reactiveValues(A=1)
#'
#' reactiveB <- reactive({
#'   values$A + 1
#' })
#'
#' # Can use quoted expressions
#' reactiveC <- reactive(quote({ values$A + 2 }), quoted = TRUE)
#'
#' # To store expressions for later conversion to reactive, use quote()
#' expr_q <- quote({ values$A + 3 })
#' reactiveD <- reactive(expr_q, quoted = TRUE)
#'
#' # View the values from the R console with isolate()
#' isolate(reactiveB())
#' isolate(reactiveC())
#' isolate(reactiveD())
#' @export
reactive <- function(x, env = parent.frame(), quoted = FALSE, label = NULL,
                     domain = getDefaultReactiveDomain(),
                     ..stacktraceon = TRUE) {
  fun <- exprToFunction(x, env, quoted)
  # Attach a label and a reference to the original user source for debugging
  srcref <- attr(substitute(x), "srcref", exact = TRUE)
  if (is.null(label)) {
    label <- rexprSrcrefToLabel(srcref[[1]],
      sprintf('reactive(%s)', paste(deparse(body(fun)), collapse='\n')))
  }
  if (length(srcref) >= 2) attr(label, "srcref") <- srcref[[2]]
  attr(label, "srcfile") <- srcFileOfRef(srcref[[1]])
  o <- Observable$new(fun, label, domain, ..stacktraceon = ..stacktraceon)
  structure(o$getValue, observable = o, class = c("reactiveExpr", "reactive"))
}

# Given the srcref to a reactive expression, attempts to figure out what the
# name of the reactive expression is. This isn't foolproof, as it literally
# scans the line of code that started the reactive block and looks for something
# that looks like assignment. If we fail, fall back to a default value (likely
# the block of code in the body of the reactive).
rexprSrcrefToLabel <- function(srcref, defaultLabel) {
  if (is.null(srcref))
    return(defaultLabel)

  srcfile <- attr(srcref, "srcfile", exact = TRUE)
  if (is.null(srcfile))
    return(defaultLabel)

  if (is.null(srcfile$lines))
    return(defaultLabel)

  lines <- srcfile$lines
  # When pasting at the Console, srcfile$lines is not split
  if (length(lines) == 1) {
    lines <- strsplit(lines, "\n")[[1]]
  }

  if (length(lines) < srcref[1]) {
    return(defaultLabel)
  }

  firstLine <- substring(lines[srcref[1]], 1, srcref[2] - 1)

  m <- regexec("(.*)(<-|=)\\s*reactive\\s*\\($", firstLine)
  if (m[[1]][1] == -1) {
    return(defaultLabel)
  }
  sym <- regmatches(firstLine, m)[[1]][2]
  res <- try(parse(text = sym), silent = TRUE)
  if (inherits(res, "try-error"))
    return(defaultLabel)

  if (length(res) != 1)
    return(defaultLabel)

  return(as.character(res))
}

#' @export
format.reactiveExpr <- function(x, ...) {
  attr(x, "observable", exact = TRUE)$format()
}

#' @export
print.reactive <- function(x, ...) {
  cat(paste(format(x), collapse = "\n"), "\n")
}

#' @export
#' @rdname reactive
is.reactive <- function(x) {
  inherits(x, "reactive")
}

# Return the number of times that a reactive expression or observer has been run
execCount <- function(x) {
  if (inherits(x, "reactiveExpr"))
    return(attr(x, "observable", exact = TRUE)$.execCount)
  else if (inherits(x, 'Observer'))
    return(x$.execCount)
  else
    stop('Unexpected argument to execCount')
}

# Observer ------------------------------------------------------------------

Observer <- R6Class(
  'Observer',
  portable = FALSE,
  public = list(
    .func = 'function',
    .label = character(0),
    .domain = 'ANY',
    .priority = numeric(0),
    .autoDestroy = logical(0),
    # A function that, when invoked, unsubscribes the autoDestroy
    # listener (or NULL if autodestroy is disabled for this observer).
    # We must unsubscribe when this observer is destroyed, or else
    # the observer cannot be garbage collected until the session ends.
    .autoDestroyHandle = 'ANY',
    .invalidateCallbacks = list(),
    .execCount = integer(0),
    .onResume = 'function',
    .suspended = logical(0),
    .destroyed = logical(0),
    .prevId = character(0),
    .ctx = NULL,

    initialize = function(observerFunc, label, suspended = FALSE, priority = 0,
                          domain = getDefaultReactiveDomain(),
                          autoDestroy = TRUE, ..stacktraceon = TRUE) {
      if (length(formals(observerFunc)) > 0)
        stop("Can't make an observer from a function that takes parameters; ",
             "only functions without parameters can be reactive.")
registerDebugHook("observerFunc", environment(), label)
      .func <<- function() {
        tryCatch(
          if (..stacktraceon)
            ..stacktraceon..(observerFunc())
          else
            observerFunc(),
          # It's OK for shiny.silent.error errors to cause an observer to stop running
          shiny.silent.error = function(e) NULL
          # validation = function(e) NULL,
          # shiny.output.cancel = function(e) NULL
        )
      }
      .label <<- label
      .domain <<- domain
      .priority <<- normalizePriority(priority)
      .execCount <<- 0L
      .suspended <<- suspended
      .onResume <<- function() NULL
      .destroyed <<- FALSE
      .prevId <<- ''

      .autoDestroy <<- FALSE
      .autoDestroyHandle <<- NULL
      setAutoDestroy(autoDestroy)

      # Defer the first running of this until flushReact is called
      .createContext()$invalidate()
    },
    .createContext = function() {
      ctx <- Context$new(.domain, .label, type='observer', prevId=.prevId)
      .prevId <<- ctx$id

      if (!is.null(.ctx)) {
        # If this happens, something went wrong.
        warning("Created a new context without invalidating previous context.")
      }
      # Store the context explicitly in the Observer object. This is necessary
      # to make sure that when the observer is destroyed, it also gets
      # invalidated. Otherwise the upstream reactive (on which the observer
      # depends) will hold a (indirect) reference to this context until the
      # reactive is invalidated, which may not happen immediately or at all.
      # This can lead to a memory leak (#1253).
      .ctx <<- ctx

      ctx$onInvalidate(function() {
        # Context is invalidated, so we don't need to store a reference to it
        # anymore.
        .ctx <<- NULL

        lapply(.invalidateCallbacks, function(invalidateCallback) {
          invalidateCallback()
          NULL
        })

        continue <- function() {
          ctx$addPendingFlush(.priority)
        }

        if (.suspended == FALSE)
          continue()
        else
          .onResume <<- continue
      })

      ctx$onFlush(function() {
        tryCatch({
          if (!.destroyed)
            shinyCallingHandlers(run())

        }, error = function(e) {
          printError(e)
          if (!is.null(.domain)) {
            .domain$unhandledError(e)
          }
        })
      })

      return(ctx)
    },
    run = function() {
      ctx <- .createContext()
      .execCount <<- .execCount + 1L
      ctx$run(.func)
    },
    onInvalidate = function(callback) {
      "Register a callback function to run when this observer is invalidated.
      No arguments will be provided to the callback function when it is
      invoked."
      .invalidateCallbacks <<- c(.invalidateCallbacks, callback)
    },
    setPriority = function(priority = 0) {
      "Change this observer's priority. Note that if the observer is currently
      invalidated, then the change in priority will not take effect until the
      next invalidation--unless the observer is also currently suspended, in
      which case the priority change will be effective upon resume."
      .priority <<- normalizePriority(priority)
    },
    setAutoDestroy = function(autoDestroy) {
      "Sets whether this observer should be automatically destroyed when its
      domain (if any) ends. If autoDestroy is TRUE and the domain already
      ended, then destroy() is called immediately."

      if (.autoDestroy == autoDestroy) {
        return(.autoDestroy)
      }

      oldValue <- .autoDestroy
      .autoDestroy <<- autoDestroy

      if (autoDestroy) {
        if (!.destroyed && !is.null(.domain)) { # Make sure to not try to destroy twice.
          if (.domain$isEnded()) {
            destroy()
          } else {
            .autoDestroyHandle <<- onReactiveDomainEnded(.domain, .onDomainEnded)
          }
        }
      } else {
        if (!is.null(.autoDestroyHandle))
          .autoDestroyHandle()
        .autoDestroyHandle <<- NULL
      }

      invisible(oldValue)
    },
    suspend = function() {
      "Causes this observer to stop scheduling flushes (re-executions) in
      response to invalidations. If the observer was invalidated prior to this
      call but it has not re-executed yet (because it waits until onFlush is
      called) then that re-execution will still occur, because the flush is
      already scheduled."
      .suspended <<- TRUE
    },
    resume = function() {
      "Causes this observer to start re-executing in response to invalidations.
      If the observer was invalidated while suspended, then it will schedule
      itself for re-execution (pending flush)."
      if (.suspended) {
        .suspended <<- FALSE
        .onResume()
        .onResume <<- function() NULL
      }
      invisible()
    },
    destroy = function() {
      "Prevents this observer from ever executing again (even if a flush has
      already been scheduled)."

      # Make sure to not try to destory twice.
      if (.destroyed)
        return()

      suspend()
      .destroyed <<- TRUE

      if (!is.null(.autoDestroyHandle)) {
        .autoDestroyHandle()
      }
      .autoDestroyHandle <<- NULL

      if (!is.null(.ctx)) {
        .ctx$invalidate()
      }
    },
    .onDomainEnded = function() {
      if (isTRUE(.autoDestroy)) {
        destroy()
      }
    }
  )
)

#' Create a reactive observer
#'
#' Creates an observer from the given expression.
#'
#' An observer is like a reactive expression in that it can read reactive values
#' and call reactive expressions, and will automatically re-execute when those
#' dependencies change. But unlike reactive expressions, it doesn't yield a
#' result and can't be used as an input to other reactive expressions. Thus,
#' observers are only useful for their side effects (for example, performing
#' I/O).
#'
#' Another contrast between reactive expressions and observers is their
#' execution strategy. Reactive expressions use lazy evaluation; that is, when
#' their dependencies change, they don't re-execute right away but rather wait
#' until they are called by someone else. Indeed, if they are not called then
#' they will never re-execute. In contrast, observers use eager evaluation; as
#' soon as their dependencies change, they schedule themselves to re-execute.
#'
#' Starting with Shiny 0.10.0, observers are automatically destroyed by default
#' when the \link[=domains]{domain} that owns them ends (e.g. when a Shiny
#' session ends).
#'
#' @param x An expression (quoted or unquoted). Any return value will be
#'   ignored.
#' @param env The parent environment for the reactive expression. By default,
#'   this is the calling environment, the same as when defining an ordinary
#'   non-reactive expression.
#' @param quoted Is the expression quoted? By default, this is \code{FALSE}.
#'   This is useful when you want to use an expression that is stored in a
#'   variable; to do so, it must be quoted with \code{quote()}.
#' @param label A label for the observer, useful for debugging.
#' @param suspended If \code{TRUE}, start the observer in a suspended state. If
#'   \code{FALSE} (the default), start in a non-suspended state.
#' @param priority An integer or numeric that controls the priority with which
#'   this observer should be executed. A higher value means higher priority: an
#'   observer with a higher priority value will execute before all observers
#'   with lower priority values. Positive, negative, and zero values are
#'   allowed.
#' @param domain See \link{domains}.
#' @param autoDestroy If \code{TRUE} (the default), the observer will be
#'   automatically destroyed when its domain (if any) ends.
#' @param ..stacktraceon Advanced use only. For stack manipulation purposes; see
#'   \code{\link{stacktrace}}.
#' @return An observer reference class object. This object has the following
#'   methods:
#'   \describe{
#'     \item{\code{suspend()}}{
#'       Causes this observer to stop scheduling flushes (re-executions) in
#'       response to invalidations. If the observer was invalidated prior to
#'       this call but it has not re-executed yet then that re-execution will
#'       still occur, because the flush is already scheduled.
#'     }
#'     \item{\code{resume()}}{
#'       Causes this observer to start re-executing in response to
#'       invalidations. If the observer was invalidated while suspended, then it
#'       will schedule itself for re-execution.
#'     }
#'     \item{\code{destroy()}}{
#'       Stops the observer from executing ever again, even if it is currently
#'       scheduled for re-execution.
#'     }
#'     \item{\code{setPriority(priority = 0)}}{
#'       Change this observer's priority. Note that if the observer is currently
#'       invalidated, then the change in priority will not take effect until the
#'       next invalidation--unless the observer is also currently suspended, in
#'       which case the priority change will be effective upon resume.
#'     }
#'     \item{\code{setAutoDestroy(autoDestroy)}}{
#'       Sets whether this observer should be automatically destroyed when its
#'       domain (if any) ends. If autoDestroy is TRUE and the domain already
#'       ended, then destroy() is called immediately."
#'     }
#'     \item{\code{onInvalidate(callback)}}{
#'       Register a callback function to run when this observer is invalidated.
#'       No arguments will be provided to the callback function when it is
#'       invoked.
#'     }
#'   }
#'
#' @examples
#' values <- reactiveValues(A=1)
#'
#' obsB <- observe({
#'   print(values$A + 1)
#' })
#'
#' # Can use quoted expressions
#' obsC <- observe(quote({ print(values$A + 2) }), quoted = TRUE)
#'
#' # To store expressions for later conversion to observe, use quote()
#' expr_q <- quote({ print(values$A + 3) })
#' obsD <- observe(expr_q, quoted = TRUE)
#'
#' # In a normal Shiny app, the web client will trigger flush events. If you
#' # are at the console, you can force a flush with flushReact()
#' shiny:::flushReact()
#' @export
observe <- function(x, env=parent.frame(), quoted=FALSE, label=NULL,
                    suspended=FALSE, priority=0,
                    domain=getDefaultReactiveDomain(), autoDestroy = TRUE,
                    ..stacktraceon = TRUE) {

  fun <- exprToFunction(x, env, quoted)
  if (is.null(label))
    label <- sprintf('observe(%s)', paste(deparse(body(fun)), collapse='\n'))

  o <- Observer$new(fun, label=label, suspended=suspended, priority=priority,
                    domain=domain, autoDestroy=autoDestroy,
                    ..stacktraceon=..stacktraceon)
  invisible(o)
}

#' Make a reactive variable
#'
#' Turns a normal variable into a reactive variable, that is, one that has
#' reactive semantics when assigned or read in the usual ways. The variable may
#' already exist; if so, its value will be used as the initial value of the
#' reactive variable (or \code{NULL} if the variable did not exist).
#'
#' @param symbol A character string indicating the name of the variable that
#'   should be made reactive
#' @param env The environment that will contain the reactive variable
#'
#' @return None.
#'
#' @examples
#' \dontrun{
#' a <- 10
#' makeReactiveBinding("a")
#' b <- reactive(a * -1)
#' observe(print(b()))
#' a <- 20
#' }
#' @export
makeReactiveBinding <- function(symbol, env = parent.frame()) {
  if (exists(symbol, envir = env, inherits = FALSE)) {
    initialValue <- env[[symbol]]
    rm(list = symbol, envir = env, inherits = FALSE)
  }
  else
    initialValue <- NULL
  values <- reactiveValues(value = initialValue)
  makeActiveBinding(symbol, env=env, fun=function(v) {
    if (missing(v))
      values$value
    else
      values$value <- v
  })

  invisible()
}

# `%<-reactive%` <- function(name, value) {
#   sym <- deparse(substitute(name))
#   assign(sym, value, pos = parent.frame())
#   makeReactiveBinding(sym, env=parent.frame())
#   invisible(NULL)
# }

# Causes flushReact to be called every time an expression is
# entered into the top-level prompt
setAutoflush <- local({
  callbackId <- NULL

  function(enable) {
    if (xor(is.null(callbackId), isTRUE(enable))) {
      return(invisible())
    }

    if (isTRUE(enable)) {
      callbackId <<- addTaskCallback(function(expr, value, ok, visible) {
        timerCallbacks$executeElapsed()
        flushReact()
        return(TRUE)
      })
    } else {
      removeTaskCallback(callbackId)
      callbackId <<- NULL
    }
    invisible()
  }
})

# ---------------------------------------------------------------------------

#' Timer
#'
#' Creates a reactive timer with the given interval. A reactive timer is like a
#' reactive value, except reactive values are triggered when they are set, while
#' reactive timers are triggered simply by the passage of time.
#'
#' \link[=reactive]{Reactive expressions} and observers that want to be
#' invalidated by the timer need to call the timer function that
#' \code{reactiveTimer} returns, even if the current time value is not actually
#' needed.
#'
#' See \code{\link{invalidateLater}} as a safer and simpler alternative.
#'
#' @param intervalMs How often to fire, in milliseconds
#' @param session A session object. This is needed to cancel any scheduled
#'   invalidations after a user has ended the session. If \code{NULL}, then
#'   this invalidation will not be tied to any session, and so it will still
#'   occur.
#' @return A no-parameter function that can be called from a reactive context,
#'   in order to cause that context to be invalidated the next time the timer
#'   interval elapses. Calling the returned function also happens to yield the
#'   current time (as in \code{\link[base]{Sys.time}}).
#' @seealso \code{\link{invalidateLater}}
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#'   sliderInput("n", "Number of observations", 2, 1000, 500),
#'   plotOutput("plot")
#' )
#'
#' server <- function(input, output) {
#'
#'   # Anything that calls autoInvalidate will automatically invalidate
#'   # every 2 seconds.
#'   autoInvalidate <- reactiveTimer(2000)
#'
#'   observe({
#'     # Invalidate and re-execute this reactive expression every time the
#'     # timer fires.
#'     autoInvalidate()
#'
#'     # Do something each time this is invalidated.
#'     # The isolate() makes this observer _not_ get invalidated and re-executed
#'     # when input$n changes.
#'     print(paste("The value of input$n is", isolate(input$n)))
#'   })
#'
#'   # Generate a new histogram each time the timer fires, but not when
#'   # input$n changes.
#'   output$plot <- renderPlot({
#'     autoInvalidate()
#'     hist(rnorm(isolate(input$n)))
#'   })
#' }
#'
#' shinyApp(ui, server)
#' }
#' @export
reactiveTimer <- function(intervalMs=1000, session = getDefaultReactiveDomain()) {
  # Need to make sure that session is resolved at creation, not when the
  # callback below is fired (see #1621).
  force(session)

  dependents <- Map$new()
  timerCallbacks$schedule(intervalMs, function() {
    # Quit if the session is closed
    if (!is.null(session) && session$isClosed()) {
      return(invisible())
    }

    timerCallbacks$schedule(intervalMs, sys.function())
    lapply(
      dependents$values(),
      function(dep.ctx) {
        dep.ctx$invalidate()
        NULL
      })
  })
  return(function() {
    ctx <- .getReactiveEnvironment()$currentContext()
    if (!dependents$containsKey(ctx$id)) {
      dependents$set(ctx$id, ctx)
      ctx$onInvalidate(function() {
        dependents$remove(ctx$id)
      })
    }
    return(Sys.time())
  })
}

#' Scheduled Invalidation
#'
#' Schedules the current reactive context to be invalidated in the given number
#' of milliseconds.
#'
#' If this is placed within an observer or reactive expression, that object will
#' be invalidated (and re-execute) after the interval has passed. The
#' re-execution will reset the invalidation flag, so in a typical use case, the
#' object will keep re-executing and waiting for the specified interval. It's
#' possible to stop this cycle by adding conditional logic that prevents the
#' \code{invalidateLater} from being run.
#'
#' @param millis Approximate milliseconds to wait before invalidating the
#'   current reactive context.
#' @param session A session object. This is needed to cancel any scheduled
#'   invalidations after a user has ended the session. If \code{NULL}, then
#'   this invalidation will not be tied to any session, and so it will still
#'   occur.
#'
#' @seealso \code{\link{reactiveTimer}} is a slightly less safe alternative.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#'
#' ui <- fluidPage(
#'   sliderInput("n", "Number of observations", 2, 1000, 500),
#'   plotOutput("plot")
#' )
#'
#' server <- function(input, output, session) {
#'
#'   observe({
#'     # Re-execute this reactive expression after 1000 milliseconds
#'     invalidateLater(1000, session)
#'
#'     # Do something each time this is invalidated.
#'     # The isolate() makes this observer _not_ get invalidated and re-executed
#'     # when input$n changes.
#'     print(paste("The value of input$n is", isolate(input$n)))
#'   })
#'
#'   # Generate a new histogram at timed intervals, but not when
#'   # input$n changes.
#'   output$plot <- renderPlot({
#'     # Re-execute this reactive expression after 2000 milliseconds
#'     invalidateLater(2000)
#'     hist(rnorm(isolate(input$n)))
#'   })
#' }
#'
#' shinyApp(ui, server)
#' }
#' @export
invalidateLater <- function(millis, session = getDefaultReactiveDomain()) {
  ctx <- .getReactiveEnvironment()$currentContext()
  timerCallbacks$schedule(millis, function() {
    # Quit if the session is closed
    if (!is.null(session) && session$isClosed()) {
      return(invisible())
    }
    ctx$invalidate()
  })
  invisible()
}

coerceToFunc <- function(x) {
  force(x);
  if (is.function(x))
    return(x)
  else
    return(function() x)
}

#' Reactive polling
#'
#' Used to create a reactive data source, which works by periodically polling a
#' non-reactive data source.
#'
#' \code{reactivePoll} works by pairing a relatively cheap "check" function with
#' a more expensive value retrieval function. The check function will be
#' executed periodically and should always return a consistent value until the
#' data changes. When the check function returns a different value, then the
#' value retrieval function will be used to re-populate the data.
#'
#' Note that the check function doesn't return \code{TRUE} or \code{FALSE} to
#' indicate whether the underlying data has changed. Rather, the check function
#' indicates change by returning a different value from the previous time it was
#' called.
#'
#' For example, \code{reactivePoll} is used to implement
#' \code{reactiveFileReader} by pairing a check function that simply returns the
#' last modified timestamp of a file, and a value retrieval function that
#' actually reads the contents of the file.
#'
#' As another example, one might read a relational database table reactively by
#' using a check function that does \code{SELECT MAX(timestamp) FROM table} and
#' a value retrieval function that does \code{SELECT * FROM table}.
#'
#' The \code{intervalMillis}, \code{checkFunc}, and \code{valueFunc} functions
#' will be executed in a reactive context; therefore, they may read reactive
#' values and reactive expressions.
#'
#' @param intervalMillis Approximate number of milliseconds to wait between
#'   calls to \code{checkFunc}. This can be either a numeric value, or a
#'   function that returns a numeric value.
#' @param session The user session to associate this file reader with, or
#'   \code{NULL} if none. If non-null, the reader will automatically stop when
#'   the session ends.
#' @param checkFunc A relatively cheap function whose values over time will be
#'   tested for equality; inequality indicates that the underlying value has
#'   changed and needs to be invalidated and re-read using \code{valueFunc}. See
#'   Details.
#' @param valueFunc A function that calculates the underlying value. See
#'   Details.
#'
#' @return A reactive expression that returns the result of \code{valueFunc},
#'   and invalidates when \code{checkFunc} changes.
#'
#' @seealso \code{\link{reactiveFileReader}}
#'
#' @examples
#' function(input, output, session) {
#'
#'   data <- reactivePoll(1000, session,
#'     # This function returns the time that log_file was last modified
#'     checkFunc = function() {
#'       if (file.exists(log_file))
#'         file.info(log_file)$mtime[1]
#'       else
#'         ""
#'     },
#'     # This function returns the content of log_file
#'     valueFunc = function() {
#'       read.csv(log_file)
#'     }
#'   )
#'
#'   output$dataTable <- renderTable({
#'     data()
#'   })
#' }
#' @export
reactivePoll <- function(intervalMillis, session, checkFunc, valueFunc) {
  intervalMillis <- coerceToFunc(intervalMillis)

  rv <- reactiveValues(cookie = isolate(checkFunc()))

  observe({
    rv$cookie <- checkFunc()
    invalidateLater(intervalMillis(), session)
  })

  # TODO: what to use for a label?
  re <- reactive({
    rv$cookie

    valueFunc()

  }, label = NULL)

  return(re)
}

#' Reactive file reader
#'
#' Given a file path and read function, returns a reactive data source for the
#' contents of the file.
#'
#' \code{reactiveFileReader} works by periodically checking the file's last
#' modified time; if it has changed, then the file is re-read and any reactive
#' dependents are invalidated.
#'
#' The \code{intervalMillis}, \code{filePath}, and \code{readFunc} functions
#' will each be executed in a reactive context; therefore, they may read
#' reactive values and reactive expressions.
#'
#' @param intervalMillis Approximate number of milliseconds to wait between
#'   checks of the file's last modified time. This can be a numeric value, or a
#'   function that returns a numeric value.
#' @param session The user session to associate this file reader with, or
#'   \code{NULL} if none. If non-null, the reader will automatically stop when
#'   the session ends.
#' @param filePath The file path to poll against and to pass to \code{readFunc}.
#'   This can either be a single-element character vector, or a function that
#'   returns one.
#' @param readFunc The function to use to read the file; must expect the first
#'   argument to be the file path to read. The return value of this function is
#'   used as the value of the reactive file reader.
#' @param ... Any additional arguments to pass to \code{readFunc} whenever it is
#'   invoked.
#'
#' @return A reactive expression that returns the contents of the file, and
#'   automatically invalidates when the file changes on disk (as determined by
#'   last modified time).
#'
#' @seealso \code{\link{reactivePoll}}
#'
#' @examples
#' \dontrun{
#' # Per-session reactive file reader
#' function(input, output, session) {
#'   fileData <- reactiveFileReader(1000, session, 'data.csv', read.csv)
#'
#'   output$data <- renderTable({
#'     fileData()
#'   })
#' }
#'
#' # Cross-session reactive file reader. In this example, all sessions share
#' # the same reader, so read.csv only gets executed once no matter how many
#' # user sessions are connected.
#' fileData <- reactiveFileReader(1000, NULL, 'data.csv', read.csv)
#' function(input, output, session) {
#'   output$data <- renderTable({
#'     fileData()
#'   })
#' }
#' }
#' @export
reactiveFileReader <- function(intervalMillis, session, filePath, readFunc, ...) {
  filePath <- coerceToFunc(filePath)
  extraArgs <- list(...)

  reactivePoll(
    intervalMillis, session,
    function() {
      path <- filePath()
      info <- file.info(path)
      return(paste(path, info$mtime, info$size))
    },
    function() {
      do.call(readFunc, c(filePath(), extraArgs))
    }
  )
}

#' Create a non-reactive scope for an expression
#'
#' Executes the given expression in a scope where reactive values or expression
#' can be read, but they cannot cause the reactive scope of the caller to be
#' re-evaluated when they change.
#'
#' Ordinarily, the simple act of reading a reactive value causes a relationship
#' to be established between the caller and the reactive value, where a change
#' to the reactive value will cause the caller to re-execute. (The same applies
#' for the act of getting a reactive expression's value.) The \code{isolate}
#' function lets you read a reactive value or expression without establishing this
#' relationship.
#'
#' The expression given to \code{isolate()} is evaluated in the calling
#' environment. This means that if you assign a variable inside the
#' \code{isolate()}, its value will be visible outside of the \code{isolate()}.
#' If you want to avoid this, you can use \code{\link[base]{local}()} inside the
#' \code{isolate()}.
#'
#' This function can also be useful for calling reactive expression at the
#' console, which can be useful for debugging. To do so, simply wrap the
#' calls to the reactive expression with \code{isolate()}.
#'
#' @param expr An expression that can access reactive values or expressions.
#'
#' @examples
#' \dontrun{
#' observe({
#'   input$saveButton  # Do take a dependency on input$saveButton
#'
#'   # isolate a simple expression
#'   data <- get(isolate(input$dataset))  # No dependency on input$dataset
#'   writeToDatabase(data)
#' })
#'
#' observe({
#'   input$saveButton  # Do take a dependency on input$saveButton
#'
#'   # isolate a whole block
#'   data <- isolate({
#'     a <- input$valueA   # No dependency on input$valueA or input$valueB
#'     b <- input$valueB
#'     c(a=a, b=b)
#'   })
#'   writeToDatabase(data)
#' })
#'
#' observe({
#'   x <- 1
#'   # x outside of isolate() is affected
#'   isolate(x <- 2)
#'   print(x) # 2
#'
#'   y <- 1
#'   # Use local() to avoid affecting calling environment
#'   isolate(local(y <- 2))
#'   print(y) # 1
#' })
#'
#' }
#'
#' # Can also use isolate to call reactive expressions from the R console
#' values <- reactiveValues(A=1)
#' fun <- reactive({ as.character(values$A) })
#' isolate(fun())
#' # "1"
#'
#' # isolate also works if the reactive expression accesses values from the
#' # input object, like input$x
#' @export
isolate <- function(expr) {
  ctx <- Context$new(getDefaultReactiveDomain(), '[isolate]', type='isolate')
  on.exit(ctx$invalidate())
  # Matching ..stacktraceon../..stacktraceoff.. pair
  ..stacktraceoff..(ctx$run(function() {
    ..stacktraceon..(expr)
  }))
}

#' Evaluate an expression without a reactive context
#'
#' Temporarily blocks the current reactive context and evaluates the given
#' expression. Any attempt to directly access reactive values or expressions in
#' \code{expr} will give the same results as doing it at the top-level (by
#' default, an error).
#'
#' @param expr An expression to evaluate.
#' @return The value of \code{expr}.
#'
#' @seealso \code{\link{isolate}}
#' @export
maskReactiveContext <- function(expr) {
  .getReactiveEnvironment()$runWith(NULL, function() {
    expr
  })
}

#' Event handler
#'
#' Respond to "event-like" reactive inputs, values, and expressions.
#'
#' Shiny's reactive programming framework is primarily designed for calculated
#' values (reactive expressions) and side-effect-causing actions (observers)
#' that respond to \emph{any} of their inputs changing. That's often what is
#' desired in Shiny apps, but not always: sometimes you want to wait for a
#' specific action to be taken from the user, like clicking an
#' \code{\link{actionButton}}, before calculating an expression or taking an
#' action. A reactive value or expression that is used to trigger other
#' calculations in this way is called an \emph{event}.
#'
#' These situations demand a more imperative, "event handling" style of
#' programming that is possible--but not particularly intuitive--using the
#' reactive programming primitives \code{\link{observe}} and
#' \code{\link{isolate}}. \code{observeEvent} and \code{eventReactive} provide
#' straightforward APIs for event handling that wrap \code{observe} and
#' \code{isolate}.
#'
#' Use \code{observeEvent} whenever you want to \emph{perform an action} in
#' response to an event. (Note that "recalculate a value" does not generally
#' count as performing an action--see \code{eventReactive} for that.) The first
#' argument is the event you want to respond to, and the second argument is a
#' function that should be called whenever the event occurs.
#'
#' Use \code{eventReactive} to create a \emph{calculated value} that only
#' updates in response to an event. This is just like a normal
#' \link[=reactive]{reactive expression} except it ignores all the usual
#' invalidations that come from its reactive dependencies; it only invalidates
#' in response to the given event.
#'
#' @section ignoreNULL and ignoreInit:
#'
#' Both \code{observeEvent} and \code{eventReactive} take an \code{ignoreNULL}
#' parameter that affects behavior when the \code{eventExpr} evaluates to
#' \code{NULL} (or in the special case of an \code{\link{actionButton}},
#' \code{0}). In these cases, if \code{ignoreNULL} is \code{TRUE}, then an
#' \code{observeEvent} will not execute and an \code{eventReactive} will raise a
#' silent \link[=validate]{validation} error. This is useful behavior if you
#' don't want to do the action or calculation when your app first starts, but
#' wait for the user to initiate the action first (like a "Submit" button);
#' whereas \code{ignoreNULL=FALSE} is desirable if you want to initially perform
#' the action/calculation and just let the user re-initiate it (like a
#' "Recalculate" button).
#'
#' Unlike what happens for \code{ignoreNULL}, only \code{observeEvent} takes in an
#' \code{ignoreInit} argument. By default, \code{observeEvent} will run right when
#' it is created (except if, at that moment, \code{eventExpr} evaluates to \code{NULL}
#' and \code{ignoreNULL} is \code{TRUE}). But when responding to a click of an action
#' button, it may often be useful to set \code{ignoreInit} to \code{TRUE}. For
#' example, if you're setting up an \code{observeEvent} for a dynamically created
#' button, then \code{ignoreInit = TRUE} will guarantee that the action (in
#' \code{handlerExpr}) will only be triggered when the button is actually clicked,
#' instead of also being triggered when it is created/initialized.
#'
#' Even though \code{ignoreNULL} and \code{ignoreInit} can be used for similar
#' purposes they are independent from one another. Here's the result of combining
#' these:
#'
#' \describe{
#'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = FALSE}}{
#'      This is the default. This combination means that \code{handlerExpr} will
#'      run every time that \code{eventExpr} is not \code{NULL}. If, at the time
#'      of the \code{observeEvent}'s creation, \code{handleExpr} happens to
#'      \emph{not} be \code{NULL}, then the code runs.
#'   }
#'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = FALSE}}{
#'      This combination means that \code{handlerExpr} will run every time no
#'      matter what.
#'   }
#'   \item{\code{ignoreNULL = FALSE} and \code{ignoreInit = TRUE}}{
#'      This combination means that \code{handlerExpr} will \emph{not} run when
#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}),
#'      but it will run every other time.
#'   }
#'   \item{\code{ignoreNULL = TRUE} and \code{ignoreInit = TRUE}}{
#'      This combination means that \code{handlerExpr} will \emph{not} run when
#'      the \code{observeEvent} is created (because \code{ignoreInit = TRUE}).
#'      After that, \code{handlerExpr} will run every time that \code{eventExpr}
#'      is not \code{NULL}.
#'   }
#' }
#'
#' @param eventExpr A (quoted or unquoted) expression that represents the event;
#'   this can be a simple reactive value like \code{input$click}, a call to a
#'   reactive expression like \code{dataset()}, or even a complex expression
#'   inside curly braces
#' @param handlerExpr The expression to call whenever \code{eventExpr} is
#'   invalidated. This should be a side-effect-producing action (the return
#'   value will be ignored). It will be executed within an \code{\link{isolate}}
#'   scope.
#' @param valueExpr The expression that produces the return value of the
#'   \code{eventReactive}. It will be executed within an \code{\link{isolate}}
#'   scope.
#' @param event.env The parent environment for \code{eventExpr}. By default,
#'   this is the calling environment.
#' @param event.quoted Is the \code{eventExpr} expression quoted? By default,
#'   this is \code{FALSE}. This is useful when you want to use an expression
#'   that is stored in a variable; to do so, it must be quoted with
#'   \code{quote()}.
#' @param handler.env The parent environment for \code{handlerExpr}. By default,
#'   this is the calling environment.
#' @param handler.quoted Is the \code{handlerExpr} expression quoted? By
#'   default, this is \code{FALSE}. This is useful when you want to use an
#'   expression that is stored in a variable; to do so, it must be quoted with
#'   \code{quote()}.
#' @param value.env The parent environment for \code{valueExpr}. By default,
#'   this is the calling environment.
#' @param value.quoted Is the \code{valueExpr} expression quoted? By default,
#'   this is \code{FALSE}. This is useful when you want to use an expression
#'   that is stored in a variable; to do so, it must be quoted with \code{quote()}.
#' @param label A label for the observer or reactive, useful for debugging.
#' @param suspended If \code{TRUE}, start the observer in a suspended state. If
#'   \code{FALSE} (the default), start in a non-suspended state.
#' @param priority An integer or numeric that controls the priority with which
#'   this observer should be executed. An observer with a given priority level
#'   will always execute sooner than all observers with a lower priority level.
#'   Positive, negative, and zero values are allowed.
#' @param domain See \link{domains}.
#' @param autoDestroy If \code{TRUE} (the default), the observer will be
#'   automatically destroyed when its domain (if any) ends.
#' @param ignoreNULL Whether the action should be triggered (or value
#'   calculated, in the case of \code{eventReactive}) when the input is
#'   \code{NULL}. See Details.
#' @param ignoreInit If \code{TRUE}, then, when this \code{observeEvent} is
#'   first created/initialized, ignore the \code{handlerExpr} (the second
#'   argument), whether it is otherwise supposed to run or not. The default is
#'   \code{FALSE}. See Details.
#' @param once Whether this \code{observeEvent} should be immediately destroyed
#'   after the first time that the code in \code{handlerExpr} is run. This
#'   pattern is useful when you want to subscribe to a event that should only
#'   happen once.
#'
#' @return \code{observeEvent} returns an observer reference class object (see
#'   \code{\link{observe}}). \code{eventReactive} returns a reactive expression
#'   object (see \code{\link{reactive}}).
#'
#' @seealso \code{\link{actionButton}}
#'
#' @examples
#' ## Only run this example in interactive R sessions
#' if (interactive()) {
#'
#'   ## App 1: Sample usage
#'   shinyApp(
#'     ui = fluidPage(
#'       column(4,
#'         numericInput("x", "Value", 5),
#'         br(),
#'         actionButton("button", "Show")
#'       ),
#'       column(8, tableOutput("table"))
#'     ),
#'     server = function(input, output) {
#'       # Take an action every time button is pressed;
#'       # here, we just print a message to the console
#'       observeEvent(input$button, {
#'         cat("Showing", input$x, "rows\n")
#'       })
#'       # Take a reactive dependency on input$button, but
#'       # not on any of the stuff inside the function
#'       df <- eventReactive(input$button, {
#'         head(cars, input$x)
#'       })
#'       output$table <- renderTable({
#'         df()
#'       })
#'     }
#'   )
#'
#'   ## App 2: Using `once`
#'   shinyApp(
#'     ui = basicPage( actionButton("go", "Go")),
#'     server = function(input, output, session) {
#'       observeEvent(input$go, {
#'         print(paste("This will only be printed once; all",
#'               "subsequent button clicks won't do anything"))
#'       }, once = TRUE)
#'     }
#'   )
#'
#'   ## App 3: Using `ignoreInit` and `once`
#'   shinyApp(
#'     ui = basicPage(actionButton("go", "Go")),
#'     server = function(input, output, session) {
#'       observeEvent(input$go, {
#'         insertUI("#go", "afterEnd",
#'                  actionButton("dynamic", "click to remove"))
#'
#'         # set up an observer that depends on the dynamic
#'         # input, so that it doesn't run when the input is
#'         # created, and only runs once after that (since
#'         # the side effect is remove the input from the DOM)
#'         observeEvent(input$dynamic, {
#'           removeUI("#dynamic")
#'         }, ignoreInit = TRUE, once = TRUE)
#'       })
#'     }
#'   )
#' }
#' @export
observeEvent <- function(eventExpr, handlerExpr,
  event.env = parent.frame(), event.quoted = FALSE,
  handler.env = parent.frame(), handler.quoted = FALSE,
  label = NULL, suspended = FALSE, priority = 0,
  domain = getDefaultReactiveDomain(), autoDestroy = TRUE,
  ignoreNULL = TRUE, ignoreInit = FALSE, once = FALSE) {

  eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
  if (is.null(label))
    label <- sprintf('observeEvent(%s)', paste(deparse(body(eventFunc)), collapse='\n'))
  eventFunc <- wrapFunctionLabel(eventFunc, "observeEventExpr", ..stacktraceon = TRUE)

  handlerFunc <- exprToFunction(handlerExpr, handler.env, handler.quoted)
  handlerFunc <- wrapFunctionLabel(handlerFunc, "observeEventHandler", ..stacktraceon = TRUE)

  initialized <- FALSE

  o <- observe({
    e <- eventFunc()

    if (ignoreInit && !initialized) {
      initialized <<- TRUE
      return()
    }

    if (ignoreNULL && isNullEvent(e)) {
      return()
    }

    if (once) {
      on.exit(o$destroy())
    }

    isolate(handlerFunc())
  }, label = label, suspended = suspended, priority = priority, domain = domain,
  autoDestroy = TRUE, ..stacktraceon = FALSE)

  invisible(o)
}

#' @rdname observeEvent
#' @export
eventReactive <- function(eventExpr, valueExpr,
  event.env = parent.frame(), event.quoted = FALSE,
  value.env = parent.frame(), value.quoted = FALSE,
  label = NULL, domain = getDefaultReactiveDomain(),
  ignoreNULL = TRUE, ignoreInit = FALSE) {

  eventFunc <- exprToFunction(eventExpr, event.env, event.quoted)
  if (is.null(label))
    label <- sprintf('eventReactive(%s)', paste(deparse(body(eventFunc)), collapse='\n'))
  eventFunc <- wrapFunctionLabel(eventFunc, "eventReactiveExpr", ..stacktraceon = TRUE)

  handlerFunc <- exprToFunction(valueExpr, value.env, value.quoted)
  handlerFunc <- wrapFunctionLabel(handlerFunc, "eventReactiveHandler", ..stacktraceon = TRUE)

  initialized <- FALSE

  invisible(reactive({
    e <- eventFunc()

    if (ignoreInit && !initialized) {
      initialized <<- TRUE
      req(FALSE)
    }

    req(!ignoreNULL || !isNullEvent(e))

    isolate(handlerFunc())
  }, label = label, domain = domain, ..stacktraceon = FALSE))
}

isNullEvent <- function(value) {
  is.null(value) || (inherits(value, 'shinyActionButtonValue') && value == 0)
}

#' Slow down a reactive expression with debounce/throttle
#'
#' Transforms a reactive expression by preventing its invalidation signals from
#' being sent unnecessarily often. This lets you ignore a very "chatty" reactive
#' expression until it becomes idle, which is useful when the intermediate
#' values don't matter as much as the final value, and the downstream
#' calculations that depend on the reactive expression take a long time.
#' \code{debounce} and \code{throttle} use different algorithms for slowing down
#' invalidation signals; see Details.
#'
#' @section Limitations:
#'
#'   Because R is single threaded, we can't come close to guaranteeing that the
#'   timing of debounce/throttle (or any other timing-related functions in
#'   Shiny) will be consistent or accurate; at the time we want to emit an
#'   invalidation signal, R may be performing a different task and we have no
#'   way to interrupt it (nor would we necessarily want to if we could).
#'   Therefore, it's best to think of the time windows you pass to these
#'   functions as minimums.
#'
#'   You may also see undesirable behavior if the amount of time spent doing
#'   downstream processing for each change approaches or exceeds the time
#'   window: in this case, debounce/throttle may not have any effect, as the
#'   time each subsequent event is considered is already after the time window
#'   has expired.
#'
#' @details
#'
#' This is not a true debounce/throttle in that it will not prevent \code{r}
#' from being called many times (in fact it may be called more times than
#' usual), but rather, the reactive invalidation signal that is produced by
#' \code{r} is debounced/throttled instead. Therefore, these functions should be
#' used when \code{r} is cheap but the things it will trigger (downstream
#' outputs and reactives) are expensive.
#'
#' Debouncing means that every invalidation from \code{r} will be held for the
#' specified time window. If \code{r} invalidates again within that time window,
#' then the timer starts over again. This means that as long as invalidations
#' continually arrive from \code{r} within the time window, the debounced
#' reactive will not invalidate at all. Only after the invalidations stop (or
#' slow down sufficiently) will the downstream invalidation be sent.
#'
#' \code{ooo-oo-oo---- => -----------o-}
#'
#' (In this graphical depiction, each character represents a unit of time, and
#' the time window is 3 characters.)
#'
#' Throttling, on the other hand, delays invalidation if the \emph{throttled}
#' reactive recently (within the time window) invalidated. New \code{r}
#' invalidations do not reset the time window. This means that if invalidations
#' continually come from \code{r} within the time window, the throttled reactive
#' will invalidate regularly, at a rate equal to or slower than than the time
#' window.
#'
#' \code{ooo-oo-oo---- => o--o--o--o---}
#'
#' @param r A reactive expression (that invalidates too often).
#' @param millis The debounce/throttle time window. You may optionally pass a
#'   no-arg function or reactive expression instead, e.g. to let the end-user
#'   control the time window.
#' @param priority Debounce/throttle is implemented under the hood using
#'   \link[=observe]{observers}. Use this parameter to set the priority of
#'   these observers. Generally, this should be higher than the priorities of
#'   downstream observers and outputs (which default to zero).
#' @param domain See \link{domains}.
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' if (interactive()) {
#' options(device.ask.default = FALSE)
#'
#' library(shiny)
#' library(magrittr)
#'
#' ui <- fluidPage(
#'   plotOutput("plot", click = clickOpts("hover")),
#'   helpText("Quickly click on the plot above, while watching the result table below:"),
#'   tableOutput("result")
#' )
#'
#' server <- function(input, output, session) {
#'   hover <- reactive({
#'     if (is.null(input$hover))
#'       list(x = NA, y = NA)
#'     else
#'       input$hover
#'   })
#'   hover_d <- hover %>% debounce(1000)
#'   hover_t <- hover %>% throttle(1000)
#'
#'   output$plot <- renderPlot({
#'     plot(cars)
#'   })
#'
#'   output$result <- renderTable({
#'     data.frame(
#'       mode = c("raw", "throttle", "debounce"),
#'       x = c(hover()$x, hover_t()$x, hover_d()$x),
#'       y = c(hover()$y, hover_t()$y, hover_d()$y)
#'     )
#'   })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {

  # TODO: make a nice label for the observer(s)

  force(r)
  force(millis)

  if (!is.function(millis)) {
    origMillis <- millis
    millis <- function() origMillis
  }

  v <- reactiveValues(
    trigger = NULL,
    when = NULL # the deadline for the timer to fire; NULL if not scheduled
  )

  # Responsible for tracking when f() changes.
  firstRun <- TRUE
  observe({
    r()

    if (firstRun) {
      # During the first run we don't want to set v$when, as this will kick off
      # the timer. We only want to do that when we see r() change.
      firstRun <<- FALSE
      return()
    }

    # The value (or possibly millis) changed. Start or reset the timer.
    v$when <- Sys.time() + millis()/1000
  }, label = "debounce tracker", domain = domain, priority = priority)

  # This observer is the timer. It rests until v$when elapses, then touches
  # v$trigger.
  observe({
    if (is.null(v$when))
      return()

    now <- Sys.time()
    if (now >= v$when) {
      # Mod by 999999999 to get predictable overflow behavior
      v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
      v$when <- NULL
    } else {
      invalidateLater((v$when - now) * 1000)
    }
  }, label = "debounce timer", domain = domain, priority = priority)

  # This is the actual reactive that is returned to the user. It returns the
  # value of r(), but only invalidates/updates when v$trigger is touched.
  er <- eventReactive(v$trigger, {
    r()
  }, label = "debounce result", ignoreNULL = FALSE, domain = domain)

  # Force the value of er to be immediately cached upon creation. It's very hard
  # to explain why this observer is needed, but if you want to understand, try
  # commenting it out and studying the unit test failure that results.
  primer <- observe({
    primer$destroy()
    er()
  }, label = "debounce primer", domain = domain, priority = priority)

  er
}

#' @rdname debounce
#' @export
throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {

  # TODO: make a nice label for the observer(s)

  force(r)
  force(millis)

  if (!is.function(millis)) {
    origMillis <- millis
    millis <- function() origMillis
  }

  v <- reactiveValues(
    trigger = 0,
    lastTriggeredAt = NULL, # Last time we fired; NULL if never
    pending = FALSE # If TRUE, trigger again when timer elapses
  )

  blackoutMillisLeft <- function() {
    if (is.null(v$lastTriggeredAt)) {
      0
    } else {
      max(0, (v$lastTriggeredAt + millis()/1000) - Sys.time()) * 1000
    }
  }

  trigger <- function() {
    v$lastTriggeredAt <- Sys.time()
    # Mod by 999999999 to get predictable overflow behavior
    v$trigger <- isolate(v$trigger) %% 999999999 + 1
    v$pending <- FALSE
  }

  # Responsible for tracking when f() changes.
  observeEvent(r(), {
    if (v$pending) {
      # In a blackout period and someone already scheduled; do nothing
    } else if (blackoutMillisLeft() > 0) {
      # In a blackout period but this is the first change in that period; set
      # v$pending so that a trigger will be scheduled at the end of the period
      v$pending <- TRUE
    } else {
      # Not in a blackout period. Trigger, which will start a new blackout
      # period.
      trigger()
    }
  }, label = "throttle tracker", ignoreNULL = FALSE, priority = priority, domain = domain)

  observe({
    if (!v$pending) {
      return()
    }

    timeout <- blackoutMillisLeft()
    if (timeout > 0) {
      invalidateLater(timeout)
    } else {
      trigger()
    }
  }, priority = priority, domain = domain)

  # This is the actual reactive that is returned to the user. It returns the
  # value of r(), but only invalidates/updates when v$trigger is touched.
  eventReactive(v$trigger, {
    r()
  }, label = "throttle result", ignoreNULL = FALSE, domain = domain)
}