R/gdsfmt-main.r

Defines functions gdsUnitTest print.gdsn.class print.gds.class system.gds lasterr.gds is.element.gdsn moveto.gdsn cache.gdsn assign.gdsn write.gdsn clusterApply.gdsn apply.gdsn readex.gdsn read.gdsn append.gdsn setdim.gdsn readmode.gdsn compression.gdsn delete.attr.gdsn get.attr.gdsn put.attr.gdsn delete.gdsn getfile.gdsn addfile.gdsn addfolder.gdsn add.gdsn objdesp.gdsn index.gdsn ls.gdsn rename.gdsn name.gdsn cnt.gdsn diagnosis.gds showfile.gds cleanup.gds sync.gds closefn.gds openfn.gds createfn.gds

Documented in addfile.gdsn addfolder.gdsn add.gdsn append.gdsn apply.gdsn assign.gdsn cache.gdsn cleanup.gds closefn.gds clusterApply.gdsn cnt.gdsn compression.gdsn createfn.gds delete.attr.gdsn delete.gdsn diagnosis.gds get.attr.gdsn getfile.gdsn index.gdsn is.element.gdsn lasterr.gds ls.gdsn moveto.gdsn name.gdsn objdesp.gdsn openfn.gds print.gds.class print.gdsn.class put.attr.gdsn readex.gdsn read.gdsn readmode.gdsn rename.gdsn setdim.gdsn showfile.gds sync.gds system.gds write.gdsn

# ===========================================================
#     _/_/_/   _/_/_/  _/_/_/_/    _/_/_/_/  _/_/_/   _/_/_/
#      _/    _/       _/             _/    _/    _/   _/   _/
#     _/    _/       _/_/_/_/       _/    _/    _/   _/_/_/
#    _/    _/       _/             _/    _/    _/   _/
# _/_/_/   _/_/_/  _/_/_/_/_/     _/     _/_/_/   _/_/
# ===========================================================
#
# gdsfmt-main.r: R Interface to CoreArray Genomic Data Structure (GDS) files
#
# Copyright (C) 2011 - 2014		Xiuwen Zheng [[email protected]]
#
# This file is part of CoreArray.
#
# CoreArray is free software: you can redistribute it and/or modify it
# under the terms of the GNU Lesser General Public License Version 3 as
# published by the Free Software Foundation.
#
# CoreArray is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with CoreArray.
# If not, see <http://www.gnu.org/licenses/>.



###############################################################################
# File Operations
###############################################################################

#############################################################
# Create a new CoreArray Genomic Data Structure (GDS) file
#
createfn.gds <- function(filename, allow.duplicate=FALSE)
{
	stopifnot(is.character(filename) & is.vector(filename))
	stopifnot(length(filename) == 1)
	stopifnot(is.logical(allow.duplicate))

	# 'normalizePath' does not work if the file does not exist
	tmpf <- file(filename, "wb")
	close(tmpf)

	filename <- normalizePath(filename, mustWork=FALSE)
	ans <- .Call(gdsCreateGDS, filename, allow.duplicate)
	names(ans) <- c("filename", "id", "root", "readonly")
	ans$filename <- filename
	class(ans$root) <- "gdsn.class"
	class(ans) <- "gds.class"
	ans
}


#############################################################
# Open an existing file
#
openfn.gds <- function(filename, readonly=TRUE, allow.duplicate=FALSE,
	allow.fork=FALSE)
{
	stopifnot(is.character(filename) & is.vector(filename))
	stopifnot(length(filename) == 1)

	filename <- normalizePath(filename, mustWork=FALSE)
	ans <- .Call(gdsOpenGDS, filename, readonly, allow.duplicate,
		allow.fork)
	names(ans) <- c("filename", "id", "root", "readonly")
	ans$filename <- filename
	class(ans$root) <- "gdsn.class"
	class(ans) <- "gds.class"
	ans
}


#############################################################
# Close an open CoreArray Genomic Data Structure (GDS) file
#
closefn.gds <- function(gdsfile)
{
	stopifnot(inherits(gdsfile, "gds.class"))
	.Call(gdsCloseGDS, gdsfile$id)
	invisible()
}


