blob: 72eceafb6843f2969eb9cc54526e68e1e076ecbe [file] [log] [blame]
#=============================================================================#
# Copyright (c) 2012, 2021 Stephan Wahlbrink and others.
#
# This program and the accompanying materials are made available under the
# terms of the Eclipse Public License 2.0 which is available at
# https://www.eclipse.org/legal/epl-2.0, or the Apache License, Version 2.0
# which is available at https://www.apache.org/licenses/LICENSE-2.0.
#
# SPDX-License-Identifier: EPL-2.0 OR Apache-2.0
#
# Contributors:
# Stephan Wahlbrink <sw@wahlbrink.eu> - initial API and implementation
#=============================================================================#
## data access (org.eclipse.statet.rj.services.utils.dataaccess) / data editor
sda002.checkDataStruct <- function(x.env, x.expr, xClass1, xDim) {
x <- eval(expr= x.expr)
if (class(x)[1] != xClass1) {
return (FALSE)
}
d <- dim(x)
if (length(d) < 2L) {
return (length(x) == xDim[1L])
}
else if (length(d) == 2) {
return (d[1L] == xDim[1L] && d[2L] == xDim[2L])
}
else {
return (FALSE)
}
}
sda002.getDataVectorValues <- function(x.env, x.expr, idxs, rowMapping) {
rowIdxs <- if (missing(rowMapping))
idxs[1L]:idxs[2L]
else
get(rowMapping, envir= .rj.tmp)[idxs[1L]:idxs[2L]]
x <- eval(expr= x.expr) [rowIdxs, drop= FALSE]
names(x) <- NULL
x
}
sda002.setDataVectorValues <- function(x.env, x.expr, idxs, values) {
expr <- quote(x[idxs[1L]:idxs[2L]] <- values)
expr[[2]][[2]] <- x.expr[[1]]
eval(expr= as.expression(expr))
TRUE
}
sda002.getDataVectorRowNames <- function(x.env, x.expr, idxs, rowMapping) {
x.names <- names(
eval(expr= x.expr) )
if (is.null(x.names) && missing(rowMapping)) {
return (NULL)
}
rowIdxs <- if (missing(rowMapping))
idxs[1L]:idxs[2L]
else
get(rowMapping, envir= .rj.tmp)[idxs[1L]:idxs[2L]]
if (!is.null(x.names))
names(rowIdxs) <- x.names[rowIdxs]
rowIdxs
}
sda002.getDataMatrixValues <- function(x.env, x.expr, idxs, rowMapping) {
rowIdxs <- if (missing(rowMapping))
idxs[1L]:idxs[2L]
else
get(rowMapping, envir= .rj.tmp)[idxs[1L]:idxs[2L]]
x <- eval(expr= x.expr) [rowIdxs, idxs[3L]:idxs[4L], drop= FALSE]
rownames(x) <- NULL
x
}
sda002.getDataMatrixRowNames <- function(x.env, x.expr, idxs, rowMapping) {
x.names <- rownames(
eval(expr= x.expr) )
if (is.null(x.names) && missing(rowMapping)) {
return (NULL)
}
rowIdxs <- if (missing(rowMapping))
idxs[1L]:idxs[2L]
else
get(rowMapping, envir= .rj.tmp)[idxs[1L]:idxs[2L]]
if (!is.null(x.names))
names(rowIdxs) <- x.names[rowIdxs]
rowIdxs
}
sda002.getDataArrayDimNames <- function(x.env, x.expr, idxs) {
x.dimnames <- dimnames(
eval(expr= x.expr) )
if (is.null(x.dimnames)) {
return (NULL)
}
names(x.dimnames)[idxs[1L]:idxs[2L]]
}
sda002.getDataArrayDimItemNames <- function(x.env, x.expr, dimIdx, idxs) {
x.dimnames <- dimnames(
eval(expr= x.expr) )
if (is.null(x.dimnames)) {
return (NULL)
}
x.dimnames[[dimIdx]][idxs[1L]:idxs[2L]]
}
sda002.getDataFrameValues <- function(x.env, x.expr, idxs, rowMapping) {
rowIdxs <- if (missing(rowMapping))
idxs[1L]:idxs[2L]
else
get(rowMapping, envir= .rj.tmp)[idxs[1L]:idxs[2L]]
x <- eval(expr= x.expr) [rowIdxs, idxs[3L]:idxs[4L], drop= FALSE]
attr(x, 'row.names') <- NULL
x
}
sda002.getDataFrameRowNames <- function(x.env, x.expr, idxs, rowMapping) {
x.names <- attr(
eval(expr= x.expr),
'row.names', exact= TRUE )
if (is.null(x.names) && missing(rowMapping)) {
return (NULL)
}
rowIdxs <- if (missing(rowMapping))
idxs[1L]:idxs[2L]
else
get(rowMapping, envir= .rj.tmp)[idxs[1L]:idxs[2L]]
if (!is.null(x.names))
names(rowIdxs) <- x.names[rowIdxs]
rowIdxs
}
sda002.getObject <- function(x.env, x.expr) {
eval(expr= x.expr)
}
.getDataLevelValues <- function(x, max= 1000) {
if (is.factor(x)) {
values <- levels(x)
if (any(is.na(x))) {
values <- c(values, NA)
}
}
else {
values <- sort(unique(x), na.last= TRUE)
}
if (length(values) > max) {
return (NULL)
}
return (values)
}
.getDataIntervalValues <- function(x) {
values <- c(min(x, na.rm= TRUE), max(x, na.rm= TRUE), if (any(is.na(x))) 1L else 0L)
return (values)
}
.searchDataTextValues <- function(x, type, pattern, max= 1000) {
if (type == 0L) { # Eclipse
values <- grep(pattern, x, ignore.case= TRUE, value= TRUE)
}
else if (type == 1L) {
values <- grep(pattern, x, ignore.case= FALSE, value= TRUE)
}
else if (type == 2L) {
values <- match(pattern, x)
if (!is.na(values)) {
values <- pattern
}
else {
values <- character(0)
}
}
else {
stop("Illegal argument: type")
}
if (length(values) > max) {
return (NULL)
}
return (values)
}
.formatInfo.maxLength <- 2L^20L
.formatInfo.sampleLength <- 2L^19L
.getFormatInfo <- function(x) {
if (length(x) > .formatInfo.maxLength) {
x <- sample(x, .formatInfo.sampleLength)
}
return (format.info(x))
}