R/interface.R

In renozao/RcppOctave: Seamless Interface to Octave -- And Matlab

# R functions to interact with an embedded Octave instance
# 
# Author: "Renaud Gaujoux"
# Creation: 26 Oct 2011
###############################################################################

#' @include utils.R
NULL

#' Calling an Octave Function
#' 
#' \code{.CallOctave} calls an Octave function and returns its value.
#' 
#' @param .NAME an Octave function name. The function must be a valid function 
#' name in the current Octave session.
#' @param ... arguments passed to the Octave function
#' @param argout the number of output values, or a vector of names to use as output
#' variable names. The names are directly used and applied to the result list in 
#' their original order.
#'  
#' The default value \code{argout=-1} returns:
#' \itemize{
#' \item all output values when their number can be determined. This would typically  
#' be the case for functions defined in .m files. Please do read section 
#' \emph{Details} for considerations about the functions that use varargout. 
#' \item only the first one otherwise.
#' }
#' @param unlist a logical that specifies if an output list of length one 
#' should be simplified and returned as a single value or kept as a list.
#' The default is to unlist unless output names were passed in \code{argout}.
#' @param buffer.std logical that indicates if Octave stdout and/or stderr should be buffered.
#' If \code{TRUE} output/errors/warnings are all displayed at the end of the computation.
#' If \code{FALSE} they are directly displayed as they come.
#' It is also possible to selectively buffer either one of stdout or stderr, via 
#' the following integer codes:
#' \itemize{
#' \item \code{0}: no buffering; 
#' \item \code{1} or \code{-2}: only stdout is buffered;
#' \item \code{2} or \code{-1}: only stderr is buffered;
#' \item \code{4} or \code{-3}: only warnings are buffered;
#' \item \code{7}: all messages are buffered.
#' }
#' 
#' Note that warnings are handle slightly differently than other messages, 
#' as they are never output directly, except when \code{buffer.std = 0}.
#' 
#' @param verbose logical that toggles verbosity (i.e. debug) messages.
#' If \code{NULL}, then the current verbosity level is used 
#' (see \code{\link{octave_verbose}}).
#' 
#' @param plot indicates if the plotting window should be redrawn after executing the command.
#' 
#' If \code{TRUE}, then the Octave function \code{drawnow} is called.
#' If a character string, then it specifies a path where to save the plot, using the Octave function \code{print}.
#' If a \code{list}, then the first element is assumed to be a path where to save the plot, 
#' and the second element options passed to Octave function \code{print}.
#' 
#' @return the value returned by the Octave function -- converted into standard 
#' R objects.
#' 
#' @export
#' @examples 
#' 
#' # data matrix
#' x <- matrix(1:9, 3)
#' 
#' # call Octave function 'svd': equivalent to [S] = svd(x). See o_help(svd)
#' .CallOctave('svd', x)
#' 
#' # call Octave function 'svd' asking for 3 output values: [U, S, V] = svd(x)  
#' .CallOctave('svd', x, argout=3)
#' 
#' # call Octave function 'svd' asking for 3 named output values: [U, S, V] = svd(x)
#' .CallOctave('svd', x, argout=c('U', 'S', 'V'))
#' 
.CallOctave <- function(.NAME, ..., argout=-1, unlist=!is.character(argout), buffer.std = -1L, verbose = NULL, plot = getOption('Octave.plot', TRUE)){
	
    # generate UUID
    uuid <- getOption('Octave.UUID', basename(tempfile("OctaveCall_")))
    
    if( !is.null(verbose) ){
        ov <- octave_verbose(verbose)
        on.exit( octave_verbose(ov), add = TRUE)
    }
    if( isTRUE(buffer.std) ) buffer.std <- 7L
    
    .CallOctave0 <- function(.NAME, ...){
        .Call("octave_feval", .NAME, list(...), -1, TRUE, buffer.std, uuid, PACKAGE='RcppOctave')
    }
    
    res <- .Call("octave_feval", .NAME, list(...), argout, unlist, buffer.std, uuid, PACKAGE='RcppOctave')
    
    # force drawing of plot
    if( isTRUE(plot) ){
        .CallOctave0("drawnow")
        
    }else if( isString(plot) ){ # plot to file
        .CallOctave0("print", plot)
        
    }else if( is.list(plot) ){ # plot to file with device options
        .CallOctave0("print", plot[[1]], plot[[2]])
    }
#    else{
#        .CallOctave0("set", 'visible', 'off', buffer.std = buffer.std, uuid = uuid)
#        on.exit( .CallOctave0("set", 'visible', 'on', buffer.std = buffer.std, uuid = uuid), add = TRUE)
#    }
	if( identical(argout, 0) || identical(argout, 0L) )	invisible()
	else if( is.null(res) && argout <= 1L ) invisible()
	else res
}