#############################################################
# Write the data cached in memory to disk
#
sync.gds <- function(gdsfile)
{
	stopifnot(inherits(gdsfile, "gds.class"))
	.Call(gdsSyncGDS, gdsfile$id)
	invisible()
}


#############################################################
# Clean up fragments of a GDS file
#
cleanup.gds <- function(filename, verbose=TRUE)
{
	stopifnot(is.character(filename) & is.vector(filename))
	stopifnot(length(filename) == 1)

	.Call(gdsTidyUp, filename, verbose)
	invisible()
}


#############################################################
# enumerate all opened GDS files
#
showfile.gds <- function(closeall=FALSE, verbose=TRUE)
{
	stopifnot(is.logical(closeall))
	rv <- .Call(gdsGetConnection, verbose)

	if (length(rv) > 0)
	{
		nm <- NULL; rd <- NULL
		for (i in 1:length(rv))
		{
			names(rv[[i]]) <- c("filename", "id", "root", "readonly")
			class(rv[[i]]$root) <- "gdsn.class"
			class(rv[[i]]) <- "gds.class"
			nm <- c(nm, rv[[i]]$filename)
			rd <- c(rd, rv[[i]]$readonly)
		}
		if (verbose & !closeall)
		{
			print(data.frame(FileName=nm, ReadOnly=rd,
				State=rep("open", length(rd))))
		}
	} else
		rv <- NULL

	# close all opened GDS files
	if (closeall & !is.null(rv))
	{
		if (verbose)
		{
			print(data.frame(FileName=nm, ReadOnly=rd,
				State=rep("closed", length(rd))))
		}
		for (i in 1:length(rv))
			closefn.gds(rv[[i]])
		rv <- NULL
	}

	invisible(rv)
}


#############################################################
# Diagnose the GDS file
#
diagnosis.gds <- function(gdsfile)
{
	stopifnot(inherits(gdsfile, "gds.class"))

	# call C function
	rv <- .Call(gdsDiagInfo, gdsfile$id)
	names(rv) <- "stream_list"
	names(rv[[1]]) <- c(
		sprintf("stream_%02d", seq_len(length(rv[[1]])-1)),
		"unused")
	rv
}





###############################################################################
# File Structure Operations
###############################################################################

#############################################################
# Get the number of variables in a specified folder
#
cnt.gdsn <- function(node)
{
	stopifnot(inherits(node, "gdsn.class"))
	.Call(gdsNodeChildCnt, node)
}


#############################################################
# Get the variable name of a node
#
name.gdsn <- function(node, fullname=FALSE)
{
	stopifnot(inherits(node, "gdsn.class"))
	.Call(gdsNodeName, node, fullname)
}


#############################################################
# Rename a GDS node
#
rename.gdsn <- function(node, newname)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.character(newname) & is.vector(newname))
	stopifnot(length(newname) == 1)

	.Call(gdsRenameNode, node, newname)
	invisible()
}


#############################################################
# Get a list of names for the child nodes
#
ls.gdsn <- function(node)
{
	if (inherits(node, "gds.class"))
		node <- node$root
	stopifnot(inherits(node, "gdsn.class"))

	.Call(gdsNodeEnumName, node)
}


#############################################################
# Get a specified node
#
index.gdsn <- function(node, path=NULL, index=NULL, silent=FALSE)
{
	# check
	if (inherits(node, "gds.class"))
		node <- node$root
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.logical(silent) & is.vector(silent))
	stopifnot(length(silent) == 1)

	ans <- .Call(gdsNodeIndex, node, path, index, silent)
	if (!is.null(ans))
		class(ans) <- "gdsn.class"
	ans
}


#############################################################
# Get the descritpion of a specified node
#
objdesp.gdsn <- function(node)
{
	stopifnot(inherits(node, "gdsn.class"))

	ans <- .Call(gdsNodeObjDesp, node)
	names(ans) <- c("name", "fullname", "storage", "type", "is.array",
		"dim", "encoder", "compress", "cpratio", "size", "good", "message")
	attr(ans$type, "levels") <- c("Label", "Folder", "VFolder", "Raw",
		"Integer", "Factor", "Logical", "Real", "String", "Unknown")
	attr(ans$type, "class") <- "factor"
	ans
}


