Nothing
##########################
##########################
##make pems
##########################
##########################
#kr
#description
##########################
#functions for making pems object
#includes
##########################
#pems (nee makePEMS)
#is.pems (nee isPEMS)
#pems.element (nee makePEMSElement)
#to think about
##########################
#as.pems...
#to do
##########################
#comments
##########################
##########################
##########################
##pems nee makePEMS
##########################
##########################
#kr 18/09/2015 ver 0.0.2
#what it does
##########################
#make pems objects from parts
#to do
##########################
#is.null handling for args
#is.wrong handling for args
#defaults for constants
##########################
#
##########################
#comments
###########
#widely used.
#think carefully before changing name or argument ordering
###########
#did it anyway...
###########
#
#############################
#to think about
##########
#currently uses rebuild cheat
###########
#
pems <- function(x, units = NULL, constants = NULL,
history = NULL, ...){
#################
#currently assuming
# x = data.frame
#################
##################
#testing
#if supply a pems/return
# unless units supplied
# then unpack/repack
#think about this
#################
if(is(x)[1]=="pems" && is.null(units)) return(rebuildPEMS(x))
##################
#testing
#allow x = vector or pems.element
##################
if(is.null(units) && "units" %in% names(attributes(x)))
units <- attr(x, "units")
x <- as.data.frame(x)
#reported issue if data.frame[1,n]
#data has dimension to work with
if(!is.null(ncol(x)) && ncol(x)>0){
#units
if(is.null(units))
units <- rep(NA, ncol(x))
if(!is.data.frame(units)){
units <- as.data.frame(t(units), stringsAsFactors = FALSE)
}
#after we know units is data.frame
units <- if(ncol(units)<ncol(x))
cbind(units, as.data.frame(t(rep(NA, ncol(x)-ncol(units))), stringsAsFactors = FALSE)) else
units[1:ncol(x)]
names(units) <- c(names(x), names(units), rep(NA, ncol(x)))[1:ncol(x)]
}
#to do
####################
#update constants
#dropping history
history <- list()
extra.args <- list(...)
#update silently?
test <- if("silent" %in% names(extra.args))
extra.args$silent else FALSE
extra.args <- extra.args[names(extra.args)!="silent"]
#history
history <- if(test)
history else c(history, match.call())
#output
output <- list(data = x, units = units, constants = constants,
history = history)
#add in ... args
temp <- extra.args
output[names(temp)] <- temp
class(output) <- "pems"
#restack pems so all columns are pems.elements
for(i in names(output))
output[["data"]][, i] <- output[, i]
rebuildPEMS(output)
}
makePEMS <- function(...) pems(...)
##########################
##########################
##is.pems nee isPEMS
##########################
##########################
#kr 18/09/2015 v 0.0.2
#what it does
##########################
#is.pems -two level tester
#to do
##########################
#make test more robust?
#comments
##########################
#widely used.
#think carefully before changing name or argument ordering
#this needs thinking about
##############
#
is.pems <- function(x, full.test = TRUE, ...){
#standard test
output <- if(is(x)[1]=="pems") TRUE else FALSE
#full.test
if(full.test){
comment(output) <- if(is.null(x)) "NULL" else
if(is(x)[1]=="pems") "pems" else
if(is.data.frame(x)) "data.frame" else "other"
}
#output
output
}
isPEMS <- function(...) is.pems(...)
##########################
##########################
##test.pems
##########################
##########################
#kr 26/09/2019 v 0.0.1
#what it does
##########################
#tests a pems for faulty configuration
#not exported
#not finished
test.pems <- function(x, verbose = FALSE, ...){
temp <- rebuildPEMS(x)[[]]
#class(temp) <- "not.pems"
reply <- names(temp$data)
if(is.null(reply))
message("\npems object: no named data [suspect]") else
message("\npems object: ", ncol(temp$data),
" data series (each ", nrow(temp$data), " cases)")
reply <- names(temp)[names(temp) %in% c("units", "constants", "history")]
if(length(reply) < 1)
message("\twith no supporting structure [suspect]") else
message("\twith supporting structures: ", paste(reply, collapse=", ", sep=""))
#remember hidden
#refine
reply <- names(temp)[!names(temp) %in% c("data", "units", "constants", "history", "dem")]
if(length(reply) > 0)
message("\t[and unique tags: ", paste(reply, collapse=", ", sep=""), "]\n")
invisible(x)
}
########################
########################
##pems.element nee makePEMSElement
########################
########################
pems.element <- function(x, name=NULL, units=NULL, ...){
attr(x, "class") <- unique(c("pems.element", attr(x, "class")))
#if(is.null(attr(x, "name")) & !is.null(name))
#caused problems because it can't reset attr in calc... functions
if(!is.null(name))
attr(x, "name") <- name
if(!is.null(units))
attr(x, "units") <- units
return(x)
}
makePEMSElement <- function(...) pems.element(...)
#######################
#######################
##as.pems....
#######################
#######################
##as.pems @S3 setup
as.pems <- function(x,...)
UseMethod("as.pems")
##as.pems @S3 default
as.pems.default <- function(x,...){
#might need to think about this
if(class(x)[1]=="pems") return(x)
stop("no 'as.pems...' method for class ",
class(x), call. = FALSE)
}
as.pems.data.frame <- function(x,...) pems(x,...)
#######################
#######################
##rebuildPEMS
#######################
#######################
##rebuild old/new pems object
rebuildPEMS <- function(x, ...){
#need to think about a robust version check
# or people could be turning olds into olds...
# which will do weird things...
#need to tidy this when it catches all bad stuff...
#get arg2 in form rebuildPEMS(pems, new) ..."new", etc...
#might drop this...
m.var <- exprs_auto_name(quos(...))
m.var <- gsub("~", "", as.character(m.var))[1]
m.var <- gsub("\"", "", as.character(m.var))[1]
if(is.na(m.var)) m.var <- "new"
# grpd <- "grouped_df" %in% class(x)
# class(x) <- class(x)[class(x) != "grouped_df"]
test <- attributes(x)$pems.tags$pems.build
if (m.var == "new") {
#quick if new checks
if (!is.null(test) && test >= 3)
return(x)
#assume old rebuild old as new
class(x) <- "broken"
out <- x$data
attributes(out)$units <- x$units
attributes(out)$pems.tags <- x[names(x)[!names(x) %in%
c("data", "units")]]
attributes(out)$pems.tags$history <- list()
attributes(out)$pems.tags$pems.build <- 3
class(out) <- c("pems")
#testing
# class(.data) <- unique(c(class(.data)[class(.data)!="pems"], c("tbl_df", "tbl", "data.frame")))
class(out) <- c("pems", "tbl_df", "tbl", "data.frame")
#this assumes grouped object never output as old
if("grouped_df.tags" %in% names(x)){
attributes(out)[names(x$grouped_df.tags)] <- x$grouped_df.tags
class(out) <- c("grouped_df", "pems")
#testing
#
class(out) <- c("grouped_df", "pems", "tbl_df", "tbl", "data.frame")
}
return(out)
}
if (m.var == "old") {
#quick check if is old
if (!is.null(test) && test < 3)
return(x)
if (is.null(test))
return(x)
#assume new and rebuild as old
bare.bones <- attributes(x)[names(attributes(x)) %in%
c("units", "pems.tags")]
attributes(x)$units <- NULL
attributes(x)$pems.tags <- NULL
class(x) <- class(x)[class(x) != "pems"]
if (length(class(x)) == 0)
class(x) <- "data.frame"
if (length(class(x)) == 1 && class(x) == "list")
class(x) <- "data.frame"
out <- listUpdate(list(data = x, units = bare.bones$units),
bare.bones$pems.tags)
#handling if grouped_df
if ("grouped_df" %in% class(x)){
class(out$data)[class(x) == "grouped_df"] <- "data.frame"
out$grouped_df.tags <- attributes(x)
}
#test
class(out$data) <- "data.frame"
out$pems.build <- 2
class(out) <- c("pems")
return(out)
}
}
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.