R/signal.R

In hadley/shinySignals: Stream functions from shiny.

#' A signal with a constant value.
#'
#' This is a wrapper aroud \code{reactive()}, used to make it clear that
#' you really do want a constant.
#'
#' @param x A value
#' @export
#' @examples
#' constant(10)
constant <- function(x) {
  reactive(x)
}

#' Lift a function onto a reactive.
#'
#' Lifting a function onto a signal creates a new signal that's been
#' transformed by the function. \code{\%~>\%} is an infix conveneience.
#'
#' @param signal,signal1,signal2 Signals.
#' @param f A function to apply: for \code{lift()} it should take a single
#'   argument, for \code{lift2()} it should take two.
#' @export
lift <- function(signal, f) {
  reactive(f(signal()))
}

#' @export
#' @rdname lift
lift2 <- function(signal1, signal2, f) {
  reactive(f(signal1(), signal2()))
}

#' @export
#' @rdname lift
`%~>%` <- function(signal, f) {
  lift(signal, f)
}

#' Merge two signals.
#'
#' Creates a new signal that contains the signals generated by both inputs.
#'
#' @param signal1,signal2 Signals. The signals should return the same
#'   type of object.
#' @export
merge <- function(signal1, signal2) {
  rv <- reactiveValues(signal = NULL)

  observe({
    signal <- signal1()
    isolate(rv$signal <- signal)
  })
  observe({
    signal <- signal2()
    isolate(rv$signal <- signal)
  })

  reactive(rv$signal)
}

# Merge a list of signals.
#
# NOT IMPLEMENTED YET
merges <- function(signals) {

}

#' Reduce a signal with its past values.
#'
#' @param signal A signal.
#' @param fun An accumulator function. Should take two arguments
#' @param init An initial value.
#' @return A reactive of the same type as \code{init}.
#' @export
#' @examples
#' # Simulate a markov random walk
#' walk <- reactive({fps(30); sample(c(-1, 0, 1), 1)})
#' location <- walk %>% reducePast(`+`, 0)
#'
#' # Eventually:
#' # reactivePlot(count(walk), location)
reducePast <- function(signal, fun, init) {
  rv <- reactiveValues(acc = init)

  observe({
    s <- signal()
    isolate(rv$acc <- fun(rv$acc, s))
  })
  reactive(rv$acc)
}

#' Count the number of times a signal has been updated.
#'
#' @param signal A signal.
#' @export
#' @return A reactive integer
count <- function(signal) {
  rv <- reactiveValues(n = 0L)
  observe({
    signal()
    isolate(rv$n <- rv$n + 1L)
  })
  reactive(rv$n)
}

#' @export
#' @param predicate A predicate; only signals for which the predicate
#'   returns true will be counted.
#' @rdname count
#' @examples
#' rand <- reactive({fps(30); rnorm(1)})
#' count(rand)
#' countIf(rand, function(x) x > 0)
countIf <- function(signal, predicate) {
  rv <- reactiveValues(n = 0)
  observe({
    if (predicate(signal())) {
      isolate(rv$n <- rv$n + 1)
    }
  })
  reactive(rv$n)
}

#' Filter signals.
#'
#' There are two variations: do you want to use a predicate function (\code{if})
#' or a boolean stream (\code{when}); and do you want to keep or drop the
#' values.
#'
#' @param signal A signal
#' @param predicate For \code{if} functions, a predicate function;
#'   for \code{when}, a signal yielding TRUE or FALSE.
#' @param init Shiny does not allow undefined signals, so an initial value
#'   must be provided in case the first signal is filtered out.
#' @name filtering
NULL

#' @export
#' @rdname filtering
keepIf <- function(signal, predicate, init = NULL) {
  rv <- reactiveValues(value = init)
  observe({
    s <- signal()
    if (predicate(s)) {
      isolate(rv$value <- s)
    }
  })
  reactive(rv$value)
}

#' @export
#' @rdname filtering
dropIf <- function(signal, predicate, init = NULL) {
  rv <- reactiveValues(value = init)
  observe({
    s <- signal()
    if (!predicate(s)) {
      isolate(rv$value <- s)
    }
  })
  reactive(rv$value)
}

#' @export
#' @rdname filtering
keepWhen <- function(signal, predicate, init = NULL) {
  rv <- reactiveValues(value = init)
  observe({
    if (!isTRUE(predicate())) return()

    s <- signal()
    isolate(rv$value <- s)
  })
  reactive(rv$value)
}

#' @export
#' @rdname filtering
dropWhen <- function(signal, predicate, init = NULL) {
  rv <- reactiveValues(value = init)
  observe({
    if (isTRUE(predicate())) return()

    s <- signal()
    isolate(rv$value <- s)
  })
  reactive(rv$value)
}

#' Drop repeated values of a signal.
#'
#' @param signal A signal
#' @export
dropRepeats <- function(signal) {
  rv <- reactiveValues(value = NULL)

  observe({
    value <- signal()
    if (!identical(rv$value, value)) {
      isolate(rv$value <- value)
    }
  })
  reactive(rv$value)
}

#' Sample one signal on another signal.
#'
#' Sample from the second input every time an event occurs on the first input.
#' For example, \code{every(1) \%>\% sampleOn(click)} will give the approximate
#' time of the latest click. This is useful for temporal up- and down-scaling.
#'
#' @param signal Signal that provides a value.
#' @param on Signal that determines when to submit a new value.
#' @export
sampleOn <- function(signal, on) {
  rv <- reactiveValues(value = NULL)

  observe({
    value <- signal()
    isolate(rv$value <- value)
  })

  reactive({
    on()
    isolate(rv$value)
  })
}