[Genabel-commits] r1651 - in pkg/DatABEL: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Mar 18 16:25:07 CET 2014
Author: lckarssen
Date: 2014-03-18 16:25:06 +0100 (Tue, 18 Mar 2014)
New Revision: 1651
Modified:
pkg/DatABEL/R/apply2dfo.R
pkg/DatABEL/R/databel.R
pkg/DatABEL/R/databel2matrix.R
pkg/DatABEL/R/databel2text.R
pkg/DatABEL/R/databel_class.R
pkg/DatABEL/R/extract_text_file_columns.R
pkg/DatABEL/R/get_temporary_file_name.R
pkg/DatABEL/R/make_empty_fvf.R
pkg/DatABEL/R/matrix2databel.R
pkg/DatABEL/R/text2databel.R
pkg/DatABEL/man/DatABEL-package.Rd
pkg/DatABEL/man/databel-class.Rd
pkg/DatABEL/man/databel.Rd
Log:
Added @export roxygen tags to a bunch of DatABEL functions so that they end up in the NAMESPACE file. Also added @useDynLib to the databel_class.R file. The NAMESPACE file generated automatically by devtools::document() is now much closer to the hand-made one, but not completely ready yet.
Modified: pkg/DatABEL/R/apply2dfo.R
===================================================================
--- pkg/DatABEL/R/apply2dfo.R 2014-03-18 12:18:43 UTC (rev 1650)
+++ pkg/DatABEL/R/apply2dfo.R 2014-03-18 15:25:06 UTC (rev 1651)
@@ -27,7 +27,7 @@
#' applying the function
#'
#' @author Yurii Aulchenko
-#'
+#' @export
#' @examples
#' a <- matrix(rnorm(50), 10, 5)
#' rownames(a) <- paste("id", 1:10, sep="")
Modified: pkg/DatABEL/R/databel.R
===================================================================
--- pkg/DatABEL/R/databel.R 2014-03-18 12:18:43 UTC (rev 1650)
+++ pkg/DatABEL/R/databel.R 2014-03-18 15:25:06 UTC (rev 1651)
@@ -1,25 +1,27 @@
#' initiates databel object
#'
-#' this is a simple wrapper for "new" function
-#' creating databel object
+#' this is a simple wrapper for the "new" function
+#' creating a databel object
#'
#' @param baseobject name of the file or \link{databel-class} object
#' @param cachesizeMb cache size (amount of RAM) to be used
#' @param readonly readonly flag
-#'
+#'
#' @author Yurii Aulchenko
+#' @export
#'
-databel <- function(baseobject,cachesizeMb=64,readonly=TRUE)
+databel <- function(baseobject, cachesizeMb=64, readonly=TRUE)
{
# if (missing(cachesizeMb)) {
-# if (is(baseobject,"databel"))
+# if (is(baseobject,"databel"))
# {
# cachesizeMb <- cachesizeMb(baseobject)
# } else if (is(baseobject,"character")) {
# cachesizeMb <- 64
# }
# }
- ret <- new(Class="databel",baseobject=baseobject,cachesizeMb=cachesizeMb,readonly=readonly);
- return(ret)
+ ret <- new(Class="databel", baseobject=baseobject,
+ cachesizeMb=cachesizeMb, readonly=readonly);
+ return(ret)
}
Modified: pkg/DatABEL/R/databel2matrix.R
===================================================================
--- pkg/DatABEL/R/databel2matrix.R 2014-03-18 12:18:43 UTC (rev 1650)
+++ pkg/DatABEL/R/databel2matrix.R 2014-03-18 15:25:06 UTC (rev 1651)
@@ -11,6 +11,7 @@
#' @return object of \code{\linkS4class{matrix}} class
#'
#' @author Stepan Yakovenko
+#' @export
#'
databel2matrix <- function(from, rows, cols) {
Modified: pkg/DatABEL/R/databel2text.R
===================================================================
--- pkg/DatABEL/R/databel2text.R 2014-03-18 12:18:43 UTC (rev 1650)
+++ pkg/DatABEL/R/databel2text.R 2014-03-18 15:25:06 UTC (rev 1651)
@@ -10,10 +10,15 @@
#' @param transpose whether the matrix should be transposed
#'
#' @author Stepan Yakovenko
+#' @export
#'
-databel2text <- function(databel, file, NAString = "NA", row.names=TRUE, col.names=TRUE, transpose = FALSE) {
+
+databel2text <- function(databel, file, NAString = "NA",
+ row.names=TRUE, col.names=TRUE, transpose =
+ FALSE) {
if (!is.character(file)) stop("databel save_as: file argument should be character")
- if (!.Call("saveAsText",databel at data, file,c(row.names, col.names,transpose),NAString))
- stop("can not databel2text(): saveAsText failed")
- return(databel)
+ if (!.Call("saveAsText", databel at data, file,c(row.names,
+ col.names,transpose), NAString))
+ stop("can not databel2text(): saveAsText failed")
+ return(databel)
}
Modified: pkg/DatABEL/R/databel_class.R
===================================================================
--- pkg/DatABEL/R/databel_class.R 2014-03-18 12:18:43 UTC (rev 1650)
+++ pkg/DatABEL/R/databel_class.R 2014-03-18 15:25:06 UTC (rev 1651)
@@ -1,6 +1,6 @@
#' DatABEL class
-#'
-#' @section Slots:
+#'
+#' @section Slots:
#' \describe{
#' \item{\code{usedRowIndex}:}{\code{"integer"}}
#' \item{\code{usedColIndex}:}{\code{"integer"}}
@@ -17,13 +17,14 @@
#' @aliases databel-class
#' @exportClass databel
#' @author Yurii Aulchenko
-#' '
+#' @useDynLib DatABEL
+#'
#
# databel R class
# (C) 2009, 2010, Yurii Aulchenko, EMCR
#
-# This class works with datable_cpp object using direct access
+# This class works with datable_cpp object using direct access
#
# SLOTS
#
@@ -58,524 +59,581 @@
#
setClass(
- Class = "databel",
- representation = representation(
- usedRowIndex = "integer",
- usedColIndex = "integer",
- uninames = "list",
- backingfilename = "character",
- cachesizeMb = "integer",
- data = "externalptr"
- ),
- package = "DatABEL"
-);
+ Class = "databel",
+ representation = representation(
+ usedRowIndex = "integer",
+ usedColIndex = "integer",
+ uninames = "list",
+ backingfilename = "character",
+ cachesizeMb = "integer",
+ data = "externalptr"
+ ),
+ package = "DatABEL"
+ );
setMethod(
- f = "initialize",
- signature = "databel",
- definition = function(.Object,baseobject,cachesizeMb=64,readonly=TRUE)
- {
+ f = "initialize",
+ signature = "databel",
+ definition = function(.Object, baseobject, cachesizeMb=64, readonly=TRUE)
+ {
# cat("----- databel ini start -----\n");
-
- if (!(is(baseobject,"character") || is(baseobject,"databel")))
- stop("databel initialize: baseobject should be of character (filename) or databel class");
- if (!is.numeric(cachesizeMb))
- stop("databel initialize: cache size must be numeric")
- readonly <- as(readonly,"logical")
- cachesizeMb <- as(cachesizeMb,"integer")
- if (cachesizeMb<0)
- stop(paste("databel initialize: cache size must be positive integer; now",cachesizeMb))
-
- if (is(baseobject,"character")){
- address <- .Call("open_FilteredMatrix_R",
- fname = baseobject,
- csize = cachesizeMb,
- rof = readonly,
- PACKAGE="DatABEL");
- if (is(address,"null")) stop("databel initialize: can not create databel object at step 1, NULL pointer returned")
- .Object at data <- address
-
- nrows <- .Call("get_nobs_R",.Object at data,PACKAGE="DatABEL")
- ncols <- .Call("get_nvars_R",.Object at data,PACKAGE="DatABEL")
- .Object at usedRowIndex <- c(1:nrows)
- .Object at usedColIndex <- c(1:ncols)
-
- .Object at uninames <- uninames(.Object at data)
-
- .Object at backingfilename <- baseobject
- .Object at cachesizeMb <- cachesizeMb
-
- } else if (is(baseobject,"databel")) {
-
- for (sn in slotNames(baseobject))
- slot(.Object,sn) <- slot(baseobject,sn)
-
- address <- .Call("open_FilteredMatrix_R",
- fname = backingfilename(baseobject),
- csize = cachesizeMb,
- rof = readonly,
- PACKAGE="DatABEL");
- if (is(address,"null")) stop("databel initialize: can not create databel object at step 2-1, NULL pointer returned")
- .Object at data <- address
- .Object at data <- .Call("setFilteredArea_R",.Object at data,.Object at usedColIndex,.Object at usedRowIndex);
-
- } else {
- stop("databel initialize: unreachable statement -- baseobject should be of databel class of FV-file name");
- }
-
-# cat("----- databel ini end -------\n");
- return(.Object)
- }
-);
+ if (!(is(baseobject, "character") || is(baseobject, "databel"))) {
+ stop("databel initialize: baseobject should be of character (filename) or databel class");
+ }
+ if (!is.numeric(cachesizeMb)) {
+ stop("databel initialize: cache size must be numeric")
+ }
+
+ readonly <- as(readonly, "logical")
+ cachesizeMb <- as(cachesizeMb, "integer")
+ if (cachesizeMb < 0) {
+ stop(paste("databel initialize: cache size must be positive integer; now",
+ cachesizeMb))
+ }
+
+ if (is(baseobject, "character")){
+ address <- .Call("open_FilteredMatrix_R",
+ fname = baseobject,
+ csize = cachesizeMb,
+ rof = readonly,
+ PACKAGE="DatABEL");
+ if (is(address, "null")) {
+ stop("databel initialize: can not create databel object at step 1, NULL pointer returned")
+ }
+
+ .Object at data <- address
+
+ nrows <- .Call("get_nobs_R", .Object at data, PACKAGE="DatABEL")
+ ncols <- .Call("get_nvars_R", .Object at data, PACKAGE="DatABEL")
+ .Object at usedRowIndex <- c(1:nrows)
+ .Object at usedColIndex <- c(1:ncols)
+
+ .Object at uninames <- uninames(.Object at data)
+
+ .Object at backingfilename <- baseobject
+ .Object at cachesizeMb <- cachesizeMb
+
+ } else if (is(baseobject, "databel")) {
+
+ for (sn in slotNames(baseobject))
+ slot(.Object, sn) <- slot(baseobject, sn)
+
+ address <- .Call("open_FilteredMatrix_R",
+ fname = backingfilename(baseobject),
+ csize = cachesizeMb,
+ rof = readonly,
+ PACKAGE="DatABEL");
+ if (is(address, "null")) {
+ stop("databel initialize: can not create databel object at step 2-1, NULL pointer returned")
+ }
+
+ .Object at data <- address
+ .Object at data <- .Call("setFilteredArea_R",
+ .Object at data,
+ .Object at usedColIndex,
+ .Object at usedRowIndex);
+
+ } else {
+ stop("databel initialize: unreachable statement -- baseobject should be of databel class of FV-file name");
+ }
+
+ # cat("----- databel ini end -------\n");
+
+ return(.Object)
+ }
+ );
+
# replace standard methods
+#' @export
setMethod(
- f = "show",
- signature = "databel",
- definition = function(object)
- {
- connected <- databel_check(object,reconnect=TRUE)
-# SHOULD ACTUALLY SHOW ONLY NON-MASKED DATA
-
- cat("uninames$unique.names =",object at uninames$unique.names,"\n")
- cat("uninames$unique.rownames =",object at uninames$unique.rownames,"\n")
- cat("uninames$unique.colnames =",object at uninames$unique.colnames,"\n")
- cat("backingfilename =",object at backingfilename,"\n")
- cat("cachesizeMb =",object at cachesizeMb,"\n")
- cat("number of columns (variables) = ",ncol(object),"\n");
- cat("number of rows (observations) = ",nrow(object),"\n");
- toCol <- 10
- toRow <- 5
- if (ncol(object)<toCol) toCol <- ncol(object)
- if (nrow(object)<toRow) toRow <- nrow(object)
- cat("usedRowIndex: ")
- for (i in 1:toRow) cat(object at usedRowIndex[i]," ")
- if (toRow<dim(object)[1]) cat("...")
- cat("\n")
- cat("usedColIndex: ")
- for (i in 1:toCol) cat(object at usedColIndex[i]," ")
- if (toCol<dim(object)[2]) cat("...")
- cat("\n")
-
- if (!connected) {
- cat("databel show: object is not connected\n")
- return();
- }
- cat("Upper-left",toCol,"columns and ",toRow,"rows:\n")
- showout <- as(object[1:toRow,1:toCol],"matrix")
- print(showout)
- }
-);
+ f = "show",
+ signature = "databel",
+ definition = function(object)
+ {
+ connected <- databel_check(object, reconnect=TRUE)
+ # SHOULD ACTUALLY SHOW ONLY NON-MASKED DATA
+ cat("uninames$unique.names =", object at uninames$unique.names, "\n")
+ cat("uninames$unique.rownames =", object at uninames$unique.rownames, "\n")
+ cat("uninames$unique.colnames =", object at uninames$unique.colnames, "\n")
+ cat("backingfilename =", object at backingfilename, "\n")
+ cat("cachesizeMb =", object at cachesizeMb, "\n")
+ cat("number of columns (variables) = ", ncol(object), "\n");
+ cat("number of rows (observations) = ", nrow(object), "\n");
+ toCol <- 10
+ toRow <- 5
+ if (ncol(object)<toCol) toCol <- ncol(object)
+ if (nrow(object)<toRow) toRow <- nrow(object)
+ cat("usedRowIndex: ")
+ for (i in 1:toRow) cat(object at usedRowIndex[i], " ")
+ if (toRow<dim(object)[1]) cat("...")
+ cat("\n")
+ cat("usedColIndex: ")
+ for (i in 1:toCol) cat(object at usedColIndex[i], " ")
+ if (toCol<dim(object)[2]) cat("...")
+ cat("\n")
+
+ if (!connected) {
+ cat("databel show: object is not connected\n")
+ return();
+ }
+ cat("Upper-left", toCol, "columns and ", toRow, "rows:\n")
+ showout <- as(object[1:toRow, 1:toCol], "matrix")
+ print(showout)
+ }
+ );
+
setMethod(
- f = "dim",
- signature = "databel",
- definition = function(x)
- {
- connected <- databel_check(x);
- if (!connected) stop("databel dim: databel_check failed")
- return(c(length(x at usedRowIndex),length(x at usedColIndex)))
- }
-);
+ f = "dim",
+ signature = "databel",
+ definition = function(x)
+ {
+ connected <- databel_check(x);
+ if (!connected) stop("databel dim: databel_check failed")
+ return(c(length(x at usedRowIndex), length(x at usedColIndex)))
+ }
+ );
setMethod(
- f = "length",
- signature = "databel",
- definition = function(x)
- {
- connected <- databel_check(x)
- if (!connected) stop("databel length: databel_check failed")
- dm <- dim(x)
- return(dm[1]*dm[2])
- }
-);
+ f = "length",
+ signature = "databel",
+ definition = function(x)
+ {
+ connected <- databel_check(x)
+ if (!connected) stop("databel length: databel_check failed")
+ dm <- dim(x)
+ return(dm[1]*dm[2])
+ }
+ );
setMethod(
- f = "dimnames",
- signature = "databel",
- definition = function(x)
- {
- connected <- databel_check(x)
- if (!connected) stop("databel dimnames: databel_check failed")
- if (x at uninames$unique.names) {
- return(get_dimnames(x))
- } else if (x at uninames$unique.rownames) {
- return(list(get_dimnames(x)[[1]],NULL))
- } else if (x at uninames$unique.colnames) {
- return(list(NULL,get_dimnames(x)[[2]]))
- } else {
- return(NULL)
- }
- }
-);
+ f = "dimnames",
+ signature = "databel",
+ definition = function(x)
+ {
+ connected <- databel_check(x)
+ if (!connected) stop("databel dimnames: databel_check failed")
+ if (x at uninames$unique.names) {
+ return(get_dimnames(x))
+ } else if (x at uninames$unique.rownames) {
+ return(list(get_dimnames(x)[[1]], NULL))
+ } else if (x at uninames$unique.colnames) {
+ return(list(NULL, get_dimnames(x)[[2]]))
+ } else {
+ return(NULL)
+ }
+ }
+ );
+
setMethod(
- f = "dimnames<-",
- signature = "databel",
- definition = function(x,value)
- {
- connected <- databel_check(x)
- if (!connected) stop("databel dimnames<-: databel_check failed")
- if (anyDuplicated(value[[1]])) stop("non-unigue names in dim [[1]] (use set_dimnames?)")
- if (anyDuplicated(value[[2]])) stop("non-unigue names in dim [[2]] (use set_dimnames?)")
- set_dimnames(x) <- value
- x at uninames <- uninames(x at data)
- return(x)
- }
-);
+ f = "dimnames<-",
+ signature = "databel",
+ definition = function(x, value)
+ {
+ connected <- databel_check(x)
+ if (!connected) stop("databel dimnames<-: databel_check failed")
+ if (anyDuplicated(value[[1]])) stop("non-unigue names in dim [[1]] (use set_dimnames?)")
+ if (anyDuplicated(value[[2]])) stop("non-unigue names in dim [[2]] (use set_dimnames?)")
+ set_dimnames(x) <- value
+ x at uninames <- uninames(x at data)
+ return(x)
+ }
+ );
setMethod(
- f = "[",
- signature = "databel",
- definition = function(x,i,j,drop)
- {
-# print("[ started")
- connected <- databel_check(x)
- if (!connected) stop("databel [: object is not connected")
- if (missing(drop)) drop = FALSE;
- newi <- convert_intlogcha_index_to_int(i,x,1)
- newj <- convert_intlogcha_index_to_int(j,x,2)
- out <- databel(x)
-# print(c("out dims orig are",dim(out)))
- out at usedRowIndex <- out at usedRowIndex[newi]
- out at usedColIndex <- out at usedColIndex[newj]
- out at data <- .Call("setFilteredArea_R",out at data,out at usedColIndex,out at usedRowIndex);
-# print(c("out dims after are",dim(out)))
- out at uninames <- uninames(out at data)
-# print("[ ended")
- return(out);
- }
-);
+ f = "[",
+ signature = "databel",
+ definition = function(x, i, j, drop)
+ {
+ # print("[ started")
+ connected <- databel_check(x)
+ if (!connected) stop("databel [: object is not connected")
+ if (missing(drop)) drop = FALSE;
+ newi <- convert_intlogcha_index_to_int(i, x, 1)
+ newj <- convert_intlogcha_index_to_int(j, x, 2)
+ out <- databel(x)
+ # print(c("out dims orig are", dim(out)))
+ out at usedRowIndex <- out at usedRowIndex[newi]
+ out at usedColIndex <- out at usedColIndex[newj]
+ out at data <- .Call("setFilteredArea_R", out at data,
+ out at usedColIndex, out at usedRowIndex);
+ # print(c("out dims after are", dim(out)))
+ out at uninames <- uninames(out at data)
+ # print("[ ended")
+ return(out);
+ }
+ );
setMethod(
- f = "[<-",
- signature = "databel",
- definition = function(x,i,j,value)
- {
-# print("started [<-")
- connected <- databel_check(x)
- if (!connected) stop("databel [<-: databel_check failed")
+ f = "[<-",
+ signature = "databel",
+ definition = function(x, i, j, value)
+ {
+ # print("started [<-")
+ connected <- databel_check(x)
+ if (!connected) stop("databel [<-: databel_check failed")
- newi <- convert_intlogcha_index_to_int(i,x,1)
- newj <- convert_intlogcha_index_to_int(j,x,2)
+ newi <- convert_intlogcha_index_to_int(i, x, 1)
+ newj <- convert_intlogcha_index_to_int(j, x, 2)
- if (length(value) != length(newi)*length(newj)) stop("databel [<-: dimensions of i,j,value do not match")
-
-# value <- matrix(value,ncol=length(newj),nrow=length(newi))
-# print(newi);
-# print(newj);
+ if (length(value) != length(newi)*length(newj)) {
+ stop("databel [<-: dimensions of i, j, value do not match")
+ }
- if(!.Call("assignDoubleMatrix", x at data, newi, newj, as.double(value),as.integer(0)))
- stop("databel [<-: can't write variable.");
-# print("finished [<-")
- return(x)
- }
-);
+ # value <- matrix(value, ncol=length(newj), nrow=length(newi))
+ # print(newi);
+ # print(newj);
+ if(!.Call("assignDoubleMatrix", x at data, newi, newj,
+ as.double(value), as.integer(0))) {
+ stop("databel [<-: can't write variable.");
+ }
+ # print("finished [<-")
+ return(x)
+ }
+ );
+
# IS
setGeneric('is.databel', function(x) standardGeneric('is.databel'))
setMethod('is.databel', signature(x='databel'),
- function(x) return(TRUE))
+ function(x) return(TRUE))
setMethod('is.databel', definition=function(x) return(FALSE))
-# setAs
+ # setAs
-as.matrix.databel <- function(x, ... )
+as.matrix.databel <- function(x, ... )
{
- return(as(x,"matrix"))
+ return(as(x, "matrix"))
}
-as.vector.databel <- function(x, ... )
+as.vector.databel <- function(x, ... )
{
- return(as(x,"vector"))
+ return(as(x, "vector"))
}
-as.double.databel <- function(x, ... )
+#' @export
+as.double.databel <- function(x, ... )
{
- to <- as(x,"matrix")
- return(as(to,"double"))
+ to <- as(x, "matrix")
+ return(as(to, "double"))
}
-setAs("databel","vector",
- function(from) {
- to <- as(from,"matrix")
- return(as(to,"vector"))
- }
-);
+setAs("databel", "vector",
+ function(from) {
+ to <- as(from, "matrix")
+ return(as(to, "vector"))
+ }
+ );
-setAs("databel","matrix",
- function(from) {
- connected <- databel_check(from)
- if (!connected) stop("setAs('databel','matrix'): check_connected failed")
- return(databel2matrix(from))
- }
-);
+setAs("databel", "matrix",
+ function(from) {
+ connected <- databel_check(from)
+ if (!connected) stop("setAs('databel', 'matrix'): check_connected failed")
+ return(databel2matrix(from))
+ }
+ );
-setAs("matrix","databel",
- function(from) {
- #print("as matrix->databel begin");
- if (!is.numeric(from)) stop("from must be numeric (integer or double)")
- type <- "DOUBLE"
- tmpfilename <- get_temporary_file_name();
- to <- matrix2databel(from,filename=tmpfilename,cachesizeMb=64,type=type)
- cat("coersion from 'matrix' to 'databel' of type",type,"; object connected to file",tmpfilename,"\n")
- #print("as matrix->databel end");
- return(to)
- }
-);
+setAs("matrix", "databel",
+ function(from) {
+ #print("as matrix->databel begin");
+ if (!is.numeric(from)) stop("from must be numeric (integer or double)")
+ type <- "DOUBLE"
+ tmpfilename <- get_temporary_file_name();
+ to <- matrix2databel(from, filename=tmpfilename, cachesizeMb=64, type=type)
+ cat("coersion from 'matrix' to 'databel' of type", type, "; object connected to file", tmpfilename, "\n")
+ #print("as matrix->databel end");
+ return(to)
+ }
+ );
### new generics
+#' @export
setGeneric(
- name = "get_dimnames",
- def = function(object) {standardGeneric("get_dimnames");}
-);
+ name = "get_dimnames",
+ def = function(object) {standardGeneric("get_dimnames");}
+ );
setMethod(
- f = "get_dimnames",
- signature = "databel",
- definition = function(object)
- {
- connected <- databel_check(object)
- if (!connected) stop("object is not connected",immediate.=TRUE)
- return(list(.Call("get_all_obsnames_R",object at data,PACKAGE="DatABEL"),.Call("get_all_varnames_R",object at data,PACKAGE="DatABEL")))
- }
-);
+ f = "get_dimnames",
+ signature = "databel",
+ definition = function(object)
+ {
+ connected <- databel_check(object)
+ if (!connected) stop("object is not connected", immediate.=TRUE)
+ return(list(.Call("get_all_obsnames_R", object at data,
+ PACKAGE="DatABEL"),
+ .Call("get_all_varnames_R", object at data,
+ PACKAGE="DatABEL")))
+ }
+ );
+#' @export
setGeneric(
- name = "set_dimnames<-",
- def = function(x,value) {standardGeneric("set_dimnames<-");}
-);
+ name = "set_dimnames<-",
+ def = function(x, value) {standardGeneric("set_dimnames<-");}
+ );
setMethod(
- f = "set_dimnames<-",
- signature = "databel",
- definition = function(x,value)
- {
-
- connected <- databel_check(x);
- if (!connected) stop("set_dimnames<-: databel_check failed")
-
- if (!is.list(value)) stop("set_dimnames<-: value is not a list")
- if (length(value)!=2) stop("set_dimnames<-: value should be a list with two vectors")
-
- if (length(value[[1]]) != dim(x)[1]) {
- if (is.null(value[[1]])) {
- value[[1]] <- as.character(c(1:dim(x)[1]))
- } else {
- stop("set_dimnames<-: dimention 1 of x and lengthof list[[1]] do not match")
- }
- }
- if (length(value[[2]]) != dim(x)[2]) {
- if (is.null(value[[2]])) {
- value[[2]] <- as.character(c(1:dim(x)[2]))
- } else {
- stop("set_dimnames<-: dimention 2 of x and lengthof list[[2]] do not match")
- }
- }
-
- if (!is.character(value[[1]])) stop("set_dimnames<-: colnames must be characters")
- if (!is.character(value[[2]])) stop("set_dimnames<-: rownames must be characters")
- if (!is.null(value[[2]]))
- r1 <- .Call("set_all_varnames_R",x at data,as.character(value[[2]]))
- if (!is.null(value[[1]]))
- r2 <- .Call("set_all_obsnames_R",x at data,as.character(value[[1]]))
-
- x at uninames <- uninames(x at data)
-
-# if (length(unique(value[[1]]))==dim(x)[1])
-# x at uninames$unique.rownames <- TRUE else x at uninames$unique.rownames <- FALSE
-# if (length(unique(value[[2]]))==dim(x)[2])
-# x at uninames$unique.colnames <- TRUE else x at uninames$unique.colnames <- FALSE
-# if (x at uninames$unique.colnames && x at uninames$unique.rownames)
-# x at uninames$unique.names <- TRUE else x at uninames$unique.names <- FALSE
-
- return(x)
- }
-);
+ f = "set_dimnames<-",
+ signature = "databel",
+ definition = function(x, value)
+ {
+ connected <- databel_check(x);
+ if (!connected) stop("set_dimnames<-: databel_check failed")
+
+ if (!is.list(value)) stop("set_dimnames<-: value is not a list")
+ if (length(value)!=2) {
+ stop("set_dimnames<-: value should be a list with two vectors")
+ }
+
+ if (length(value[[1]]) != dim(x)[1]) {
+ if (is.null(value[[1]])) {
+ value[[1]] <- as.character(c(1:dim(x)[1]))
+ } else {
+ stop("set_dimnames<-: dimention 1 of x and lengthof list[[1]] do not match")
+ }
+ }
+
+ if (length(value[[2]]) != dim(x)[2]) {
+ if (is.null(value[[2]])) {
+ value[[2]] <- as.character(c(1:dim(x)[2]))
+ } else {
+ stop("set_dimnames<-: dimention 2 of x and lengthof list[[2]] do not match")
+ }
+ }
+
+ if (!is.character(value[[1]])) {
+ stop("set_dimnames<-: colnames must be characters")
+ }
+ if (!is.character(value[[2]])) {
+ stop("set_dimnames<-: rownames must be characters")
+ }
+ if (!is.null(value[[2]])) {
+ r1 <- .Call("set_all_varnames_R", x at data,
+ as.character(value[[2]]))
+ }
+ if (!is.null(value[[1]])) {
+ r2 <- .Call("set_all_obsnames_R", x at data,
+ as.character(value[[1]]))
+ }
+
+ x at uninames <- uninames(x at data)
+
+ # if (length(unique(value[[1]]))==dim(x)[1])
+ # x at uninames$unique.rownames <- TRUE else x at uninames$unique.rownames <- FALSE
+ # if (length(unique(value[[2]]))==dim(x)[2])
+ # x at uninames$unique.colnames <- TRUE else x at uninames$unique.colnames <- FALSE
+ # if (x at uninames$unique.colnames && x at uninames$unique.rownames)
+ # x at uninames$unique.names <- TRUE else x at uninames$unique.names <- FALSE
+
+ return(x)
+ }
+ );
+
+#' @export
setGeneric(
- name = "backingfilename",
- def = function(object) {standardGeneric("backingfilename");}
-);
+ name = "backingfilename",
+ def = function(object) {standardGeneric("backingfilename");}
+ );
setMethod(
- f = "backingfilename",
- signature = "databel",
- definition = function(object)
- {
- return(object at backingfilename)
- }
-);
+ f = "backingfilename",
+ signature = "databel",
+ definition = function(object)
+ {
+ return(object at backingfilename)
+ }
+ );
-#
-
+#' @export
setGeneric(
- name = "cachesizeMb",
- def = function(object) {standardGeneric("cachesizeMb");}
-);
+ name = "cachesizeMb",
+ def = function(object) {standardGeneric("cachesizeMb");}
+ );
setMethod(
- f = "cachesizeMb",
- signature = "databel",
- definition = function(object)
- {
- return(object at cachesizeMb)
- }
-);
+ f = "cachesizeMb",
+ signature = "databel",
+ definition = function(object)
+ {
+ return(object at cachesizeMb)
+ }
+ );
-#
+#' @export
setGeneric(
- name = "cachesizeMb<-",
- def = function(x,value) {standardGeneric("cachesizeMb<-");}
-);
+ name = "cachesizeMb<-",
+ def = function(x, value) {standardGeneric("cachesizeMb<-");}
+ );
setMethod(
- f = "cachesizeMb<-",
- signature = "databel",
- definition = function(x,value)
- {
-# cat("set_cachesizeMb not implemented yet, leaving cachesizeMb unchanged\n")
- connected <- databel_check(x)
- if (!connected) stop("cachesizeMb<-: databel_check failed")
- if (!is.numeric(value)) stop("value must be numeric")
- value <- as.integer(value)
- if (value<0) stop("can not set cachesizeMb to <0")
- .Call("set_cachesizeMb_R",x at data,value)
- x at cachesizeMb <- .Call("get_cachesizeMb_R",x at data)
- return(x)
- }
-);
+ f = "cachesizeMb<-",
+ signature = "databel",
+ definition = function(x, value)
+ {
+ # cat("set_cachesizeMb not implemented yet, leaving cachesizeMb unchanged\n")
+ connected <- databel_check(x)
+ if (!connected) stop("cachesizeMb<-: databel_check failed")
+ if (!is.numeric(value)) stop("value must be numeric")
+ value <- as.integer(value)
+ if (value < 0) stop("can not set cachesizeMb to <0")
+ .Call("set_cachesizeMb_R", x at data, value)
+ x at cachesizeMb <- .Call("get_cachesizeMb_R", x at data)
+ return(x)
+ }
+ );
+
+#' @export
setGeneric(
- name = "save_as",
- def = function(x,rows,cols,file,cachesizeMb=64,readonly=TRUE) {standardGeneric("save_as");}
-);
+ name = "save_as",
+ def = function(x, rows, cols, file, cachesizeMb=64, readonly=TRUE)
+ {
+ standardGeneric("save_as");
+ }
+ );
setMethod(
- f = "save_as",
- signature = "databel",
- definition = function(x,rows,cols,file,cachesizeMb=64,readonly=TRUE)
- {
- #allowd_types <- c("databel","text")
- if (!is.character(file)) stop("databel save_as: file argument should be character")
- if (!missing(rows)) {
- newi <- convert_intlogcha_index_to_int(rows,x,1)
- } else {
- newi <- 1:dim(x)[1]
- }
- if (!missing(cols)) {
- newj <- convert_intlogcha_index_to_int(cols,x,2)
- } else {
- newj <- 1:dim(x)[2]
- }
-
- ### check order!!!
-# print(newj)
-# print(newi)
- intpar <- as.integer(c(length(newj),length(newi),(newj-1),(newi-1)))
-# print(intpar)
- if (!.Call("save_R",file,intpar,x at data))
- stop("can not save_as(): save_R failed")
- newobj <- databel(file,cachesizeMb=cachesizeMb,readonly=readonly)
- return(newobj)
- }
-);
+ f = "save_as",
+ signature = "databel",
+ definition = function(x, rows, cols, file, cachesizeMb=64, readonly=TRUE)
+ {
+ #allowd_types <- c("databel", "text")
+ if (!is.character(file)) {
+ stop("databel save_as: file argument should be character")
+ }
+ if (!missing(rows)) {
+ newi <- convert_intlogcha_index_to_int(rows, x, 1)
+ } else {
+ newi <- 1:dim(x)[1]
+ }
+ if (!missing(cols)) {
+ newj <- convert_intlogcha_index_to_int(cols, x, 2)
+ } else {
+ newj <- 1:dim(x)[2]
+ }
+### check order!!!
+ # print(newj)
+ # print(newi)
+ intpar <- as.integer(c(length(newj), length(newi), (newj-1), (newi-1)))
+ # print(intpar)
+ if (!.Call("save_R", file, intpar, x at data)) {
+ stop("can not save_as(): save_R failed")
+ }
+ newobj <- databel(file, cachesizeMb=cachesizeMb, readonly=readonly)
+ return(newobj)
+ }
+ );
+
+#' @export
setGeneric(
- name = "connect",
- def = function(object,readonly=TRUE) {standardGeneric("connect");}
-);
+ name = "connect",
+ def = function(object, readonly=TRUE) {standardGeneric("connect");}
+ );
setMethod(
- f = "connect",
- signature = "databel",
- definition = function(object,readonly=TRUE)
- {
-# print("connect for databel started")
- connected <- databel_check(object, reconnect = FALSE, stop_on_error = FALSE, quiet = TRUE)
- if (connected) {
-# print("connect for databel finished")
- warning("object already connected, nothing done") #,immediate. = TRUE)
- return();
- } else {
- new_obj <- databel(backingfilename(object), cachesizeMb=cachesizeMb(object),readonly=readonly)
- new_obj at usedColIndex <- object at usedColIndex
- new_obj at usedRowIndex <- object at usedRowIndex
- res <- .Call("setFilteredArea_R",new_obj at data,object at usedColIndex,object at usedRowIndex);
-# print("after setFilteredArea_R in connect")
-# print("before eval.parent(sub...")
- eval.parent(substitute(object <- new_obj));
-# print("after eval.parent(sub...")
- }
-# print("connect for databel finished")
- }
-);
+ f = "connect",
+ signature = "databel",
+ definition = function(object, readonly=TRUE)
+ {
+ # print("connect for databel started")
+ connected <- databel_check(object, reconnect = FALSE,
+ stop_on_error = FALSE, quiet =
+ TRUE)
+ if (connected) {
+ # print("connect for databel finished")
+ warning("object already connected, nothing done") #, immediate. = TRUE)
+ return();
+ } else {
+ new_obj <- databel(backingfilename(object),
+ cachesizeMb=cachesizeMb(object),
+ readonly=readonly)
+ new_obj at usedColIndex <- object at usedColIndex
+ new_obj at usedRowIndex <- object at usedRowIndex
+ res <- .Call("setFilteredArea_R", new_obj at data,
+ object at usedColIndex, object at usedRowIndex);
+ # print("after setFilteredArea_R in connect")
+ # print("before eval.parent(sub...")
+ eval.parent(substitute(object <- new_obj));
+ # print("after eval.parent(sub...")
+ }
+ # print("connect for databel finished")
+ }
+ );
+
+#' @export
setGeneric(
- name = "disconnect",
- def = function(object) {standardGeneric("disconnect");}
-);
+ name = "disconnect",
+ def = function(object) {standardGeneric("disconnect");}
+ );
-
-
setMethod(
- f = "disconnect",
- signature = "databel",
- definition = function(object)
- {
- connected <- databel_check(object, reconnect = FALSE, stop_on_error = FALSE)
- if (!connected) {
- warning("object is already disconnected")
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/genabel -r 1651
More information about the Genabel-commits
mailing list