Nothing
setGeneric("merge")
setMethod("merge", c("OPM", "missing"), function(x, y, sort.first = TRUE,
parse = TRUE) {
x
}, sealed = SEALED)
setMethod("merge", c("OPM", "numeric"), function(x, y, sort.first = TRUE,
parse = TRUE) {
x
}, sealed = SEALED)
setMethod("merge", c("OPM", "OPM"), function(x, y, sort.first = TRUE,
parse = TRUE) {
merge(new(Class = "OPMS", plates = list(x, y)), 0.25, sort.first, parse)
}, sealed = SEALED)
setMethod("merge", c("OPMS", "numeric"), function(x, y, sort.first = TRUE,
parse = TRUE) {
if (any(y <= 0))
stop("'y' must be positive throughout")
if (L(sort.first))
x <- sort(x, by = "setup_time", parse = parse, na.last = TRUE)
m <- do.call(rbind, measurements(x))
if (is.matrix(tp <- hours(x, "all"))) {
to.add <- c(0, must(cumsum(tp[-nrow(tp), ncol(tp), drop = FALSE] + y)))
m[, 1L] <- as.vector(t(tp + to.add))
} else if (is.list(tp)) {
to.add <- c(0, must(cumsum(vapply(tp[-length(tp)], tail, 1, 1L) + y)))
m[, 1L] <- unlist(mapply(FUN = `+`, x = tp, y = to.add, SIMPLIFY = FALSE,
USE.NAMES = FALSE), FALSE, FALSE)
} else {
stop(BUG_MSG)
}
new(Class = "OPM", measurements = m, csv_data = csv_data(x[1L]),
metadata = metadata(x[1L]))
}, sealed = SEALED)
setMethod("merge", c("OPMS", "missing"), function(x, y, sort.first = TRUE,
parse = TRUE) {
merge(x, 0.25, sort.first, parse)
}, sealed = SEALED)
setMethod("merge", c("MOPMX", "missing"), function(x, y) {
combine <- function(x) if (length(x <- plates(x)) > 1L)
new(Class = "OPMS", plates = x)
else
x[[1L]]
if (!anyDuplicated.default(pt <- plate_type(x)))
return(x)
x@.Data <- lapply(split.default(x@.Data, as.factor(pt)), combine)
x
}, sealed = SEALED)
setMethod("merge", c("MOPMX", "ANY"), function(x, y) {
merge(x + y)
}, sealed = SEALED)
setMethod("merge", c("CMAT", "logical"), function(x, y) {
merge(x, if (L(y))
as.factor(rownames(x))
else
as.factor(seq_len(nrow(x))))
}, sealed = SEALED)
setMethod("merge", c("CMAT", "ANY"), function(x, y) {
merge(x, as.factor(y))
}, sealed = SEALED)
setMethod("merge", c("CMAT", "factor"), function(x, y) {
if (length(y) != nrow(x)) # this also covers NULL row names
stop("length of 'y' not equal to number of rows")
if (anyNA(y))
stop("'y' must not contain NA values")
if (length(levels(y)) == length(y))
return(x)
cn <- colnames(x) # later put back, avoiding correction of duplicate names
x <- aggregate(x = as.data.frame(x = x, stringsAsFactors = FALSE),
by = list(y), FUN = c, recursive = TRUE, simplify = FALSE)
x <- as.matrix(x[, -1L, drop = FALSE])
x[] <- lapply(x, sort.int, NULL, TRUE)
rownames(x) <- levels(y)
colnames(x) <- cn
new("CMAT", x)
}, sealed = SEALED)
setGeneric("split")
setMethod("split", c("OPM", "missing", "missing"), function(x, f, drop) {
split(x, drop = FALSE)
}, sealed = SEALED)
setMethod("split", c("OPMS", "missing", "missing"), function(x, f, drop) {
split(x, drop = FALSE)
}, sealed = SEALED)
setMethod("split", c("OPM", "missing", "ANY"), function(x, f, drop) {
extract_concentration <- function(x) {
m <- regexpr("(?<=#)\\s*\\d+\\s*$", x, FALSE, TRUE)
conc <- as.integer(substr(x, m, m + attr(m, "match.length") - 1L))
regmatches(x, m) <- "1"
list(Concentration = conc,
Standardized = structure(.Data = names(x), names = x))
}
regular_size <- function(x) {
counts <- tabulate(x$Concentration)
length(counts) > 1L || all(duplicated.default(counts)[-1L])
}
regular_composition <- function(x) {
for (i in seq_along(x)[-1L])
if (!setequal(names(x[[1L]]), names(x[[i]])))
return(FALSE)
TRUE
}
get_and_rename <- function(x, w1, w2, conc, drop, key) {
x <- rename_wells(x[, w1, drop = drop], w2)
x@metadata[[key]] <- conc
x
}
w <- extract_concentration(wells(x, TRUE, FALSE))
if (!regular_size(w) || !regular_composition(
w <- split.default(w$Standardized, w$Concentration))) {
warning("no regular concentration structure found")
return(x)
}
for (i in seq_along(w)[-1L])
w[[i]] <- w[[i]][names(w[[1L]])]
new(Class = "OPMS", plates = mapply(FUN = get_and_rename,
conc = as.integer(names(w)), w1 = w, SIMPLIFY = FALSE, USE.NAMES = FALSE,
MoreArgs = list(x = x, w2 = w[[1L]], drop = drop,
key = get("series.key", OPM_OPTIONS))))
}, sealed = SEALED)
setMethod("split", c("OPMS", "missing", "ANY"), function(x, f, drop) {
x@plates <- lapply(X = x@plates, FUN = split, drop = drop)
x@plates <- unlist(lapply(x@plates, slot, "plates"), FALSE, FALSE)
x
}, sealed = SEALED)
setMethod("split", c("OPM", "ANY", "missing"), function(x, f, drop) {
split(x, f, FALSE)
}, sealed = SEALED)
setMethod("split", c("OPMS", "ANY", "missing"), function(x, f, drop) {
split(x, f, FALSE)
}, sealed = SEALED)
setMethod("split", c("OPM", "factor", "missing"), function(x, f, drop) {
split(x, f, FALSE)
}, sealed = SEALED)
setMethod("split", c("OPM", "factor", "ANY"), function(x, f, drop) {
object <- split.default(0L, f, FALSE) # to get the warnings/errors
object[[1L]] <- x[drop = drop]
new("MOPMX", object)
}, sealed = SEALED)
setMethod("split", c("OPMS", "factor", "missing"), function(x, f, drop) {
split(x, f, FALSE)
}, sealed = SEALED)
setMethod("split", c("OPMS", "factor", "ANY"), function(x, f, drop) {
new("MOPMX", lapply(split.default(x, f, FALSE), `[`, drop = drop))
}, sealed = SEALED)
setMethod("split", c("OPMX", "ANY", "ANY"), function(x, f, drop) {
split(x, as.factor(extract_columns(x, f, TRUE, " ", "ignore")), drop)
}, sealed = SEALED)
setMethod("split", c("MOPMX", "factor", "missing"), function(x, f, drop) {
split.default(x, f, FALSE)
}, sealed = SEALED)
setMethod("split", c("MOPMX", "factor", "ANY"), function(x, f, drop) {
split.default(x, f, drop)
}, sealed = SEALED)
setMethod("split", c("MOPMX", "list", "missing"), function(x, f, drop) {
split(x, f, FALSE)
}, sealed = SEALED)
setMethod("split", c("MOPMX", "list", "ANY"), function(x, f, drop) {
if (!all(vapply(f, is.factor, NA)))
f <- metadata2factorlist(x, f)
x <- mapply(FUN = split, x = x, f = f, MoreArgs = list(drop = drop),
SIMPLIFY = FALSE)
f <- sort.int(unique.default(unlist(lapply(f, levels), FALSE, FALSE)))
result <- structure(.Data = vector("list", length(f)), names = f)
for (level in f)
result[[level]] <- lapply(x, `[[`, level)
lapply(lapply(result, close_index_gaps), as, "MOPMX")
}, sealed = SEALED)
setMethod("split", c("MOPMX", "ANY", "missing"), function(x, f, drop) {
split(x, f, FALSE)
}, sealed = SEALED)
setMethod("split", c("MOPMX", "ANY", "ANY"), function(x, f, drop) {
split(x, metadata2factorlist(x, f), drop)
}, sealed = SEALED)
setGeneric("plates", function(object, ...) standardGeneric("plates"))
setMethod("plates", "WMDS", function(object) {
object@plates
}, sealed = SEALED)
setMethod("plates", "WMD", function(object) {
list(object)
}, sealed = SEALED)
setMethod("plates", "list", function(object) {
to_opm_list.list(object, TRUE, TRUE, FALSE)
}, sealed = SEALED)
setMethod("plates", "MOPMX", function(object) {
unlist(lapply(object@.Data, plates), FALSE)
}, sealed = SEALED)
setGeneric("oapply", function(object, fun, ...) standardGeneric("oapply"))
setMethod("oapply", "OPM", function(object, fun, ...,
simplify = TRUE) {
fun(object, ...)
}, sealed = SEALED)
setMethod("oapply", "OPMS", function(object, fun, ...,
simplify = TRUE) {
result <- sapply(X = object@plates, FUN = fun, ..., simplify = simplify,
USE.NAMES = FALSE)
if (simplify && is.list(result))
result <- try_opms.list(result)
result
}, sealed = SEALED)
setMethod("oapply", "MOPMX", function(object, fun, ...,
simplify = TRUE) {
result <- sapply(X = object, FUN = fun, ..., simplify = simplify,
USE.NAMES = TRUE) # using object@.Data would lose the names
if (simplify && is.list(result))
tryCatch(expr = new(class(object), result[!vapply(result, is.null, NA)]),
error = function(e) result)
else
result
}, sealed = SEALED)
setGeneric("sort")
setMethod("sort", c("OPM", "missing"), function(x, decreasing, ...) {
x
}, sealed = SEALED)
setMethod("sort", c("OPM", "ANY"), function(x, decreasing, ...) {
x
}, sealed = SEALED)
setMethod("sort", c("OPMS", "missing"), function(x, decreasing, ...) {
sort(x = x, decreasing = FALSE, ...)
}, sealed = SEALED)
setMethod("sort", c("OPMS", "ANY"), function(x, decreasing, by = "setup_time",
parse = identical(by, "setup_time"), exact = TRUE, strict = TRUE,
na.last = TRUE) {
if (is.list(by)) {
keys <- lapply(X = by, FUN = metadata, object = x, exact = exact,
strict = strict)
if (!strict)
if (!length(keys <- keys[!vapply(keys, is.null, NA)]))
return(x)
} else if (is.character(by)) {
case(length(by),
stop("if a character scalar, 'by' must not be empty"),
switch(EXPR = by,
hours = keys <- list(hours(x, "max")),
{
keys <- csv_data(object = x, what = by)
if (L(parse))
keys <- must(parse_time(keys))
keys <- list(keys)
}
),
# note that this works via the 'keys' argument, not the 'by' argument
keys <- lapply(X = by, FUN = csv_data, object = x)
)
} else {
stop("'by' must be a list or a character vector")
}
keys <- insert(object = keys, decreasing = decreasing, na.last = na.last,
.force = TRUE)
x@plates <- x@plates[do.call(order, keys)]
x
}, sealed = SEALED)
setMethod("sort", c("MOPMX", "missing"), function(x, decreasing, ...) {
sort(x = x, decreasing = FALSE, ...)
}, sealed = SEALED)
setMethod("sort", c("MOPMX", "ANY"), function(x, decreasing,
by = c("plate.type", "length"), exact = TRUE, strict = TRUE,
na.last = TRUE, ...) {
if (length(x) < 2L)
return(x)
selection <- tryCatch(expr = match.arg(by), error = function(e) "other")
case(selection,
length = criterion <- lengths(x, FALSE),
plate.type = criterion <- plate_type(x),
other = {
m <- metadata(object = x, key = by, exact = exact, strict = strict)
criterion <- sapply(X = m, FUN = max, na.rm = TRUE, USE.NAMES = FALSE)
}
)
x[sort.list(x = criterion, decreasing = decreasing, na.last = na.last, ...)]
}, sealed = SEALED)
setGeneric("unique")
setMethod("unique", c("OPM", "ANY"), function(x, incomparables, ...) {
x
}, sealed = SEALED)
setMethod("unique", c("OPM", "missing"), function(x, incomparables, ...) {
x
}, sealed = SEALED)
setMethod("unique", c("OPMS", "missing"), function(x, incomparables, ...) {
unique(x = x, incomparables = FALSE, ...)
}, sealed = SEALED)
setMethod("unique", c("OPMS", "ANY"), function(x, incomparables, ...) {
x[!duplicated(x = x, incomparables = incomparables, ...)]
}, sealed = SEALED)
setMethod("unique", c("MOPMX", "missing"), function(x, incomparables, ...) {
unique(x = x, incomparables = FALSE, ...)
}, sealed = SEALED)
setMethod("unique", c("MOPMX", "ANY"), function(x, incomparables, ...) {
x[!duplicated(x = x, incomparables = incomparables, ...)]
}, sealed = SEALED)
setGeneric("rev")
setMethod("rev", "OPM", function(x) {
x
}, sealed = SEALED)
setMethod("rev", "OPMS", function(x) {
x@plates <- x@plates[seq.int(length(x), 1L)]
x
}, sealed = SEALED)
setGeneric("rep")
setMethod("rep", "OPM", function(x, ...) {
x <- rep(list(x), ...)
case(length(x), NULL, x[[1L]], new(Class = "OPMS", plates = x))
}, sealed = SEALED)
setMethod("rep", "OPMS", function(x, ...) {
x <- rep(x@plates, ...)
case(length(x), NULL, x[[1L]], new(Class = "OPMS", plates = x))
}, sealed = SEALED)
setGeneric("extract", function(object, ...) standardGeneric("extract"))
setMethod("extract", "MOPMX", function(object, as.labels,
subset = opm_opt("curve.param"), ci = FALSE, trim = "full",
dataframe = FALSE, as.groups = NULL, sep = " ", ...) {
convert_row_groups <- function(x) { # for generated matrices only
result <- unlist(lapply(x, rownames), FALSE, FALSE)
result <- sort.int(unique.default(result))
result <- structure(.Data = character(length(result)), names = result)
for (mat in x) # last one wins, as in collect()
result[rownames(mat)] <- as.character(attr(mat, "row.groups"))
as.factor(unname(result))
}
protected <- function(x) x[seq_len(match(RESERVED_NAMES[["parameter"]], x))]
group_columns <- function(x, other) { # for generated data frames only
x <- metadata_key(x)
setdiff(c(unlist(x, FALSE, FALSE), names(attr(x, "combine"))), other)
}
if (all.rows <- is.na(L(dataframe)))
dataframe <- TRUE
x <- lapply(X = object, FUN = extract, as.labels = as.labels,
subset = subset, ci = ci, trim = trim, dataframe = dataframe,
as.groups = as.groups, sep = sep, ...)
plot.na <- unique.default(unlist(lapply(x, attr, "plot.NA"), FALSE, FALSE))
if (!dataframe) {
if (!length(as.labels)) { # create potentially unique row names
if (is.null(base <- names(object)))
base <- plate_type(object)
for (i in seq_along(x))
rownames(x[[i]]) <- paste(base[[i]], seq_len(nrow(x[[i]])), sep = ".")
}
return(structure(.Data = collect(x, "datasets"), plot.NA = plot.na,
row.groups = if (length(as.groups)) convert_row_groups(x) else NULL))
}
p.col <- protected(colnames(x[[1L]]))
g.col <- group_columns(as.groups, p.col)
if (length(as.labels) && !all.rows) {
l.col <- setdiff(p.col, g.col)
if (is.null(base <- names(object)))
base <- plate_type(object)
for (i in seq_along(x))
rownames(x[[i]]) <- make.unique(do.call(paste, c(x[[i]][, l.col,
drop = FALSE], list(X = base[[i]], sep = sep))))
x <- collect(x = x, what = "datasets", dataframe = TRUE,
stringsAsFactors = TRUE)
} else {
x <- collect(x = x, what = "rows", dataframe = TRUE,
stringsAsFactors = TRUE)
}
rownames(x) <- NULL
x[, c(p.col, setdiff(colnames(x), c(p.col, g.col)), g.col), drop = FALSE]
}, sealed = SEALED)
setMethod("extract", "OPMS", function(object, as.labels,
subset = opm_opt("curve.param"), ci = FALSE, trim = "full",
dataframe = FALSE, as.groups = NULL, sep = " ", dups = "warn",
exact = TRUE, strict = TRUE, full = TRUE, max = 10000L, ...) {
do_extract <- function(what, join, dups = "ignore") {
extract_columns(object, what = what, join = join, sep = sep, dups = dups,
exact = exact, strict = strict)
}
create_groups <- function(x, join, ci) {
result <- do_extract(x, join)
if (join) {
result <- as.factor(result)
if (ci)
result <- rep(result, each = 3L)
} else if (ci)
result <- result[rep(seq_len(nrow(result)), each = 3L), , drop = FALSE]
result
}
# Collect parameters in a matrix
subset <- match.arg(subset, c(HOUR,
unlist(map_param_names(plain = TRUE, disc = TRUE))))
if (subset == DISC_PARAM) {
ci <- FALSE
result <- discretized(object, full = full, max = max, ...)
} else if (subset == HOUR) {
ci <- FALSE
result <- as.matrix(hours(object, "max"))
colnames(result) <- plate_type(object)
rownames(result) <- rep.int(HOUR, nrow(result))
} else {
result <- do.call(rbind, lapply(X = object@plates, FUN = aggregated,
subset = subset, ci = ci, trim = trim, full = full, max = max, ...))
}
if (dataframe) {
orig.rownames <- rownames(result)
result <- as.data.frame(result)
if (length(as.labels)) {
columns <- do_extract(as.labels, join = FALSE)
if (ci)
columns <- columns[rep(seq_len(nrow(columns)), each = 3L), ,
drop = FALSE]
#columns <- cbind(columns, rownames(result))
columns <- cbind(columns, orig.rownames)
colnames(columns)[ncol(columns)] <- RESERVED_NAMES[["parameter"]]
rownames(result) <- rownames(columns) # otherwise a warning is likely
result <- cbind(columns, result)
} else {
params <- rownames(result)
rownames(result) <- seq_len(nrow(result))
result <- cbind(params, result)
colnames(result)[1L] <- RESERVED_NAMES[["parameter"]]
}
if (length(as.groups))
result <- cbind(result, create_groups(as.groups, FALSE, ci))
} else {
if (length(as.labels)) {
labels <- do_extract(as.labels, join = TRUE, dups = dups)
rownames(result) <- if (ci)
paste(rep(labels, each = 3L), rownames(result))
else
labels
} else {
rownames(result) <- if (ci)
paste(rownames(result), rep(seq_len(nrow(result) / 3L), each = 3L),
sep = sep)
else
seq_len(nrow(result))
}
if (length(as.groups))
attr(result, "row.groups") <- create_groups(as.groups, TRUE, ci)
if (subset == HOUR)
attr(result, "plot.NA") <- 0
}
result
}, sealed = SEALED)
setMethod("extract", "data.frame", function(object, as.groups = TRUE,
norm.per = c("row", "column", "none"), norm.by = TRUE, subtract = TRUE,
direct = inherits(norm.by, "AsIs"), dups = c("warn", "error", "ignore"),
split.at = param_names("split.at")) {
do_norm <- function(x, row, by, direct, subtract) sweep(x, 2L - row,
if (direct)
by
else if (row)
rowMeans(x[, by, drop = FALSE])
else
colMeans(x[by, , drop = FALSE]), if (subtract)
"-"
else
"/"
)
LL(subtract, direct)
param.pos <- assert_splittable_matrix(object, split.at)
num.pos <- seq.int(param.pos + 1L, ncol(object))
case(match.arg(norm.per), # compute the normalisation if requested
none = NULL,
row = object[, num.pos] <- do_norm(object[, num.pos, drop = FALSE],
TRUE, norm.by, direct, subtract),
column = object[, num.pos] <- do_norm(object[, num.pos, drop = FALSE],
FALSE, norm.by, direct, subtract)
)
if (!length(as.groups) || identical(c(as.groups), FALSE))
return(object)
# make list or vector from the grouping columns and note its length
# metadata_key() enables lists to be passed as used for selecting metadata
as.groups <- metadata_key(as.groups, FALSE)
if (!is.logical(as.groups) && anyDuplicated(as.groups))
case(match.arg(dups), ignore = as.null, warn = warning, error = stop)(
"duplicated grouping values")
as.groups <- unclass(object[, seq_len(param.pos - 1L), drop = FALSE][,
as.groups, drop = FALSE])
gl <- length(as.groups)
# compute the means and CIs with respect to the stated grouping
aggr.mean <- aggregate(object[, num.pos, drop = FALSE], by = as.groups,
FUN = mean)
aggr.CI <- aggregate(object[, num.pos, drop = FALSE], by = as.groups,
FUN = var) # first the variances
# The output has to be organized in a certain structure, three rows per group:
# first the mean, second the lower CI limit third the upper CI limit. This
# step creates the factor-data part up to the parameter column.
result <- as.data.frame(sapply(aggr.mean[, seq_len(gl), drop = FALSE],
rep, each = 3L))
colnames(result) <- names(as.groups)
result[, RESERVED_NAMES[["parameter"]]] <- as.factor(unlist(map_param_names(
subset = as.character(object[1L, param.pos]), ci = TRUE)))
# Reduce to numeric part and get CIs from means and variances.
aggr.mean <- as.matrix(aggr.mean[, seq.int(gl + 1L, ncol(aggr.mean)),
drop = FALSE])
aggr.CI <- norm.ci(t0 = aggr.mean,
var.t0 = aggr.CI[, seq.int(gl + 1L, ncol(aggr.CI)), drop = FALSE])
aggr.CI <- as.matrix(aggr.CI[, -1L, drop = FALSE]) # remove the 'conf' column
# Prepare the numerical part of the results.
output <- matrix(ncol = 3L * nrow(aggr.mean), nrow = ncol(aggr.mean))
pos.1 <- ncol(aggr.CI)
pos.2 <- seq.int(pos.1 / 2L + 1L, pos.1)
pos.1 <- seq_len(pos.1 / 2L)
for (i in seq_len(nrow(aggr.mean)))
output[, seq.int(i * 3L - 2L, 3L * i)] <- c(aggr.mean[i, , drop = TRUE],
aggr.CI[i, pos.1, drop = TRUE], aggr.CI[i, pos.2, drop = TRUE])
output <- t(output)
colnames(output) <- colnames(aggr.mean)
# Done.
cbind(result, output)
}, sealed = SEALED)
setGeneric("extract_columns",
function(object, ...) standardGeneric("extract_columns"))
setMethod("extract_columns", "WMD", function(object, what, join = FALSE,
sep = " ", dups = c("warn", "error", "ignore"), factors = TRUE,
exact = TRUE, strict = TRUE) {
what <- metadata_key(what, FALSE, NULL)
if (is.logical(what)) {
result <- 1L
if (!L(join)) {
result <- as.data.frame(result)
colnames(result) <- get("group.name", OPM_OPTIONS)
}
return(result)
}
result <- metadata(object, what, exact, strict)
result <- if (is.list(result))
rapply(result, as.character)
else
as.character(result)
if (L(join)) {
result <- paste0(result, collapse = sep)
} else {
result <- as.list(result)
if (is.null(names(result)))
names(result) <- paste0(what, collapse = get("key.join", OPM_OPTIONS))
result <- as.data.frame(result, optional = TRUE, stringsAsFactors = factors)
if (ncol(result) > length(colnames(result)))
colnames(result) <- paste0(what, collapse = get("key.join", OPM_OPTIONS))
if (is.list(attr(what, "combine")))
result <- extract_columns(result, attr(what, "combine"),
factors = factors, direct = TRUE)
}
result
}, sealed = SEALED)
setMethod("extract_columns", "WMDS", function(object, what, join = FALSE,
sep = " ", dups = c("warn", "error", "ignore"), factors = TRUE,
exact = TRUE, strict = TRUE) {
what <- metadata_key(what, FALSE, NULL)
if (is.logical(what)) {
result <- if (L(what))
rep.int(1L, length(object))
else
seq_len(length(object))
if (!L(join)) {
result <- as.data.frame(result)
colnames(result) <- get("group.name", OPM_OPTIONS)
}
return(result)
}
result <- metadata(object, what, exact, strict)
result <- if (is.list(result))
lapply(result, rapply, as.character)
else
as.list(as.character(result))
if (L(join)) {
result <- unlist(lapply(X = result, FUN = paste0, collapse = sep))
msg <- if (is.dup <- anyDuplicated(result))
paste("duplicated label:", result[is.dup])
else
NULL
if (length(msg))
case(match.arg(dups), ignore = as.null, warn = warning, error = stop)(msg)
} else {
result <- must(do.call(rbind, result))
result <- as.data.frame(result, optional = TRUE, stringsAsFactors = factors)
if (ncol(result) > length(colnames(result)))
colnames(result) <- paste0(what, collapse = get("key.join", OPM_OPTIONS))
if (is.list(attr(what, "combine")))
result <- extract_columns(result, attr(what, "combine"),
factors = factors, direct = TRUE)
}
result
}, sealed = SEALED)
setMethod("extract_columns", "data.frame", function(object, what,
as.labels = NULL, as.groups = NULL, sep = opm_opt("comb.value.join"),
factors = is.list(what), direct = is.list(what) || inherits(what, "AsIs")) {
join <- function(x, what, sep)
do.call(paste, c(x[, what, drop = FALSE], list(sep = sep)))
find_stuff <- function(x, what) {
x <- x[, vapply(x, inherits, NA, what), drop = FALSE]
if (!ncol(x))
stop("no data of class(es) ", paste0(what, collapse = "/"), " found")
as.matrix(x)
}
LL(direct, factors)
if (direct) {
if (is.list(what)) {
if (is.null(names(what)))
names(what) <- vapply(what, paste0, "",
collapse = get("comb.key.join", OPM_OPTIONS))
result <- object
what <- what[!match(names(what), colnames(result), 0L)]
if (factors)
for (i in seq_along(what))
result[, names(what)[i]] <- as.factor(join(object, what[[i]], sep))
else
for (i in seq_along(what))
result[, names(what)[i]] <- join(object, what[[i]], sep)
if (length(as.labels))
rownames(result) <- join(object, as.labels, sep)
attr(result, "joined.columns") <- c(attr(result, "joined.columns"), what)
} else {
result <- join(object, what, sep)
if (length(as.labels))
names(result) <- join(object, as.labels, sep)
if (factors)
result <- as.factor(result)
}
} else {
result <- find_stuff(object, what)
if (length(as.labels))
rownames(result) <- join(object, as.labels, sep)
}
if (length(as.groups))
attr(result, "row.groups") <- as.factor(join(object, as.groups, sep))
result
}, sealed = SEALED)
setGeneric("as.data.frame")
setMethod("as.data.frame", "OPM", function(x, row.names = NULL,
optional = FALSE, sep = "_", csv.data = TRUE, settings = TRUE,
include = FALSE, ..., stringsAsFactors = default.stringsAsFactors()) {
result <- as.data.frame(wells(x), NULL, optional, ...,
stringsAsFactors = stringsAsFactors)
colnames(result) <- RESERVED_NAMES[["well"]]
if (L(csv.data))
result <- data.frame(as.data.frame(as.list(x@csv_data[CSV_NAMES]), NULL,
optional, ..., stringsAsFactors = stringsAsFactors), result,
check.names = FALSE, stringsAsFactors = FALSE)
if (is.logical(include)) {
if (L(include))
result <- data.frame(result, to_metadata(x, stringsAsFactors, optional),
check.names = FALSE, stringsAsFactors = FALSE)
} else if (length(include)) {
result <- data.frame(result, extract_columns(object = x, what = include,
factors = stringsAsFactors), check.names = FALSE,
stringsAsFactors = FALSE)
}
rownames(result) <- row.names
if (length(sep))
colnames(result) <- gsub("\\W+", sep, colnames(result), FALSE, TRUE)
result
}, sealed = SEALED)
setMethod("as.data.frame", "OPMA", function(x, row.names = NULL,
optional = FALSE, sep = "_", csv.data = TRUE, settings = TRUE,
include = FALSE, ..., stringsAsFactors = default.stringsAsFactors()) {
result <- as.data.frame(t(x@aggregated), NULL, optional, ...,
stringsAsFactors = stringsAsFactors)
if (length(sep))
colnames(result) <- gsub("\\W+", sep, colnames(result), FALSE, TRUE)
result <- data.frame(callNextMethod(x, row.names, optional, sep, csv.data,
settings, include, ..., stringsAsFactors = stringsAsFactors), result,
check.names = FALSE, stringsAsFactors = FALSE)
if (L(settings)) {
settings <- x@aggr_settings[c(SOFTWARE, VERSION, METHOD)]
if (length(sep)) {
names(settings) <- gsub("\\W+", sep, names(settings), FALSE, TRUE)
names(settings) <- paste("Aggr", names(settings), sep = sep)
} else {
names(settings) <- paste("Aggr", names(settings),
sep = get("comb.key.join", OPM_OPTIONS))
}
result <- data.frame(result, as.data.frame(settings, NULL, optional, ...,
stringsAsFactors = stringsAsFactors), check.names = FALSE,
stringsAsFactors = FALSE)
}
result
}, sealed = SEALED)
setMethod("as.data.frame", "OPMD", function(x, row.names = NULL,
optional = FALSE, sep = "_", csv.data = TRUE, settings = TRUE,
include = FALSE, ..., stringsAsFactors = default.stringsAsFactors()) {
result <- callNextMethod(x, row.names, optional, sep, csv.data, settings,
include, ..., stringsAsFactors = stringsAsFactors)
result$Discretized <- x@discretized
if (settings) {
settings <- x@disc_settings[c(SOFTWARE, VERSION, METHOD)]
if (length(sep)) {
names(settings) <- gsub("\\W+", sep, names(settings), FALSE, TRUE)
names(settings) <- paste("Disc", names(settings), sep = sep)
} else
names(settings) <- paste("Disc", names(settings),
sep = get("comb.key.join", OPM_OPTIONS))
result <- data.frame(result, as.data.frame(settings, NULL, optional, ...,
stringsAsFactors = stringsAsFactors), check.names = FALSE,
stringsAsFactors = FALSE)
}
result
}, sealed = SEALED)
setMethod("as.data.frame", "OPMS", function(x, row.names = NULL,
optional = FALSE, sep = "_", csv.data = TRUE, settings = TRUE,
include = FALSE, ..., stringsAsFactors = default.stringsAsFactors()) {
if (!length(row.names))
row.names <- vector("list", length(x@plates))
do.call(rbind, mapply(FUN = as.data.frame, x = x@plates,
row.names = row.names, MoreArgs = list(optional = optional, sep = sep,
csv.data = csv.data, settings = settings, include = include, ...,
stringsAsFactors = stringsAsFactors),
SIMPLIFY = FALSE, USE.NAMES = FALSE))
}, sealed = SEALED)
setMethod("as.data.frame", "MOPMX", function(x, row.names = NULL,
optional = FALSE, sep = "_", csv.data = TRUE, settings = TRUE,
include = FALSE, ..., stringsAsFactors = default.stringsAsFactors()) {
if (!length(row.names))
row.names <- vector("list", length(x@.Data))
do.call(rbind, mapply(FUN = as.data.frame, x = x@.Data,
row.names = row.names, MoreArgs = list(optional = optional, sep = sep,
csv.data = csv.data, settings = settings, include = include, ...,
stringsAsFactors = stringsAsFactors),
SIMPLIFY = FALSE, USE.NAMES = FALSE))
}, sealed = SEALED)
setOldClass("kegg_compounds")
setMethod("as.data.frame", "kegg_compounds", function(x, row.names = NULL,
optional = TRUE, ..., stringsAsFactors = FALSE) {
result <- lapply(x, as.data.frame, row.names, optional, ...,
stringsAsFactors = stringsAsFactors)
do.call(rbind, structure(.Data = result, names = names(x)))
}, sealed = SEALED)
setOldClass("kegg_compound")
setMethod("as.data.frame", "kegg_compound", function(x, row.names = NULL,
optional = TRUE, ..., stringsAsFactors = FALSE) {
# store database links for later
links <- strsplit(as.character(x$DBLINKS), "\\s*:\\s*", FALSE, TRUE)
links <- do.call(rbind, links)
links <- structure(.Data = links[, 2L], names = links[, 1L])
# get non-link components
wanted <- c("ENTRY", "NAME", "FORMULA", "SEEALSO", "BRITE", "ACTIVITY",
"EXACT_MASS")
x <- structure(.Data = x[wanted], names = wanted)
x$EXACT_MASS <- must(as.numeric(x$EXACT_MASS))
# 'ACTIVITY' is actually only present in KEGG 'drug' descriptions
x$ACTIVITY <- paste0(x$ACTIVITY, collapse = " ")
x$NAME <- sub("\\s*;\\s*$", "", x$NAME, FALSE, TRUE)
x$SEEALSO <- grep(pat <- "^Same\\s+as:\\s*", x$SEEALSO, FALSE, TRUE, TRUE)
x$SEEALSO <- sub(pat, "", x$SEEALSO, FALSE, TRUE)
x$SEEALSO <- gsub("\\s+", "||", x$SEEALSO, FALSE, TRUE)
## Note that several hierarchies may be present.
## Maybe we can use YAML to better represent this, either directly or after
## conversion to nested list.
x$BRITE <- paste0(x$BRITE, collapse = "\n")
x <- lapply(x, paste0, collapse = "||")
# add database-link components
x$CAS <- if (pos <- match("CAS", names(links), 0L))
sub("\\s+", "||", links[[pos]], FALSE, TRUE)
else
NA_character_
x$ChEBI <- if (pos <- match("ChEBI", names(links), 0L))
sub("\\s+", "||", links[[pos]], FALSE, TRUE)
else
NA_character_
# done
x[!nzchar(x)] <- NA_character_
as.data.frame(x, row.names, optional, ...,
stringsAsFactors = stringsAsFactors)
}, sealed = SEALED)
setMethod("flatten", "OPM", function(object, include = NULL, fixed = list(),
factors = TRUE, exact = TRUE, strict = TRUE, full = TRUE,
numbers = FALSE, ...) {
# Convert to flat data frame
well.names <- if (L(numbers))
seq_len(ncol(object@measurements) - 1L)
else
well.names <- wells(object, full = full, ...)
## the home-brewn solution was much faster than reshape():
# if (factors)
# well.names <- as.factor(well.names)
# result <- reshape(as.data.frame(object@measurements,
# stringsAsFactors = factors), direction = "long", idvar = "Hour",
# varying = wells(object), v.names = "Value", timevar = "Well",
# times = well.names)
# colnames(result)[1L] <- "Time"
times <- hours(object, "all")
rep.times <- rep.int(times, length(well.names))
rep.wells <- rep(well.names, each = length(times))
result <- data.frame(time = rep.times, well = rep.wells,
value = as.vector(object@measurements[, -1L]), check.names = FALSE,
stringsAsFactors = factors)
colnames(result) <- RESERVED_NAMES[colnames(result)]
if (length(fixed)) # Include fixed stuff
result <- data.frame(as.list(fixed), result, check.names = FALSE,
stringsAsFactors = factors)
if (length(include)) # Pick metadata and include them in the data frame
result <- data.frame(metadata(object, include, exact = exact,
strict = strict), result, stringsAsFactors = factors,
check.names = FALSE)
result
}, sealed = SEALED)
setMethod("flatten", "OPMS", function(object, include = NULL, fixed = list(),
...) {
nums <- paste(RESERVED_NAMES[["plate"]], seq_along(object@plates))
nums <- lapply(as.list(nums), `names<-`, RESERVED_NAMES[["plate"]])
nums <- lapply(nums, c, fixed, recursive = FALSE)
do.call(rbind, mapply(FUN = flatten, object = object@plates, fixed = nums,
MoreArgs = list(include = include, ...), SIMPLIFY = FALSE))
}, sealed = SEALED)
setMethod("flatten", "MOPMX", function(object, include = NULL, fixed = list(),
factors = FALSE, ...) {
pt <- vapply(object@.Data, plate_type, "")
pt <- lapply(as.list(pt), `names<-`, CSV_NAMES[["PLATE_TYPE"]])
pt <- lapply(pt, c, fixed, recursive = FALSE)
x <- mapply(FUN = flatten, object = object@.Data, fixed = pt,
MoreArgs = list(include = include, factors = factors, ...),
SIMPLIFY = FALSE, USE.NAMES = FALSE)
nr <- vapply(x, ncol, 0L)
if (any(bad <- nr < max(nr))) {
pn <- RESERVED_NAMES[["plate"]]
pn <- structure(.Data = list(paste(pn, 1L)), names = pn)
for (i in seq_along(which(bad)))
x[[i]] <- data.frame(x[[i]], pn, stringsAsFactors = factors,
check.names = FALSE)
}
do.call(rbind, x)
}, sealed = SEALED)
setGeneric("to_yaml", function(object, ...) standardGeneric("to_yaml"))
setMethod("to_yaml", "list", function(object, sep = TRUE,
line.sep = "\n", json = FALSE, listify = nodots, nodots = FALSE, ...) {
replace_dots <- function(x) {
if (any(bad <- grepl(".", x, FALSE, FALSE, TRUE)))
x[bad] <- paste0("_", chartr(".", "_", x[bad]))
x
}
to_map <- function(items) if (is.null(names(items)))
items
else
as.list(items)
LL(sep, line.sep, json, listify, nodots)
if (listify)
object <- rapply(object, to_map, "ANY", NULL, "replace")
if (nodots)
object <- map_names(object, replace_dots)
if (json) {
result <- toJSON(object, "C")
} else {
result <- as.yaml(x = object, line.sep = line.sep, ...)
if (sep)
result <- sprintf(sprintf("---%s%%s%s", line.sep, line.sep), result)
}
result
}, sealed = SEALED)
setMethod("to_yaml", "YAML_VIA_LIST", function(object, ...) {
n <- names(object)
object <- as(object, "list")
if (is.null(names(object)) && length(object) == length(n))
names(object) <- n
to_yaml(object, ...)
}, sealed = SEALED)
setMethod("to_yaml", "MOPMX", function(object, ...) {
to_yaml(lapply(object, as, "list"), ...)
}, sealed = SEALED)
setGeneric("opmx", function(object, ...) standardGeneric("opmx"))
setMethod("opmx", "data.frame", function(object,
format = c("horizontal", "rectangular", "vertical"), plate.type = NULL,
position = NULL, well = NULL, prefix = "T_", sep = object[1L, 1L],
full.name = NULL, setup.time = date(), filename = "", interval = NULL,
na.strings = "NA", dec = ".") {
try_numeric <- function(x, na.strings, dec) {
if (is.numeric(x))
return(x)
type.convert(x, na.strings, TRUE, dec)
}
convert_interval <- function(x, y) {
if (length(x) == 1L)
return(x * (seq_len(y) - 1L))
if (length(x) != y)
stop(sprintf("expected 1 or %i as length of non-empty 'interval', got %i",
y, length(x)))
if (!is.numeric(x))
stop("non-empty 'interval' must be numeric")
x
}
# Create a matrix acceptable as 'measurements' entry.
#
convert_rectangular_matrix <- function(x, sep, interval, na.strings, dec) {
empty <- function(x) {
if (is.character(x))
!nzchar(x) | is.na(x)
else
is.na(x)
}
convert_time_point <- function(x, header, na.strings, dec) {
make_coords <- function(left, right, na.strings, dec) {
vapply(toupper(left), sprintf, character(length(right)),
fmt = "%s%02i", try_numeric(right, na.strings, dec))
}
if (all(x[-1L, 1L] %in% c(LETTERS, letters))) {
coords <- make_coords(x[-1L, 1L], unlist(x[1L, -1L], FALSE, FALSE),
na.strings, dec)
x <- t(as.matrix(x[-1L, -1L, drop = FALSE]))
} else if (all(x[1L, -1L] %in% c(LETTERS, letters))) {
coords <- make_coords(x[1L, -1L], x[-1L, 1L], na.strings, dec)
x <- as.matrix(x[-1L, -1L, drop = FALSE])
} else if (header) {
stop("expected row and column names comprising letters or integers")
} else if (nrow(x) > ncol(x)) {
coords <- make_coords(LETTERS[seq_len(ncol(x))], seq_len(nrow(x)),
na.strings, dec)
x <- as.matrix(x)
} else {
coords <- make_coords(LETTERS[seq_len(nrow(x))], seq_len(ncol(x)),
na.strings, dec)
x <- t(as.matrix(x))
}
dim(x) <- NULL
if (!is.numeric(x <- try_numeric(x))) {
warning("skipping uninterpretable (non-numeric) alleged time point")
return(NULL)
}
names(x) <- coords
if (is.unsorted(names(x)))
return(x[order(names(x))])
x
}
if (any(pos <- vapply(x, function(x) all(empty(x)), NA)))
x <- x[, !pos, drop = FALSE] # remove all-NA columns
if (!length(sep)) {
pos <- Reduce(`&`, lapply(x, empty)) # split at empty rows
pos <- sections(pos, FALSE)
header <- FALSE
} else if (is.character(sep)) {
pos <- logical(nrow(x))
for (i in seq_along(x))
if (any(pos <- x[, i] %in% sep)) {
x <- x[, c(i, setdiff(seq_along(x), i)), drop = FALSE]
break
}
if (!any(pos))
stop("'sep' found in none of the columns")
pos <- sections(pos, TRUE)
header <- TRUE
} else if (is.numeric(sep) && length(sep) == 1L && !is.na(sep) && sep > 0) {
if (nrow(x) %% sep > 0L)
stop("number of rows must be a multiple of any number given as 'sep'")
pos <- factor(rep(seq.int(nrow(x) / sep), each = sep))
header <- FALSE
} else {
stop("'sep' must be empty or character vector or positive number")
}
x <- split.data.frame(x, pos)
x <- do.call(rbind, lapply(x, convert_time_point, header, na.strings, dec))
if (any(bad <- apply(is.na(x), 2L, all)))
x <- x[, !bad, drop = FALSE] # removal of all-NA columns
if (is.integer(x))
storage.mode(x) <- "double"
x <- cbind(if (length(interval))
convert_interval(interval, nrow(x))
else
seq_len(nrow(x)) - 1L, x)
colnames(x)[1L] <- HOUR
rownames(x) <- NULL
x
}
# Create a matrix acceptable as 'measurements' entry.
#
convert_vertical_matrix <- function(x, interval, na.strings, dec) {
select_columns <- function(x) {
n <- clean_coords(colnames(x))
if (any(ok <- grepl("^[A-H]\\d{2}$", n, FALSE, TRUE))) {
colnames(x)[ok] <- n[ok]
} else if (any(ok <- grepl("^\\d{3}$", n, FALSE, TRUE))) {
colnames(x)[ok] <- rownames(WELL_MAP)[as.integer(colnames(x)[ok])]
} else if (any(ok <- grepl("^V\\d{2}$", n, FALSE, TRUE))) {
colnames(x)[ok] <- rownames(WELL_MAP)[
as.integer(chartr("V", " ", colnames(x)[ok]))]
} else {
ok <- !logical(ncol(x))
if (!length(interval) && is.integer(attr(x, "row.names")))
ok[1L] <- FALSE # first column contains time points
colnames(x)[ok] <- rownames(WELL_MAP)[seq_along(which(ok))]
}
cbind(if (length(interval))
convert_interval(interval, nrow(x))
else if (any(!ok))
x[, !ok, drop = FALSE][, 1L]
else
rownames(x), x[, ok, drop = FALSE])
}
x <- try_numeric(as.matrix(select_columns(x)), na.strings, dec)
if (is.integer(x))
storage.mode(x) <- "double"
else if (!is.double(x))
stop("could not convert mesurements to numeric type")
rownames(x) <- NULL
colnames(x)[1L] <- HOUR
x
}
# Where 'x' must be a matrix acceptable as 'measurements' entry, but
# optionally containing NA values.
#
filter_times <- function(x) {
if (!any(bad <- rowSums(is.na(x)) > 0L))
return(x)
warning("removing ", sum(bad), " time points that contain NAs")
x[!bad, , drop = FALSE]
}
# At this stage, 'x' must be a matrix acceptable as 'measurements' entry, the
# only exception being that rows with NAs are removed. Not used for the
# 'horizontal' format.
#
create_opm_object <- function(x, position, plate.type, full.name, setup.time,
filename) {
L(plate.type, .msg = "plate type missing or non-unique")
L(position, .msg = "'position' missing or non-unique")
if (inherits(plate.type, "AsIs")) { # undocumented behaviour
plate.type <- unclass(plate.type)
} else {
plate.type <- custom_plate_normalize_all(plate.type)
custom_plate_assert(plate.type, colnames(x)[-1L])
if (!is.na(full <- full.name[plate.type]))
custom_plate_set_full(plate.type, full)
}
y <- c(L(filename), plate.type, position, L(setup.time))
names(y) <- CSV_NAMES
new(Class = "OPM", measurements = filter_times(x), csv_data = y,
metadata = list())
}
# 'plate.type' and 'full.name' must already be normalized at this stage.
#
register_substrates <- function(wells, plate.type, full.name) {
wn <- unique.default(wells) # already sorted at this stage
if (all(grepl("^\\s*[A-Za-z]\\s*\\d+\\s*$", wn, FALSE, TRUE))) {
map <- structure(.Data = clean_coords(wn), names = wn)
} else if (custom_plate_exists(plate.type)) {
map <- custom_plate_get(plate.type)
if (any(bad <- !wn %in% map))
stop("plate type '", plate.type, "' already exists but lacks ",
"substrate '", wn[bad][1L], "'")
map <- structure(.Data = names(map), names = map)
} else {
map <- structure(.Data = rownames(WELL_MAP)[seq_along(wn)], names = wn)
custom_plate_set(plate.type, structure(.Data = names(map), names = map))
}
if (!is.na(full <- full.name[plate.type]))
custom_plate_set_full(plate.type, full)
map_values(wells, map)
}
# A mapping of the column names of 'x' must already have been conducted at
# this stage.
#
convert_horizontal_format <- function(x, prefix, full.name, setup.time,
filename) {
repair_csv_data <- function(x, full.name, setup.time, filename) {
map <- c(CSV_NAMES, RESERVED_NAMES[["well"]])
map <- structure(.Data = map, names = chartr(" ", ".", map))
names(x) <- map_values(names(x), map)
n <- CSV_NAMES[["PLATE_TYPE"]]
if (pos <- match(n, colnames(x), 0L))
x[, pos] <- custom_plate_normalize_all(x[, pos])
else
x[, n] <- L(names(full.name),
.msg = "plate type neither in 'object' nor (uniquely) in 'full.name'")
n <- CSV_NAMES[["SETUP"]]
if (!n %in% names(x))
x[, n] <- setup.time
n <- CSV_NAMES[["FILE"]]
if (!n %in% names(x))
x[, n] <- filename
x
}
csv_positions <- function(x) {
pos <- get("csv.selection", OPM_OPTIONS)
pos <- unique.default(c(pos, CSV_NAMES[["PLATE_TYPE"]]))
match(pos, colnames(x))
}
time_point_columns <- function(x, prefix) {
first <- substring(x, 1L, nchar(prefix))
x <- substring(x, nchar(prefix) + 1L, nchar(x))
x <- suppressWarnings(as.numeric(x))
x[first != prefix] <- NA_real_
if (all(is.na(x)))
stop("no columns with time points found -- wrong prefix?")
x
}
per_plate_type <- function(cd, tp, x, md, full.name) {
pos <- match(RESERVED_NAMES[["well"]], colnames(md))
colnames(x) <- register_substrates(md[, pos],
cd[1L, CSV_NAMES[["PLATE_TYPE"]]], full.name)
md <- md[, -pos, drop = FALSE]
indexes <- cd[, get("csv.keys", OPM_OPTIONS), drop = FALSE]
indexes <- apply(indexes, 1L, paste0, collapse = " ")
indexes <- split.default(seq_len(ncol(x)), indexes)
result <- vector("list", length(indexes))
for (i in seq_along(indexes)) {
val <- x[, idx <- indexes[[i]], drop = FALSE]
result[[i]] <- new(Class = "OPM", csv_data = cd[idx[1L], ],
metadata = lapply(md[idx, , drop = FALSE], unique.default),
measurements = filter_times(cbind(tp,
val[, order(colnames(val)), drop = FALSE])))
}
case(length(result), NULL, result[[1L]],
new(Class = "OPMS", plates = result))
}
traverse_plate_types <- function(cd, tp, x, md, full.name) {
indexes <- split.default(seq_len(ncol(x)),
cd[, CSV_NAMES[["PLATE_TYPE"]]])
result <- vector("list", length(indexes))
for (i in seq_along(indexes)) {
idx <- indexes[[i]]
result[[i]] <- per_plate_type(cd[idx, , drop = FALSE], tp,
x[, idx, drop = FALSE], md[idx, , drop = FALSE], full.name)
}
names(result) <- names(indexes)
result
}
x <- x[order(x[, RESERVED_NAMES[["well"]]]), , drop = FALSE]
x <- repair_csv_data(x, full.name, setup.time, filename)
pos <- csv_positions(x)
cd <- as.matrix(x[, pos, drop = FALSE])
x <- x[, -pos, drop = FALSE]
tp <- time_point_columns(names(x), prefix)
md <- x[, is.na(tp), drop = FALSE]
x <- t(as.matrix(x[, !is.na(tp), drop = FALSE]))
rownames(x) <- NULL
tp <- matrix(tp[!is.na(tp)], nrow(x), 1L, FALSE, list(NULL, HOUR))
result <- traverse_plate_types(cd, tp, x, md, full.name)
case(length(result), NULL, result[[1L]], as(result, "MOPMX"))
}
# Only for the 'horizontal' format.
#
map_colnames <- function(x, plate.type, position, well) {
to_positions <- function(x) {
if (is.factor(x) || is.double(x))
x <- as.integer(x)
else if (!is.integer(x))
x <- as.integer(as.factor(x))
clean_plate_positions(paste(x, "A"))
}
map <- list()
map[[CSV_NAMES[["PLATE_TYPE"]]]] <- plate.type
map[[RESERVED_NAMES[["well"]]]] <- well
if (length(map)) {
map <- structure(.Data = names(map), names = unlist(map, TRUE, FALSE))
names(x) <- map_values(names(x), map)
}
if (length(position)) {
if (length(map))
position <- map_values(position, map)
wanted <- list(position)
names(wanted) <- pos <- CSV_NAMES[["POS"]]
x <- extract_columns(x, wanted)
x[, pos] <- to_positions(x[, pos])
}
x
}
prepare_full_name <- function(x) {
if (!length(x))
return(structure(.Data = character(), names = character()))
names(x) <- custom_plate_normalize_all(names(x))
x
}
for (i in which(vapply(object, is.factor, NA)))
object[, i] <- as.character(object[, i])
full.name <- prepare_full_name(full.name)
case(match.arg(format),
horizontal = convert_horizontal_format(map_colnames(object,
plate.type, position, well), prefix, full.name, setup.time, filename),
rectangular = create_opm_object(convert_rectangular_matrix(object, sep,
interval, na.strings, dec), position, plate.type, full.name,
setup.time, filename),
vertical = create_opm_object(convert_vertical_matrix(object, interval,
na.strings, dec), position, plate.type, full.name, setup.time, filename)
)
}, sealed = SEALED)
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.