#' Low-level Function Interfacing with Octave
#' 
#' \code{octave_start} Initialize an Octave session.
#' 
#' @param verbose logical that toggle verbosity.
#' In \code{octave_start}, it is the value used as the initial global verbosity state. 
#' If \code{TRUE} all calls and conversions between R and Octave produce diagnostic messages.
#' @param warnings logical that indicates if Octave startup warnings
#' @param force logical that indicates if Octave session should be reinitialised, 
#' even if one was previously started (not meant to be used by end-users).  
#' should be shown.
#' 
#' @rdname octave-ll
#' @export
octave_start <- local({
    .Initialised <- FALSE
    function(verbose=FALSE, warnings = FALSE, force = FALSE){
        res <- FALSE
        if( !.Initialised || force ){
	        res <- .Call("octave_start", verbose, warnings, PACKAGE='RcppOctave')
            .Initialised <<- TRUE
        }
        res
    }
})
#' \code{octave_end} clears and terminates the current Octave session.
#' 
#' @rdname octave-ll
#' @export
octave_end <- function(verbose = getOption('verbose')){
	.Call("octave_end", verbose, PACKAGE='RcppOctave')
}

#' \code{octave_verbose} toggles the verbosity of RcppOctave calls: messages tracks 
#' any function call, or conversion of objects between R and Octave 
#' (e.g. arguments and results).
#' 
#' @param value logical value to toggle verbosity
#' 
#' @rdname octave-ll
#' @export
octave_verbose <- function(value){
    value <- if( !missing(value) ) value
	res <- .Call("octave_verbose", value, PACKAGE='RcppOctave')
    if( !is.null(value) ) invisible(res) else res
}

#' Octave Utils: octave-config
#' 
#' Retrieves Octave configuration variables using \code{octave-config}. 
#' 
#' \code{octave_config} uses the \code{octave-config} utility binary shipped with 
#' Octave to query details about the local Octave installation.
#' Failure to retrieve such information is generally due to the binary
#' not being found.
#' By default, it is looked up in the \code{bin/} sub-directory of the path 
#' returned by \code{\link{Octave.home}()}.
#' 
#' @param varname Name (as a character string) of the Octave configuration 
#' variable to retrieve. It is used in following system call 
#' \samp{octave-config -p <varname>}.
#' This function is vectorised and returns a character vector of the same length
#' as its argument.
#' @param verbose logical that toggles verbose messages.
#' @param warn logical that indicates if a warning should be thrown when a 
#' variable is returned empty, which generally means that \code{x} is not a valid 
#' config variable name.
#' @param mustWork logical that indicates if an error should be thrown if failing 
#' to load Octave configuration.
#' @param exec name of the executable to query
#' @param bindir path to Octave bin/ sub-directory where to look for \code{octave-config}.
#' If \code{NULL} or \code{NA}, then the system PATH is looked up.
#'  
#' @family Octave.info
#' @export
#' @examples
#' octave_config('VERSION') 
#' octave_config('BINDIR')
#' 
octave_config <- function(varname, verbose=FALSE, warn=TRUE, mustWork = TRUE, exec = c('octave-config', 'mkoctfile'), bindir = Octave.home('bin')){

    # use custom BINDIR if requested
    octave_config_cmd <- match.arg(exec)
    if( !is.null(bindir) && !is_NA(bindir) ){
        if( verbose ) message("# Using Octave BINDIR '", bindir, "'")
        octave_config_cmd <- file.path(normalizePath(bindir), octave_config_cmd) 
    }

	tryCatch({
        sapply(varname, function(x){
                
            # run octave-config command
            if( verbose ) message("# Loading Octave config variable '", x, "' ... ", appendLF=FALSE)
            cmd <- paste('"', octave_config_cmd, '" -p ', x, sep = '')
    		res <- system_call(cmd)
                       
            # check result
    		if( res == '' ){
    			if( verbose ) message("WARNING")
    			if( warn ) warning("Octave config variable '", x, "' is empty")
    			return(res)
    		}
    		if( verbose ) message('OK')
    		res
    	})
    }
    , error = function(e){
        if( mustWork ) stop(e)
        if( warn ) warning("Failed loading Octave configuration: ", e)
        NULL
        }
    )
}

