# in-memory direct functionality
#' @importFrom stats as.formula
NULL
#' @export
#' @rdname build_pivot_control
build_pivot_control.default <- function(table,
columnToTakeKeysFrom,
columnToTakeValuesFrom,
...,
prefix = columnToTakeKeysFrom,
sep = NULL,
tmp_name_source = wrapr::mk_tmp_name_source("bpcd"),
temporary = TRUE) {
wrapr::stop_if_dot_args(substitute(list(...)), "cdata::build_pivot_control")
if(!is.data.frame(table)) {
stop("build_pivot_control.default table should be a data.frame")
}
controlTable <- data.frame(vals = unique(table[[columnToTakeKeysFrom]]),
stringsAsFactors = FALSE)
colnames(controlTable) <- columnToTakeKeysFrom
controlTable[[columnToTakeKeysFrom]] <- as.character(controlTable[[columnToTakeKeysFrom]])
controlTable[[columnToTakeValuesFrom]] <- controlTable[[columnToTakeKeysFrom]]
if(!is.null(sep)) {
controlTable[[columnToTakeValuesFrom]] <- paste(prefix,
controlTable[[columnToTakeValuesFrom]],
sep=sep)
}
controlTable
}
#' Build a rowrecs_to_blocks() control table that specifies a un-pivot (or "shred").
#'
#' Some discussion and examples can be found here:
#' \url{https://winvector.github.io/FluidData/FluidData.html} and
#' here \url{https://github.com/WinVector/cdata}.
#'
#' @param nameForNewKeyColumn character name of column to write new keys in.
#' @param nameForNewValueColumn character name of column to write new values in.
#' @param columnsToTakeFrom character array names of columns to take values from.
#' @param ... not used, force later args to be by name
#' @return control table
#'
#' @seealso \code{\link{rowrecs_to_blocks}}
#'
#' @examples
#'
#' build_unpivot_control("measurmentType", "measurmentValue", c("c1", "c2"))
#'
#' @export
build_unpivot_control <- function(nameForNewKeyColumn,
nameForNewValueColumn,
columnsToTakeFrom,
...) {
wrapr::stop_if_dot_args(substitute(list(...)), "cdata::build_unpivot_control")
controlTable <- data.frame(x = as.character(columnsToTakeFrom),
y = as.character(columnsToTakeFrom),
stringsAsFactors = FALSE)
colnames(controlTable) <- c(nameForNewKeyColumn, nameForNewValueColumn)
controlTable
}
#' @export
#' @rdname rowrecs_to_blocks
rowrecs_to_blocks.default <- function(wideTable,
controlTable,
...,
checkNames = TRUE,
checkKeys = FALSE,
strict = FALSE,
controlTableKeys = colnames(controlTable)[[1]],
columnsToCopy = NULL,
tmp_name_source = wrapr::mk_tmp_name_source("rrtobd"),
temporary = TRUE,
allow_rqdatatable = FALSE) {
wrapr::stop_if_dot_args(substitute(list(...)), "cdata::rowrecs_to_blocks")
if(!is.data.frame(wideTable)) {
stop("cdata::rowrecs_to_blocks.default wideTable should be a data.frame")
}
check_rowrecs_to_blocks_args(wideTable_columns = colnames(wideTable),
controlTable = controlTable,
checkNames = checkNames,
strict = strict,
controlTableKeys = controlTableKeys,
columnsToCopy = columnsToCopy)
rownames(wideTable) <- NULL
controlTableValueColumns <- setdiff(colnames(controlTable), controlTableKeys)
# check more
if(checkKeys) {
if(!check_cols_form_unique_keys(wideTable, columnsToCopy)) {
stop("cdata::rowrecs_to_blocks columnsToCopy do not uniquely key the rows")
}
}
# see if it is an obvious simple unpivot
if(allow_rqdatatable &&
(ncol(controlTable)==2) &&
requireNamespace("rqdatatable", quietly = TRUE) &&
(isTRUE(all.equal(controlTable[ ,1, drop = TRUE],
controlTable[ ,2, drop = TRUE]))) &&
(controlTableKeys == colnames(controlTable)[[1]])) {
res <- rqdatatable::layout_to_blocks_data_table(
data = wideTable,
nameForNewKeyColumn = colnames(controlTable)[[1]],
nameForNewValueColumn = colnames(controlTable)[[2]],
columnsToTakeFrom = controlTable[, 2, drop = TRUE],
columnsToCopy = columnsToCopy)
res <- data.frame(res)
rownames(res) <- NULL
return(res)
}
# do the work
n_row_in <- nrow(wideTable)
n_rep <- nrow(controlTable)
n_row_res <- n_rep*n_row_in
# build and start filling in result
res <- data.frame(x = seq_len(n_row_in))
res[['x']] <- NULL
for(cn in columnsToCopy) {
res[[cn]] <- wideTable[[cn]]
}
for(cn in controlTableKeys) {
res[[cn]] <- NA_character_
}
for(cn in controlTableValueColumns) {
wtn <- wideTable[[controlTable[1, cn, drop = TRUE]]]
if(is.factor(wtn)) {
wtn <- as.character(wtn)
}
res[[cn]] <- wtn
res[[cn]][seq_len(n_row_in)] <- NA
}
# cross product with control table
res <- res[sort(rep(seq_len(n_row_in), n_rep)), , drop = FALSE] # TODO: speedup hotspot
rownames(res) <- NULL
for(cn in controlTableKeys) {
res[[cn]] <- rep(controlTable[[cn]], n_row_in)
}
# fill in values
for(cn in controlTableValueColumns) {
res_cn <- res[[cn]]
for(i in seq_len(n_rep)) {
indxs <- i + n_rep*(0:(n_row_in-1))
col <- controlTable[i, cn, drop = TRUE]
wtni <- wideTable[[col]]
if(is.factor(wtni)) {
wtni <- as.character(wtni)
}
res_cn[indxs] <- wtni # TODO: speedup hotspot
}
res[[cn]] <- res_cn
}
rownames(res) <- NULL
res
}
#' @export
#' @rdname blocks_to_rowrecs
blocks_to_rowrecs.default <- function(tallTable,
keyColumns,
controlTable,
...,
columnsToCopy = NULL,
checkNames = TRUE,
checkKeys = FALSE,
strict = FALSE,
controlTableKeys = colnames(controlTable)[[1]],
tmp_name_source = wrapr::mk_tmp_name_source("btrd"),
temporary = TRUE,
allow_rqdatatable = FALSE) {
wrapr::stop_if_dot_args(substitute(list(...)), "cdata::blocks_to_rowrecs")
if(!is.data.frame(tallTable)) {
stop("cdata::blocks_to_rowrecs.default tallTable should be a data.frame")
}
check_blocks_to_rowrecs_args(tallTable_columns = colnames(tallTable),
keyColumns = keyColumns,
controlTable = controlTable,
columnsToCopy = columnsToCopy,
checkNames = checkNames,
strict = strict,
controlTableKeys = controlTableKeys)
rownames(tallTable) <- NULL
clear_key_column <- FALSE
if(length(keyColumns)<=0) {
# avoid no-keys case
tallTable$cdata_key_column <- 1
keyColumns <- "cdata_key_column"
clear_key_column <- TRUE
}
controlTableValueColumns <- setdiff(colnames(controlTable), controlTableKeys)
# check more
if(checkKeys) {
# check keyColumns plus controltable keys key data
if(!check_cols_form_unique_keys(tallTable, c(controlTableKeys, keyColumns))) {
stop(paste("cdata::blocks_to_rowrecs: controlTableKeys plus keyColumns do not uniquely index data"))
}
}
# see if it is an obvious simple unpivot
if(allow_rqdatatable &&
(ncol(controlTable)==2) &&
requireNamespace("rqdatatable", quietly = TRUE) &&
(isTRUE(all.equal(controlTable[ ,1, drop = TRUE],
controlTable[ ,2, drop = TRUE]))) &&
(controlTableKeys == colnames(controlTable)[[1]])) {
res <- rqdatatable::layout_to_rowrecs_data_table(
data = tallTable,
columnToTakeKeysFrom = colnames(controlTable)[[1]],
columnToTakeValuesFrom= colnames(controlTable)[[2]],
rowKeyColumns = keyColumns)
res <- data.frame(res)
rownames(res) <- NULL
return(res)
}
# do the work
# make simple grouping keys
tallTable$cdata_group_key_col <- 1
if(length(keyColumns)>=1) {
cols <- as.list(tallTable[ , keyColumns, drop=FALSE])
names(cols) <- NULL
keys <- do.call("paste", c(cols, sep = " CDATA_SEP "))
tallTable$cdata_group_key_col <- match(keys, keys)
tallTable <- tallTable[order(tallTable$cdata_group_key_col), , drop = FALSE]
}
first_idxs <- match(unique(tallTable$cdata_group_key_col), tallTable$cdata_group_key_col)
res <- tallTable[first_idxs,
c("cdata_group_key_col", keyColumns, columnsToCopy),
drop = FALSE]
rownames(res) <- NULL
n_res <- nrow(res)
# fill in values
tallTable$composite_meas_col <- do.call(paste,
c(as.list(tallTable[, controlTableKeys, drop = FALSE]),
list(sep = " CDATA_K_SEP ")))
controlTable$composite_meas_col <- do.call(paste,
c(as.list(controlTable[, controlTableKeys, drop = FALSE]),
list(sep = " CDATA_K_SEP ")))
n_rep <- nrow(controlTable)
for(i in seq_len(n_rep)) {
srccol <- controlTable$composite_meas_col[[i]]
indxs <- which(tallTable$composite_meas_col == srccol) # TODO: speedup hotspot
for(cn in controlTableValueColumns) {
destcol <- controlTable[[cn]][i]
vals <- tallTable[[cn]][indxs]
if(length(vals)>0) {
res[[destcol]] <- vals[[1]]
} else {
res[[destcol]] <- FALSE
}
res[[destcol]][seq_len(n_res)] <- NA
posns <- match(res$cdata_group_key_col,
tallTable$cdata_group_key_col[indxs])
lhs <- seq_len(n_res)
lhs <- lhs[!is.na(posns)]
posns <- posns[!is.na(posns)]
res[[destcol]][lhs] <- vals[posns]
}
}
res$cdata_group_key_col <- NULL
if(clear_key_column) {
res$cdata_key_column <- NULL
}
rownames(res) <- NULL
res
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.