#############################################################
# Add a GDS node
#
add.gdsn <- function(node, name, val=NULL, storage=storage.mode(val),
	valdim=NULL, compress=c("", "ZIP", "ZIP_RA", "LZ4", "LZ4_RA"),
	closezip=FALSE, check=TRUE, replace=FALSE, ...)
{
	if (inherits(node, "gds.class"))
		node <- node$root
	stopifnot(inherits(node, "gdsn.class"))

	if (missing(name))
		name <- paste("Item", cnt.gdsn(node)+1, sep="")
	stopifnot(is.character(name) & is.vector(name))
	stopifnot(length(name) == 1)

	stopifnot(is.character(storage) & is.vector(storage))
	stopifnot(length(storage) == 1)

	stopifnot(is.character(compress) & is.vector(compress))
	stopifnot(length(compress) > 0)
	compress <- compress[1L]

	stopifnot(is.logical(closezip) & is.vector(closezip))
	stopifnot(length(closezip) == 1)

	stopifnot(is.logical(check) & is.vector(check))
	stopifnot(length(check) == 1)

	stopifnot(is.logical(replace) & is.vector(replace))
	stopifnot(length(replace) == 1)

	ans <- .Call(gdsAddNode, node, name, val, storage, valdim, compress,
		closezip, check, replace, list(...))
	class(ans) <- "gdsn.class"

	if (storage == "list")
	{
		nm <- class(val)
		if (!identical(nm, "data.frame") & !("list" %in% nm))
			nm <- c(nm, "list")
		put.attr.gdsn(ans, "R.class", nm)

		nm <- names(val)
		for (i in 1:length(nm))
		{
			add.gdsn(ans, nm[i], val[[i]], compress=compress,
				closezip=closezip, check=check)
		}
	} else if (storage == "logical")
	{
		put.attr.gdsn(ans, "R.logical")
	} else if (is.factor(val))
	{
		put.attr.gdsn(ans, "R.class", "factor")
		put.attr.gdsn(ans, "R.levels", levels(val))
	}

	ans
}


#############################################################
# Add a (virtual) folder
#
addfolder.gdsn <- function(node, name, type=c("directory", "virtual"),
	gds.fn="", replace=FALSE)
{
	if (inherits(node, "gds.class"))
		node <- node$root
	stopifnot(inherits(node, "gdsn.class"))

	if (missing(name))
		name <- paste("Item", cnt.gdsn(node)+1, sep="")
	stopifnot(is.character(name) & is.vector(name))
	stopifnot(length(name) == 1)

	type <- match.arg(type)
	if (type == "virtual")
	{
		stopifnot(is.character(gds.fn) & is.vector(gds.fn))
		stopifnot(length(gds.fn) == 1)
		stopifnot(!is.na(gds.fn))
		stopifnot(gds.fn != "")
	}

	stopifnot(is.logical(replace) & is.vector(replace))
	stopifnot(length(replace) == 1)

	# call C function
	ans <- .Call(gdsAddFolder, node, name, type, gds.fn, replace)
	class(ans) <- "gdsn.class"
	ans
}


#############################################################
# Add a GDS node with a file
#
addfile.gdsn <- function(node, name, filename,
	compress=c("ZIP", "ZIP_RA", "LZ4", "LZ4_RA"), replace=FALSE)
{
	if (inherits(node, "gds.class"))
		node <- node$root
	stopifnot(inherits(node, "gdsn.class"))

	if (missing(name))
		name <- paste("Item", cnt.gdsn(node)+1, sep="")
	stopifnot(is.character(name) & is.vector(name))
	stopifnot(length(name) == 1)

	stopifnot(is.character(filename) & is.vector(filename))
	stopifnot(length(filename) == 1)

	stopifnot(is.character(compress) & is.vector(compress))
	stopifnot(length(compress) > 0)
	compress <- compress[1L]

	stopifnot(is.logical(replace) & is.vector(replace))
	stopifnot(length(replace) == 1)

	# call C function
	ans <- .Call(gdsAddFile, node, name, filename, compress, replace)
	class(ans) <- "gdsn.class"
	ans
}


#############################################################
# Get a file from a stream container
#
getfile.gdsn <- function(node, out.filename)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.character(out.filename) & is.vector(out.filename))
	stopifnot(length(out.filename) == 1)

	.Call(gdsGetFile, node, out.filename)
	invisible()
}


