setOldClass("trellis")
setOldClass("ggplot")
setClass("ElementList", contains="list")
setClassUnion("ListOrNull", members = c("list", "NULL"))
setClass("OutputList", contains = "list")
setClass("ThreadList", contains = "list")
setClass("FormattedOutput", representation(value = "ANY", format = "character", info = "list"))
setClass("FormattedOutputList", contains = "list", valid = function(object) all(sapply(object, is, "FormattedOutput")))
setClass("WidgetsList", contains="list")
setClass("WidgetBase", contains="VIRTUAL")
setClass("IWidget", representation(var = "character",
#I think we want to specify widget by class, but I'll leave this here for custom widgets?
# widget = "character",
linenum = "integer",
default = "ANY",
additional.info = "list"),
contains = "WidgetBase")
setClass("IWidgetSlider", representation(range = "numeric",
step = "numeric"),
contains = "IWidget")
setClass("IWidgetTextbox", contains = "IWidget")
setClass("IWidgetIntTextbox", contains = "IWidgetTextbox")
setClass("IWidgetNumTextbox", contains = "IWidgetTextbox")
setClass("IWidgetSelector", representation(values = "list", labels="list"), contains = "IWidget")
setClass("IWidgetDropDownMenu", contains = "IWidgetSelector")
setClass("IWidgetRadioButton", contains = "IWidgetSelector")
dynDoc = setRefClass("DynDoc", fields = list(
.envir = "environment",
envir = function(value)
{
if(missing(value))
.envir
else
.envir <<- value
},
.children = "ElementList",
children = function(value)
{
if(missing(value))
.children
else
{
if(is(value, "DocElement"))
value = as(list(value), "ElementList")
value = as(sapply(seq(along = value), function(i)
{
el = value[[i]]
el$parent = .self
el$posInParent = i
el
}), "ElementList")
.children <<- value
}
},
metadata = "ListOrNull",
formatSpecific = "ListOrNull",
.testbit = "ANY",
cacheEngine = "CachingEngine",
formatters = "list"),
methods = list(
addChild = function(newel)
{
newpos = length(children)+1
newel$posInParent = newpos
newel$parent = .self
children[[newpos]] <<- newel
newel
},
insertChildren = function(elList, startPos)
{
if (is(elList, "DocElement"))
elList = as(list(elList), "ElementList")
if(!is(elList, "ElementList"))
stop("elList does not seem to be an ElementList. Unable to insert children")
if(startPos > length(children))
return(sapply(elList, function(el) .self$addChild(el)))
afterinds = seq(startPos, length(children))
elsafter = children[afterinds]
elsbefore = children[-afterinds]
.self$children = as(c(elsbefore, elList, elsafter), "ElementList")
#parent/child stuff taken care off in field assignment
},
removeChild = function(oldel)
{
children <<- children[-oldel$posInParent]
oldel$parent = NULL
oldel$posInParent = 0
},
initialize = function(cacheEngine, ...)
{
if(missing(cacheEngine))
cEngine = cachingEngine( base_dir = "./r_caches/", eval_fun = parseWithVis, return_handler = withVisRaw)
else
cEngine = cacheEngine
callSuper(cacheEngine = cEngine, ...)
}
))
docElement = setRefClass("DocElement",
fields = list(
parent = "ANY",
#metadata = "ListOrNull", #attributes makes more sense, so changing to that
attributes = "ListOrNull",
formatSpecific = "ListOrNull",
posInParent = "numeric",
id = "character",
.testbit = "logical",
cacheEngine = "CachingEngine",
styleClasses = "ANY",
formatters = "list" #currently these will only affect code elements...
),
methods = list(
initialize = function(obj, .testbit,cacheEngine, ...)
{
if(!missing(.testbit))
{
warning("The .testbit field is for internal use only and should not be manually initialized. Ignoring initialization value.")
}
args = list(...)
if(missing(cacheEngine)){
if("parent" %in% names(args))
cEngine = args$parent$cacheEngine
else
cEngine = new("CachingEngine", base_dir = "./r_caches/", return_handler = withVisRaw, eval_fun = parseWithVis)
} else {
cEngine = cacheEngine
}
callSuper(.testbit = TRUE, cacheEngine = cEngine, ...)
})
)
containerElement = setRefClass("ContainerElement", contains = "DocElement",
fields = list(
.envir = "environment",
envir = function(value)
{
if(missing(value))
.envir
else
.envir <<- value
},
.children = "ElementList",
children = function(value)
{
if(missing(value))
.children
else
{
if(is(value, "DocElement"))
value = as(list(value), "ElementList")
value = as(sapply(seq(along = value),
function(i)
{
el = value[[i]]
el$parent = .self
el$posInParent = i
el
}),
"ElementList")
.children <<- value
.self$resetInOutVars()
}
},
.invars = "character",
invars = function(value)
{
if(missing(value))
.invars
else
.invars <<- value
},
.outvars = "character",
outvars = function(value)
{
if(missing(value))
.outvars
else
.outvars <<- value
}
),
methods = list(
resetInOutVars = function()
{
listin = lapply(.self$children, function(el)
{
if(!(is(el, "CodeElement")||is(el, "ContainerElement")))
return(NULL)
el$resetInOutVars()
el$invars
})
listout = lapply(.self$children, function(el)
{
if(!(is(el, "CodeElement")||is(el, "ContainerElement")))
return(NULL)
el$outvars
})
retin = character()
retout = character()
for(i in seq(along=listin))
{
tmpin = listin[[i]]
if(!is.null(tmpin))
{
retin = c(retin, tmpin[! (tmpin %in% retout) ] )
retout = c(retout, listout[[i]])
}
}
.self$invars = retin
.self$outvars = retout
},
removeChild = function(oldel)
{
children <<- children[-oldel$posInParent]
oldel$parent = NULL
oldel$posInParent = 0
},
addChild = function(newel)
{
newpos = length(children) + 1
newel$posInParent = newpos
newel$parent = .self
children[[newpos]] <<- newel
newel
},
insertChildren = function(elList, startPos)
{
if (is(elList, "DocElement"))
elList = as(list(elList), "ElementList")
if(!is(elList, "ElementList"))
stop("elList does not seem to be an ElementList. Unable to insert children")
if(startPos > length(children))
return(sapply(elList, function(el) .self$addChild(el)))
afterinds = seq(startPos, length(children))
elsafter = children[afterinds]
elsbefore = children[-afterinds]
.self$children = as(c(elsbefore, elList, elsafter), "ElementList")
#parent child stuff is now taken care of in activeBinding methods on the fields themselves.
})
)
taskElement = setRefClass("TaskElement", contains = "ContainerElement")
codeElement = setRefClass("CodeElement", contains = "DocElement",
fields = list(
.envir = "environment",
envir = function(value)
{
if(missing(value))
.envir
else
.envir <<- value
},
.codehash = "character",
codehash = function(value)
{
if(missing(value))
.codehash
else
.codehash <<- value
},
.invars = "character",
invars = function(value)
{
if(missing(value))
.invars
else
.invars <<- value
},
.outvars = "character",
outvars = function(value)
{
if(missing(value))
.outvars
else
.outvars <<- value
},
.content = "character",
content = function(value)
{
if(missing(value))
.content
else
{
.content <<- value
valhash = fastdigest(value)#digest(unparse(parse(text=value)))
#the first time content is added during construction, codehash will be character(0)
if(length(codehash) && valhash != codehash)
{
codehash <<- valhash
.self$resetInOutVars(force=TRUE)
}
value
}
},
outputs = "ElementList")
)
rCodeElement = setRefClass("RCodeElement", contains = "CodeElement",
fields = list(
content = function(value)
{
if(missing(value))
.content
else
{
if(!is.character(value))
value = deparse(value, control="all")
.content <<- value
valhash = fastdigest(unparse(parse(text=value, keep.source=FALSE)))
if(length(codehash) && valhash != codehash)
{
codehash <<- valhash
.self$resetInOutVars
}
}
}),
methods = list(
resetInOutVars = function(force= FALSE, extra.inputs = NULL, extra.outputs = NULL)
{
#Are there any times that this gets called that it doesn't need to update the in and out variables?
# if(!is(invars, "uninitializedField") && !is(outvars, "uninitializedField") && !force && is.null(extra.inputs) && is.null(extra.outputs))
# return()
#this will add the `{` function to our functions called, but thats probably ok...?
code = content
lastline = code[length(code)]
if(substr(code[1], 1, 1) != "{" || substr(lastline, nchar(lastline), nchar(lastline)) != "}")
code2 = c("{", code, "}")
else
code2 = code
if(length(code2) > 1)
code = paste(code, collapse="\n")
scr = readScript("", type="R", txt=code2)
codeInfo = getInputs(scr)[[1]]
invars <<- c(codeInfo@inputs, extra.inputs)
outvars <<- c( codeInfo@outputs, extra.outputs)
invisible(list(inputs = invars, outputs = outvars))
}
)
)
pyCodeElement = setRefClass("PyCodeElement", contains = "CodeElement",
methods = list(
resetInOutVars = function() NULL #currently we don't know how to do this for python
))
intCodeElement = setRefClass("IntCodeElement", contains = "CodeElement",
fields = list(widgets = function(val)
{
if(missing(val))
.widgets
else
{
if(is(val, "IWidget"))
val = list(val)
.widgets <<- val
}
},
.widgets = "WidgetsList"))
intRCodeElement = setRefClass("IntRCodeElement", contains = c("IntCodeElement", "RCodeElement"))
intPyCodeElement = setRefClass("IntPyCodeElement", contains = c("IntCodeElement", "PyCodeElement"))
outputElement = setRefClass("OutputElement", contains = "DocElement",
fields = list(
codeElement = "CodeElement",
format = "ANY",
content="ANY"
))
textElement = setRefClass("TextElement", contains="DocElement",
fields = list(content="ANY", encoding = "character"))
mdElement = setRefClass("MDTextElement", contains="TextElement")
latexElement = setRefClass("LatexTextElement", contains = "TextElement")
dbElement = setRefClass("DbTextElement", contains="TextElement")
inlineR = setRefClass("InlineRCode", contains = "RCodeElement")
inlineLatex = setRefClass("InlineLatex", contains = "LatexTextElement")
mixedElement = setRefClass("MixedTextElement", contains = "ContainerElement")
mixedMDElement = setRefClass("MixedMDElement", contains = "MixedTextElement")
mixedDBElement = setRefClass("MixedDBElement", contains = "MixedTextElement")
mixedLatexElement = setRefClass("MixedLatexElement", contains = "MixedTextElement")
branchElement = setRefClass("AltElement", contains = "ContainerElement")
branchSetElement = setRefClass("DecisionElement", contains = "ContainerElement")
altImplElement = setRefClass("AltImplElement", contains = "AltElement")
altImplSetElement = setRefClass("AltImplSetElement", contains = "DecisionElement")
altMethodElement = setRefClass("AltMethodElement", contains = "AltElement")
altMethodSetElement = setRefClass("AltMethodSetElement", contains = "DecisionElement")
altQuestElement = setRefClass("AltQuestElement", contains = "AltElement")
altQuestSetElement = setRefClass("AltQuestSetElement", contains = "DecisionElement")
sectElement = setRefClass("SectionElement", contains = "ContainerElement",
fields = list(
.title = "character",
title = function(value)
{
if(missing(value))
.title
else
.title <<- value
}
))
headerSectElement = setRefClass("HeaderSectElement", contains = "SectionElement")
#XXX do we want S4 classes or referenceClasses? We want evaluate(mythread) to both return the return value and change the thread, right? Is there a downside to using ReferenceClasses for this?
elementInstance <- setRefClass("ElementInstance",
fields = list(
element = "DocElement",
formatters = "list",
outputs = "list",
.children = "list",
envir = "environment",
children = function(value)
{
if(missing(value))
.children
else
replaceKids(value, .self)
},
.parentInstance = "ANY", #want Instances, but recursive class defs in R are hard
parentInstance = function(value)
{
if(missing(value))
.parentInstance
else
{
.parentInstance <<- value
if(!is.null(value)) {
parent.env(envir) <<- value$envir
cacheEngine <<- value$cacheEngine
}
.parentInstance
}
},
posInParentInst = "numeric",
cacheEngine = "CachingEngine"),
methods = list(
initialize = function(envir, doChildren = TRUE, branchInstructs = list(), cacheEngine, ...)
{
if(missing(envir))
env = new.env()
else
env = envir
if(missing(cacheEngine))
{
if(!is.null(list(...)$element))
cacheEngine = list(...)$element$cacheEngine
else
cacheEngine = new("CachingEngine", base_dir = "./r_caches/", return_handler = withVisRaw, eval_fun = parseWithVis)
}
callSuper(envir = env, cacheEngine = cacheEngine, ...)
if(doChildren)
.self$instanceChildren(branchInstructs, doChildren = FALSE)
.self
},
instanceChildren = function(branchInstructs, doChildren = TRUE)
{
if(!is(element, "ContainerElement"))
return()
kids = vector("list", length(element$children))
for(k in seq(kids))
{
kids[[k]] = makeInstance(element$children[[k]], branchInstructs, doKids = doChildren, cacheEngine = .self$cacheEngine)
}
children <<- kids
}
)
)
setRefClass("ContainerInstance", contains = "ElementInstance")
setRefClass("BranchSetInstance", contains = "ElementInstance")
#setIs("Instance", "ElementInstance")
setRefClass("DocInstance",
fields = list(.children = "list",
children = function(value)
{
if(missing(value))
.children
else
replaceKids(value, .self)
},
envir = "environment",
parentDoc = "DynDoc",
formatters = "list",
cacheEngine = "CachingEngine"),
methods = list(
initialize = function(envir, cacheEngine, ...)
{
if(missing(envir))
env = new.env()
else
env = envir
args = list(...)
if(missing(cacheEngine)) {
if("parentDoc" %in% names(args))
cEngine = args$parentDoc$cacheEngine
else
cEngine = new("CachingEngine", base_dir = "./r_caches/", eval_fun = parseWithVis, return_handler = withVisRaw)
} else {
cEngine = cacheEngine
}
callSuper( envir = env, cacheEngine = cEngine, ...)
})
)
#setIs("Instance", "DocInstance")
setRefClass("DocThread", contains = "DocInstance")
replaceKids = function(value, self)
{
old = self$.children
sapply(old, function(x)
{
x$parentInstance = NULL
x$posInParentInst = numeric()
})
value = lapply(value, function(x)
{
if(is(x, "DocElement"))
new("ElementInstance", element = x, doChildren=FALSE, cacheEngine = self$cacheEngine)
else
x
})
self$.children <- value
sapply(seq(along = value), function(i)
{
el = value[[i]]
el$parentInstance = self
el$posInParentInst = i
})
self$.children
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.