Nothing
##########################################################################
# #
# SPRINT: Simple Parallel R INTerface #
# Copyright � 2008,2009 The University of Edinburgh #
# #
# This program is free software: you can redistribute it and/or modify #
# it under the terms of the GNU General Public License as published by #
# the Free Software Foundation, either version 3 of the License, or #
# any later version. #
# #
# This program 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 General Public License for more details. #
# #
# You should have received a copy of the GNU General Public License #
# along with this program. If not, see <http://www.gnu.or/licenses/>. #
# #
##########################################################################
# The R stub for the pcor function. This does some rudimentary
# argument type checking and then hands off to the C stub.
pcor <- function(
data_x # input numerical matrix
, data_y = NULL # matrix with compatible dimensions to data_x.
, distance = FALSE # Return the distance matrix instead of the correlation coefficients
, caching_ = "mmeachflush" # getOption("ffcaching")
, filename_ = NULL # tempfile(pattern = pattern, tmpdir = getOption("fftempdir"))
)
{
# we only work on doubles
vmode_ = "double"
# determine filename and finalizer
# if user choses to work on a temporary file it will be deleted whenn all
# references to the ff object are closed
if (is.null(filename_)){
# delete if temporary ff object
finalizer_<- "delete"
} else {
finalizer_<- "close"
}
if (is.null(filename_)){
# temporary ff object
filename_<- tempfile(pattern = "ff" , tmpdir = getwd())
}
# determine length of the result correlation matrix
if (is.matrix(data_x) && is.numeric(data_x)) {
height = dim(data_x)[2]
length_ <- height * height
}
else
stop(..sprintMsg$error["non.numeric"])
if(!is.null(data_y)) {
if (!is.matrix(data_y) && !is.numeric(data_y))
stop(..sprintMsg$error["non.numeric"])
if (dim(data_x)[0] != dim(data_y)[0] && dim(data_x)[1] != dim(data_y)[1])
stop(..sprintMsg$error["no.dims"])
}
if (is.null(caching_))
caching_<- getOption("ffcaching")
else
caching_<- match.arg(caching_, c("mmnoflush", "mmeachflush"))
# Check the value of the "distance" option
if ( (!is.logical(distance)) || (length(distance)>1) ) {
warning(paste("Value of option \"distance\" must be a scalar logical (TRUE of FALSE). You supplied : ", distance))
return(FALSE)
}
# Call C interface
return_val <- .Call("pcor", data_x, data_y, filename_, distance)
colnames1 <- colnames(data_x)
if(is.null(data_y))
colnames2 <- colnames(data_x)
else
colnames2 <- colnames(data_y)
# Return values from the interface have meaning.
# 0 --> success
# -1 --> MPI is not initialized
# -2 --> Only the master process exists, no workers
if ( return_val == 0 ) {
# Open result binary file and return as ff object
result = ff(
dim=c(height,height),
dimnames=list(colnames1,colnames2),
, filename=filename_
, vmode=vmode_
, caching=caching_
, finalizer=finalizer_
, length=length_
)
} else {
if ( return_val == -1 )
warning(paste("MPI is not initialized. Function is aborted.\n"))
if ( return_val == -2 )
warning(paste("No worker processes exist. Function pcor() is aborted.\n"))
result <- FALSE
}
return(result)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.