#############################################################
# Delete a specified node
#
delete.gdsn <- function(node, force=FALSE)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.logical(force) & is.vector(force))
	stopifnot(length(force) == 1)

	.Call(gdsDeleteNode, node, force)
	invisible()
}




###############################################################################
# Attribute
###############################################################################

#############################################################
# Add an attribute to a GDS node
#
put.attr.gdsn <- function(node, name, val=NULL)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.character(name) & is.vector(name))
	stopifnot(length(name) == 1)

	.Call(gdsPutAttr, node, name, val)
	invisible()
}


#############################################################
# Get the attributes of a GDS node
#
get.attr.gdsn <- function(node)
{
	stopifnot(inherits(node, "gdsn.class"))
	.Call(gdsGetAttr, node)
}


#############################################################
# Remove an attribute from a GDS node
#
delete.attr.gdsn <- function(node, name)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.character(name) & is.vector(name))
	stopifnot(length(name) == 1)

	.Call(gdsDeleteAttr, node, name)
	invisible()
}





###############################################################################
# Data Operations
###############################################################################

#############################################################
# Modify the data compression mode of data field
#
compression.gdsn <- function(node,
	compress=c("", "ZIP", "ZIP_RA", "LZ4", "LZ4_RA"))
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.character(compress) & is.vector(compress))
	stopifnot(length(compress) > 0)
	compress <- compress[1L]

	.Call(gdsObjCompress, node, compress)
	return(node)
}


#############################################################
# Get into read mode of compression
#
readmode.gdsn <- function(node)
{
	stopifnot(inherits(node, "gdsn.class"))
	.Call(gdsObjCompressClose, node)
	return(node)
}


#############################################################
# Set the new dimension of the data field for a GDS node
#
setdim.gdsn <- function(node, valdim)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.numeric(valdim) & is.vector(valdim))

	.Call(gdsObjSetDim, node, valdim)
	return(node)
}


#############################################################
# Append data to a specified variable
#
append.gdsn <- function(node, val, check=TRUE)
{
	stopifnot(inherits(node, "gdsn.class"))

	.Call(gdsObjAppend, node, val, check)
	invisible()
}


#############################################################
# Read data field of a GDS node
#
read.gdsn <- function(node, start=NULL, count=NULL,
	simplify=c("auto", "none", "force"), .useraw=FALSE)
{
	stopifnot(inherits(node, "gdsn.class"))
	simplify <- match.arg(simplify)

	if (is.null(start) & is.null(count))
	{
		rvattr <- get.attr.gdsn(node)
		rvclass <- rvattr$R.class
		if (!is.null(rvclass))
		{
			if (identical(rvclass, "data.frame") | ("list" %in% rvclass))
			{
				cnt <- cnt.gdsn(node)
				r <- vector("list", cnt)
				if (cnt > 0)
				{
					for (i in 1:cnt)
					{
						n <- index.gdsn(node, index=i)
						r[[i]] <- read.gdsn(n)
						names(r)[i] <- name.gdsn(n)
					}
				}

				if (identical(rvclass, "data.frame"))
				{
					r <- as.data.frame(r, stringsAsFactors=FALSE)
				} else {
					rvclass <- setdiff(rvclass, "list")
					if (length(rvclass) > 0)
						class(r) <- rvclass
				}

				return(r)
			}
		}
	}

	.Call(gdsObjReadData, node, start, count, simplify, .useraw)
}


#############################################################
# Read data field of a GDS node
#
readex.gdsn <- function(node, sel=NULL, simplify=c("auto", "none", "force"),
	.useraw=FALSE)
{
	stopifnot(inherits(node, "gdsn.class"))
	simplify <- match.arg(simplify)

	if (!is.null(sel))
	{
		stopifnot(is.logical(sel) | is.list(sel))
		if (is.logical(sel)) sel <- list(d1=sel)
		# read
		.Call(gdsObjReadExData, node, sel, simplify, .useraw)
	} else {
		# output
		read.gdsn(node)
	}
}


