Nothing
R/gaggle.R
In gaggle: Broadcast data between R and Gaggle
Defines functions
newTuple
addSingle
newSingle
tupleToList
getTupleAsList
disconnectFromGaggle
connectToGaggle
testGagglePackage
.captureQuotedNumbersAsStrings
getJavaClassName
isJavaTuple
Documented in
addSingle
connectToGaggle
disconnectFromGaggle
getJavaClassName
getTupleAsList
newSingle
newTuple
testGagglePackage
tupleToList
# gaggle.R
#---------------------------------------------------------------------------------
.onLoad <- function (libname, pkgname)
{
#require ("methods")
require ("rJava")
libname = gsub(" ", "%20", libname, "+")
cat (paste ('\nonLoad -- libname:', libname, 'pkgname:', pkgname, '\n'))
# All Bioconductor packages should use an x.y.z version scheme. The following rules apply:
# The y number should be odd for packages in devel and even for packages in release.
# This makes it easier for users to know whether the package they have installed
# is release or devel. We encourage package maintainers to increment z whenever
# committing changes to a package in devel. Any change committed to a released
# package, no matter how small, must bump z.
fullPathToGaggleJar = paste (libname, pkgname, 'jars', 'gaggleRShell.jar', sep=.Platform$file.sep)
cat ('path to jar:', fullPathToGaggleJar, '\n')
cat (' script: ', .scriptVersion (), '\n')
# Before starting VM, set the system classpath to a blank string
# this gets around a bug where RMI objects fail to unmarshal
# if the classpath has spaces in it (which it often does on
# Windows machines). Yes, this is a weird error.
Sys.unsetenv("CLASSPATH")
.jinit (fullPathToGaggleJar)
cat (' os version: ', .jcall ("java/lang/System", "S", "getProperty", "os.name"),'\n')
#-----------------------------------------------------------
# as of february 2006, the gaggle requires java 1.5.
# bail out if the version found by .jinit is some other version
# java versions on macos can be especially confusing. the
# url supplied below explains what to do
#-----------------------------------------------------------
jvmVersion = .jcall ("java/lang/System", "S", "getProperty", "java.version")
cat (' jvm version: ', jvmVersion, '\n')
if (is.na (pmatch ("1.5.", jvmVersion)) &&
is.na (pmatch ("1.6.", jvmVersion)) &&
is.na (pmatch("1.7", jvmVersion)))
{
cat ('\n You are using the wrong version of Java.\n',
' Please see http://gaggle.systemsbiology.org/docs/html/java\n\n')
return ()
}
} # first lib
#---------------------------------------------------------------------------------
gaggleInit <- function (bossHost = 'localhost')
# the user must call this, to create the java R goose, to register it with
# the boss, and before sending or receiving any broadcasts
{
cat (paste(' initializing gaggle package', .pkgVersion(), '(2007-04)\n'))
goose <<- .jnew ("org/systemsbiology/gaggle/geese/rShell/RShellGoose", bossHost)
tester = geese ()
if (is.null (tester)) {
cat ('\n\n\tFailed to connect to a Gaggle Boss. Is one running on your computer?\n')
cat ('\tUse this Java Web Start link to start a boss:\n')
cat ('\t\thttp://gaggle.systemsbiology.org/2007-04/boss.jnlp\n')
cat ('\tYou need to exit R, start the boss, re-enter R, and load the gaggle package once again.\n\n')
}
else {
targetGoose <<- "boss"
cat (' name: ', .jcall (goose, "S", "getName"), "\n")
cat (' RShellGoose: ', .jcall (goose, "S", "getVersion"), "\n")
}
} # gaggleInit
.pkgVersion <- function ()
{
return (as.character(sessionInfo()$otherPkgs$gaggle)[2])
}
#---------------------------------------------------------------------------------
.scriptVersion <- function ()
{
return ("gaggle.R $Revision: 4499 $ $Date: 2010-08-10 17:15:03 -0700 (Tue, 10 Aug 2010) $");
}
#---------------------------------------------------------------------------------
getNameList <- function ()
{
nameList <- .jcall (goose, "[S", "getNameList")
return (nameList)
}
#---------------------------------------------------------------------------------
getCluster <- function ()
{
result = list ()
result$name = .jcall (goose, "S", "getClusterName")
result$rowNames = .jcall (goose, "[S", "getClusterRowNames")
result$columnNames = .jcall (goose, "[S", "getClusterColumnNames")
return (result)
}
#---------------------------------------------------------------------------------
getTuple <- function ()
{
hash = new.env ()
hash$title = .jcall (goose, "S", "getTupleTitle")
#hash$attributeName = .jcall (goose, "S". "getTupleAttributeName") #leave this be for now; it might mess things up
keys = .jcall (goose, "[S", "getTupleKeys")
rawValues = .jcall (goose, "[S", "getTupleValues")
#print (keys)
#print (rawValues)
options (warn = -1) # failed conversion to numeric prints an message to stdout; disable it
for (i in seq (length (keys))) {
value = as.numeric (rawValues [i])
if (is.na (value)) value = rawValues [i]
assign (keys [i], value, envir=hash)
}
options (warn = 1) # turn warnings back on
return (hash)
} # getHashMap
getMatrix <- function ()
{
rowCount <- .jcall (goose, "I", "getMatrixRowCount")
columnCount <- .jcall (goose, "I", "getMatrixColumnCount")
matrixRowNames <- .jcall (goose, "[S", "getMatrixRowNames")
matrixColumnNames <- .jcall (goose, "[S", "getMatrixColumnNames")
#cat ("rows: ", rowCount, "\n");
#cat ("cols: ", columnCount, "\n");
#cat ("row names ", matrixRowNames, "\n");
#cat ("col names ", matrixColumnNames, "\n");
data <- .jcall (goose, "[D", "getAllMatrixData");
m <- matrix (data, nrow=rowCount, ncol=columnCount, byrow=T,
dimnames = list (matrixRowNames, matrixColumnNames))
return (m)
}
#---------------------------------------------------------------------------------
getNetwork <- function (directed=TRUE)
{
edgeStrings = .jcall (goose, "[S", "getNetworkAsStringArray")
nodeAttributeStrings = .jcall (goose, "[S", "getNetworkNodeAttributesAsStringArray")
edgeAttributeStrings = .jcall (goose, "[S", "getNetworkEdgeAttributesAsStringArray")
result = .gaggleNetworkToGraphNEL (edgeStrings, nodeAttributeStrings, edgeAttributeStrings, directed)
#print (paste ('getNetwork: ', result))
return (result)
}
#---------------------------------------------------------------------------------
#getHashMap <- function ()
#{
# hash = new.env ()
# hash$title = .jcall (goose, "S", "getHashMapTitle")
# keys = .jcall (goose, "[S", "getHashMapKeys")
# rawValues = .jcall (goose, "[S", "getHashMapValues")
# #print (keys)
# #print (rawValues)
#
# options (warn = -1) # failed conversion to numeric prints an message to stdout; disable it
#
# for (i in seq (length (keys))) {
# value = as.numeric (rawValues [i])
# if (is.na (value)) value = rawValues [i]
# assign (keys [i], value, envir=hash)
# }
#
# options (warn = 1) # turn warnings back on
#
# return (hash)
#
#} # getHashMap
#---------------------------------------------------------------------------------
.graphNELtoGaggleNetwork <- function (g)
# the name of this function is a slight exaggeration: we don't really create
# a Gaggle Network object here, but we do translate the R graph into 3 String
# arrays, which are easy to send to Java, and from which RShellGoose.java can
# easily construct a real Gaggle Network.
#
# these are the string types
#
# edges: "VNG0723G::VNG1233G::PhylogeneticProfile"
# edge attributes: "VNG0723G::VNG1233G::PhylogeneticProfile::confidence::0.533"
# node attributes: "VNG1233G::commonName::pepq2"
{
# set some default values. these will be assigned in this function.
# node attributes may not exist, but the other two will, always.
edgeStringList = NA
nodeAttributeStringList = NA
edgeAttributeStringList = NA
# does it have an explicit edge type? gaggle network graphs always do, but
# those originating in R may not. supply one if needed
hasExplicitEdgeType = .listMember ("edgeType", names (edgeDataDefaults (g)))
if (!hasExplicitEdgeType)
edgeDataDefaults (g, "edgeType") = "edge"
#------------------------------------------------------------------------
# create the edge strings: nodeA::nodeB:<edgeType>
# and the degenerate case: nodeC
#------------------------------------------------------------------------
edgeStringList = c ()
for (node in nodes (g)) {
#print (paste ('looking for nodes linked to', node))
edgePartners = edges (g)[[node]]
#print (paste (' partners:', edgePartners))
if (length (edgePartners) == 0) {
edgeString = node
if (!.listMember (edgeString, edgeStringList))
edgeStringList = c (edgeStringList, edgeString)
} # a degenerate edge, just a node
else {
for (partner in edgePartners) {
nodeA = node
nodeB = partner
# keep edge strings nodes alphabetically sorted, so we can check for duplicates
if (!isDirected (g) && nodeA > nodeB) {
tmp = nodeB
nodeB = nodeA
nodeA = tmp
}
edgeType = edgeData (g, nodeA, nodeB, "edgeType")
edgeString = paste (nodeA, nodeB, edgeType, sep='::')
#print (paste ('new edge:', edgeString))
if (!.listMember (edgeString, edgeStringList))
edgeStringList = c (edgeStringList, edgeString)
} # for partner
} # else: a real edge
}# for node
#------------------------------------------------------------------------------
# now create the node attribute strings: node::attributeName::attributeValue
#------------------------------------------------------------------------------
nodeAttributeNames = names (nodeDataDefaults (g))
if (length (nodeAttributeNames) > 0) {
nodeAttributeStringList = c ()
for (attributeName in nodeAttributeNames) {
for (node in nodes (g)) {
value = nodeData (g, node, attributeName )[[1]]
noaString = paste (node, attributeName, value, sep='::')
nodeAttributeStringList = c (nodeAttributeStringList, noaString)
} # for node
} # for attributeName
}# if > 0
#------------------------------------------------------------------------------
# lastly, create the edge attribute strings:
# nodeA::nodeB::edgeType::attributeName::attributeValue
#------------------------------------------------------------------------------
edgeAttributeStringList = c ()
edgeAttributeNames = names (edgeDataDefaults (g))
# partner nodes (sharing an edge) have already been identifed, and stroed in edgeStringList
# exploit that rather than searching again
for (attributeName in edgeAttributeNames) {
for (edgeString in edgeStringList) {
tokens = unlist (strsplit (edgeString, "::"))
if (length (tokens) != 3) # is this a degenerate 'edge' -- just a node?
next
nodeA = tokens [1]
nodeB = tokens [2]
edgeType = tokens [3]
attributeValue = edgeData (g, nodeA, nodeB, attributeName)[[1]]
edaString = paste (nodeA, nodeB, edgeType, attributeName, attributeValue, sep="::")
edgeAttributeStringList = c (edgeAttributeStringList, edaString)
} # for edgeString
} # for attributeName
results = list ()
results$edges = edgeStringList
results$noa = nodeAttributeStringList
results$eda = edgeAttributeStringList
return (results)
} # .graphNELtoGaggleNetwork
#---------------------------------------------------------------------------------
.gaggleNetworkToGraphNEL <- function (edges, noas, edas, directed)
# it's easy to send arrays of strings between java and R, so that's what we rely on.
# there are three types of strings, each of which has some 'magic' coding, as you can
# see below:
# edges consist of strings like "VNG0723G::VNG1233G::PhylogeneticProfile"
# edge attributes: "VNG0723G::VNG1233G::PhylogeneticProfile::confidence::0.533"
# node attributes: "VNG1233G::commonName::pepq2"
{
# ---- create the graph, add nodes, add edges between them,
# add edgeType attributes (which are implicit in the edge strings)
#print (cat ('lkjsadf;lkjasdf;lkjasdf;lkjasd;lfgkj'))
edgeMode = "directed"
if (directed) {
edgeMode = "directed"
} else {
edgeMode = "undirected"
}
g = new ("graphNEL", edgemode=edgeMode)
edgeDataDefaults (g, "edgeType") = ""
if (!is.null (edges) && !is.na (edges)) for (edge in edges) {
tokens = unlist (strsplit (edge, '::'))
if (length (tokens) == 1) {
orphanNode = tokens [1]
if (!.listMember (orphanNode, nodes (g)))
g = addNode (tokens [1], g)
} # 1 token only
else if (length (tokens) == 3) {
nodeA = tokens [1]
nodeB = tokens [2]
edgeType = tokens [3]
if (!.listMember (nodeA, nodes (g)))
g = addNode (nodeA, g)
if (!.listMember (nodeB, nodes (g)))
g = addNode (nodeB, g)
g = addEdge (nodeA, nodeB, g)
edgeData (g, from=nodeA, to=nodeB, attr="edgeType") = edgeType
} # 3 tokens
} # for
# ---- now traverse the explicit edge attributes, and add them
if ((!length (edas) == 0) && !is.null (edas) && !is.na (edas)) for (eda in edas) {
tokens = unlist (strsplit (eda, '::'))
nodeA = tokens [1]
nodeB = tokens [2]
edgeType = tokens [3] # we ignore this for now, since graph allows only 1 edge
attributeName = tokens [4]
#print (paste ('edge attribute name:', attributeName))
rawAttributeValue = tokens [5]
options (warn = -1)
attributeValue = as.numeric (rawAttributeValue)
options (warn = 1)
if (is.na (attributeValue)) attributeValue = rawAttributeValue
# is this an unknown edge attribute type? if so, initialize it
if (!.listMember (attributeName, names (edgeDataDefaults (g)))) {
if (attributeName == 'weight')
edgeDataDefaults (g, attributeName) = 1.0
else
edgeDataDefaults (g, attributeName) = ""
} # if new edge attribute
edgeData (g, from=nodeA, to=nodeB, attr=attributeName) = attributeValue
} # if edge attributes
if ((!length (noas) == 0) && !is.null (noas) && !is.na (noas)) for (noa in noas) {
tokens = unlist (strsplit (noa, '::'))
node = tokens [1]
attributeName = tokens [2]
rawAttributeValue = tokens [3]
# is this an unknown node attribute type? if so, initialize it
if (!.listMember (attributeName, names (nodeDataDefaults (g))))
nodeDataDefaults (g, attributeName) = ""
options (warn = -1)
attributeValue = as.numeric (rawAttributeValue)
options (warn = 1)
if (is.na (attributeValue)) attributeValue = rawAttributeValue
nodeData (g, node, attributeName) = attributeValue
} # for
return (g)
}# .gaggleNetworkToGraphNEL
#-------------------------------------------------------------------------------------------
# test whether the given object is an instance of a Java Tuple object
isJavaTuple <- function(obj) {
return (class(obj)=="jobjRef" && isS4(obj) && slot(obj, "jclass")=="org/systemsbiology/gaggle/core/datatypes/Tuple" && !is.jnull(obj))
}
#-------------------------------------------------------------------------------------------
# get the Java class name of an rJava object
getJavaClassName <- function(jobj, quiet=FALSE) {
if (class(jobj)=='jobjRef') {
if (is.jnull(jobj)) {
return("null")
}
return(.jcall(.jcall(jobj, 'Ljava/lang/Class;', 'getClass'), 'S', 'getName'))
}
else {
if (!quiet) {
cat("Error in getJavaClassName: Not a java object?\n")
}
return("Not a java object")
}
}
#-------------------------------------------------------------------------------------------
broadcast <- function (x, name='from R')
{
if (is.matrix (x) || is.data.frame(x)) {
#cat ('broadcasting matrix, name: ', name, '\n')
# java stores matrices in row-major order, R uses column-major, so be sure to
# transpose the actual data before sending it to java
if (is.null(rownames(x)) || is.null(colnames(x))) {
cat('Error: row and column names required to broadcast matrix')
} else {
.jcall (goose, "V", "createAndBroadcastMatrix", rownames (x), colnames (x),
as.numeric (as.vector (t(x))), name)
}
}
else if (is.vector (x)) {
if (length (intersect (c("rowNames", "columnNames"), names (x))) == 2) {
rowNames = x$rowNames
columnNames = x$columnNames
.jcall (goose, "V", "broadcastCluster", name, rowNames, columnNames)
}
else if (!is.null (names (x))) {
.broadcastAssociativeArray (x, name)
} else {
if (length (x) == 1) #
x <- as.vector(c(x))
.jcall (goose, "V", "broadcastList", x, name)
} # unnamed list
} # vector
# Broadcast a (Java) Tuple object.
# Added by JCB to support genome browser.
else if (isJavaTuple(x)) {
if (name!='from R') {
.jcall(x, "V", "setName", name)
}
.jcall(goose, "V", "broadcastTuple", x)
}
else if (class (x) == "graphNEL") {
.broadcastGraph (x, name)
}
else if (class (x) == "environment") {
.broadcastEnvironment (x, name)
#.broadcastAssociativeArray(x, name)
}
else {
cat ("no support yet for broadcasting variables of type ", typeof (x), "\n")
}
invisible (NULL)
} # generic broadcast
#---------------------------------------------------------------------------------
geese <- function ()
{
return (.jcall (goose, "[S", "getGeeseNames"));
}
#------------------------------------------------------------------------------------------------
getTargetGoose <- function ()
{
return (.jcall (goose, "S", "getTargetGoose"))
} # getTargetGoose
#--------------------------------------------------------------------------------------------------
setTargetGoose <- function (gooseName)
{
targetGoose <<- gooseName
.jcall (goose, "V", "setTargetGoose", gooseName)
invisible (NULL)
} # setTargetGoose
#--------------------------------------------------------------------------------------------------
setSpecies <- function (newValue)
{
.jcall (goose, "V", "setSpecies", newValue)
invisible (NULL)
} # setSpecies
#--------------------------------------------------------------------------------------------------
getSpecies <- function ()
{
return (.jcall (goose, "S", "getSpecies"))
} # getSpecies
#--------------------------------------------------------------------------------------------------
showGoose <- function (target=NULL)
{
if (is.null (target))
target = getTargetGoose ()
.jcall (goose, "V", "show", target);
invisible (NULL)
}
#------------------------------------------------------------------------------------------------
hideGoose <- function (target=NULL)
{
if (is.null (target))
target = getTargetGoose ()
.jcall (goose, "V", "hide", target);
invisible (NULL)
}
#------------------------------------------------------------------------------------------------
.getEdgeType = function (edgeList, targetNodeIndex)
{
if (.listMember ("type", names (edgeList)))
return (edgeList [["type"]][targetNodeIndex])
else
return ("edge")
} # .getEdgeType
#-----------------------------------------------------------------------------------------
.broadcastAssociativeArray <- function (list, name)
{
listBaseType = typeof (as.vector (list) [1])
cat ('list base type:', listBaseType, '\n')
if (listBaseType == 'list') {
cat ('error! cannot broadcast a nested list\n')
return (NULL)
}
listKeys = names (list)
if (is.null (listKeys)) {
cat ('error! no names found as index to list\n')
return (NULL)
}
if (listBaseType == 'double') {
listValues = as.double (list)
.jcall (goose, "V", "createAndBroadcastDoubleAttributes", name, listKeys, listValues)
}
else if (listBaseType == 'integer') {
listValues = as.integer (list)
#cat (' type of int list elements:', typeof (listValues [1]), '\n')
.jcall (goose, "V", "createAndBroadcastIntegerAttributes", name, listKeys, listValues)
#cat (' after int call \n')
}
else {
cat ('error! cannot broadcast hash of listBaseType ', listBaseType, '\n')
}
} # broadcastAssociativeArray
#--------------------------------------------------------------------------------
.broadcastGraph <- function (graph, name)
{
graphAsStrings = .graphNELtoGaggleNetwork (graph)
interactionStrings = graphAsStrings$edges
nodeAttributeStrings = graphAsStrings$noa
#print (paste ('gnoa:', graphAsStrings$noa))
#print (paste ('noas:', nodeAttributeStrings))
edgeAttributeStrings = graphAsStrings$eda
emptyStringArray = c ('', '') # two elements to keep JNI from making this a scalar
options (warn = -1) # is.na prints a warning about length > 1. turn it off
if (is.na (interactionStrings)) interactionStrings = emptyStringArray
if (is.na (nodeAttributeStrings)) {
#print (paste ('noa before:', nodeAttributeStrings))
nodeAttributeStrings = emptyStringArray
#print (paste ('noa after:', nodeAttributeStrings))
}
if (length (edgeAttributeStrings) == 0 || is.na (edgeAttributeStrings))
edgeAttributeStrings = emptyStringArray
options (warn = 1)
#print (paste ("is:", interactionStrings))
#print (paste ("na:", nodeAttributeStrings))
#print (paste ("ea:", edgeAttributeStrings))
if (length (interactionStrings) == 1)
interactionStrings = c (interactionStrings, "")
if (length (nodeAttributeStrings) == 1)
nodeAttributeStrings = c (nodeAttributeStrings, "")
if (length (edgeAttributeStrings) == 1)
edgeAttributeStrings = c (edgeAttributeStrings, "")
l = names(attributes(graph))
#e = new.env()
for (i in 1:length(l)) {
item <- l[i]
result = grep('^gaggle\\.', item)
if (length(result) > 0) {
#cat(item)
#cat(attr(n,item))
#assign(item, attr(graph, item), envir=e)
.jcall(goose, "V", "addNetworkMetadata", item, attr(graph, item))
}
}
.jcall (goose, "V", "createAndBroadcastNetwork", interactionStrings,
nodeAttributeStrings, edgeAttributeStrings, name)
} # broadcastGraph
#--------------------------------------------------------------------------------------------------
.broadcastEnvironment <- function (map, attributeName)
# the map has a magic field: 'title'
# this slot, if present, supplies the title of this hash map, which is not to
# be confused with the name of the attribute being assigned.
# for example:
# title = 'simulation #4'
# attributeName='log2 ratio'
# names = c ("A", "B", "C")
# values = c (0.5, 1.8, 0.85)
#
# in code:
# m = new.env ()
# m$title = 'simulation #4'
# assign ("A", 0.5, envir=m)
# assign ("B", 1.8, envir=m)
# assign ("C", 0.85, envir=m)
# broadcast (m, "log2 ratio")
#
# -- or, if Biobase:mulitassign is available:
#
# m = new.env ()
# m$title = 'simuluation #4'
# assign ("A", 0.5, envir=m)
{
keys = ls (map)
allNames = c ()
allValues = c ()
for (name in keys) {
allNames = c (allNames, name)
values = get (name, map)
valueCount = length (get (name, map))
capturedValue = .captureQuotedNumbersAsStrings(values[1])
valuesAsString = as.character(capturedValue)
valuesAsString = paste (capturedValue)
allValues = c (allValues, valuesAsString)
}
if (! "title" %in% ls (map))
title = "from R"
else
title = map$title
.jcall (goose, "V", "createAndBroadcastGaggleTuple", title, attributeName, allNames, allValues)
invisible ()
} # broadcastEnvironment
.captureQuotedNumbersAsStrings <- function(i) {
previousWarnLevel = getOption('warn')
if (is.numeric(i)) {
return (i)
}
options(warn = -1)
if (is.na(as.numeric(i))) {
options(warn = previousWarnLevel)
return (i)
}
options(warn = previousWarnLevel)
return (paste("|",i,"|", sep=""))
}
#--------------------------------------------------------------------------------------------------
.listMember <- function (item, list)
{
return (length (intersect (item, list)) > 0)
}
#-------------------------------------------------------------------------------------------------------
testGagglePackage <- function()
{
require ("RUnit", quietly=TRUE) || stop ("RUnit package not found")
testScript = paste (system.file (package="gaggle"), "unitTests/gaggleTest.R", sep="/")
file.exists (testScript) || stop (paste (testScript, "not found."))
source (testScript)
test.gaggle ()
} # testGagglePackage
#-------------------------------------------------------------------------------------------------------
connectToGaggle <- function()
{
.jcall (goose, "V", "connectToGaggle")
invisible()
}
#--------------------------------------------------------------------------------------------------
disconnectFromGaggle <- function()
{
.jcall (goose, "V", "doExit")
invisible()
}
#--------------------------------------------------------------------------------------------------
# Receive a gaggle tuple and converts it to an R list
getTupleAsList <- function() {
tuple <- .jcall(goose, "Lorg/systemsbiology/gaggle/core/datatypes/Tuple;", "getTuple")
return(tupleToList(tuple))
}
#--------------------------------------------------------------------------------------------------
# Converts a Gaggle Tuple into a nested list structure. Receiving gaggle data
# types other than tuple nested in the list is not supported.
tupleToList <- function(tuple) {
result <- list()
if (!is.null(tuple) && !is.jnull(tuple)) {
singles <- .jcall(tuple, "Ljava/util/List;", "getSingleList")
len <- .jcall(singles, "I", "size")
for (i in seq(from=0, length.out = len)) {
single <- .jcall(tuple, "Lorg/systemsbiology/gaggle/core/datatypes/Single;", "getSingleAt", as.integer(i))
key <- .jcall(single, "Ljava/lang/String;", "getName")
value <- .jcall(single, "Ljava/io/Serializable;", "getValue")
if (is.null(value) || is.jnull(value)) {
r.value <- NULL
}
else {
# I'd like to use instanceof, which requires rJava 0.8.
# Note that the current method will fail to detect subclasses of Tuple
j.class <- .jcall(.jcall(value, "Ljava/lang/Class;", "getClass"), "Ljava/lang/String;", "getName")
# cat("j.class = ", j.class, "\n")
if (j.class == "org.systemsbiology.gaggle.core.datatypes.Tuple") {
# recurse into tuple values
r.value <- tupleToList(value)
} else {
r.value <- .jsimplify(value)
}
}
# append the value or key/value pair to the result
if (is.jnull(key)) {
result[[length(result)+1]] <- r.value
} else {
result[[key]] <- r.value
}
}
}
return(result)
}
#--------------------------------------------------------------------------------------------------
# Create a Gaggle Single object from an R value of type integer, double, logical, or character.
# Numeric values are naturally doubles in R, so use as.integer(x) to create an integer.
newSingle <- function(name, value) {
if (typeof(value)=="integer") {
jvalue = .jnew('java/lang/Integer', value)
}
else if (typeof(value)=="double") {
jvalue = .jnew('java/lang/Double', value)
}
else if (typeof(value)=="character") {
jvalue = .jnew('java/lang/String', value)
}
else if (typeof(value)=="logical") {
jvalue = .jnew('java/lang/Boolean', value)
}
else if (class(value)=='list') {
jvalue = newTuple(name, value)
}
else if (class(value)=='jobjRef') {
if (isJavaTuple(value)) {
jvalue <- value
}
}
else {
cat("Can't convert R type ", typeof(value), " to Java.\n")
}
return(.jnew('org/systemsbiology/gaggle/core/datatypes/Single', name, .jcast(jvalue, 'java/io/Serializable')))
}
#--------------------------------------------------------------------------------------------------
# add a single to a tuple, either as a name,value pair
# or add a premade single object.
addSingle <- function(tuple, name=NULL, value=NULL, single=NULL) {
if (is.null(single)) {
single = newSingle(name, value)
}
.jcall(tuple, 'V', 'addSingle', single)
return(tuple)
}
#--------------------------------------------------------------------------------------------------
# Create a new tuple. Use with addSingle.
# list can hold values that map to a java primitive type or recursively list of such values
newTuple <- function(name, list=NULL) {
tuple <- .jnew('org/systemsbiology/gaggle/core/datatypes/Tuple', name)
if (!is.null(list) && is.environment(list)) {
for (key in ls(list)) {
addSingle(tuple, key, list[[key]])
}
}
else if (!is.null(list)) {
# can't figure out how to get the name of each element inside the reduce function, we have
# to wimp out and use a loop
# Reduce(function(t, element) { addSingle(t, ??name of element??, element)}, cmd.import.track, tuple)
for(i in 1:length(list)) {
if (!is.null(list[[i]]))
addSingle(tuple, names(list)[i], list[[i]])
}
}
return(tuple)
}
#--------------------------------------------------------------------------------------------------
Try the gaggle package in your browser
Any scripts or data that you put into this service are public.
gaggle documentation built on Nov. 8, 2020, 8:07 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions newTuple addSingle newSingle tupleToList getTupleAsList disconnectFromGaggle connectToGaggle testGagglePackage .captureQuotedNumbersAsStrings getJavaClassName isJavaTuple
Documented in addSingle connectToGaggle disconnectFromGaggle getJavaClassName getTupleAsList newSingle newTuple testGagglePackage tupleToList
# gaggle.R
#---------------------------------------------------------------------------------
.onLoad <- function (libname, pkgname)
{
#require ("methods")
require ("rJava")
libname = gsub(" ", "%20", libname, "+")
cat (paste ('\nonLoad -- libname:', libname, 'pkgname:', pkgname, '\n'))
# All Bioconductor packages should use an x.y.z version scheme. The following rules apply:
# The y number should be odd for packages in devel and even for packages in release.
# This makes it easier for users to know whether the package they have installed
# is release or devel. We encourage package maintainers to increment z whenever
# committing changes to a package in devel. Any change committed to a released
# package, no matter how small, must bump z.
fullPathToGaggleJar = paste (libname, pkgname, 'jars', 'gaggleRShell.jar', sep=.Platform$file.sep)
cat ('path to jar:', fullPathToGaggleJar, '\n')
cat (' script: ', .scriptVersion (), '\n')
# Before starting VM, set the system classpath to a blank string
# this gets around a bug where RMI objects fail to unmarshal
# if the classpath has spaces in it (which it often does on
# Windows machines). Yes, this is a weird error.
Sys.unsetenv("CLASSPATH")
.jinit (fullPathToGaggleJar)
cat (' os version: ', .jcall ("java/lang/System", "S", "getProperty", "os.name"),'\n')
#-----------------------------------------------------------
# as of february 2006, the gaggle requires java 1.5.
# bail out if the version found by .jinit is some other version
# java versions on macos can be especially confusing. the
# url supplied below explains what to do
#-----------------------------------------------------------
jvmVersion = .jcall ("java/lang/System", "S", "getProperty", "java.version")
cat (' jvm version: ', jvmVersion, '\n')
if (is.na (pmatch ("1.5.", jvmVersion)) &&
is.na (pmatch ("1.6.", jvmVersion)) &&
is.na (pmatch("1.7", jvmVersion)))
{
cat ('\n You are using the wrong version of Java.\n',
' Please see http://gaggle.systemsbiology.org/docs/html/java\n\n')
return ()
}
} # first lib
#---------------------------------------------------------------------------------
gaggleInit <- function (bossHost = 'localhost')
# the user must call this, to create the java R goose, to register it with
# the boss, and before sending or receiving any broadcasts
{
cat (paste(' initializing gaggle package', .pkgVersion(), '(2007-04)\n'))
goose <<- .jnew ("org/systemsbiology/gaggle/geese/rShell/RShellGoose", bossHost)
tester = geese ()
if (is.null (tester)) {
cat ('\n\n\tFailed to connect to a Gaggle Boss. Is one running on your computer?\n')
cat ('\tUse this Java Web Start link to start a boss:\n')
cat ('\t\thttp://gaggle.systemsbiology.org/2007-04/boss.jnlp\n')
cat ('\tYou need to exit R, start the boss, re-enter R, and load the gaggle package once again.\n\n')
}
else {
targetGoose <<- "boss"
cat (' name: ', .jcall (goose, "S", "getName"), "\n")
cat (' RShellGoose: ', .jcall (goose, "S", "getVersion"), "\n")
}
} # gaggleInit
.pkgVersion <- function ()
{
return (as.character(sessionInfo()$otherPkgs$gaggle)[2])
}
#---------------------------------------------------------------------------------
.scriptVersion <- function ()
{
return ("gaggle.R $Revision: 4499 $ $Date: 2010-08-10 17:15:03 -0700 (Tue, 10 Aug 2010) $");
}
#---------------------------------------------------------------------------------
getNameList <- function ()
{
nameList <- .jcall (goose, "[S", "getNameList")
return (nameList)
}
#---------------------------------------------------------------------------------
getCluster <- function ()
{
result = list ()
result$name = .jcall (goose, "S", "getClusterName")
result$rowNames = .jcall (goose, "[S", "getClusterRowNames")
result$columnNames = .jcall (goose, "[S", "getClusterColumnNames")
return (result)
}
#---------------------------------------------------------------------------------
getTuple <- function ()
{
hash = new.env ()
hash$title = .jcall (goose, "S", "getTupleTitle")
#hash$attributeName = .jcall (goose, "S". "getTupleAttributeName") #leave this be for now; it might mess things up
keys = .jcall (goose, "[S", "getTupleKeys")
rawValues = .jcall (goose, "[S", "getTupleValues")
#print (keys)
#print (rawValues)
options (warn = -1) # failed conversion to numeric prints an message to stdout; disable it
for (i in seq (length (keys))) {
value = as.numeric (rawValues [i])
if (is.na (value)) value = rawValues [i]
assign (keys [i], value, envir=hash)
}
options (warn = 1) # turn warnings back on
return (hash)
} # getHashMap
getMatrix <- function ()
{
rowCount <- .jcall (goose, "I", "getMatrixRowCount")
columnCount <- .jcall (goose, "I", "getMatrixColumnCount")
matrixRowNames <- .jcall (goose, "[S", "getMatrixRowNames")
matrixColumnNames <- .jcall (goose, "[S", "getMatrixColumnNames")
#cat ("rows: ", rowCount, "\n");
#cat ("cols: ", columnCount, "\n");
#cat ("row names ", matrixRowNames, "\n");
#cat ("col names ", matrixColumnNames, "\n");
data <- .jcall (goose, "[D", "getAllMatrixData");
m <- matrix (data, nrow=rowCount, ncol=columnCount, byrow=T,
dimnames = list (matrixRowNames, matrixColumnNames))
return (m)
}
#---------------------------------------------------------------------------------
getNetwork <- function (directed=TRUE)
{
edgeStrings = .jcall (goose, "[S", "getNetworkAsStringArray")
nodeAttributeStrings = .jcall (goose, "[S", "getNetworkNodeAttributesAsStringArray")
edgeAttributeStrings = .jcall (goose, "[S", "getNetworkEdgeAttributesAsStringArray")
result = .gaggleNetworkToGraphNEL (edgeStrings, nodeAttributeStrings, edgeAttributeStrings, directed)
#print (paste ('getNetwork: ', result))
return (result)
}
#---------------------------------------------------------------------------------
#getHashMap <- function ()
#{
# hash = new.env ()
# hash$title = .jcall (goose, "S", "getHashMapTitle")
# keys = .jcall (goose, "[S", "getHashMapKeys")
# rawValues = .jcall (goose, "[S", "getHashMapValues")
# #print (keys)
# #print (rawValues)
#
# options (warn = -1) # failed conversion to numeric prints an message to stdout; disable it
#
# for (i in seq (length (keys))) {
# value = as.numeric (rawValues [i])
# if (is.na (value)) value = rawValues [i]
# assign (keys [i], value, envir=hash)
# }
#
# options (warn = 1) # turn warnings back on
#
# return (hash)
#
#} # getHashMap
#---------------------------------------------------------------------------------
.graphNELtoGaggleNetwork <- function (g)
# the name of this function is a slight exaggeration: we don't really create
# a Gaggle Network object here, but we do translate the R graph into 3 String
# arrays, which are easy to send to Java, and from which RShellGoose.java can
# easily construct a real Gaggle Network.
#
# these are the string types
#
# edges: "VNG0723G::VNG1233G::PhylogeneticProfile"
# edge attributes: "VNG0723G::VNG1233G::PhylogeneticProfile::confidence::0.533"
# node attributes: "VNG1233G::commonName::pepq2"
{
# set some default values. these will be assigned in this function.
# node attributes may not exist, but the other two will, always.
edgeStringList = NA
nodeAttributeStringList = NA
edgeAttributeStringList = NA
# does it have an explicit edge type? gaggle network graphs always do, but
# those originating in R may not. supply one if needed
hasExplicitEdgeType = .listMember ("edgeType", names (edgeDataDefaults (g)))
if (!hasExplicitEdgeType)
edgeDataDefaults (g, "edgeType") = "edge"
#------------------------------------------------------------------------
# create the edge strings: nodeA::nodeB:<edgeType>
# and the degenerate case: nodeC
#------------------------------------------------------------------------
edgeStringList = c ()
for (node in nodes (g)) {
#print (paste ('looking for nodes linked to', node))
edgePartners = edges (g)[[node]]
#print (paste (' partners:', edgePartners))
if (length (edgePartners) == 0) {
edgeString = node
if (!.listMember (edgeString, edgeStringList))
edgeStringList = c (edgeStringList, edgeString)
} # a degenerate edge, just a node
else {
for (partner in edgePartners) {
nodeA = node
nodeB = partner
# keep edge strings nodes alphabetically sorted, so we can check for duplicates
if (!isDirected (g) && nodeA > nodeB) {
tmp = nodeB
nodeB = nodeA
nodeA = tmp
}
edgeType = edgeData (g, nodeA, nodeB, "edgeType")
edgeString = paste (nodeA, nodeB, edgeType, sep='::')
#print (paste ('new edge:', edgeString))
if (!.listMember (edgeString, edgeStringList))
edgeStringList = c (edgeStringList, edgeString)
} # for partner
} # else: a real edge
}# for node
#------------------------------------------------------------------------------
# now create the node attribute strings: node::attributeName::attributeValue
#------------------------------------------------------------------------------
nodeAttributeNames = names (nodeDataDefaults (g))
if (length (nodeAttributeNames) > 0) {
nodeAttributeStringList = c ()
for (attributeName in nodeAttributeNames) {
for (node in nodes (g)) {
value = nodeData (g, node, attributeName )[[1]]
noaString = paste (node, attributeName, value, sep='::')
nodeAttributeStringList = c (nodeAttributeStringList, noaString)
} # for node
} # for attributeName
}# if > 0
#------------------------------------------------------------------------------
# lastly, create the edge attribute strings:
# nodeA::nodeB::edgeType::attributeName::attributeValue
#------------------------------------------------------------------------------
edgeAttributeStringList = c ()
edgeAttributeNames = names (edgeDataDefaults (g))
# partner nodes (sharing an edge) have already been identifed, and stroed in edgeStringList
# exploit that rather than searching again
for (attributeName in edgeAttributeNames) {
for (edgeString in edgeStringList) {
tokens = unlist (strsplit (edgeString, "::"))
if (length (tokens) != 3) # is this a degenerate 'edge' -- just a node?
next
nodeA = tokens [1]
nodeB = tokens [2]
edgeType = tokens [3]
attributeValue = edgeData (g, nodeA, nodeB, attributeName)[[1]]
edaString = paste (nodeA, nodeB, edgeType, attributeName, attributeValue, sep="::")
edgeAttributeStringList = c (edgeAttributeStringList, edaString)
} # for edgeString
} # for attributeName
results = list ()
results$edges = edgeStringList
results$noa = nodeAttributeStringList
results$eda = edgeAttributeStringList
return (results)
} # .graphNELtoGaggleNetwork
#---------------------------------------------------------------------------------
.gaggleNetworkToGraphNEL <- function (edges, noas, edas, directed)
# it's easy to send arrays of strings between java and R, so that's what we rely on.
# there are three types of strings, each of which has some 'magic' coding, as you can
# see below:
# edges consist of strings like "VNG0723G::VNG1233G::PhylogeneticProfile"
# edge attributes: "VNG0723G::VNG1233G::PhylogeneticProfile::confidence::0.533"
# node attributes: "VNG1233G::commonName::pepq2"
{
# ---- create the graph, add nodes, add edges between them,
# add edgeType attributes (which are implicit in the edge strings)
#print (cat ('lkjsadf;lkjasdf;lkjasdf;lkjasd;lfgkj'))
edgeMode = "directed"
if (directed) {
edgeMode = "directed"
} else {
edgeMode = "undirected"
}
g = new ("graphNEL", edgemode=edgeMode)
edgeDataDefaults (g, "edgeType") = ""
if (!is.null (edges) && !is.na (edges)) for (edge in edges) {
tokens = unlist (strsplit (edge, '::'))
if (length (tokens) == 1) {
orphanNode = tokens [1]
if (!.listMember (orphanNode, nodes (g)))
g = addNode (tokens [1], g)
} # 1 token only
else if (length (tokens) == 3) {
nodeA = tokens [1]
nodeB = tokens [2]
edgeType = tokens [3]
if (!.listMember (nodeA, nodes (g)))
g = addNode (nodeA, g)
if (!.listMember (nodeB, nodes (g)))
g = addNode (nodeB, g)
g = addEdge (nodeA, nodeB, g)
edgeData (g, from=nodeA, to=nodeB, attr="edgeType") = edgeType
} # 3 tokens
} # for
# ---- now traverse the explicit edge attributes, and add them
if ((!length (edas) == 0) && !is.null (edas) && !is.na (edas)) for (eda in edas) {
tokens = unlist (strsplit (eda, '::'))
nodeA = tokens [1]
nodeB = tokens [2]
edgeType = tokens [3] # we ignore this for now, since graph allows only 1 edge
attributeName = tokens [4]
#print (paste ('edge attribute name:', attributeName))
rawAttributeValue = tokens [5]
options (warn = -1)
attributeValue = as.numeric (rawAttributeValue)
options (warn = 1)
if (is.na (attributeValue)) attributeValue = rawAttributeValue
# is this an unknown edge attribute type? if so, initialize it
if (!.listMember (attributeName, names (edgeDataDefaults (g)))) {
if (attributeName == 'weight')
edgeDataDefaults (g, attributeName) = 1.0
else
edgeDataDefaults (g, attributeName) = ""
} # if new edge attribute
edgeData (g, from=nodeA, to=nodeB, attr=attributeName) = attributeValue
} # if edge attributes
if ((!length (noas) == 0) && !is.null (noas) && !is.na (noas)) for (noa in noas) {
tokens = unlist (strsplit (noa, '::'))
node = tokens [1]
attributeName = tokens [2]
rawAttributeValue = tokens [3]
# is this an unknown node attribute type? if so, initialize it
if (!.listMember (attributeName, names (nodeDataDefaults (g))))
nodeDataDefaults (g, attributeName) = ""
options (warn = -1)
attributeValue = as.numeric (rawAttributeValue)
options (warn = 1)
if (is.na (attributeValue)) attributeValue = rawAttributeValue
nodeData (g, node, attributeName) = attributeValue
} # for
return (g)
}# .gaggleNetworkToGraphNEL
#-------------------------------------------------------------------------------------------
# test whether the given object is an instance of a Java Tuple object
isJavaTuple <- function(obj) {
return (class(obj)=="jobjRef" && isS4(obj) && slot(obj, "jclass")=="org/systemsbiology/gaggle/core/datatypes/Tuple" && !is.jnull(obj))
}
#-------------------------------------------------------------------------------------------
# get the Java class name of an rJava object
getJavaClassName <- function(jobj, quiet=FALSE) {
if (class(jobj)=='jobjRef') {
if (is.jnull(jobj)) {
return("null")
}
return(.jcall(.jcall(jobj, 'Ljava/lang/Class;', 'getClass'), 'S', 'getName'))
}
else {
if (!quiet) {
cat("Error in getJavaClassName: Not a java object?\n")
}
return("Not a java object")
}
}
#-------------------------------------------------------------------------------------------
broadcast <- function (x, name='from R')
{
if (is.matrix (x) || is.data.frame(x)) {
#cat ('broadcasting matrix, name: ', name, '\n')
# java stores matrices in row-major order, R uses column-major, so be sure to
# transpose the actual data before sending it to java
if (is.null(rownames(x)) || is.null(colnames(x))) {
cat('Error: row and column names required to broadcast matrix')
} else {
.jcall (goose, "V", "createAndBroadcastMatrix", rownames (x), colnames (x),
as.numeric (as.vector (t(x))), name)
}
}
else if (is.vector (x)) {
if (length (intersect (c("rowNames", "columnNames"), names (x))) == 2) {
rowNames = x$rowNames
columnNames = x$columnNames
.jcall (goose, "V", "broadcastCluster", name, rowNames, columnNames)
}
else if (!is.null (names (x))) {
.broadcastAssociativeArray (x, name)
} else {
if (length (x) == 1) #
x <- as.vector(c(x))
.jcall (goose, "V", "broadcastList", x, name)
} # unnamed list
} # vector
# Broadcast a (Java) Tuple object.
# Added by JCB to support genome browser.
else if (isJavaTuple(x)) {
if (name!='from R') {
.jcall(x, "V", "setName", name)
}
.jcall(goose, "V", "broadcastTuple", x)
}
else if (class (x) == "graphNEL") {
.broadcastGraph (x, name)
}
else if (class (x) == "environment") {
.broadcastEnvironment (x, name)
#.broadcastAssociativeArray(x, name)
}
else {
cat ("no support yet for broadcasting variables of type ", typeof (x), "\n")
}
invisible (NULL)
} # generic broadcast
#---------------------------------------------------------------------------------
geese <- function ()
{
return (.jcall (goose, "[S", "getGeeseNames"));
}
#------------------------------------------------------------------------------------------------
getTargetGoose <- function ()
{
return (.jcall (goose, "S", "getTargetGoose"))
} # getTargetGoose
#--------------------------------------------------------------------------------------------------
setTargetGoose <- function (gooseName)
{
targetGoose <<- gooseName
.jcall (goose, "V", "setTargetGoose", gooseName)
invisible (NULL)
} # setTargetGoose
#--------------------------------------------------------------------------------------------------
setSpecies <- function (newValue)
{
.jcall (goose, "V", "setSpecies", newValue)
invisible (NULL)
} # setSpecies
#--------------------------------------------------------------------------------------------------
getSpecies <- function ()
{
return (.jcall (goose, "S", "getSpecies"))
} # getSpecies
#--------------------------------------------------------------------------------------------------
showGoose <- function (target=NULL)
{
if (is.null (target))
target = getTargetGoose ()
.jcall (goose, "V", "show", target);
invisible (NULL)
}
#------------------------------------------------------------------------------------------------
hideGoose <- function (target=NULL)
{
if (is.null (target))
target = getTargetGoose ()
.jcall (goose, "V", "hide", target);
invisible (NULL)
}
#------------------------------------------------------------------------------------------------
.getEdgeType = function (edgeList, targetNodeIndex)
{
if (.listMember ("type", names (edgeList)))
return (edgeList [["type"]][targetNodeIndex])
else
return ("edge")
} # .getEdgeType
#-----------------------------------------------------------------------------------------
.broadcastAssociativeArray <- function (list, name)
{
listBaseType = typeof (as.vector (list) [1])
cat ('list base type:', listBaseType, '\n')
if (listBaseType == 'list') {
cat ('error! cannot broadcast a nested list\n')
return (NULL)
}
listKeys = names (list)
if (is.null (listKeys)) {
cat ('error! no names found as index to list\n')
return (NULL)
}
if (listBaseType == 'double') {
listValues = as.double (list)
.jcall (goose, "V", "createAndBroadcastDoubleAttributes", name, listKeys, listValues)
}
else if (listBaseType == 'integer') {
listValues = as.integer (list)
#cat (' type of int list elements:', typeof (listValues [1]), '\n')
.jcall (goose, "V", "createAndBroadcastIntegerAttributes", name, listKeys, listValues)
#cat (' after int call \n')
}
else {
cat ('error! cannot broadcast hash of listBaseType ', listBaseType, '\n')
}
} # broadcastAssociativeArray
#--------------------------------------------------------------------------------
.broadcastGraph <- function (graph, name)
{
graphAsStrings = .graphNELtoGaggleNetwork (graph)
interactionStrings = graphAsStrings$edges
nodeAttributeStrings = graphAsStrings$noa
#print (paste ('gnoa:', graphAsStrings$noa))
#print (paste ('noas:', nodeAttributeStrings))
edgeAttributeStrings = graphAsStrings$eda
emptyStringArray = c ('', '') # two elements to keep JNI from making this a scalar
options (warn = -1) # is.na prints a warning about length > 1. turn it off
if (is.na (interactionStrings)) interactionStrings = emptyStringArray
if (is.na (nodeAttributeStrings)) {
#print (paste ('noa before:', nodeAttributeStrings))
nodeAttributeStrings = emptyStringArray
#print (paste ('noa after:', nodeAttributeStrings))
}
if (length (edgeAttributeStrings) == 0 || is.na (edgeAttributeStrings))
edgeAttributeStrings = emptyStringArray
options (warn = 1)
#print (paste ("is:", interactionStrings))
#print (paste ("na:", nodeAttributeStrings))
#print (paste ("ea:", edgeAttributeStrings))
if (length (interactionStrings) == 1)
interactionStrings = c (interactionStrings, "")
if (length (nodeAttributeStrings) == 1)
nodeAttributeStrings = c (nodeAttributeStrings, "")
if (length (edgeAttributeStrings) == 1)
edgeAttributeStrings = c (edgeAttributeStrings, "")
l = names(attributes(graph))
#e = new.env()
for (i in 1:length(l)) {
item <- l[i]
result = grep('^gaggle\\.', item)
if (length(result) > 0) {
#cat(item)
#cat(attr(n,item))
#assign(item, attr(graph, item), envir=e)
.jcall(goose, "V", "addNetworkMetadata", item, attr(graph, item))
}
}
.jcall (goose, "V", "createAndBroadcastNetwork", interactionStrings,
nodeAttributeStrings, edgeAttributeStrings, name)
} # broadcastGraph
#--------------------------------------------------------------------------------------------------
.broadcastEnvironment <- function (map, attributeName)
# the map has a magic field: 'title'
# this slot, if present, supplies the title of this hash map, which is not to
# be confused with the name of the attribute being assigned.
# for example:
# title = 'simulation #4'
# attributeName='log2 ratio'
# names = c ("A", "B", "C")
# values = c (0.5, 1.8, 0.85)
#
# in code:
# m = new.env ()
# m$title = 'simulation #4'
# assign ("A", 0.5, envir=m)
# assign ("B", 1.8, envir=m)
# assign ("C", 0.85, envir=m)
# broadcast (m, "log2 ratio")
#
# -- or, if Biobase:mulitassign is available:
#
# m = new.env ()
# m$title = 'simuluation #4'
# assign ("A", 0.5, envir=m)
{
keys = ls (map)
allNames = c ()
allValues = c ()
for (name in keys) {
allNames = c (allNames, name)
values = get (name, map)
valueCount = length (get (name, map))
capturedValue = .captureQuotedNumbersAsStrings(values[1])
valuesAsString = as.character(capturedValue)
valuesAsString = paste (capturedValue)
allValues = c (allValues, valuesAsString)
}
if (! "title" %in% ls (map))
title = "from R"
else
title = map$title
.jcall (goose, "V", "createAndBroadcastGaggleTuple", title, attributeName, allNames, allValues)
invisible ()
} # broadcastEnvironment
.captureQuotedNumbersAsStrings <- function(i) {
previousWarnLevel = getOption('warn')
if (is.numeric(i)) {
return (i)
}
options(warn = -1)
if (is.na(as.numeric(i))) {
options(warn = previousWarnLevel)
return (i)
}
options(warn = previousWarnLevel)
return (paste("|",i,"|", sep=""))
}
#--------------------------------------------------------------------------------------------------
.listMember <- function (item, list)
{
return (length (intersect (item, list)) > 0)
}
#-------------------------------------------------------------------------------------------------------
testGagglePackage <- function()
{
require ("RUnit", quietly=TRUE) || stop ("RUnit package not found")
testScript = paste (system.file (package="gaggle"), "unitTests/gaggleTest.R", sep="/")
file.exists (testScript) || stop (paste (testScript, "not found."))
source (testScript)
test.gaggle ()
} # testGagglePackage
#-------------------------------------------------------------------------------------------------------
connectToGaggle <- function()
{
.jcall (goose, "V", "connectToGaggle")
invisible()
}
#--------------------------------------------------------------------------------------------------
disconnectFromGaggle <- function()
{
.jcall (goose, "V", "doExit")
invisible()
}
#--------------------------------------------------------------------------------------------------
# Receive a gaggle tuple and converts it to an R list
getTupleAsList <- function() {
tuple <- .jcall(goose, "Lorg/systemsbiology/gaggle/core/datatypes/Tuple;", "getTuple")
return(tupleToList(tuple))
}
#--------------------------------------------------------------------------------------------------
# Converts a Gaggle Tuple into a nested list structure. Receiving gaggle data
# types other than tuple nested in the list is not supported.
tupleToList <- function(tuple) {
result <- list()
if (!is.null(tuple) && !is.jnull(tuple)) {
singles <- .jcall(tuple, "Ljava/util/List;", "getSingleList")
len <- .jcall(singles, "I", "size")
for (i in seq(from=0, length.out = len)) {
single <- .jcall(tuple, "Lorg/systemsbiology/gaggle/core/datatypes/Single;", "getSingleAt", as.integer(i))
key <- .jcall(single, "Ljava/lang/String;", "getName")
value <- .jcall(single, "Ljava/io/Serializable;", "getValue")
if (is.null(value) || is.jnull(value)) {
r.value <- NULL
}
else {
# I'd like to use instanceof, which requires rJava 0.8.
# Note that the current method will fail to detect subclasses of Tuple
j.class <- .jcall(.jcall(value, "Ljava/lang/Class;", "getClass"), "Ljava/lang/String;", "getName")
# cat("j.class = ", j.class, "\n")
if (j.class == "org.systemsbiology.gaggle.core.datatypes.Tuple") {
# recurse into tuple values
r.value <- tupleToList(value)
} else {
r.value <- .jsimplify(value)
}
}
# append the value or key/value pair to the result
if (is.jnull(key)) {
result[[length(result)+1]] <- r.value
} else {
result[[key]] <- r.value
}
}
}
return(result)
}
#--------------------------------------------------------------------------------------------------
# Create a Gaggle Single object from an R value of type integer, double, logical, or character.
# Numeric values are naturally doubles in R, so use as.integer(x) to create an integer.
newSingle <- function(name, value) {
if (typeof(value)=="integer") {
jvalue = .jnew('java/lang/Integer', value)
}
else if (typeof(value)=="double") {
jvalue = .jnew('java/lang/Double', value)
}
else if (typeof(value)=="character") {
jvalue = .jnew('java/lang/String', value)
}
else if (typeof(value)=="logical") {
jvalue = .jnew('java/lang/Boolean', value)
}
else if (class(value)=='list') {
jvalue = newTuple(name, value)
}
else if (class(value)=='jobjRef') {
if (isJavaTuple(value)) {
jvalue <- value
}
}
else {
cat("Can't convert R type ", typeof(value), " to Java.\n")
}
return(.jnew('org/systemsbiology/gaggle/core/datatypes/Single', name, .jcast(jvalue, 'java/io/Serializable')))
}
#--------------------------------------------------------------------------------------------------
# add a single to a tuple, either as a name,value pair
# or add a premade single object.
addSingle <- function(tuple, name=NULL, value=NULL, single=NULL) {
if (is.null(single)) {
single = newSingle(name, value)
}
.jcall(tuple, 'V', 'addSingle', single)
return(tuple)
}
#--------------------------------------------------------------------------------------------------
# Create a new tuple. Use with addSingle.
# list can hold values that map to a java primitive type or recursively list of such values
newTuple <- function(name, list=NULL) {
tuple <- .jnew('org/systemsbiology/gaggle/core/datatypes/Tuple', name)
if (!is.null(list) && is.environment(list)) {
for (key in ls(list)) {
addSingle(tuple, key, list[[key]])
}
}
else if (!is.null(list)) {
# can't figure out how to get the name of each element inside the reduce function, we have
# to wimp out and use a loop
# Reduce(function(t, element) { addSingle(t, ??name of element??, element)}, cmd.import.track, tuple)
for(i in 1:length(list)) {
if (!is.null(list[[i]]))
addSingle(tuple, names(list)[i], list[[i]])
}
}
return(tuple)
}
#--------------------------------------------------------------------------------------------------
Try the gaggle package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.