#' \code{octave_modules} add the Octave modules that ship with RcppOctave to 
#' Octave loading path.
#' 
#' @rdname octave-ll
#' @export
octave_modules <- function(verbose=getOption('verbose')){
	
	path <- Octave.info('modules')
    if( verbose )
		message("Loading Octave modules for ", packageName()
				, " from '", path, "'");
	o_addpath(path)
}

#' Loading Example M-files
#' 
#' Source an example M-file in the sub-directory \dQuote{scripts/} of RcppOctave
#' installation. 
#' 
#' @param file filename of the example script to source. If missing, the function 
#' lists all the m-files from the \dQuote{scripts/} sub-directory. 
#' 
#' @export
#' @examples 
#' 
#' sourceExamples()
#' sourceExamples('ex_source.m')
#' 
sourceExamples <- function(file){
	if( missing(file) ){
		list.files(packagePath('scripts'), pattern="\\.m$")
	}else{# source script
		o_source(packagePath('scripts', file))
	}
	
}


#' inline C++ Function with Octave Integration
#' 
#' @param ... arguments passed to \code{\link[inline]{cxxfunction}}
#' @param plugin Name of the plugin to use. See \code{\link[inline]{getPlugin}} for 
#' details about plugins.
#' 
#' @export
#' @examples
#' 
#' 
#' # call from R
#' set.seed(1)
#' res1 <- .O$rand(10)
#' 
#' # call from c++
#' feval <- RcppOctave:::rcppoctave(signature(), '
#' Rcpp::List args = Rcpp::List::create(10);
#'   SEXP result = CallOctave("rand", args);
#'   return(result);
#' ')
#' 
#' set.seed(1)
#' res2 <- feval()
#' stopifnot( identical(res1, res2) ) 
#' 
rcppoctave <- function(..., plugin = 'RcppOctave'){
	if( !requireNamespace('inline') )
		stop("Package 'inline' is required to define RcppOctave functions.")
	
  # Fix issue when runnin in unit tests
  # See: https://github.com/hadley/testthat/issues/144
  oval <- Sys.getenv('R_TESTS')
  if( nzchar(oval) ){
    on.exit( Sys.setenv("R_TESTS" = oval) )
    Sys.setenv("R_TESTS" = "")
  }
  
  inline::cxxfunction(..., plugin = plugin)
}


inlineCxxPlugin <- function(){
	
	if( !requireNamespace('inline') )
		stop("Package 'inline' is required to define RcppOctave functions.")

  p <- inline::getPlugin('Rcpp')
	p0 <- list(includes = '\n#include <RcppOctave.h>\n'
		, LinkingTo = c('Rcpp', 'RcppOctave')
		, Depends = c('Rcpp', 'RcppOctave')
	)
	for(n in names(p0)) p[[n]] <- c(p[[n]], p0[[n]])
	p
	
}