#############################################################
# Apply functions over array margins of a GDS node
#
apply.gdsn <- function(node, margin, FUN, selection=NULL,
	as.is=c("list", "integer", "double", "character", "none", "gdsnode"),
	var.index=c("none", "relative", "absolute"), target.node=NULL,
	.useraw=FALSE, ...)
{
	# check
	if (inherits(node, "gdsn.class"))
	{
		stopifnot(inherits(node, "gdsn.class"))
		stopifnot(is.numeric(margin) & (length(margin)==1))
		stopifnot(is.null(selection) | is.list(selection))

		node <- list(node)
		if (!is.null(selection))
			selection <- list(selection)
	} else {
		if (!is.list(node))
			stop("'node' should be 'gdsn.class' or a list of 'gdsn.class' objects.")
		for (i in 1:length(node))
		{
			if (!inherits(node[[i]], "gdsn.class"))
				stop(sprintf("node[[%d]] should be an object of 'gdsn' class.", i))
		}
	
		stopifnot(is.numeric(margin))
		stopifnot(length(margin) == length(node))
	
		stopifnot(is.null(selection) | is.list(selection))
		if (!is.null(selection))
			stopifnot(length(selection) == length(node))
	}

	FUN <- match.fun(FUN)
	as.is <- match.arg(as.is)
	var.index <- match.arg(var.index)
	var.index <- match(var.index, c("none", "relative", "absolute"))

	if (as.is == "gdsnode")
	{
		if (inherits(target.node, "gdsn.class"))
			target.node <- list(target.node)
		if (is.list(target.node))
		{
			for (i in seq_len(length(target.node)))
				stopifnot(inherits(target.node[[i]], "gdsn.class"))
		} else {
			stop(
			"'target.node' should be 'gdsn.class' or a list of 'gdsn.class'.")
		}
	} else {
		if (!is.null(target.node))
			stop("'target.node' should be NULL.")
	}

	# call C function -- set starting index
	.Call(gdsApplySetStart, 1L)
	# call C function -- apply calling
	ans <- .Call(gdsApplyCall, node, as.integer(margin), FUN,
		selection, as.is, var.index, .useraw, target.node, new.env())

	if (is.null(ans))
		invisible()
	else
		ans
}


#############################################################
# Apply functions over array margins of a list of GDS nodes in parallel
#
clusterApply.gdsn <- function(cl, gds.fn, node.name, margin,
	FUN, selection=NULL,
	as.is = c("list", "integer", "double", "character", "none"),
	var.index = c("none", "relative", "absolute"), .useraw=FALSE, ...)
{
	#########################################################
	# library
	#
	if (!require(parallel))
		stop("The 'parallel' package should be installed.")


	#########################################################
	# check
	#
	stopifnot(inherits(cl, "cluster"))
	stopifnot(is.character(gds.fn) & (length(gds.fn)==1))
	stopifnot(is.character(node.name))
	stopifnot(is.numeric(margin) & (length(margin)==length(node.name)))
	margin <- as.integer(margin)

	if (!is.null(selection))
	{
		if (!is.list(selection[[1]]))
			selection <- list(selection)
	}


	FUN <- match.fun(FUN)
	as.is <- match.arg(as.is)
	var.index <- match.arg(var.index)


	#########################################################
	# new selection
	#

	gfile <- openfn.gds(gds.fn, allow.duplicate=TRUE)
	on.exit({ closefn.gds(gfile) })

	nd_nodes <- vector("list", length(node.name))
	names(nd_nodes) <- names(node.name)
	for (i in 1:length(nd_nodes))
	{
		v <- index.gdsn(gfile, path=node.name[i], silent=TRUE)
		nd_nodes[[i]] <- v
		if (is.null(v))
		{
			stop(sprintf("There is no node \"%s\" in the specified gds file.",
				node.name[i]))
		}
	}

	new.selection <- .Call(gdsApplyCreateSelection, nd_nodes,
		margin, selection)

	# the count of elements
	MarginCount <- sum(new.selection[[1]][[ margin[1] ]], na.rm=TRUE)
	if (MarginCount <= 0)
		return(invisible())


	#########################################################
	# run
	#

	if (length(cl) > 1)
	{
		# close the GDS file
		closefn.gds(gfile)
		on.exit()

		clseq <- parallel::splitIndices(MarginCount, length(cl))
		sel.list <- vector("list", length(cl))
		start <- 1L

		# for - loop: multi processes
		for (i in 1:length(cl))
		{
			n <- length(clseq[[i]])
			if (n > 0L)
			{
				tmp <- new.selection

				# for - loop: multiple variables
				for (j in 1:length(tmp))
				{
					sel <- tmp[[j]]
					idx <- which(sel[[ margin[j] ]])
					flag <- rep(FALSE, length(sel[[ margin[j] ]]))
					flag[ idx[ clseq[[i]] ] ] <- TRUE
					sel[[ margin[j] ]] <- flag
					tmp[[j]] <- sel
				}

				sel.list[[i]] <- list(start=start, n=n, sel=tmp)
				start <- start + n
			} else {
				sel.list[[i]] <- list(start=start, n=0L, sel=NULL)
			}
		}

		# enumerate
		ans <- parallel::clusterApply(cl, sel.list, fun =
				function(item, gds.fn, node.name, margin, FUN,
					as.is, var.index, ...)
			{
				if (item$n <= 0L) return(NULL)

				# load the package
				library(gdsfmt)

				# open the file
				gfile <- openfn.gds(gds.fn, allow.duplicate=TRUE)
				on.exit({ closefn.gds(gfile) })

				nd_nodes <- vector("list", length(node.name))
				names(nd_nodes) <- names(node.name)
				for (i in 1:length(nd_nodes))
					nd_nodes[[i]] <- index.gdsn(gfile, path=node.name[i])

				# call C function -- set starting index
				.Call(gdsApplySetStart, item$start)
				# call C function -- apply calling
				.Call(gdsApplyCall, nd_nodes, margin, FUN, item$sel, as.is,
					match(var.index, c("none", "relative", "absolute")),
					.useraw, NULL, new.env())

			}, gds.fn=gds.fn, node.name=node.name, margin=margin,
				FUN=FUN, as.is=as.is, var.index=var.index, ...
		)

		if (as.is != "none")
			unlist(ans, recursive=FALSE)
		else 
			invisible()

	} else {
		apply.gdsn(nd_nodes, margin, FUN, selection, as.is,
			var.index, .useraw, ...)
	}
}


