Nothing
##########################
##########################
##generic pems handlers
##########################
##########################
#check re pems.element but I don't think it contains any
#might to archive a copy of this and then tidy
#because it is a real mess at the moment
##rebuild 11/2017
#exporting
#print.pems
#names.pems, names<-.pems
#as.data.frame.pems
#dim.pems
#cheated old code
#[.pems, [<-.pems using cheat code
#$.pems, $<- works if above works
#summary, head, tail,
###############################
#to fix
#########
#pems[ breaking on example(pems)
#########
#tail not giving actual numbers...
# tail(pems) should be row 995 not 1
#########
#all needs tidying
#########
#
###############################
#to think about
##########
#
##########################
##########################
##print.pems
##########################
##########################
#kr 06/06/2013 v 0.3.0
#kr 14/11/2017 v 0.4.0
#what it does
##########################
#handles pems console appearance
#
###################################
#too fix
###################################
#
##################################
#to watch
##################################
#print(pems, width [smaller than first column width])
#print(pems, cols [less than 1])
#
#to think about
##########################
# group labelling that includes number of cases
# paste(names(attributes(x)$labels), "[", lapply(attributes(x)$labels, function(x) length(unique(x))),"]", sep="", collapse="; ")
#####
#hide width?
#####
#option to show class
# instead of units?
#####
#col=-1, rows=-1 as a
# show full data range?
#####
#
print.pems <- function(x,..., rows=NULL, cols=NULL, width=NULL){
##################################
#new print.pems for new structure
#based
#this could be simplified/tidied...
x <- rebuildPEMS(x)
#test structure
has.units <- !is.null(attributes(x)$units)
grpd <- "grouped_df" %in% class(x)
#plot setup
#to tidy using rows not n....
n <- if(is.null(rows)) 6 else rows
if(n > nrow(x)) n <- nrow(x)
if(is.null(width)) width <- getOption("width") * 0.9
###
#new bit
#foreshortening shown other columns
######################
extra.args <- list(...)
max.other.cols <- if("max.other.cols" %in% names(extra.args))
extra.args$max.other.cols else 6
########################
#make all columns characters
########################
#a lot of this can go when
#pems[works again...
#for example here
b <- x
class(b) <- class(b)[class(b)!="pems"]
if(length(class(b))==1) class(b) <- "data.frame"
#this can go if 2nd b
#in next line becomes x
########################
b <- data.frame(lapply(b[1:n,], as.character), stringsAsFactors=FALSE,
check.names=FALSE)
#or it corrects names like velocity<5
if(n==0) b[] <- "<empty>" #to catch empty frames
b[is.na(b)] <- "NA" #to catch NAs
#unit labels extensions
if(has.units){
#if data and units do not have same dimensions or names...
if(length(names(b))!=length(names(attributes(x)$units)) || any(names(b)!=names(attributes(x)$units))){
cat("suspect pems [data/units conflict]; halted print\n")
return(invisible(x))
}
#note the leading space on temp
attributes(x)$units[] <- gsub("[[][]]", "", paste("[", attributes(x)$units, "]", sep=""))
b <- rbind(attributes(x)$units, b)
}
temp <- data.frame(t(names(b)))
names(temp) <- names(b)
b <- rbind(temp, b)
######################
#replacing
## b <- if(has.units) cbind(data.frame(..rows=c("", "", 1:n), b)) else
## cbind(data.frame(..rows=c("", 1:n), b))
#to catch empty data frames
#also to use row.names if there...
temp <- if (has.units) c("", "") else c("")
temp <- if(n>0) c(temp, if(!is.null(row.names(x))) row.names(x)[1:n] else 1:n) else
c(temp, " ")
b <- cbind(data.frame(..rows = temp, b))
######################
b.n <- apply(b, 2, function(x) nchar(x))
b.max <- apply(b.n, 2, function(x) max(x))+1
#NAs might be an issue
b.n <- data.frame(t(b.max-t(b.n)))
b.n <- apply(b.n, c(1,2), function(x) paste(rep(" ", x), collapse=""))
for(i in 1:ncol(b))
b[,i] <- paste(b.n[,i], b[,i], sep=" ")
test <- if(is.null(cols)) max(which(cumsum(b.max)<width)) else
cols + 1 #because we add ..row column
if(test>ncol(b)) test <- ncol(b)
b <- b[,1:test]
#############################
#the header
#test removed \n from start of header
header <- paste("pems (", nrow(x), "x", ncol(x), ")", sep="")
if(grpd) {
gg <- names(attributes(x)$groups)
gg <- gg[gg != ".rows"]
header <- paste(header, "\n<grp>: ", paste(gg, collapse="; "), sep="", collapse="")
}
#############################
#the shown data grid
#############################
#test == 1 does not show data....
#############################
#replaced code
##out <- apply(b, 1, function(x) paste(x, collapse=""))
##out <- paste(paste(out, collaspe="\n", sep=""), collapse="")
if(test>1){
out <- apply(b, 1, function(x) paste(x, collapse=""))
out <- paste(paste(out, collaspe="\n", sep=""), collapse="")
} else {
out <- ""
}
##############################
out <- paste(header, out, sep="\n", collapse="\n")
#############################
#with above replaced code
##h.row <- nrow(x)-nrow(b)+2 #+2 for header
##h.col <- ncol(x)-ncol(b)+1 #+1 for row.number
h.row <- if(is.null(nrow(b)))
nrow(x) else nrow(x)-nrow(b) +2 ##+2 for header
h.col <- if(is.null(ncol(b)))
ncol(x) else ncol(x)-ncol(b) +1 #+1 for row.number
################################
#################################
#first footer rows and rows not plotted
footer <-""
if(h.row > 0 | h.col>0){
temp <- " ... not showing: "
if(h.row>0) temp <- paste(temp, h.row, " rows", sep="")
if(h.row>0 & h.col>0) temp <- paste(temp, "; ", sep="")
if(h.col>0) temp <- paste(temp, h.col, " cols (elements)", sep="")
footer <- paste(temp, footer, collapse="\n")
footer <- paste(footer, "\n", sep="")
}
#this needs tidying
#header and foooter widths not controlled by forced width.....
################################
#second footer other columns
#if range reduced
footer2 <- ""
if(h.col>0){
#note: not test+1 because I added column to b
footer2 <- names(x)[(test):ncol(x)]
if(has.units){
footer2 <- paste(footer2, attributes(x)$units[(test):ncol(x)], sep="")
}
footer2[1:(length(footer2)-1)] <- paste(footer2[1:(length(footer2)-1)], "; ", sep="")
footer2[1] <- paste("other cols: ", footer2[1], sep="")
footer2 <- strwrap(paste(footer2, collapse=""), width=width)
footer2[1] <- paste(" ... ", footer2[1], sep="")
if(length(footer2)>1)
footer2[2:length(footer2)] <- paste(" ", footer2[2:length(footer2)], sep="")
footer2 <- paste(footer2, "\n", collapse="", sep="")
test <- gregexpr("\n", footer2)[[1]]
###########################################
#new bit foreshortening other cols
#might change
if(attributes(test)$match.length[1]>0){
if(length(test)>max.other.cols){
test2 <- length(gregexpr(";", substr(footer2, test[max.other.cols], nchar(footer2)))[[1]])+1
footer2 <- substr(footer2, 1, test[max.other.cols])
footer2 <- paste(footer2, " ... and ", test2, " other unreported columns", sep="")
}
}
############################################
#footer2 <- paste(footer2, "\n", sep="")
}
#out
cat(out, footer, footer2, "\n", collapse="", sep="")
invisible(x)
}
##########################
##########################
##names.pems
##########################
##########################
#kr 07/12/2011 v 0.2.0
#kr 14/11/2017 v 0.3.0
#what it does
##########################
#names()
#returns data series names from pems
############
#names()<-
#as above
#these do names()[] and names()[]<-
#by passing lot....
###########################
#to fix
##########
#
###########################
#to think about
###########
#
##' @S3method print pems
names.pems <- function(x, ...) {
x <- rebuildPEMS(x)
class(x) <- class(x)[class(x)!="pems"]
if(length(class(x))==1) class(x) <- "data.frame"
if(is.null(attributes(x)$pems.tags)){
message("\npems object [suspect]")
#not of enough of a reason not to try
##return(invisible(NULL))
}
names(x)
}
## @S3method names<-.pems
`names<-.pems` <- function(x, ..., value) {
#variation on units<-
#very crude handling of names$ and names[]
x <- rebuildPEMS(x)
old.class <- class(x)
#############################
#x <- as.data.frame(x) #need data.frame to get at
# #element attributes
#############################
#since as.data.frame strips units
#############################
class(x) <- "data.frame"
#check for duplication
#currently corrects names without saying anything....
if(any(duplicated(value))){
value <- make.names(value, unique=TRUE)
}
# if(***************){
# warning("In units(pems): [suspect units]", call.=FALSE)
# units <- data.frame(matrix(NA, nrow = 1, ncol = ncol(x$data)))
# names(units) <- names(x$data)
# }
#might also think about adding units if not there
#see above
#error check on state of value?
#this sets all of x and all names even for names[]<-
names(x) <- value
names(attributes(x)$units) <- value
for(i in value)
attributes(x[,i])$name <- i
class(x) <- old.class
return(x)
}
##########################
##########################
##as.data.frame.pems
##########################
##########################
#############################
#what it does
#############
#pull data.frame out of pems
#for lattice, lm, etc.
############################
#to fix
############
#
############################
#to think about
############
#could make a more aggressive
# clean clean-up like
# fortify
as.data.frame.pems <- function(x, ...){
#in whatever, makes/uses new, exports df
x <- rebuildPEMS(x, "new")
class(x) <- "data.frame"
#########################
#added unit reset because
# df <- as.data.frame(pems)); modify df; pems(df)
# can cause units/data conflict if
attributes(x) <- attributes(x)[names(attributes(x))!="units"]
x
}
##########################
##########################
##dim
##ncol
##nrow
##########################
##########################
#############################
#what it does
#############
#get pems dimensions
#
############################
#to fix
############
#
############################
#to think about
############
#don't need ncol and nrow
# because the use dim...
# and only need dim to
# catch any older pems
# objects...
############
#
################################
#doh
#############
#using dim(rebuildPEMS(x)) causes issue
# because it tries to dim.pems inside
# dim.pems...
#############
#
dim.pems <- function(x, ...) dim(as.data.frame(x))
##########################################################
#older code
##########################################################
#any of that not deactivated as ...pems.old...,
# works in form
# rebuildPEMS(x, "old")
# old code
# rebuildPEMS(x)
#[, [<- (these enable $ and $<-)
#kr 01/02/2012 v 0.3.1
#includes
#(functions/code below)
##########################
#as.data.frame.pems
#dim.pems
#############->nrow.pems
#############->ncol.pems
#[.pems
#[<-.pems
#[[.pems
#[[.<-pems
#$.pems
#$<-.pems
#with.pems
#subset.pems
#print.pems
#plot.pems
#names.pems
#names<-.pems
#summary.pems
#head.pems
#tail.pems
#units.pems
#units<-.pems
#
##########################
##########################
##[[.pems
##########################
##########################
#kr 18/08/2015 v 0.1.0
#what it does
##########################
#handles pems[[]] calls
#for access to data, units and other tags
#
#to do
##########################
#tidy
#think about this
##need pems[[]]<- operator
`[[.pems` <- function(x, k, ...){
x <- rebuildPEMS(x, "old")
#break pems
class(x) <- "list"
#special operators
#####################
#testing
#####################
if("extra.pems.tags" %in% as.character(match.call())){
#out
###########################
#cat(out, footer, footer2, "\n", collapse="", sep="")
#invisible(x)
return(x[!tolower(names(x)) %in%
c("data", "units", "constants", "history", "pems.build")])
}
#return as list if nothing declared
if(missing(k)) return(x)
#select structural elements
temp.fun <- function(k){
ans <- try(x[[k]], silent=TRUE)
if(class(ans)[1] == "try-error") NULL else ans
}
if(length(k)==1) return(temp.fun(k))
x <- lapply(k, temp.fun)
rebuildPEMS(x)
}
#########################
#########################
##[[<-.pems
#########################
#########################
`[[<-.pems` <- function(x, k, ..., value){
x <-rebuildPEMS(x, "old")
#break pems
old.class <- class(x)
class(x) <- "list"
#return as list is nothing declared
if(missing(k) | missing(value)) return(x)
#add in if it exists or not
#might want to think about this?
x[[k]] <- value
class(x) <- old.class
rebuildPEMS(x)
}
##########################
##########################
##[.pems
##########################
##########################
#kr 06/06/2013 v 0.3.0
#what it does
##########################
#handles pems[] calls
#etc
#
#to do
##########################
#tidy
#think about force, simplify
`[.pems` <- function(x, i, j, ..., force = FALSE, simplify = TRUE){
#quick cheat
x <- rebuildPEMS(x, "old")
########################
#generic pems handling
########################
#x[1] element 1 as 1 col data.frame
#x[1,] row 1
#x[,1] element 1
#x[1,1] row, element 1,1
#output options
#force=FALSE fail call if any requested elements/rows invalid
#force=TRUE return valid element/row requests, discard invalid
#simplify=TRUE as pems.element if possible else pems
#simplify=FALSE as pems
#force = FALSE, simplify = TRUE gives the response most like a
#conventional data frame
#currently handles negs like data.frame (I think)...
#negs are discarded if a mixed (neg and pos) vector supplied
#and forced. Possibly a better way of handling this
call1 <- sys.call()
call2 <- match.call()
check.i <- !missing(i)
check.j <- !missing(j)
#request pems[], pems[,], etc
#do nothing
if(!check.i & !check.j) return(x)
#in progress
#current na.pad.output is functional but in testing
#might still be issues
#force special handling
#options omit.err.cases (default forcing)
# no.forcing
# na.pad.output
if(is.logical(force))
force <- if(force) "omit.err.cases" else "no.forcing"
#make
old.class <- class(x)
class(x) <- "not.pems"
#request pems[i], etc
#columns/elements, etc
if(check.i && !check.j && length(as.character(call1))==length(as.character(call2))){
j <- i
i <- 1:nrow(x$data)
}
#request pems[i,], etc
#rows, etc
if(check.i && !check.j && length(as.character(call1))!=length(as.character(call2)))
j <- 1:ncol(x$data)
#request pems[,j], etc
#columns/elements
if(!check.i && check.j)
i <- 1:nrow(x$data)
#otherwise it is pems[i,j], etc
#####################
#new fix/testing
#####################
#fix for logicals
if(is.logical(i))
i <- c(1:length(i))[i]
if(is.logical(j))
j <- c(1:length(j))[j]
#negative handling
#at this stage we err out on negs
test <- character()
if(is.numeric(j) && any(j<=0)) test <- c(test, "elements")
if(is.numeric(i) && any(i<=0)) test <- c(test, "rows")
if(length(test)>0)
stop(paste("In pems[i,j]<-: neg ",
paste(test, sep=" and ", collapse=" and "),
" requested \n [not currently allowed]",
sep=""), call. = FALSE)
#data.frame like neg handling
#note/known issue
#currently regards zero as negative
# if(is.numeric(i) && any(i<=0))
# if(all(i<=0))
# i <- c(1:nrow(x$data))[!1:nrow(x$data) %in% abs(i)] else
# if(force=="omit.err.cases")
# i <- i[i>0] else
# stop("In pems[i,j]: mixed (pos & neg) elements and/or rows not allowed",
# call. = FALSE)
# if(is.numeric(j) && any(j<=0))
# if(all(j<=0))
# j <- c(1:ncol(x$data))[!1:ncol(x$data) %in% abs(j)] else
# if(force=="omit.err.cases")
# j <- j[j>0] else
# stop("In pems[i,j]: mixed (pos & neg) elements and/or rows not allowed",
# call. = FALSE)
#make dummy data.frame for force == na.pad.output
if(force=="na.pad.output"){
dummy <- as.data.frame(matrix(nrow=length(i), ncol=length(j)), row.names = NULL, optional = TRUE)
if(is.character(j)) names(dummy) <- j
if(is.numeric(j)) names(dummy) <- names(x$data)[j]
row.names(dummy) <- i
}
#try allows pems[does.not.exist,]
#generates as data.frame of NAs
#so using another check
#note
#might have fixed this later
#this need thinking about
#could be rationalised
index.i <- if(is.character(i))
!i %in% row.names(x$data) else !i %in% 1:nrow(x$data)
check.i <- i[index.i]
index.i <- c(1:length(index.i))[!index.i]
index.j <- if(is.character(j))
!j %in% names(x$data) else !j %in% 1:ncol(x$data)
check.j <- j[index.j]
index.j <- c(1:length(index.j))[!index.j]
#old version -with no index.j and .j
## check.i <- if(is.character(i))
## i[!i %in% row.names(x$data)] else i[!i %in% 1:nrow(x$data)]
## check.j <- if(is.character(j))
## j[!j %in% names(x$data)] else j[!j %in% 1:ncol(x$data)]
if(length(check.i)>0 || length(check.j)>0){
#previously told user what was missing
#but that was messy if lots missing
if("no.forcing" %in% force){
temp <- paste(c("elements", "rows")[c(length(check.j)>0, length(check.i)>0)], sep="", collapse=" and ")
stop(paste("In pems[i,j]: unknown ", temp, " called", sep="", collapse=""),
call. = FALSE)
}
#these are know known i and j terms
i <- i[!i %in% check.i]
j <- j[!j %in% check.j]
if("omit.err.cases" %in% force | "na.pad.output" %in% force){
if(length(i)<1 || length(j)<1){
temp <- paste(c("elements", "rows")[c(length(j)<1, length(i)<1)], sep="", collapse=" or ")
if("omit.err.cases" %in% force)
stop(paste("In pems[i,j]: no known ", temp, " even after forcing", sep="", collapse=""),
call. = FALSE)
}
}
}
#try to get x$data[i,j]
ans <- try(x$data[i,j,..., drop=F], silent=TRUE)
if(class(ans)[1]=="try-error" || (is.data.frame(ans) && nrow(ans)==0))
if(force=="na.pad.output")
ans <- dummy else
stop("In pems[i,j], unexpected issue [please contact package admin.]",
call. = FALSE)
#this is still in progress
#put everything that is there and then
#transfer the attributes?
if("na.pad.output" %in% force){
dummy[index.i,index.j] <- ans
##this works (I think...)
##but is well messy
##also suspect the following might die
##if units are present but does not contain
##an expected entry
if(length(j)>0)
for(jj in 1:length(j))
attributes(dummy[,index.j[jj]]) <- attributes(ans[,jj])
ans <- dummy
dummy <- dummy[1,,drop = FALSE]
dummy[index.j] <- x$units[j, drop=FALSE]
names(ans) <- make.names(names(ans), unique = TRUE)
names(dummy) <- names(ans)
j <- names(ans)
x$units <- dummy
#known issue
#this makes no unit cases NA
#elsewhere units "" if not set
#does this matter
#which to do, if doing only one?
#if doing both, are both handled elsewhere?
}
#if simplify can be done return pems.element
if(simplify & ncol(ans)==1){
############
#testing as.data.frame because I think tbl_df is stopping this
out <- as.data.frame(ans)[,1]
############
attr(out, "row.names") <- NULL
attr(out, "name") <- names(ans)
attr(out, "units") <- as.character(x$units[1,j])
class(out) <- unique(c("pems.element", class(out)))
################
#think about makePEMSElement
################
return(out)
}
#otherwise return rebuilt pems
x$data <- ans
#######################
#this update to stop pems.1[1, simplify=FALSE] killing print.pems
##x$units <- x$units[1,j]
x$units <- x$units[j]
if("history" %in% names(x))
x$history <- c(x$history, call2)
# class(x) <- old.class
class(x) <- "pems"
rebuildPEMS(x)
}
#########################
#########################
##[<-.pems
#########################
#########################
#########################
#to think about
#########################
#with pems...
#> a[["data"]][1,1:5] <- rep(NA,5)
#works but...
#> a[1,1:5] <- rep(NA,5)
#Error: In pems[i,j]<-value: questionable request
# elements and rows pems[i,j] and insert[i,j] dimension mismatch
# [check force setting if insertion required]
#should you be able to change multiple rows at a go with a pems...
`[<-.pems` <- function(x, i, j, ..., force = FALSE, value){
#cheat
x <- rebuildPEMS(x, "old")
########################
#generic pems handling
########################
#overwrite not currently doing anything
#?option for pems[1,1] <- 1:10 to force insert as pems[1:10,1]
#even if pems[1:10,1] exists
#this would be the overwrite???
#?option for pems[1:2] <- vector shorter than pems rows
#to write as element replicated as vector+NAs
#note: this is na.pad.target for elements then fill.target/insert for rows.
#x[1] element 1 as 1 col data.frame
#x[1,] row 1
#x[,1] element 1
#x[1,1] row, element 1,1
#x[,] <- value insert value into
#output options
#force=FALSE fail call if any requested elements/rows dimensions
# do not fit exactly or is any missing
#force=TRUE return valid element/row requests, discard invalid
# trim dimensions to trim smallest
#
#??? #simplify=TRUE as pems.element if possible else pems
#??? #simplify=FALSE as pems
#currently handles negs like data.frame (I think)...
#negs are discarded if a mixed (neg and pos) vector supplied
#and forced. Possibly a better way of handling this
#???? #overwrite = TRUE, if pems info/attributes in value
# write them over what is pems else use
# pems attributes if there
#???? #overwrite = FALSE, if pems info/attributes in pems
# write retain it. If nothing and
# something in value should be use it?
# or does this make third case
#???? #attribute.source = "x", x only "x.value" x then value, etc, ...
# "value", "value.x"
#######################
#check what I was supplied
#######################
call1 <- sys.call()
call2 <- match.call()
check.i <- !missing(i)
check.j <- !missing(j)
check.op <- FALSE
###########################
#force special handling
###########################
#options omit.err.cases (default forcing)
if(is.logical(force))
force <- if(force) "omit.err.cases" else "no.forcing"
if(!is.character(force))
stop("In pems[i,j]<-: unknown force option",
call. = FALSE)
# this would restrict forcing to known types
# if(!all(force %in% c("no.forcing", "omit.err.cases", "na.pad.target", "na.pad.insert", "fill.target", "crop.insert")))
# stop("In pems[i,j]<-: unknown force option",
# call. = FALSE)
##############################
#crack open pems
##############################
old.class <- class(x)
class(x) <- "not.pems"
#########################
#make it a standard pems[i,j]
#########################
#request pems[], pems[,], etc
#might think about this
if(!check.i & !check.j) {
i <- 1:nrow(x$data)
j <- 1:ncol(x$data)
}
#request pems[i], etc
#columns/elements, etc
if(check.i && !check.j && length(as.character(call1))==length(as.character(call2))){
j <- i
i <- 1:nrow(x$data)
check.op <- TRUE
}
#request pems[i,], etc
#rows, etc
if(check.i && !check.j && length(as.character(call1))!=length(as.character(call2)))
j <- 1:ncol(x$data)
#request pems[,j], etc
#columns/elements
if(!check.i && check.j)
i <- 1:nrow(x$data)
#at this point the request must be in form pems[i,j]
##############################
#special case - negatives
##############################
#current not going to accept them
test <- character()
if(is.numeric(j) && any(j<=0)) test <- c(test, "elements")
if(is.numeric(i) && any(i<=0)) test <- c(test, "rows")
if(length(test)>0)
stop(paste("In pems[i,j]<-: neg ",
paste(test, sep=" and ", collapse=" and "),
" requested \n [not currently allowed]",
sep=""), call. = FALSE)
################################
#identify allowed cases
################################
#T/F - is/isnt there
check.i <- if(is.character(i))
i %in% row.names(x$data) else i %in% 1:nrow(x$data)
check.j <- if(is.character(j))
j %in% names(x$data) else j %in% 1:ncol(x$data)
###################
#get value dimensions
###################
#previous attempts to standardise value did not work
check.value <- NULL
#testing grepl("POSIX*", is(value)[1])
#to insert time stamp into pems object
if(is.vector(value) | is(value)[1]=="pems.element" | is.factor(value) | grepl("POSIX*", is(value)[1])){
check.value <- "vector"
value.dim <- c(length(value),1)
}
if(is.data.frame(value)){
check.value <- "data.frame"
value.dim <- dim(value)
}
if(is(value)[1]=="pems"){
check.value <- "pems"
class(value) <- "not.pems"
pems.units <- value$units
value <- value$data
value.dim <- dim(value)
}
if(is.null(check.value)){
stop("In pems[i,j]<-: can't insert insert of that class!", call.=FALSE)
}
# if(is.vector(value) | is(value)[1]=="pems.element"){
# temp <- attributes(value)
# value <- as.data.frame(value, drop=F, stringsAsFactors=FALSE)
# if(!is.null(temp)) attributes(value[,1]) <- temp
# }
# if(is.data.frame(value)){
#replace with makePEMS???
#need to make sure 1x1 data.frame
#does not revert to vector
# value <- list(data=as.data.frame(value, drop=F, stringsAsFactors =FALSE),
# units=data.frame())
# class(value)<- "not.pems"
# }
# if(class(value)[1]=="pems"){
# class(value)<- "not.pems"
# }
# if(class(value)[1]!="not.pems"){
# stop("In pems[i,j]<-: can't insert insert of that class!", call.=FALSE)
# }
# #here value must have structure value$data
#######################
#get dim of value
#######################
# value.dim <- dim(value$data)
#value.dim = value[rows, elements]
#################
#fixed for update
#################
#######################
#force by omit.err.cases
#######################
if("omit.err.cases" %in% force){
i <- i[check.i]
j <- j[check.j]
check.i <- check.i[check.i]
check.j <- check.i[check.j]
}
#################
#fixed in update
#################
#########################
#force by na.pad.target (1)
#########################
#second part to this after crop.value
if("na.pad.target" %in% force){
if(any(!check.j)){
if(is.character(j)){
temp.j <- j[!check.j]
j <- j[check.j]
temp <- names(x$data)
x$data[,temp.j] <- NA
temp.j <- names(x$data)[!names(x$data) %in% temp]
#this could still fall over
#if data and unit names mismatched before
x$units[,temp.j] <- NA
j <- c(j, temp.j)
check.j <- rep(TRUE, length(j))
} else {
#assuming it is numeric
temp.j <- (ncol(x$data)+1) : max(j[!check.j], na.rm=TRUE)
temp <- names(x$data)
x$data[,temp.j] <- NA
temp.j <- names(x$data)[!names(x$data) %in% temp]
#as above but remember
#,10 would create 10
#plus missing before it
x$units[,temp.j] <- NA
check.j <- rep(TRUE, length(j))
}
}
#like above but for row.name, nrow, i, etc...
#no unit update
if(any(!check.i)){
if(is.character(i)){
temp.i <- i[!check.i]
i <- i[check.i]
temp <- row.names(x$data)
x$data[temp.i,] <- NA
temp.i <- row.names(x$data)[!row.names(x$data) %in% temp]
i <- c(i, temp.i)
check.i <- rep(TRUE, length(i))
} else {
#assuming it is numeric
temp.i <- (nrow(x$data)+1) : max(i[!check.i], na.rm=TRUE)
temp <- row.names(x$data)
x$data[temp.i,] <- NA
check.i <- rep(TRUE, length(i))
}
}
}
###################
#working for update
###################
#########################
#force by crop.insert
#########################
if("crop.insert" %in% force){
if(value.dim[1] > length(i)){
if(check.value=="vector")
value <- rep(value, length.out=value.dim[1])
if(check.value=="data.frame" | check.value=="pems")
value <- value[1:length(i),]
value.dim[1]<- length(i)
}
if(value.dim[2] > length(j)){
#should not happen?? with vector
if(check.value=="data.frame")
value <- value[,1:length(j)]
if(check.value=="pems"){
value$data <- value$data[,1:length(i)]
pems.units <- pems.units[,1:length(i)]
}
}
}
#######################
#fixed in update
#######################
#########################
#force by na.pad.target part 2
#########################
#this must be after crop or we pad for something in value
#we then remove...
#just do these as numerics for now
#could look into assigning names from value if there later???
if("na.pad.target" %in% force){
if(length(j) < value.dim[2]){
#assuming it is numeric
temp.j <- (ncol(x$data)+1) : (ncol(x$data)+(value.dim[2]-length(j)))
temp <- names(x$data)
x$data[,temp.j] <- NA
temp.j <- names(x$data)[!names(x$data) %in% temp]
#as na.pad.target 1
x$units[,temp.j] <- NA
j <- c(j, temp.j)
check.j <- rep(TRUE, length(j))
}
if(length(i) < value.dim[1]){
temp.i <- (nrow(x$data)+1) : (nrow(x$data)+(value.dim[1]-length(i)))
temp <- row.names(x$data)
x$data[temp.i,] <- NA
temp.i <- row.names(x$data)[!row.names(x$data) %in% temp]
i <- c(i, temp.i)
check.i <- rep(TRUE, length(i))
}
}
#####################
#fixed for update
#####################
#############################
#na.pad.insert
#############################
if("na.pad.insert" %in% force){
if(length(j) > value.dim[2]){
#if value is a vector don't need to do anything
#except tell it that it is OK
if(check.value=="vector"){
value.dim[2] <- length(j)
} else {
temp.j <- (ncol(value)+1) : (ncol(value)+(length(j)-value.dim[2]))
value[,temp.j] <- NA
value.dim <- dim(value)
}
}
if(length(i) > value.dim[1]){
if(check.value=="vector"){
value <- c(value, rep(NA, length.out=length(i) - value.dim[1]))
value.dim[1] <- length(i)
} else {
temp.i <- (nrow(value)+1) : (nrow(value)+(length(i)-value.dim[1]))
value[temp.i,] <- NA
value.dim <- dim(value)
}
}
}
#####################
#fixed for update
#####################
#############################
#fill.insert
#############################
if("fill.insert" %in% force){
if(length(i) > value.dim[1]){
if(check.value=="vector"){
value <- c(value, rep(value, length.out=length(i) - value.dim[1]))
value.dim[1] <- length(i)
} else {
temp.i <- (nrow(value)+1) : (nrow(value)+(length(i)-value.dim[1]))
value[temp.i,] <- value[rep(1:nrow(value), length.out=length(temp.i)),]
value.dim <- dim(value)
}
}
if(length(j) > value.dim[2]){
#if value is a vector don't need to do anything
#except tell it that it is OK
if(check.value=="vector"){
value.dim[2] <- length(j)
} else {
temp.j <- (ncol(value)+1) : (ncol(value)+(length(j)-value.dim[2]))
value[,temp.j] <- value[,rep(1:ncol(value), length.out=length(temp.j))]
value.dim <- dim(value)
}
}
}
###############################
#check dimensions
###############################
#could move the first of these message to just after
#omit.err.cases
#might fall over otherwise
#error out if it does not fit.
fault.message <- "In pems[i,j]<-value: questionable request"
if(length(i)<1 | length(j)<1){
temp <- paste(c("elements", "rows")[c(length(j)<1, length(i)<1)], sep="", collapse=" and ")
fault.message <- paste(fault.message, "\n no valid ", temp, " set in pems[i,j]", sep="", collapse="")
fault.message <- paste(fault.message, "\n [check force setting if insertion required]", sep="", collapse="")
stop(fault.message, call.=FALSE)
}
if(any(!check.i) | any(!check.j)){
temp <- paste(c("elements", "rows")[c(any(!check.j), any(!check.i))], sep="", collapse=" and ")
fault.message <- paste(fault.message, "\n unknown ", temp, " set in pems[i,j]", sep="", collapse="")
fault.message <- paste(fault.message, "\n [check force setting if insertion required]", sep="", collapse="")
stop(fault.message, call.=FALSE)
}
if(length(i) != value.dim[1] | length(j) != value.dim[2]){
temp <- paste(c("elements", "rows")[c(length(j)!=value.dim[2], length(i)!=value.dim[1])], sep="", collapse=" and ")
fault.message <- paste(fault.message, "\n ", temp, " pems[i,j] and insert[i,j] dimension mismatch", sep="", collapse="")
fault.message <- paste(fault.message, "\n [check force setting if insertion required]", sep="", collapse="")
stop(fault.message, call.=FALSE)
}
#################################
#try insert
#################################
test <- if(check.op)
try(x$data[j] <- value, silent=T) else
try(x$data[i,j] <- value, silent=T)
if(class(test)[1]=="try-error")
stop("In pems[i,j]<-value: bad insertion \n significant pems[i,j]/value class mismatch",
call.=FALSE)
#error messaging could be more informative?
#could like this into addition force/overwrite options
##################################
#update units
##################################
#currently
#only copying attributes if units not there
#options could be possible, overwrite or force options
#could also do a method for data.frames or pems without units
#would read attributes of each column
if(check.value=="vector"){
if("units" %in% names(attributes(value))){
for(jj in j){
######################
#update units of input
#replaces units of pems
#######################
## if(check.op || is.null(x$units[1,jj]) || is.na(x$units[1,jj]) || x$units[1,jj]=="")
x$units[1,jj] <- attributes(value)$units
## attributes(x$data[,jj]) <- attributes(value)
}
}
}
if(check.value=="pems"){
#might need an error catcher for
#not pems.units
for(jj in 1:length(j))
######################
#update units of input
#replaces units of pems
#######################
## if(is.null(x$units[1,j[jj]]) || is.na(x$units[1,j[jj]]) || x$units[1,j[jj]]==""){
x$units[1,j[jj]] <- pems.units[1,jj]
## attributes(x$data[,j[jj]]) <- attributes(value[,jj])
## }
}
#####################
#history update
#####################
#might want a silence history logging option?
if ("history" %in% names(x))
x$history <- c(x$history, call2)
################################
#class conflicts not currently handled
#next jobs....
#think about simplify
#does it have meaning here?
################################
#check for broken time.stamps
test <- names(x$data)[sapply(x$data, function(x) any(grep("POSIX", class(x))))]
if(length(test)>0)
for(t in test)
class(x$data[,t]) <- unique(c(class(x$data[,t]), "POSIXct", "POSIXt"))
####################################
# send back data
####################################
# class(x) <- old.class
class(x) <- "pems"
return(rebuildPEMS(x))
}
##########################
#########################
##$.pems
#########################
#########################
`$.pems` <- function(x, name, ...){
#####################
#old version
#####################
# class(x) <- "not.pems"
# ans <- try(x$data[, i], silent = TRUE)
# if(class(ans)[1] == "try-error"){
# warning("Element '", i, "' not found in pems", call. = FALSE)
# return(NULL)
# }
# if (!is.null(ans))
# attr(ans, "name") <- i
# if (!is.null(ans) && !is.null(units))
# if (is.null(attributes(ans)$units))
# attr(ans, "units") <- x$units[1,i]
# class(ans) <- "pems.element"
# ans
#think about x[,i, simplify=TRUE]
#might not be need because
#######################
#another old version
#######################
# ans <- try(x[, i], silent = TRUE)
# if(class(ans)[1] == "try-error"){
# warning("Element '", i, "' not found in pems", call. = FALSE)
# return(NULL)
# }
# if (!is.null(ans))
# attr(ans, "name") <- i
##########################
#this looks a bit screwy
#########################
# if (!is.null(ans) && !is.null(units))
# if (is.null(attributes(ans)$units))
# attr(ans, "units") <- x$units[1,i]
# ans
########################
#another old version
########################
# ans <- try(x[, name, simplify = TRUE, force = FALSE], silent = TRUE)
#make silent like data.frame$does.not.exist
# if(class(ans)[1] == "try-error"){
# warning("Element '", i, "' not found in pems", call. = FALSE)
# return(NULL)
# } else return(ans)
ans <- try(x[, name, simplify = TRUE, force = FALSE], silent = TRUE)
if(class(ans)[1] == "try-error") NULL else ans
}
#########################
#########################
##$<-.pems
#########################
#########################
`$<-.pems`<- function(x, name, ..., value){
x[name, force=c("na.pad.insert", "na.pad.target")] <- value
x
}
#########################
#########################
##with.pems
#########################
#########################
#version 0.1.0 kr 2015-08-02
#test run parsync/carb data analysis
#note currently discards units
#not sure there is a way around this...
with.pems <- function(data, expr, ...) {
eval(substitute(expr), pemsData(data), enclos = parent.frame())
}
#########################
#########################
##subset.pems
#########################
#########################
#version 0.1.0 kr 2015-09-07
#test run parsync/ucr data analysis
subset.pems <- function(x,...){
x <- rebuildPEMS(x, "old")
x[["data"]] <- subset(x[["data"]], ...)
rebuildPEMS(x)
}
##########################
##########################
##plot.pems
##########################
##########################
#kr 07/12/2011 v 0.2.0
#what it does
##########################
#generates simple plot
#does not keep units
#
#to do
##############################
#remove temp
##' @S3method plot pems
plot.pems <- function(x, id = NULL, ignore = "time.stamp", n = 3, ...) {
temp <- rebuildPEMS(x, "old")
class(temp) <- "no.class"
reply <- temp$data
if(is.null(reply)){
message("\npems object [suspect]")
return(invisible(NULL))
}
if(is.null(id)){
id <- 1:ncol(reply)
if(length(ignore)>0)
id <- id[!names(reply) %in% ignore]
if(n>0 && length(id)>n)
id <- id[1:n]
}
reply <- reply[id]
plot(reply, ...)
}
##########################
##########################
##summary.pems
##########################
##########################
#kr 07/12/2011 v 0.2.0
#what it does
##########################
#generates summary reports
#
#to do
##########################
#make dedicated summary
#and option for as current as alternative
#
#comments
##########################
#to tidy
##' @S3method print pems
summary.pems <- function(object, ...) {
object <- rebuildPEMS(object, "old")
class(object) <- "no.class"
object <- object$data
if(is.null(object)){
message("\npems object [suspect]")
return(invisible(NULL))
}
return(summary(object))
}
##########################
##########################
##units.pems
##########################
##########################
#kr 07/12/2011 v 0.2.0
#what it does
##########################
#extracts units from pems
#
#to do
##########################
#make dedicated summary
#and option for as current as alternative
#
#comments
##########################
#to tidy
#units uses new structure
#units<- uses old structure
##' @S3method units.pems
units.pems <- function(x) {
x <- attributes(rebuildPEMS(x))$units
#old
# class(x) <- "no.class"
# x <- x$units
if(is.null(x)){
warning("In units(pems): pems unitless [suspect]", call.=FALSE)
return(invisible(NULL))
}
return(x)
}
## @S3method unit<-.pems
`units<-.pems` <- function(x, value) {
x <- rebuildPEMS(x, "old")
call2 <- match.call()
class(x)[1] <- "no.class"
units <- x$units
if(is.null(units)){
warning("In units(pems): [suspect units]", call.=FALSE)
units <- data.frame(matrix(NA, nrow = 1, ncol = ncol(x$data)))
names(units) <- names(x$data)
}
#should this be a try?
#should this foreshorten/expand?
#should be check bad moves
#######################
#way units methods works this is only ever a data.frame and what you have to send it have to work
#so thinking what follows is a waste of time
#could just be x$units <- value
if(is.data.frame(value)){
units[1, 1:ncol(value)] <- value[1,]
if(!is.null(names(units)))
names(units)[1:ncol(value)] <- names(value)
} else {
units[1,1:length(value)] <- as.character(value)
}
########################
if ("history" %in% names(x))
x$history <- c(x$history, call2)
x$units <- units
class(x)[1] <- "pems"
return(rebuildPEMS(x))
}
##########################
##########################
##head.pems
##tail.pems
##########################
##########################
#kr 31/04/2014 v 0.2.4
#if number of columns less than n?
#need to catch this
head.pems <- function(x, n=6, ...){
x <- rebuildPEMS(x)
out <- x[1:n,,force=T,simplify=F]
print(out, rows=n)
invisible(out)
}
tail.pems <- function(x, n=6, ...) {
x <- rebuildPEMS(x)
out <- dim(as.data.frame(x))[1]
out <- (out-n+1):(out)
out <- out[out>0]
out <- x[out,,force=TRUE,simplify=F]
print(out, rows=n)
invisible(out)
}
######################################
######################################
##na.omit.pems
######################################
######################################
#kr 0.0.1 2018/07/06
#not sure why I now need this...
#needs more work
#not sure why pems[complete.cases(pems),] dies
# when all rows contain NAs
# might be down to pems[i,] dying on pems[FALSE,] etc...
#might be able to reduce code if I fix this...
na.omit.pems <- function(object, ...) {
object[["data"]] <- object[["data"]][complete.cases(object[["data"]]),]
object
}
############################################################
############################################################
###############################
#working
###############################
###########################
#i do not think you can do anymore than
#units(pems) <- value
##########################
#error out if it does not work
#not even sure we can do this
##########################
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.