Nothing
########################
########################
##pems.structure
########################
########################
#pemsElement (gone 2018/06/30 0.2.25.17)
#pemsElement.old (gone 2018/06/30 0.2.25.17)
#pemsin, pemsin2, pemsin2.old (gone 2018/06/30 0.2.25.17)
#in place
#################
#getPEMSElement
#cpe
#other pems... function under review
########################################
#pemsData
#pemsConstants
#pemsHistory
#pemsDim
#next project
################
#getPEMSData/pemsData
#TO DO
##########################
#pemsConstants
#tidy
#document
#namespace
#questions
###################
#is this better than check...
#do functions need a test that first element is pems, etc?
#
########################
########################
##getPEMSElement
########################
########################
#version 0.3.0
#karl 22/06/2018
#getPEMSElement replaces pemsElement
#pemsElement using rlang/dplyr
#getElement already used...
#########################
#need to think about
#########################
#if.missing warning
#attribute name handling
#attribute units handling
getPEMSElement <- function (x, pems = NULL, units = NULL, ...,
fun.name = "getPEMSElement",
if.missing = "stop",
if.null = if.missing,
track.name = TRUE,
.x = enquo(x)){
#################################################
#I guess there must be a better way of doing this
#but I am not seeing it
#################################################
#################################################
#I die if arg is missing
#################################################
#element.name <- quo_name(.x)
#test...
#NB if quo_is_null(.x) that means x is null because nothing to do???
#return(.x)
ref.name <- if(is.null(list(...)$ref.name)) "element" else list(...)$ref.name
##element.name <- try(quo_name(.x), silent=TRUE)
if(quo_is_null(.x)){
checkIfMissing(if.missing = if.null,
reply = paste("required ", ref.name, " NULL", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
return(NULL)
}
element.name <- try(quo_name(.x), silent = TRUE)
if(class(element.name)[1]=="try-error"){
element.name <- ""
}
ans <- if (is.null(pems)) NULL else
try(as.data.frame(pems)[[element.name]], silent = TRUE)
###############
#testing cond eval
if (is.null(ans) | class(ans)[1] == "try-error") {
ans <- try(eval_tidy(enquo(x), pemsData(pems)), silent=TRUE)
}
#################
if (is.null(ans) | class(ans)[1] == "try-error") {
ans <- try(eval_tidy(.x), silent = TRUE)
}
if (is.null(ans) | class(ans)[1] == "try-error") {
ans <- try(eval_tidy(x), silent = TRUE)
}
if (class(ans)[1] == "try-error")
ans <- NULL
if(is.null(ans))
checkIfMissing(if.missing = if.missing,
reply = paste(ref.name, " '", element.name[1], "' not found or NULL", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
##name management
if(track.name) {
attributes(ans)$name <- element.name
}
#pass ref to convertUnits?
#no option if units are set but ans does not have units...
if (!is.null(units) & !is.null(ans)){
temp <- attributes(ans)$name
ans <- convertUnits(ans, to = units)
attributes(ans)$name <- temp
}
ans
}
##################################
#cpe
##################################
#c.pems.element alternative
#################################
#currently have a problem with c.pems.element
#so using this as work around
cpe <- function(...){
ref <- quos(..., .named=TRUE)
ans <- list(...)
#get attributes
temp <- lapply(ans, function(x) attributes(x))
b <- temp[[1]]
if(length(temp)>1){
for(i in 2:length(temp)){
for(j in names(b)){
if(j %in% names(temp[[i]])){
b[[j]] <- c(b[[j]], temp[[i]][[j]])
}
nms <- names(temp[[i]])[!names(temp[[i]]) %in% names(b)]
if(length(nms)>0){
for(j in nms){
b[[j]] <- temp[[i]][[j]]
}
}
}
}
}
######################################
#this might not be best way to handle
#cpe() same repeat elements, cpe(a,a)
######################################
local.names <- make.unique(names(ref))
#update name because they might have modified
b$name <- paste(local.names, collapse=", ")
temp <- names(b)[names(b)!="name"]
for(i in temp){
if(i=="units"){
if(length(unique(b[[i]]))>1){
b$sub.un <- b$units
b$units <- paste(b$units, collapse = ", ")
} else {
b$units <- unique(b$units)
b$sub.un <- NULL
}
} else {
b[[i]] <- unique(b[[i]])
}
}
refs <- unlist(lapply(ans, function(x) length(x)))
if(any(refs==0)){
stop("unknown element requested")
}
if(length(refs)>1){
b$sub.id <- refs
b$sub.nm <- local.names
} else {
b$sub.id <- NULL
b$sub.nm <- NULL
}
if(any(b$class=="factor")){
warning("dropping factor structure")
b$class <- b$class[b$class!="factor"]
b$levels <- NULL
b$labels <- NULL
}
b$class <- unique("pems.element", b$class)
ans <- lapply(ans, as.vector)
ans <- do.call(c, ans)
attributes(ans) <- b
return(ans)
}
#########################
#########################
##getPEMSSetUp
#########################
#########################
#version 0.0.1
#karl 24/06/2018
#this is a general test for several of the getPEMS... functions
#not exporting it....
#this kills function if missing and if.missing="stop"
#returns NULL, FALSE or TRUE
getPEMSSetUp <- function(pems=NULL, fun.name = "getPEMSSetUp",
if.missing = "stop",
.pems = enquo(pems), ...){
if(quo_is_null(.pems)){
checkIfMissing(if.missing = if.missing,
reply = paste("required pems NULL", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
return(NULL)
}
pems.name <- quo_name(.pems)
if(is.null(pems)){
checkIfMissing(if.missing = if.missing,
reply = paste("pems '", pems.name[1], "' not found", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
return(NULL)
}
if(!"pems" %in% class(pems)) {
checkIfMissing(if.missing = if.missing,
reply = paste("pems '", pems.name[1], "' not a pems", sep=""),
suggest = "checking pems",
if.warning = NULL,
fun.name = fun.name)
return(FALSE)
}
TRUE
}
##############################
##############################
##getPEMSConstants
##############################
##############################
#replacing pemsConstants
getPEMSConstants <- function(pems=NULL, ...,
fun.name = "getPEMSConstants", if.missing = "stop",
.pems = enquo(pems)){
test <- getPEMSSetUp(pems, fun.name=fun.name, if.missing=if.missing,
.pems=.pems)
if(is.logical(test) && test) pems[["constants"]] else NULL
}
##############################
##############################
##getPEMSData
##############################
##############################
#replacing with pemsData
getPEMSData <- function(pems=NULL, ...,
fun.name = "getPEMSData", if.missing = "stop",
.pems = enquo(pems)){
#################
#might want to include option for
#more aggressive conversions
#################
test <- getPEMSSetUp(pems, fun.name=fun.name, if.missing=if.missing,
.pems=.pems)
if(is.logical(test) && test) pems[["data"]] else NULL
}
##############################
##############################
##pemsData
##############################
##############################
pemsData <- function(pems=NULL, ...,
fun.name = "pemsData", if.missing = "stop",
pems.name = deparse(substitute(pems))){
if(is.null(pems)){
checkIfMissing(if.missing = if.missing,
reply = paste("pems '", pems.name[1], "' not found", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
}
#class(pems) <- "not.pems"
#pems$data
#new build
#might want to strip out units, etc...?
pems <- rebuildPEMS(pems)
as.data.frame(pems)
}
##############################
##############################
##pemsConstants
##############################
##############################
#replacing with getPEMSContansts
pemsConstants <- function(pems=NULL, ...,
fun.name = "pemsConstants", if.missing = "stop",
pems.name = deparse(substitute(pems))){
if(is.null(pems)){
checkIfMissing(if.missing = if.missing,
reply = paste("pems '", pems.name[1], "' not found", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
}
pems <- rebuildPEMS(pems, "old")
class(pems) <- "not.pems"
pems$constants
}
##############################
##############################
##pemsHistory
##############################
##############################
pemsHistory <- function(pems=NULL, ...,
fun.name = "pemsHistory", if.missing = "stop",
pems.name = deparse(substitute(pems))){
if(is.null(pems)){
checkIfMissing(if.missing = if.missing,
reply = paste("pems '", pems.name[1], "' not found", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
}
pems <- rebuildPEMS(pems, "old")
class(pems) <- "not.pems"
pems$history
}
##############################
##############################
##pemsDim
##############################
##############################
pemsDim <- function(pems=NULL, ...,
fun.name = "pemsDim", if.missing = "stop",
pems.name = deparse(substitute(pems))){
if(is.null(pems)){
checkIfMissing(if.missing = if.missing,
reply = paste("pems '", pems.name[1], "' not found", sep=""),
suggest = "checking call arguments",
if.warning = NULL,
fun.name = fun.name)
}
pems <- rebuildPEMS(pems, "old")
class(pems) <- "not.pems"
dim(pems$data)
}
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.