#############################################################
# Write data to a GDS node
#
write.gdsn <- function(node, val, start=NULL, count=NULL, check=TRUE)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(!missing(val))

	if (is.null(start) & is.null(count))
	{
		.Call(gdsObjWriteAll, node, val, check)
	} else {
		.Call(gdsObjWriteData, node, val, start, count, check)
	}
	
	invisible()
}


#############################################################
# Assign a GDS variable from another variable
#
assign.gdsn <- function(dest.obj, src.obj, append=TRUE)
{
	stopifnot(inherits(dest.obj, "gdsn.class"))
	stopifnot(inherits(src.obj, "gdsn.class"))
	stopifnot(is.logical(append) & is.vector(append))
	stopifnot(length(append) == 1)

	# call C function
	.Call(gdsAssign, dest.obj, src.obj, append)

	invisible()
}


#############################################################
# Caching the data associated with a GDS variable
#
cache.gdsn <- function(node)
{
	stopifnot(inherits(node, "gdsn.class"))

	# call C function
	.Call(gdsCache, node)
	invisible()
}


#############################################################
# move to a new location
#
moveto.gdsn <- function(node, loc.node,
	relpos = c("after", "before", "replace"))
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(inherits(loc.node, "gdsn.class"))
	relpos <- match.arg(relpos)
	relpos <- match(relpos, c("after", "before", "replace"))

	# call C function
	.Call(gdsMoveTo, node, loc.node, relpos)
	if (relpos == 3L)
	{
		nm <- name.gdsn(loc.node)
		delete.gdsn(loc.node)
		rename.gdsn(node, nm)
	}

	invisible()
}


#############################################################
# whether elements in node
#
is.element.gdsn <- function(node, set)
{
	stopifnot(inherits(node, "gdsn.class"))
	stopifnot(is.vector(set))
	stopifnot(is.numeric(set) | is.character(set))

	# call C function
	.Call(gdsIsElement, node, set)
}



###############################################################################
# Error function
###############################################################################

#############################################################
# Return the last error
#
lasterr.gds <- function()
{
	.Call(gdsLastErrGDS)
}

