Nothing
# Reference class for data.frame-like objects
# Author : Sylvain Mareschal <maressyl@gmail.com>
# License : GPL3 http://www.gnu.org/licenses/gpl.html
### expression() shortcut ###
e = expression
### R5 class definition ###
setRefClass(
Class = "refTable",
fields = list(
rowCount = "integer",
rowNames = "character",
rowNamed = "logical",
colCount = "integer",
colNames = "character",
colReferences = "character",
colIterator = "integer",
values = "environment"
),
methods = list(
addColumn = function(content, name, after=colCount) {
"Adds a column in the table
- content : values to fill in the new column, as a vector.
- name : name of the new column, as character.
- after : where to add the column, as the index (numeric) or name (character) of the column on its left"
# Position (0 is OK)
if(length(after) !=1 || after != 0) {
after <- (1:colCount)[ indexes(after, "column") ]
if(length(after) != 1) stop("'after' must be a single value")
}
# Name
if(length(name) != 1) stop("'name' must be a single value")
if(!is.character(name)) stop("'name' must be a character")
if(is.na(name)) stop("'name' must not be NA")
if(name %in% colNames) stop("'name' is already in use")
# Content
if(!is.atomic(content)) stop("'content' must be atomic")
if(is.array(content)) stop("'content' must be a vector, not an array")
if(rowCount == 0) { rowCount <<- length(content)
} else if(length(content) != rowCount) { stop("'content' must have 'rowCount' elements")
}
# New reference
colCount <<- colCount + 1L
colIterator <<- colIterator + 1L
colReferences <<- append(x=colReferences, values=as.character(colIterator), after=after)
colNames <<- append(x=colNames, values=name, after=after)
# Binding column name in values (for expression-based extraction)
makeActiveBinding(
sym = name,
fun = eval(
parse(text=sprintf("function(v) get(\"%s\")", colIterator)),
envir = values
),
env = values
)
# Forget value names
names(content) <- NULL
# Filling
values[[ as.character(colIterator) ]] <<- content
},
addDataFrame = function(dataFrame) {
"Adds a data.frame content to the refTable
- dataFrame : the data to add."
# Checks
if(!is.data.frame(dataFrame)) stop("Input must be a data.frame")
if(ncol(dataFrame) == 0) invisible(TRUE)
# Relocation
invisible(.self$addList(dataFrame, row.names=row.names(dataFrame)))
},
addEmptyRows = function(amount, newNames) {
"Add rows filled with NA at the bottom of the table.
- amount : single integer value, the amount of rows to add.
- newNames : character vector, the names of the new rows. Ignored if the table is not row named."
# Checks
if(amount == 0) return(TRUE)
if(!is.integer(amount) || amount < 1) stop("'amount' must be a positive integer")
if(isTRUE(rowNamed)) {
if(!is.character(newNames)) stop("'newNames' must be a character vector")
if(any(is.na(newNames))) stop("'newNames' must not contain NA values")
if(length(newNames) != amount) stop("'newNames' must have 'amount' elements")
if(any(newNames %in% rowNames)) stop("'newNames' contains row names already in use")
} else {
if(!missing(newNames)) warning("'newNames' was ignored as the table is not row named")
}
# Counter update
rowCount <<- rowCount + amount
# Row names update
if(isTRUE(rowNamed)) {
names(newNames) <- NULL
rowNames <<- c(rowNames, newNames)
}
# Value update
toAppend <- rep(NA, amount)
for(colReference in colReferences) {
content <- c(values[[ colReference ]], toAppend)
if(is.factor(values[[ colReference ]])) attributes(content) <- attributes(values[[ colReference ]])
values[[ colReference ]] <<- content
}
},
addList = function(dataList, row.names) {
"Adds a list content to the refTable
- dataList : the data to add.
- row.names : character vector with the names of the enw rows."
# Checks
if(!is.list(dataList)) stop("Input must be a list")
if(length(dataList) == 0) invisible(TRUE)
if(is.null(names(dataList))) stop("Input must have named elements")
# Strict class check for existing columns
for(k in intersect(names(dataList), .self$getColNames())) {
if(!identical(class(dataList[[k]]), class(.self$extract(0,k)))) stop("New values class does not match the existing column class for column \"", k, "\"")
if(is.factor(dataList[[k]]) && !identical(levels(dataList[[k]]), levels(.self$extract(0,k)))) stop("New values levels do not match the existing column levels for column \"", k, "\"")
}
# Rows to add
newRows <- max(sapply(dataList, length))
oldRows <- .self$getRowCount()
# Row coordinates
if(.self$getRowCount() > 0) { rows <- .self$getRowCount() + 1:newRows
} else { rows <- NULL
}
# Rows
if(.self$rowNamed) {
# Checks
if(missing(row.names)) stop("'row.names' must be provided for row named tables")
if(length(row.names) != newRows) stop("'row.names' must contain a value for every new row")
if(any(row.names %in% .self$getRowNames())) stop("'row.names' must not contain names already in use")
# New rows
.self$addEmptyRows(newRows, row.names)
} else {
# New rows
.self$addEmptyRows(newRows)
}
# Filling (recycling)
for(colName in names(dataList)) {
if(colName %in% .self$getColNames()) {
# Fill existing column
.self$fill(
i = rows,
j = colName,
newValues = if(newRows == length(dataList[[colName]])) { dataList[[colName]] }
else { rep(dataList[[colName]], length.out=newRows) }
)
} else {
if(oldRows > 0) {
# New column content, appending
content <- c(
rep(NA, length.out=oldRows),
if(newRows == length(dataList[[colName]])) { dataList[[colName]] }
else { rep(dataList[[colName]], length.out=newRows) }
)
if(is.factor(dataList[[colName]])) attributes(content) <- attributes(dataList[[colName]])
# Update
.self$addColumn(
content = content,
name = colName
)
} else {
# New column in empty table
.self$addColumn(
name = colName,
content = if(newRows == length(dataList[[colName]])) { dataList[[colName]] }
else { rep(dataList[[colName]], length.out=newRows) }
)
}
}
}
invisible(TRUE)
},
addVectors = function(..., row.names) {
"Adds vectors to the refTable
- ... : named vectors to add."
# Relocation
invisible(.self$addList(list(...), row.names=row.names))
},
check = function(warn=TRUE) {
"Raises an error if the object is not valid, else returns TRUE"
# Unique values
if(length(rowCount) != 1) stop("'rowCount' must be a single value")
if(length(colCount) != 1) stop("'colCount' must be a single value")
if(length(rowNamed) != 1) stop("'rowNamed' must be a single value")
if(length(colIterator) != 1) stop("'colIterator' must be a single value")
# Rows
if(isTRUE(rowNamed)) {
if(length(rowNames) != rowCount) stop("'rowCount' and 'rowNames' does not match")
if(any(duplicated(rowNames))) stop("All 'rowNames' must be unique")
} else {
if(length(rowNames) > 0) stop("'rowNames' must be empty if 'rowNamed' is FALSE")
}
# Columns
if(length(colNames) != colCount) stop("'colCount' and 'colNames' does not match")
if(length(colReferences) != colCount) stop("'colCount' and 'colReferences' does not match")
if(length(ls(values)) != colCount*2) stop("'values' length and 'colCount' does not match")
# Values
k = 1
while(k <= colCount) {
if(!exists(colReferences[k], values)) stop("'colReferences' must all exist in 'values'")
if(length(values[[ colReferences[k] ]]) != rowCount) stop("'values' element lengths and 'rowCount' does not match")
k = k + 1
}
return(TRUE)
},
coerce = function(j=NULL, class, levels, ...) {
"Coerces a single column to a different class
- j : column index (numeric) or name (character).
- class : name of the class to coerce 'j' to.
- levels : if 'class' is factor, the levels to use.
- ... : further arguments to be passed to the 'as' method (for atomics) or function (for other classes)."
# Reference
j <- indexes(j, "column")
# Single column
colRefSubset <- colReferences[j]
if(length(colRefSubset) != 1) stop("'j' must be defined and unique")
# Coercion
if(class == "factor") {
if(missing(levels)) { values[[ colRefSubset ]] <<- factor(values[[ colRefSubset ]])
} else { values[[ colRefSubset ]] <<- factor(values[[ colRefSubset ]], levels=levels)
}
} else if(class == "logical") { values[[ colRefSubset ]] <<- as.logical(values[[ colRefSubset ]], ...)
} else if(class == "integer") { values[[ colRefSubset ]] <<- as.integer(values[[ colRefSubset ]], ...)
} else if(class == "numeric") { values[[ colRefSubset ]] <<- as.numeric(values[[ colRefSubset ]], ...)
} else if(class == "double") { values[[ colRefSubset ]] <<- as.double(values[[ colRefSubset ]], ...)
} else if(class == "complex") { values[[ colRefSubset ]] <<- as.complex(values[[ colRefSubset ]], ...)
} else if(class == "character") { values[[ colRefSubset ]] <<- as.character(values[[ colRefSubset ]], ...)
} else { values[[ colRefSubset ]] <<- as(object=values[[ colRefSubset ]], class=class, ...)
}
},
colOrder = function(newOrder, na.last=TRUE, decreasing=FALSE) {
"Reorder the columns of the tables (duplication / subsetting are NOT handled)
- newOrder : new order to apply, as an integer vector of character vector of column names."
# Index conversion
newOrder <- indexes(newOrder, type="column")
# Security
if(any(sort(newOrder) != 1:colCount)) stop("Column duplication and subsetting are not handled")
# Apply
colReferences <<- colReferences[ newOrder ]
colNames <<- colNames[ newOrder ]
},
copy = function(shallow=FALSE) {
"Overloads 'envRefClass' copy method to force 'values' duplication in deep copy"
if(shallow) {
# Copy 'values' reference for shallow copy is fine
return(callSuper(shallow=TRUE))
} else {
# Copy other fields
value <- callSuper(shallow=FALSE)
# New empty 'values' environment
value$values <- new.env()
# Copy content
for(content in value$colReferences) {
assign(content, get(content, envir=values), envir=value$values)
}
# Rebuild bindings
for(i in 1:colCount) {
makeActiveBinding(
sym = value$colNames[i],
fun = eval(
parse(text=sprintf("function(v) get(\"%s\")", value$colReferences[i])),
envir = value$values
),
env = value$values
)
}
return(value)
}
},
delColumns = function(targets) {
"Deletes a column from the table
- targets : character vector, the name(s) of the column(s) to delete."
# Arg checks
if(!is.character(targets) || length(targets) == 0) stop("'targets' must be a non empty character vector")
if(any(!targets %in% colNames)) stop("'targets' must refer to existing column(s)")
for(name in targets) {
# Target position
colPos = (colNames == name)
# Binding and content
rm(list=name, pos=values)
rm(list=colReferences[ colPos ], pos=values)
# Column dereferencement
colReferences <<- colReferences[ !colPos ]
colNames <<- colNames[ !colPos ]
# Column count
colCount <<- colCount - 1L
}
},
erase = function() {
"Remove all the rows and columns in the table."
# Empty environment
rm(list=c(colReferences, colNames), envir=values)
# Reset parameters
rowCount <<- 0L
rowNames <<- character(0)
colCount <<- 0L
colNames <<- character(0)
colReferences <<- character(0)
colIterator <<- 0L
},
extract = function(i=NULL, j=NULL, drop=TRUE, asObject=FALSE) {
"Extracts values into a data.frame or vector
- i : row selection, see indexes() for further details.
- j : column selection, see indexes() for further details.
- drop : if TRUE and querying a single column, will return a vector instead of a data.frame.
- asObject : if TRUE results will be served in the same class as the current object."
# References
i = indexes(i, "row")
j = indexes(j, "column")
colRefSubset <- colReferences[j]
if(isTRUE(drop) && length(colRefSubset) == 1) {
# Vector results
if(is.null(i)) {
results <- values[[ colRefSubset ]]
if(rowNamed) names(results) <- rowNames
} else {
results <- values[[ colRefSubset ]][i]
if(rowNamed) names(results) <- rowNames[i]
}
} else {
# Empty data.frame
results <- data.frame()
if(rowNamed) {
if(is.null(i)) attr(results, "row.names") <- rowNames
else attr(results, "row.names") <- rowNames[i]
} else {
if(is.null(i)) attr(results, "row.names") <- 1:rowCount
else attr(results, "row.names") <- (1:rowCount)[i]
}
# Filling data.frame
if(is.null(j)) {
if(is.null(i)) {
# No subset
k = 1
while(k <= colCount) {
results[[ colNames[k] ]] <- values[[ colReferences[k] ]]
k = k + 1
}
} else {
# Row subset
k = 1
while(k <= colCount) {
results[[ colNames[k] ]] <- values[[ colReferences[k] ]][i]
k = k + 1
}
}
} else {
if(is.null(i)) {
# Col subset
for(k in (1:colCount)[j]) results[[ colNames[k] ]] <- values[[ colReferences[k] ]]
} else {
# Both subset
for(k in (1:colCount)[j]) results[[ colNames[k] ]] <- values[[ colReferences[k] ]][i]
}
}
}
if(isTRUE(asObject)) {
# New object with same meta-data
output <- new(class(.self))
for(fieldName in .self$metaFields()) output[[fieldName]] <- .self$field(fieldName)
output$addDataFrame(results)
results <- output
}
return(results)
},
fill = function(i=NULL, j=NULL, newValues) {
"Replaces values in a single column
- i : row indexes (numeric) or names (character). NULL or missing for all rows.
- j : column index (numeric) or name (character).
- newValues : vector of values to put in the object"
# References
i = indexes(i, "row")
j = indexes(j, "column")
# Single column
colRefSubset <- colReferences[j]
if(length(colRefSubset) != 1) stop("'j' must be defined and unique")
# Strict class check
if(!identical(class(newValues), class(values[[ colRefSubset ]]))) stop("New values class does not match the existing column class")
if(is.factor(newValues) && !identical(levels(newValues), levels(values[[ colRefSubset ]]))) stop("New values levels do not match the existing column levels")
# Forget value names
names(newValues) <- NULL
# Replacing in a single column
if(is.null(i)) {
values[[ colRefSubset ]] <<- newValues
} else {
values[[ colRefSubset ]][i] <<- newValues
}
},
getColCount = function() {
"'colCount' field accessor."
return(colCount)
},
getColNames = function() {
"'colNames' field accessor."
return(colNames)
},
getLevels = function(j=NULL) {
"Get levels of a factor column
- j : column index (numeric) or name (character)."
# Reference
j <- indexes(j, "column")
# Single column
colRefSubset <- colReferences[j]
if(length(colRefSubset) != 1) stop("'j' must be defined and unique")
if(is.factor(values[[ colRefSubset ]])) {
return(levels(values[[ colRefSubset ]]))
} else stop("'j' must refer to a column of class 'factor'")
},
getRowCount = function() {
"'rowCount' field accessor."
return(rowCount)
},
getRowNames = function() {
"'rowNames' field accessor."
return(rowNames)
},
indexes = function(i, type=c("row", "column")) {
"Checks row or column references and return numeric indexes
- i : reference to the rows or columns to select (NA not allowed), as :
- missing or NULL (all rows or columns)
- vector of numeric indexes to select
- vector of character indexes to select (if the dimension is named)
- vector of logical with TRUE on each value to select, FALSE otherwise
- expression object (as returned by e(...)), to be evaluated in the 'values' environment"
# Pass through
if(is.null(i)) {
return(i)
}
if(is.numeric(i)) {
if(any(is.na(i))) stop("NA reference not allowed")
return(i)
}
if(is.logical(i)) {
if(any(is.na(i))) stop("NA reference not allowed")
return(i)
}
# Expression evaluation
if(is.expression(i)) {
return(
indexes(
eval(i, envir=new.env(parent=values)),
type
)
)
}
# Character matching
if(is.character(i)) {
# Dimension to query
type <- match.arg(type)
if(type == "column") {
names <- colNames
} else if(type == "row") {
if(!rowNamed) stop("No names to match in")
names <- rowNames
} else {
stop("Invalid 'type'")
}
# Matching
notFound <- ! i %in% names
if(any(notFound)) stop("Name(s) not found : ", paste(sprintf("\"%s\"", i[notFound]), collapse=", "))
return(match(i, names))
}
# Unknown
stop("Invalid 'i' type")
},
initialize = function(
rowCount = as.integer(0),
rowNames = character(0),
rowNamed = FALSE,
colCount = as.integer(0),
colNames = character(0),
colReferences = character(0),
colIterator = as.integer(0),
values = new.env(),
...
) {
# Initialize an empty table
.self$initFields(
rowCount = rowCount,
rowNames = rowNames,
rowNamed = rowNamed,
colCount = colCount,
colNames = colNames,
colReferences = colReferences,
colIterator = colIterator,
values = values
)
.self
},
metaFields = function() {
"Returns a character vector of fields that do not directly depend on the tabular content, for clonage."
out <- names(.self$getRefClass()$fields())
out <- setdiff(out, names(getRefClass("refTable")$fields()))
return(out)
},
rowOrder = function(newOrder, na.last=TRUE, decreasing=FALSE) {
"Reorder the rows of the tables (duplication / subsetting are handled)
- newOrder : new order to apply, as an integer vector of row indexes or a character vector of column names.
- na.last : to be passed to order(), if 'newOrder' is a column name vector.
- decreasing : to be passed to order(), if 'newOrder' is a column name vector."
# Build order
if(is.character(newOrder)) {
# Queried columns
if(any(!newOrder %in% colNames)) stop("'newOrder' must refer to existing columns")
columns <- sprintf("`%s`", colReferences[ match(newOrder, colNames) ])
# order() call
expr <- sprintf("order(%s, na.last=%s, decreasing=%s)", paste(columns, collapse=", "), na.last, decreasing)
newOrder <- eval(parse(text=expr), values)
} else if(!is.integer(newOrder)) {
stop("'newOrder' must be an integer order or a character vector of columns")
}
# Apply order to columns
for(colRef in colReferences) {
values[[ colRef ]] <<- values[[ colRef ]][ newOrder ]
}
# Apply order to row names
if(isTRUE(rowNamed)) {
rowNames <<- rowNames[ newOrder ]
}
# Change row count if necessary
if(rowCount != length(newOrder)) {
rowCount <<- length(newOrder)
}
},
setColNames = function(j, value) {
"Replaces one or many column names.
- j : subset of columns to rename.
- value : new column names to use, as a character vector."
# References
j <- indexes(j, "column")
# Forget value names
names(value) <- NULL
# Remove old bindings
rm(list=colNames[j], pos=values)
# Update colNames vector
if(is.null(j)) {
colNames <<- value
} else {
colNames[j] <<- value
}
# Create new bindings
for(index in j) {
makeActiveBinding(
sym = colNames[index],
fun = eval(
parse(text=sprintf("function(v) get(\"%s\")", colReferences[index])),
envir = values
),
env = values
)
}
},
setLevels = function(j=NULL, newLevels) {
"Get or replace levels of a factor column
- j : column index (numeric) or name (character).
- newLevels : new levels to use, as a character vector."
# Reference
j <- indexes(j, "column")
# Single column
colRefSubset <- colReferences[j]
if(length(colRefSubset) != 1) stop("'j' must be defined and unique")
if(is.factor(values[[ colRefSubset ]])) {
levels(values[[ colRefSubset ]]) <<- newLevels
} else stop("'j' must refer to a column of class 'factor'")
},
setRowNames = function(value) {
"Replaces the entire row names set.
- value : new row names to use in the table, as a character vector. NULL will disable row naming."
# Forget value names
names(value) <- NULL
if(is.null(value)) {
# No row names
rowNamed <<- FALSE
rowNames <<- character(0)
} else {
# New row names
if(!is.character(value)) stop("'value' must be of type 'character'")
if(length(value) != rowCount) stop("'value' must have 'rowCount' elements")
if(any(is.na(value))) stop("'value' must not contain NA values")
if(any(duplicated(value))) stop("'value' must not contain duplicated values")
rowNamed <<- TRUE
rowNames <<- value
}
},
show = function(include=FALSE, fieldWidth=10) {
"Interactive printing
- include : single logical value, if TRUE class name will not be printed."
# Class name
if(!isTRUE(include)) {
cat("\n \"refTable\" reference class object\n")
} else {
cat("\n Extends \"refTable\"\n")
}
cat("\n")
if(rowCount > 6) {
# Content summary
content <- as.matrix(format.data.frame(.self$extract(c(1:3, rowCount-(2:0))), na.encode=FALSE))
content <- rbind(
content[1:3,],
rep("...", ncol(content)),
content[4:6,],
rep(" ", ncol(content))
)
rownames(content)[4] = "..."
print(content, quote=FALSE, right=TRUE)
} else if(rowCount == 0) {
# No content
cat(" ", paste(colNames, collapse=" "), "\n\n")
} else {
# Full content
content <- as.matrix(format.data.frame(extract(), na.encode=FALSE))
content <- rbind(
content,
rep(" ", ncol(content))
)
print(content, quote=FALSE, right=TRUE)
}
},
types = function(j=NULL) {
"Returns classes of selected columns
- j : column indexes or names (NULL for all columns)"
# References
j = indexes(j, "column")
# Apply class()
results = character(0)
if(is.null(j)) {
k = 1
while(k <= colCount) {
results[ colNames[k] ] = class(values[[ colReferences[k] ]])
k = k + 1
}
} else {
for(k in (1:colCount)[j]) {
results[ colNames[k] ] = class(values[[ colReferences[k] ]])
}
}
return(results)
}
)
)
### Constructor ###
refTable = function(..., row.names, warn=TRUE) {
# Arguments
argList = list(...)
# Dispatch
if(length(argList) == 0) {
# Empty table
object = new("refTable")
} else if(length(argList) == 1 && is.data.frame(argList[[1]])) {
# Data.frame
object = new("refTable")
object$rowNamed = !is.integer(attr(argList[[1]], "row.names"))
if(!missing(row.names)) warning("'row.names' ignored")
object$addDataFrame(argList[[1]])
} else if(length(argList) == 1 && is.list(argList[[1]])) {
# List
object = new("refTable")
if(!missing(row.names)) object$rowNamed = TRUE
object$addList(argList[[1]], row.names=row.names)
} else if(length(argList) > 0 && all(sapply(argList, is.vector) | sapply(argList, is.factor))) {
# Vectors
object = new("refTable")
if(!missing(row.names)) object$rowNamed = TRUE
object$addList(argList, row.names=row.names)
} else {
stop("Provide a single data.frame or multiple vectors")
}
# Check
object$check(warn=warn)
return(object)
}
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.