##***************************************************************************** ## Unordered internal helper functions. ##***************************************************************************** ##***************************************************************************** ## Creates a directory if needed and stops on failure. ## ## PARAMETER: String directory ## RETURN: Boolean success (true, on fail, execution stops) ##***************************************************************************** dirCreateStop <- function( dir=NULL ) { if( !is.null( dir ) && !file.exists( dir ) ) { if( dir.create( dir, recursive=TRUE ) ) { message( "Created directory: ", dir ) return( invisible( TRUE ) ); } else stop( "UNABLE to create directory: ", dir ) } ## Never reached. return( invisible( FALSE ) ); } ##*************************************************************************** ## Add a file (with absolute path) to remove list after sfStop(). ## Used for save/restore-files. ## ## PARAMETER: file String abs. filepath ##*************************************************************************** addRestoreFile <- function( file=NULL ) { if( !is.null( file ) ) if( is.vector( .sfOption$RESTOREFILES ) ) .sfOption$RESTOREFILES <<- c( .sfOption$RESTOREFILES, file ) else .sfOption$RESTOREFILES <<- c( file ) ## cat( "Added file for delete: ", file, "\n" ) return( invisible( length( .sfOption$RESTOREFILES ) ) ) } ##*************************************************************************** ## Clean up save/restore files after successfull cluster shutdown. ##*************************************************************************** deleteRestoreFiles <- function() { if( !is.null( .sfOption$RESTOREFILES ) ) { ## File names are absolute: just unlink all. ## lapply( .sfOption$RESTOREFILES, unlink ) for( file in .sfOption$RESTOREFILES ) { if( unlink( file ) != 0 ) cat( "Unable to delete save/restore file:", file, "\n" ) else cat( "Deleted save/restore file:", file, "\n" ) } .sfOption$RESTOREFILES <- NULL } } ##*************************************************************************** ## Check if any element of a given list produced a stop or try-error. ## RETURN: Vector of logicals (true: ok, false: try error caught). ##*************************************************************************** checkTryErrorAny <- function( res ) { return( sapply( res, function( x ) { if( inherits( x, "try-error" ) ) return( FALSE ) else return( TRUE ) } ) ) } ##*************************************************************************** ## Check if given argument is a function. ##*************************************************************************** checkFunction <- function( fun, stopOnError=TRUE ) { return( TRUE ) state <- FALSE try( if( !exists( as.character( substitute( fun ) ), inherit=TRUE ) || !is.function( fun ) || is.null( get( as.character( substitute( fun ) ), inherit=TRUE ) ) || !is.function( fun ) ) state <- TRUE ) if( !state ) { ## if( !is.function( fun ) ) cat( "FAIL SYMBOL\n" ) ## if( !exists( as.character( substitute( fun ) ), inherit=TRUE ) ) cat( "FAIL EXIST\n" ) ## if( is.null( get( as.character( substitute( fun ) ), inherit=TRUE ) ) ) cat( "FAIL GET\n" ) ## if( !is.function( fun ) ) cat( "FAIL FUNCTION\n" ) if( stopOnError ) stop( paste( "Not a function in sfCluster function call: '", fun, "'" ) ) } return( state ) } errHandler <- function( ... ) { print( "ERROR IN HANDLING STUFF!\n" ) } ##*************************************************************************** ## Treat given three dot arguments as strings (for names listings ## like in sfExport). ## Ripped from buildin R function rm (by XXX). ## Returns list with names, stops on errors. ##*************************************************************************** fetchNames <- function( ... ) { ## Dot argument to list of characters: ripped from rm()... dots <- match.call(expand.dots = FALSE)$... if( length(dots) && !all( sapply( dots, function(x) is.symbol(x) || is.character(x) ) ) ) stop( "... must contain names or character strings in function ", as.character( sys.call( -1 ) ) ) names <- sapply(dots, as.character) ## End ripp. return( names ) } ##*************************************************************************** ## Create named list with all parameters from an function call. ## Idea somewhere from R-help (not tracked). ## This does not work if above env is not global env! ##*************************************************************************** getNamedArguments <- function( ... ) { pars <- as.list( substitute( {...} )[-1] ) ## pars <- as.list( substitute( {...} )[-1] ) ## pars <- lapply( pars, function( x ) { ## if( is.atomic( x ) ) ## return( x ) ## else ## return( deparse( x ) ) ## } ) return( pars ) } ##*************************************************************************** ## Ensure a given filename contains an absolute path. ## Kind of silly and lame. But works in most cases. ##*************************************************************************** absFilePath <- function( file ) { ## If not starting with separator, path is most likely relative. ## Make it absolute then. if( substr( file, 0, 1 ) != .Platform$file.sep ) file <- file.path( getwd(), file ) return( file ) } .onLoad <- function( lib, pkg ) { ## options( "error"=errHandler ) }