#############################################################
# Return the parameters in the GDS system
#
system.gds <- function()
{
	rv <- .Call(gdsSystem)
	s <- rv$compression.encoder
	rv$compression.encoder <- data.frame(
		encoder = rv$compression.encoder[seq(1, length(s), 2)],
		description = rv$compression.encoder[seq(2, length(s), 2)],
		stringsAsFactors = FALSE)
	rv$class.list <- data.frame(rv$class.list, stringsAsFactors=FALSE)
	colnames(rv$class.list) <- c("name", "description")
	rv$class.list <- rv$class.list[order(rv$class.list$description), ]
	rownames(rv$class.list) <- NULL
	rv
}



###############################################################################
# R Generic functions
###############################################################################

print.gds.class <- function(x, all=FALSE, ...)
{
	# check
	stopifnot(inherits(x, "gds.class"))
	stopifnot(is.logical(all) & is.vector(all))
	stopifnot(length(all) == 1)

	.Call(gdsFileValid, x$id)
	cat("File: ", x$filename, "\n", sep="");
	print(x$root, all=all, ...)
}

print.gdsn.class <- function(x, expand=TRUE, all=FALSE, ...)
{
	enum <- function(node, space, level, expand, fullname)
	{
		at <- get.attr.gdsn(node)
		if (!all)
		{
			if ("R.invisible" %in% names(at))
				return(invisible())
		}

		n <- objdesp.gdsn(node)
		if (n$type == "Label")
		{
			lText <- " "; rText <- " "
		} else if (n$type == "VFolder")
		{
			lText <- if (n$good) "[ -->" else "[ -X-"
			rText <- "]"
		} else if (n$type == "Folder")
		{
			lText <- "["; rText <- "]"
		} else if (n$type == "Unknown")
		{
			lText <- "  -X-"; rText <- ""
		} else {
			lText <- "{"; rText <- "}"
		}
		cat(space, "+ ", name.gdsn(node, fullname), "	",
			lText, " ", n$storage, sep="")

		# if logical, factor, list, or data.frame
		if (n$type == "Logical")
		{
			cat(",logical")
		} else if (n$type == "Factor")
		{
			cat(",factor")
		} else if ("R.class" %in% names(at))
		{
			if (n$storage != "")
				cat(",")
			if (!is.null(at$R.class))
				cat(paste(at$R.class, sep="", collapse=","))
		}

		# show the dimension
		if (!is.null(n$dim))
		{
			cat(" ")
			cat(n$dim, sep="x")
		}

		# show compression
		if (is.character(n$encoder))
		{
			if (n$encoder != "") cat("", n$encoder)
		}
		if (is.numeric(n$cpratio))
		{
			if (is.finite(n$cpratio))
				cat(sprintf("(%0.2f%%)", 100*n$cpratio))
		}

		if (length(at) > 0)
			cat(" ", rText, " *\n", sep="")
		else
			cat(" ", rText, "\n", sep="")

		if (expand)
		{
			cnt <- cnt.gdsn(node)
			if (cnt > 0)
			{
				for (i in 1:cnt)
				{
					m <- index.gdsn(node, index=i)
					if (level==1)
						s <- paste("|--", space, sep="")
					else
						s <- paste("|  ", space, sep="")
					enum(m, s, level+1, TRUE, FALSE)
				}
			}
		}
	}

	# check
	stopifnot(inherits(x, "gdsn.class"))
	stopifnot(is.logical(all) & is.vector(all))
	stopifnot(length(all) == 1)
	stopifnot(is.logical(expand) & is.vector(expand))
	stopifnot(length(expand) == 1)

	.Call(gdsNodeValid, x)
	enum(x, "", 1, expand, TRUE)

	invisible()
}





###############################################################################
# Unit testing
###############################################################################

#############################################################
# Run all unit tests
#
gdsUnitTest <- function()
{
	# load R packages
	if (!require(RUnit))
		stop("Please install RUnit package!")

	# define a test suite
	myTestSuite <- RUnit::defineTestSuite("gdsfmt examples",
		system.file("unitTests", package = "gdsfmt"))

	# run the test suite
	testResult <- RUnit::runTestSuite(myTestSuite)

	# print detailed text protocol to standard out:
	RUnit::printTextProtocol(testResult)

	# return
	invisible()
}

Try the gdsfmt package in your browser

Any scripts or data that you put into this service are public.

gdsfmt documentation built on May 2, 2019, 4:41 p.m.