R/dsmodel.R
In Trinity-Automata-Research/dsmodels: A Language to Facilitate Simulation and Visualization of Two-Dimensional Dynamical Systems
Defines functions
dsassert
finite.points
sqdist
safe.apply
NaNRemove
colorVector
is.model
dsmodel
#' Defines a model object encapsulating a dynamical system
#'
#' To begin, define a two dimensional function that outputs
#' a two-dimensional list. For instance:
#' \code{fun <- function(x,y) list(x,y)}. Then
#' \code{dsmodel(fun)} will initialize the model.
#' \strong{Make sure that the function defining your model indeed outputs a \code{list}.}
#' The model is used to hold the data for graphics.
#' To display a desired graphic, add the corresponding
#' feature of type "dsproto" to your model.
#'
#' Models are constructed
#' incrementally using the + operator to add features
#' to the existing dsmodel object. A \code{\link{dsrange}} must be one of the objects added to a model.
#'
#' @section Methods:
#' \code{dsmodel} objects support the following methods, which may be helpful for advanced users.
#'
#' \code{dsmodel$points(format="list", filter="all")} returns a list of the points in the model.
#' \describe{
#' \item{\code{filter}}{Valid values are \code{"all"}, \code{"fixed"}, \code{"attractor"}, and \code{"sim"}.
#' \code{"sim"} returns only points generated by \code{\link{simattractors}}. }
#' \item{\code{format}}{If \code{"list"}, return a list with \code{x}, \code{y}, \code{col}, and \code{ind} fields holding
#' the coordinates, color, and index. Other formats are \code{"objects"}, returning a vector of \code{dspoint} objects,
#' and \code{"pairs"}, returning a list of pairs of coordinates.}
#' }
#'
#' \code{dsmodel$display()} forces the model to re-render the plot from scratch. Primarily useful if \code{display=TRUE} was set.
#'
#' \code{dsmodel$basins()} returns a list of which fixed points have a basin. This requires \code{simbasins()} to have been composed
#' with the model, and is primarily useful when testing if a dynamical system is globally stable. In that case, the method
#' will return a list of length 1. The list will contain the indices of the fixed points, as given in
#' \code{dsmodel$points(format="list", filter="attractor")}. An index of 0 means that some points never moved within
#' epsilon of an attractor.
#'
#' \code{dsmodel$sim.is.stable()} attempts to determine if the system is stable by simulation. If no attractors have
#' been composed with the model, \code{simattractors()} is composed with defaults. If \code{simbasins} has not
#' been composed with the model, it is be composed with defaults. If every point is drawn to a single attractor, the
#' system has been deemed stable. Note that boundary points on the range will not be tested.
#'
#' @family Foundation
#' @param fun Function with two inputs and two outputs which defines the dynamical system. The output should be a list, preferably with field names x and y.
#' @param title A string title for the graph. Text can be input in the form of pseudo-LaTeX code within quotes.
#' See \code{\link[latex2exp]{TeX}} for more details.
#' @param display If set to \code{FALSE}, the model will be drawn only when the user calls \code{`MODELNAME`$display()}. Otherwise,
#' the model will be drawn with every \code{dsmodels} object added after the \code{dsrange} is added.
#' @import grDevices latex2exp
#' @include dsproto.R
#' @seealso \code{\link{dsrange}}
#' @export
#' @examples
#' library(dsmodels)
#'
#' fun <- function(X,Y) {
#' list(
#' x = X/exp(Y),
#' y = Y/exp(X)
#' )
#' }
#' # Add dsRange to see the actual range.
#' model <- dsmodel(fun)
#'
#' dsmodel(function(x,y) {
#' list(
#' x = x^2,
#' y = x/(y+1)
#' )
#' }, title = "Another function showing $f(x)=x^{\\alpha}$!")
dsmodel <- function(fun, title="", display = TRUE) {
texTitle <- TeX(title)
par(mar=c(5, 4, 4, 2) + 0.1)
#if(length(formals(fun)) != 2)
# stop("dsmodel: Please make sure your function has 2 distinct, variable inputs.")
dsproto(
`_class` = "model",
`_inherit` = NULL,
fun = fun,
title = texTitle,
dim = 2,
funParams=formals(fun),
range = NULL,
facade = c(),
background = c(),
feature = c(),
visualization = c(),
autoDisplay = display,
properNames = NULL,
print = function(self, ...) {
invisible(self)
},
#methods for applying the underlying function of the model
apply = function(self, x, y, ..., iters=1, accumulate=TRUE, crop = TRUE) {
if(is.null(x) || is.null(y))
stop("dsmodel: Please make sure your x and y values are defined in latest object created.")
if(crop){
dsassert(self$has.xyrange(),"Applying the model's fucntion with crop set to true requires the model's range to be defined.")
}
if(is.null(self$properNames))
{
tmp = self$fun(x[1], y[1],...)
if(length(tmp) != 2)
stop("dsmodel: Please make sure your function outputs a list with 2 values. (for example: list(x+1,y^2)")
if(is.element("x", names(tmp)) && is.element("y", names(tmp)))
self$properNames = TRUE
else {
self$properNames = FALSE
if(!is.null(names(tmp)))
warning("dsmodel function has outputs names that are not \"x\" and \"y\". Assuming first output is x, and second is y.")
}
}
properNames <- self$properNames
if(accumulate) {
iterAccum = vector("list",iters+1)
startvals = list(x=x, y=y)
if(crop){
startvals <- self$cropframe(startvals)
}
iterAccum[[1]] <- startvals
iterSeq = 1:iters
if(identical(iters,0))
iterSeq <- NULL
for(i in iterSeq){
tmp=self$fun(x,y,...)
if(any(is.nan(tmp[[1]])) || any(is.nan(tmp[[2]])))
{
warning("dsmodel: model undefined, NaN computed. (Division by zero). Removing points with NaN value and continuing procedure..")
tmp = NaNRemove(tmp)
}
if(crop){
tmp = self$cropframe(tmp)
}
if(!properNames)
names(tmp) <- c("x","y")
x = tmp$x
y = tmp$y
iterAccum[[i+1]] <- tmp
}
iterAccum
} else {
for(i in 1:iters){
tmp=self$fun(x,y,...)
if(crop){
tmp <- self$cropframe(tmp)
}
if(!properNames) {
x = tmp[[1]]
y = tmp[[2]]
}
else {
x = tmp$x
y = tmp$y
}
}
if(!properNames)
names(tmp) <- c("x","y")
tmp
}
},
cropframe = function(self, vals) { #dosent check if range is defined first. should only
if(self$properNames){ #be called if has.xyrange is asserted first
xin <- vals$x
yin <- vals$y
}
else{
xin <- vals[[1]]
yin <- vals[[2]]
}
xlim <- self$range$xlim
ylim <- self$range$ylim
keeps <- !( xin > max(xlim) | xin < min(xlim) | yin > max(ylim) | yin < min(ylim))
if(all(keeps)) {
list(
x = xin,
y = yin
)
}
else {
list(
x = xin[keeps],
y = yin[keeps]
)
}
},
has.xyrange= function(self){
!is.null(self$range) && self$has.xlim() && self$has.ylim()
},
has.xlim = function(self){
!all(self$range$xlim==c(0,0))
},
has.ylim = function(self){
!all(self$range$ylim==c(0,0))
},
#visualization methods
bind = function(self, obj = NULL) {
if(is.null(obj)) {
stop("Bind called on null object: severe error. Please notify developers.")
}
if(is.range(obj)) {
obj$on.bind(model = self)
for(ba in self$background)
ba$on.bind(model = self)
for(vi in self$visualization)
vi$on.bind(model = self)
for(fe in self$feature)
fe$on.bind(model = self)
for(fa in self$facade)
fa$on.bind(model=self)
if(self$autoDisplay)
self$display(obj)
}
else if(!(is.null(self$range) && obj$requiresRange)) {
obj$on.bind(self)
if(self$autoDisplay)
self$display(obj)
}
},
display = function(self, obj = NULL) {
rerender = FALSE
if(is.null(obj))
rerender = TRUE #render called with no arguments to force a rendering.
else if(is.range(obj)) {
if(!is.range(self$range))
stop("Range not added properly: severe error. Please notify developers.")
if(!self$range$rendered)
rerender = TRUE
}
else if(!is.null(self$range)) {
if( (is.background(obj) && !(is.null(self$visualization) && is.null(self$feature)))
|| (is.visualization(obj) && ! is.null(self$feature)) )
rerender = TRUE
else
if(!is.facade(obj))
stop("Attempting to render a non-facade object. This will go poorly. Notify developers")
obj$render(model=self)
}
if(rerender) {
self$redisplay()
}
},
recalculate = function(self) {
if(!is.null(self$range)) {
if(is.range(self$range)) {
self$range$render(model = self)
}
for(ba in self$background)
ba$recalculate(model = self)
for(vi in self$visualization)
vi$recalculate(model = self)
for(fe in self$feature)
fe$recalculate(model = self)
for(fa in self$facade)
fa$recalculate(model=self)
}
},
redisplay = function(self){
self$range$render(model = self)
for(bg in self$background)
bg$render(model = self)
for(fa in self$facade)
fa$render(model = self)
for(vi in self$visualization)
vi$render(model = self)
for(fe in self$feature)
fe$render(model = self)
},
#Methods related to models-as-interactable-objects (for simulation to test, not visualize)
points = function(self, format="list", filter="all") {
points <- Filter(is.dspoint, self$feature)
if(identical(filter,"attractor"))
points <- Filter(function(p) {p$attractor}, points)
else if(identical(filter,"sim"))
points <- Filter(function(p) {p$artificial}, points)
else if(identical(filter,"fixed") || identical(filter,"fixedpoint"))
points <- Filter(function(p) {p$fixed}, points)
else if(!identical(filter,"all"))
stop("dsmodel: valid filters for dsmodel$points method are: \"all\", \"attractor\", \"fixed\", \"sim\".")
if(identical(format,"objects"))
points
else if(identical(format,"list")) {
res <- pointsToList(points)
res$inds = c(res$inds,recursive=TRUE)
res
}
else if(identical(format,"pairs"))
Map(function(pnt) c(pnt$x, pnt$y), points)
else
stop("dsmodel: valid formats for dsmodel$points method are: \"objects\", \"list\", \"pairs\"")
},
basins = function(self){
basins <- Filter(is.dsimage,c(self$background,self$feature))
if(length(basins) == 0)
stop("dsmodel$basins requires simbasins() to have been composed with the model.")
if(length(basins) > 1)
stop("dsmodel$basins can't handle models with multiple simbasins().")
basin <- basins[[1]]
if(!basin$bound)
basin$recalculate(self)
res <- unique(c(basin$colMatrix))
if(is.element(0,res))
warning("dsmodel$basins: simbasins did not find an attractor for every point.")
res
},
has.diverged = function(self, x, y, crop=FALSE){
if(length(x)<1 || length(y)<1){ #check for numeric(0)
return(TRUE) #this only works if x and y are not lists. to check has.diverged on multiple
} #points, you would need to either use mapply or change has.diverged.
if(!crop)
!finite.points(c(x,y))
else
!all(x <= self$range$xlim[[2]] & x >= self$range$xlim[[1]] & y <= self$range$ylim[[2]] & y >= self$range$ylim[[1]])
},
sim.is.stable = function(self) {
attractors <- Filter(
function(x) {
if(is.dspoint(x))
x$attractor
else
FALSE
}, self$feature)
if(length(attractors) == 0)
self + simattractors()
basins <- Filter(is.dsimage,c(self$background,self$feature))
if(length(basins) == 0)
self$simbasins()
if(length(basins) > 1)
stop("dsmodel$basins can't handle models with multiple simbasins().")
basin <- basins[[1]]
if(!basin$bound)
basin$recalculate(self)
res <- unique(c(basin$colMatrix))
(length(res) == 1) && !(is.element(0,res))
},
find.period= function(self, x, y=NULL, ..., iters=1000, maxPeriod=128, numTries=1, powerOf2=TRUE,
epsilon=sqrt(sqrt(.Machine$double.eps)), crop=FALSE){
#i dont think this works with ...
#if(!(!is.null(y) && length(x)==1 && length(y)==1)){
# if(is.dspoint(x)){
# y=x$y
# x=x$x
# }
# else if(is.vector(x) && length(x)==2){
# y=x[[2]]
# x=x[[1]]
# }
# else {
# stop("dsmodel: expected input formats for find.period's starting point are two scalars, a vector of length two or a dspoint")
# }
#}
if(crop){
dsassert(self$has.xyrange(),"Finding period with crop set to true requires the model's range to be defined.")
}
#moves all the points. stops if they are either all infinite, fixed, or if(crop==TRUE), outside of range
for(i in 1:numTries) {
startPoint <- self$apply(x,y,...,iters=iters,accumulate=FALSE,crop=FALSE)
candidates=self$apply(startPoint$x, startPoint$y, ...,iters=maxPeriod*2-1,accumulate=TRUE,crop=FALSE)
lastCan=candidates[[2*maxPeriod]]
if(self$has.diverged(lastCan$x,lastCan$y,crop=crop)){
#print("no period found, diverged")
return(FALSE)
}
period=FALSE
i=1
while(i<=maxPeriod && !period){
test=candidates[1:i]
image=candidates[(i+1):(2*i)]
dists=mapply(sqdist,test,image)
if(all(dists < epsilon))
period=TRUE
else{
if(powerOf2)
i=2*i
else
i=i+1
}
}
if(period){
return(i)
}
last=candidates[[2*maxPeriod]]
if(self$properNames){
x=last$x
y=last$y
}
else{
x=last[[1]]
y=last[[2]]
}
}
warning(paste("Assuming Chaotic: no period found after",(iters+maxPeriod)*numTries,"iterations. Consider increasing iters."))
return(Inf)
}
)
}
#' Checks if object is a mode.
#'
#' @param x Object to check
#' @export
#' @keywords internal
#' @usage NULL
is.model <- function(x) inherits(x,"model")
#' Set Color Vector From Parameters
#'
#' Outputs a color vector.
#' If the combined length of \code{col} and \code{image} is 2, and \code{iters} is greather than 1,
#' this function creates a gradient from first specified color to the second. The length of said
#' vector will be equal to \code{iters}.
#' If the combined length of \code{col} and \code{image} is greater than two, then the output will
#' be a vector of whatever was input into \code{col} and \code{image} with output length being
#' \code{min(length(col) + length(image), iters)}.
#' @param col A vector or list of colors
#' @param image A vector or list of colors
#' @param iters A number indicating the number of iterations desired.
#' If set to greater than 1, \code{iters} becomes the length of the output.
#' @keywords internal
#' @export
colorVector <- function(col, image, iters) {
if(is.null(image))
image <- ""
if((length(col) == 2 && iters > 1 && identical(image, "")) # GRADIENT
|| (length(col) == 1 && length(image) == 1 && iters > 1)){
if(!is.null(image)) {
if(!identical(image,""))
col <- append(col,image)
}
colf <- colorRamp(col)
colptr <- seq(0,1, length.out = iters+1)
vect <- vector(mode = "list", iters+1)
for(i in 1:(iters+1)) {
tmp <- colf(colptr[[i]])
vect[[i]] = rgb(red = tmp[1],
green = tmp[2],
blue = tmp[3], maxColorValue = 255)
}
vect
}
else{ # NOT GRADIENT
if(!identical(image,""))
col <- append(col, image)
lengthOfCol <- length(col)
if( iters > 1 )
len <- min(lengthOfCol, iters)
else
len <- lengthOfCol
vect <- vector(mode = "list", len)
for(i in 1:len){
if(identical(col[[i]],""))
col[[i]] = "NA"
vect[[i]] <- col[[i]]
}
vect
}
}
#' NaNRemove
#'
#' Finds and removes all 2-d points which produce NaNs
#' @keywords internal
#' @param twoDList Data of form \code{list(list(),list())}.
#' @export
NaNRemove <- function(twoDList){
tmp <- twoDList
if(length(tmp[[1]])!=length(tmp[[2]])){
stop("dsmodel: X and Y of different length. Internal Error.")
}
keeps <- is.finite(tmp[[1]]) & is.finite(tmp[[2]])
if(!all(keeps)) {
list(
tmp[[1]] <- tmp[[1]][keeps],
tmp[[2]] <- tmp[[2]][keeps]
)
}
}
#can this just be replaced with > k[is.finite(k)&is.finite(r)]? (yes. why god why)
#' Abstract a Function which does not Crash Upon Failure
#'
#' This function takes a boolean function and abstracts it. If the given function fails, the program will not crash.
#' @keywords internal
#' @param fun Input function to abstract.
#' @param inp Input to that function.
#' @export
safe.apply <- function(fun,inp){
tryCatch({fun(inp)},
warning=function(w) { FALSE},
error=function(e) { FALSE })
}
#' Returns the squared distance from a to b
#'
#' This function takes two points and returns
#' the squared distance between the points.
#' @keywords internal
#' @param a a list of points to test in the form c(xValue,Yvalue)
#' @param b a list of points to test in the form c(xValue,Yvalue)
#' @export
sqdist <- function(a, b) {
return((a[[1]]-b[[1]])^2 + (a[[2]]-b[[2]])^2)
}
#' Check if points are finite
#'
#' This function takes a list of points and returns true if all values in points are finite.
#' @keywords internal
#' @param points a list of points to test
#' @export
finite.points = function(points) {
all(is.finite(unlist(points)))
}
#' Asserts a boolean condition is true
#'
#' This function takes a boolean and a string, replicating the common assert pattern.
#' @keywords internal
#' @param t Boolean condition which must be true.
#' @param str Error message to return if the condition fails.
#' @param critical If the condition can only arise from a bug in dsmodels.
#' @export
dsassert = function(t,str,critical=FALSE) {
if(!t) {
if(critical)
stop(paste("Critical error:",str,"Please notify developers."))
else
stop(str)
}
}
Trinity-Automata-Research/dsmodels documentation built on May 18, 2024, 1:20 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions dsassert finite.points sqdist safe.apply NaNRemove colorVector is.model dsmodel
#' Defines a model object encapsulating a dynamical system
#'
#' To begin, define a two dimensional function that outputs
#' a two-dimensional list. For instance:
#' \code{fun <- function(x,y) list(x,y)}. Then
#' \code{dsmodel(fun)} will initialize the model.
#' \strong{Make sure that the function defining your model indeed outputs a \code{list}.}
#' The model is used to hold the data for graphics.
#' To display a desired graphic, add the corresponding
#' feature of type "dsproto" to your model.
#'
#' Models are constructed
#' incrementally using the + operator to add features
#' to the existing dsmodel object. A \code{\link{dsrange}} must be one of the objects added to a model.
#'
#' @section Methods:
#' \code{dsmodel} objects support the following methods, which may be helpful for advanced users.
#'
#' \code{dsmodel$points(format="list", filter="all")} returns a list of the points in the model.
#' \describe{
#' \item{\code{filter}}{Valid values are \code{"all"}, \code{"fixed"}, \code{"attractor"}, and \code{"sim"}.
#' \code{"sim"} returns only points generated by \code{\link{simattractors}}. }
#' \item{\code{format}}{If \code{"list"}, return a list with \code{x}, \code{y}, \code{col}, and \code{ind} fields holding
#' the coordinates, color, and index. Other formats are \code{"objects"}, returning a vector of \code{dspoint} objects,
#' and \code{"pairs"}, returning a list of pairs of coordinates.}
#' }
#'
#' \code{dsmodel$display()} forces the model to re-render the plot from scratch. Primarily useful if \code{display=TRUE} was set.
#'
#' \code{dsmodel$basins()} returns a list of which fixed points have a basin. This requires \code{simbasins()} to have been composed
#' with the model, and is primarily useful when testing if a dynamical system is globally stable. In that case, the method
#' will return a list of length 1. The list will contain the indices of the fixed points, as given in
#' \code{dsmodel$points(format="list", filter="attractor")}. An index of 0 means that some points never moved within
#' epsilon of an attractor.
#'
#' \code{dsmodel$sim.is.stable()} attempts to determine if the system is stable by simulation. If no attractors have
#' been composed with the model, \code{simattractors()} is composed with defaults. If \code{simbasins} has not
#' been composed with the model, it is be composed with defaults. If every point is drawn to a single attractor, the
#' system has been deemed stable. Note that boundary points on the range will not be tested.
#'
#' @family Foundation
#' @param fun Function with two inputs and two outputs which defines the dynamical system. The output should be a list, preferably with field names x and y.
#' @param title A string title for the graph. Text can be input in the form of pseudo-LaTeX code within quotes.
#' See \code{\link[latex2exp]{TeX}} for more details.
#' @param display If set to \code{FALSE}, the model will be drawn only when the user calls \code{`MODELNAME`$display()}. Otherwise,
#' the model will be drawn with every \code{dsmodels} object added after the \code{dsrange} is added.
#' @import grDevices latex2exp
#' @include dsproto.R
#' @seealso \code{\link{dsrange}}
#' @export
#' @examples
#' library(dsmodels)
#'
#' fun <- function(X,Y) {
#' list(
#' x = X/exp(Y),
#' y = Y/exp(X)
#' )
#' }
#' # Add dsRange to see the actual range.
#' model <- dsmodel(fun)
#'
#' dsmodel(function(x,y) {
#' list(
#' x = x^2,
#' y = x/(y+1)
#' )
#' }, title = "Another function showing $f(x)=x^{\\alpha}$!")
dsmodel <- function(fun, title="", display = TRUE) {
texTitle <- TeX(title)
par(mar=c(5, 4, 4, 2) + 0.1)
#if(length(formals(fun)) != 2)
# stop("dsmodel: Please make sure your function has 2 distinct, variable inputs.")
dsproto(
`_class` = "model",
`_inherit` = NULL,
fun = fun,
title = texTitle,
dim = 2,
funParams=formals(fun),
range = NULL,
facade = c(),
background = c(),
feature = c(),
visualization = c(),
autoDisplay = display,
properNames = NULL,
print = function(self, ...) {
invisible(self)
},
#methods for applying the underlying function of the model
apply = function(self, x, y, ..., iters=1, accumulate=TRUE, crop = TRUE) {
if(is.null(x) || is.null(y))
stop("dsmodel: Please make sure your x and y values are defined in latest object created.")
if(crop){
dsassert(self$has.xyrange(),"Applying the model's fucntion with crop set to true requires the model's range to be defined.")
}
if(is.null(self$properNames))
{
tmp = self$fun(x[1], y[1],...)
if(length(tmp) != 2)
stop("dsmodel: Please make sure your function outputs a list with 2 values. (for example: list(x+1,y^2)")
if(is.element("x", names(tmp)) && is.element("y", names(tmp)))
self$properNames = TRUE
else {
self$properNames = FALSE
if(!is.null(names(tmp)))
warning("dsmodel function has outputs names that are not \"x\" and \"y\". Assuming first output is x, and second is y.")
}
}
properNames <- self$properNames
if(accumulate) {
iterAccum = vector("list",iters+1)
startvals = list(x=x, y=y)
if(crop){
startvals <- self$cropframe(startvals)
}
iterAccum[[1]] <- startvals
iterSeq = 1:iters
if(identical(iters,0))
iterSeq <- NULL
for(i in iterSeq){
tmp=self$fun(x,y,...)
if(any(is.nan(tmp[[1]])) || any(is.nan(tmp[[2]])))
{
warning("dsmodel: model undefined, NaN computed. (Division by zero). Removing points with NaN value and continuing procedure..")
tmp = NaNRemove(tmp)
}
if(crop){
tmp = self$cropframe(tmp)
}
if(!properNames)
names(tmp) <- c("x","y")
x = tmp$x
y = tmp$y
iterAccum[[i+1]] <- tmp
}
iterAccum
} else {
for(i in 1:iters){
tmp=self$fun(x,y,...)
if(crop){
tmp <- self$cropframe(tmp)
}
if(!properNames) {
x = tmp[[1]]
y = tmp[[2]]
}
else {
x = tmp$x
y = tmp$y
}
}
if(!properNames)
names(tmp) <- c("x","y")
tmp
}
},
cropframe = function(self, vals) { #dosent check if range is defined first. should only
if(self$properNames){ #be called if has.xyrange is asserted first
xin <- vals$x
yin <- vals$y
}
else{
xin <- vals[[1]]
yin <- vals[[2]]
}
xlim <- self$range$xlim
ylim <- self$range$ylim
keeps <- !( xin > max(xlim) | xin < min(xlim) | yin > max(ylim) | yin < min(ylim))
if(all(keeps)) {
list(
x = xin,
y = yin
)
}
else {
list(
x = xin[keeps],
y = yin[keeps]
)
}
},
has.xyrange= function(self){
!is.null(self$range) && self$has.xlim() && self$has.ylim()
},
has.xlim = function(self){
!all(self$range$xlim==c(0,0))
},
has.ylim = function(self){
!all(self$range$ylim==c(0,0))
},
#visualization methods
bind = function(self, obj = NULL) {
if(is.null(obj)) {
stop("Bind called on null object: severe error. Please notify developers.")
}
if(is.range(obj)) {
obj$on.bind(model = self)
for(ba in self$background)
ba$on.bind(model = self)
for(vi in self$visualization)
vi$on.bind(model = self)
for(fe in self$feature)
fe$on.bind(model = self)
for(fa in self$facade)
fa$on.bind(model=self)
if(self$autoDisplay)
self$display(obj)
}
else if(!(is.null(self$range) && obj$requiresRange)) {
obj$on.bind(self)
if(self$autoDisplay)
self$display(obj)
}
},
display = function(self, obj = NULL) {
rerender = FALSE
if(is.null(obj))
rerender = TRUE #render called with no arguments to force a rendering.
else if(is.range(obj)) {
if(!is.range(self$range))
stop("Range not added properly: severe error. Please notify developers.")
if(!self$range$rendered)
rerender = TRUE
}
else if(!is.null(self$range)) {
if( (is.background(obj) && !(is.null(self$visualization) && is.null(self$feature)))
|| (is.visualization(obj) && ! is.null(self$feature)) )
rerender = TRUE
else
if(!is.facade(obj))
stop("Attempting to render a non-facade object. This will go poorly. Notify developers")
obj$render(model=self)
}
if(rerender) {
self$redisplay()
}
},
recalculate = function(self) {
if(!is.null(self$range)) {
if(is.range(self$range)) {
self$range$render(model = self)
}
for(ba in self$background)
ba$recalculate(model = self)
for(vi in self$visualization)
vi$recalculate(model = self)
for(fe in self$feature)
fe$recalculate(model = self)
for(fa in self$facade)
fa$recalculate(model=self)
}
},
redisplay = function(self){
self$range$render(model = self)
for(bg in self$background)
bg$render(model = self)
for(fa in self$facade)
fa$render(model = self)
for(vi in self$visualization)
vi$render(model = self)
for(fe in self$feature)
fe$render(model = self)
},
#Methods related to models-as-interactable-objects (for simulation to test, not visualize)
points = function(self, format="list", filter="all") {
points <- Filter(is.dspoint, self$feature)
if(identical(filter,"attractor"))
points <- Filter(function(p) {p$attractor}, points)
else if(identical(filter,"sim"))
points <- Filter(function(p) {p$artificial}, points)
else if(identical(filter,"fixed") || identical(filter,"fixedpoint"))
points <- Filter(function(p) {p$fixed}, points)
else if(!identical(filter,"all"))
stop("dsmodel: valid filters for dsmodel$points method are: \"all\", \"attractor\", \"fixed\", \"sim\".")
if(identical(format,"objects"))
points
else if(identical(format,"list")) {
res <- pointsToList(points)
res$inds = c(res$inds,recursive=TRUE)
res
}
else if(identical(format,"pairs"))
Map(function(pnt) c(pnt$x, pnt$y), points)
else
stop("dsmodel: valid formats for dsmodel$points method are: \"objects\", \"list\", \"pairs\"")
},
basins = function(self){
basins <- Filter(is.dsimage,c(self$background,self$feature))
if(length(basins) == 0)
stop("dsmodel$basins requires simbasins() to have been composed with the model.")
if(length(basins) > 1)
stop("dsmodel$basins can't handle models with multiple simbasins().")
basin <- basins[[1]]
if(!basin$bound)
basin$recalculate(self)
res <- unique(c(basin$colMatrix))
if(is.element(0,res))
warning("dsmodel$basins: simbasins did not find an attractor for every point.")
res
},
has.diverged = function(self, x, y, crop=FALSE){
if(length(x)<1 || length(y)<1){ #check for numeric(0)
return(TRUE) #this only works if x and y are not lists. to check has.diverged on multiple
} #points, you would need to either use mapply or change has.diverged.
if(!crop)
!finite.points(c(x,y))
else
!all(x <= self$range$xlim[[2]] & x >= self$range$xlim[[1]] & y <= self$range$ylim[[2]] & y >= self$range$ylim[[1]])
},
sim.is.stable = function(self) {
attractors <- Filter(
function(x) {
if(is.dspoint(x))
x$attractor
else
FALSE
}, self$feature)
if(length(attractors) == 0)
self + simattractors()
basins <- Filter(is.dsimage,c(self$background,self$feature))
if(length(basins) == 0)
self$simbasins()
if(length(basins) > 1)
stop("dsmodel$basins can't handle models with multiple simbasins().")
basin <- basins[[1]]
if(!basin$bound)
basin$recalculate(self)
res <- unique(c(basin$colMatrix))
(length(res) == 1) && !(is.element(0,res))
},
find.period= function(self, x, y=NULL, ..., iters=1000, maxPeriod=128, numTries=1, powerOf2=TRUE,
epsilon=sqrt(sqrt(.Machine$double.eps)), crop=FALSE){
#i dont think this works with ...
#if(!(!is.null(y) && length(x)==1 && length(y)==1)){
# if(is.dspoint(x)){
# y=x$y
# x=x$x
# }
# else if(is.vector(x) && length(x)==2){
# y=x[[2]]
# x=x[[1]]
# }
# else {
# stop("dsmodel: expected input formats for find.period's starting point are two scalars, a vector of length two or a dspoint")
# }
#}
if(crop){
dsassert(self$has.xyrange(),"Finding period with crop set to true requires the model's range to be defined.")
}
#moves all the points. stops if they are either all infinite, fixed, or if(crop==TRUE), outside of range
for(i in 1:numTries) {
startPoint <- self$apply(x,y,...,iters=iters,accumulate=FALSE,crop=FALSE)
candidates=self$apply(startPoint$x, startPoint$y, ...,iters=maxPeriod*2-1,accumulate=TRUE,crop=FALSE)
lastCan=candidates[[2*maxPeriod]]
if(self$has.diverged(lastCan$x,lastCan$y,crop=crop)){
#print("no period found, diverged")
return(FALSE)
}
period=FALSE
i=1
while(i<=maxPeriod && !period){
test=candidates[1:i]
image=candidates[(i+1):(2*i)]
dists=mapply(sqdist,test,image)
if(all(dists < epsilon))
period=TRUE
else{
if(powerOf2)
i=2*i
else
i=i+1
}
}
if(period){
return(i)
}
last=candidates[[2*maxPeriod]]
if(self$properNames){
x=last$x
y=last$y
}
else{
x=last[[1]]
y=last[[2]]
}
}
warning(paste("Assuming Chaotic: no period found after",(iters+maxPeriod)*numTries,"iterations. Consider increasing iters."))
return(Inf)
}
)
}
#' Checks if object is a mode.
#'
#' @param x Object to check
#' @export
#' @keywords internal
#' @usage NULL
is.model <- function(x) inherits(x,"model")
#' Set Color Vector From Parameters
#'
#' Outputs a color vector.
#' If the combined length of \code{col} and \code{image} is 2, and \code{iters} is greather than 1,
#' this function creates a gradient from first specified color to the second. The length of said
#' vector will be equal to \code{iters}.
#' If the combined length of \code{col} and \code{image} is greater than two, then the output will
#' be a vector of whatever was input into \code{col} and \code{image} with output length being
#' \code{min(length(col) + length(image), iters)}.
#' @param col A vector or list of colors
#' @param image A vector or list of colors
#' @param iters A number indicating the number of iterations desired.
#' If set to greater than 1, \code{iters} becomes the length of the output.
#' @keywords internal
#' @export
colorVector <- function(col, image, iters) {
if(is.null(image))
image <- ""
if((length(col) == 2 && iters > 1 && identical(image, "")) # GRADIENT
|| (length(col) == 1 && length(image) == 1 && iters > 1)){
if(!is.null(image)) {
if(!identical(image,""))
col <- append(col,image)
}
colf <- colorRamp(col)
colptr <- seq(0,1, length.out = iters+1)
vect <- vector(mode = "list", iters+1)
for(i in 1:(iters+1)) {
tmp <- colf(colptr[[i]])
vect[[i]] = rgb(red = tmp[1],
green = tmp[2],
blue = tmp[3], maxColorValue = 255)
}
vect
}
else{ # NOT GRADIENT
if(!identical(image,""))
col <- append(col, image)
lengthOfCol <- length(col)
if( iters > 1 )
len <- min(lengthOfCol, iters)
else
len <- lengthOfCol
vect <- vector(mode = "list", len)
for(i in 1:len){
if(identical(col[[i]],""))
col[[i]] = "NA"
vect[[i]] <- col[[i]]
}
vect
}
}
#' NaNRemove
#'
#' Finds and removes all 2-d points which produce NaNs
#' @keywords internal
#' @param twoDList Data of form \code{list(list(),list())}.
#' @export
NaNRemove <- function(twoDList){
tmp <- twoDList
if(length(tmp[[1]])!=length(tmp[[2]])){
stop("dsmodel: X and Y of different length. Internal Error.")
}
keeps <- is.finite(tmp[[1]]) & is.finite(tmp[[2]])
if(!all(keeps)) {
list(
tmp[[1]] <- tmp[[1]][keeps],
tmp[[2]] <- tmp[[2]][keeps]
)
}
}
#can this just be replaced with > k[is.finite(k)&is.finite(r)]? (yes. why god why)
#' Abstract a Function which does not Crash Upon Failure
#'
#' This function takes a boolean function and abstracts it. If the given function fails, the program will not crash.
#' @keywords internal
#' @param fun Input function to abstract.
#' @param inp Input to that function.
#' @export
safe.apply <- function(fun,inp){
tryCatch({fun(inp)},
warning=function(w) { FALSE},
error=function(e) { FALSE })
}
#' Returns the squared distance from a to b
#'
#' This function takes two points and returns
#' the squared distance between the points.
#' @keywords internal
#' @param a a list of points to test in the form c(xValue,Yvalue)
#' @param b a list of points to test in the form c(xValue,Yvalue)
#' @export
sqdist <- function(a, b) {
return((a[[1]]-b[[1]])^2 + (a[[2]]-b[[2]])^2)
}
#' Check if points are finite
#'
#' This function takes a list of points and returns true if all values in points are finite.
#' @keywords internal
#' @param points a list of points to test
#' @export
finite.points = function(points) {
all(is.finite(unlist(points)))
}
#' Asserts a boolean condition is true
#'
#' This function takes a boolean and a string, replicating the common assert pattern.
#' @keywords internal
#' @param t Boolean condition which must be true.
#' @param str Error message to return if the condition fails.
#' @param critical If the condition can only arise from a bug in dsmodels.
#' @export
dsassert = function(t,str,critical=FALSE) {
if(!t) {
if(critical)
stop(paste("Critical error:",str,"Please notify developers."))
else
stop(str)
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.