Nothing
##########################
##########################
##condition pems objects
##########################
##########################
#kr
#description
##########################
#functions to condition pems
#includes
##########################
#cutBy
#
#to do
##########################
#comments
##########################
#
##########################
##########################
##cutBy
##########################
##########################
#kr 23/01/2012 v 0.0.6
#what it does
##########################
#wrapper for cutting data
#to do
##########################
#make test more robust?
#comments
##########################
#
cutBy <- function(ref = NULL, ..., data = NULL, cut.method = NULL,
labels = NULL,
fun.name = "cutBy", hijack= FALSE){
#setup
this.call <- match.call()
#run checks
settings <- calcChecks(fun.name, ..., data = data)
#get what there is
if(!hijack)
ref <- checkInput(ref, data=data, fun.name = fun.name,
if.missing = settings$if.missing,
unit.conversions = settings$unit.conversions)
if(is.null(cut.method)){
#select suiitable cut.method
cut.method <- cutByRow
}
if(is.function(cut.method)){
cut <- cut.method(ref = ref, data = data, output = "input",
..., fun.name = "calcVSP", hijack= TRUE)
#check for attributes
#if not give it some
if(is.null(attributes(cut)$name))
attr(cut, "name") <- "cut"
if(is.null(attributes(cut)$units))
attr(cut, "units") <- "cut.region"
#do any renaming
if(!is.null(labels)){
levels(cut) <- labels
}
return(calcPack(output = cut, data = data, settings = settings,
fun.name = fun.name, this.call = this.call))
}
#not good
checkIfMissing(if.missing = settings$if.missing,
reply = "could not run cut.method!",
suggest = "check ?cutBy if reason unclear", if.warning = "returning NULL",
fun.name = fun.name)
return(NULL)
}
cutByRow <- function(ref = NULL, n = 4, rows = NULL, ..., data = NULL,
fun.name = "cutByRow", hijack= FALSE){
#setup
this.call <- match.call()
#run checks
settings <- calcChecks(fun.name, ..., data = data)
#get what there is
if(!hijack)
ref <- checkInput(ref, data=data, fun.name = fun.name,
if.missing = settings$if.missing,
unit.conversions = settings$unit.conversions)
#both n and row should
if(!is.numeric(n) & !is.numeric(rows)){
checkIfMissing(if.missing = settings$if.missing,
reply = "require at least numeric 'n' or 'rows' to cut something!",
suggest = "check ?cutBy", if.warning = "returning NULL",
fun.name = fun.name)
return(NULL)
}
if(is.numeric(n) & !is.numeric(rows)){
if(n > length(ref)) n <- length(ref)
rows <- floor(length(ref)/n[1])
rows <- seq(1, length(ref), by = rows)
}
if(is.numeric(rows)){
rows <- floor(rows)
rows <- rows[rows>0 & rows<(length(ref)+1)]
cut <- rep(0, length(ref))
cut[rows] <- 1
cut[1] <- 1
cut <- cumsum(cut)
}
cut <- factor(cut)
#add attributes
attr(cut, "name") <- "cut"
attr(cut, "units") <- "cut.region"
#return
return(calcPack(output = cut, data = data, settings = settings,
fun.name = fun.name, this.call = this.call))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.