R/dsintersection.R

In Trinity-Automata-Research/dsmodels: A Language to Facilitate Simulation and Visualization of Two-Dimensional Dynamical Systems

#' Intersections of curves
#'
#' The \code{dsintersection} function creates an object rendering the intersection between two curves.
#'
#' @include dsproto.R uniroot.all.R
#' @param c1,c2 Functions, vectors, or \code{dscurve} objects representing curves.
#' @param range A numeric vector containing the endpoints of the range of x values to be input to the function. If c1 and c2 are functions or unbound dscurves,
#' this parameter must be passed in.
#' @param col A string color representing the color of the points generated by the \code{dsintersection} object.
#' @param pch The plotting character, i.e. symbol, to use for the points. Defaults to 21, a round point.
#' @param size The size of the points.
#' @param bg A vector of string colors representing the color of the point's (or points') background. This typically manifests itself as the color of the outline of the point.
#' @param display A boolean determining whether or not to render the points found by dsintersection.
#' @param labels A string or list of strings representing the label (or labels) of the points.
#' @param labelCols A string color or vector of string colors representing the font color of the points.
#' @param labelBgs A string color or vector of string colors representing the color of the background of the label text.
#' @param offsets A vector of offsets for the label. Enter as c(x, y). Defaults to an automatic scale dependant on the range's y axis size.
#' @import stats
#' @export
dsintersection <- function(c1, c2, range = NULL, col = "blue", pch = 21, size = 2, bg = "black", display = TRUE, labels = "",
                           labelCols = "black", labelBgs = "white", offsets = NULL) {
  if(is.curve(c1) && c1$bound && !c1$isParametric) {
    fun1 <- eval(c1$fun)
    if(is.null(range)) range <- c1$model$range$xlim
  }
  else if(is.function(c1)) fun1 <- c1
  else if(is.list(c1)) {
    fun1 <- approxfun(c1$x, c1$y)
    if(1 %in% sign(diff(c1$x)) && -1 %in% sign(diff(c1$x))) warning("We advise against using dsintersections with nonfunctional curves.")
    if(is.null(range)) range <- c(min(c1$x), max(c1$x))
  }
  if(is.curve(c2) && c2$bound && !c2$isParametric) {
    fun2 <- eval(c2$fun)
    if(is.null(range)) range <- c2$model$range$xlim
  }
  else if(is.function(c2)) fun2 <- c2
  else if(is.list(c2)) {
    fun2 <- approxfun(c2$x, c2$y)
    if(1 %in% sign(diff(c2$x)) && -1 %in% sign(diff(c2$x))) warning("We advise against using dsintersections with nonfunctional curves.")
    if(is.null(range)) range <- c(min(c2$x), max(c2$x))
  }

  subtractionFun <- function(x) fun1(x) - fun2(x)
  intersections <- uniroot.all(subtractionFun, range)
  dsproto(
    `_class` = "dsintersection", `_inherit` = feature,
    c1 = c1,
    c2 = c2,
    fun1 = fun1,
    fun2 = fun2,
    range = range,
    col = col,
    pch = pch,
    bg = bg,
    size = size,
    display = display,
    labels = labels,
    labelCols = labelCols,
    labelBgs = labelBgs,
    offsets = offsets,
    intersections = intersections,
    render = function(self, model) {
      if(self$display) {
        pnts <- if(!is.null(offsets)) mapply(dspoint, self$intersections, fun1(self$intersections),
                       self$labels, self$labelBgs, self$labelCols,
                       self$pch, self$size, self$col, offset = self$offsets)
                else  mapply(dspoint, self$intersections, fun1(self$intersections),
                              self$labels, self$labelBgs, self$labelCols,
                              self$pch, self$size, self$col)
        mapply(model$bind, pnts)
      }
    }
  )
}

#' Reports whether x is a dsintersection
#' @param x An object to test.
# @rdname dsintersection
#' @keywords internal
#' @export
is.intersection <- function(x) inherits(x, "dsintersection")