R.batch
Methods to run batch jobs in R

Package index
Search the R.batch package
Vignettes
Functions
354
Source code
29
Man pages
57
Home
/
R-Forge
/
R.batch
/
R/Job.R

R/Job.R
In R.batch: Methods to run batch jobs in R 

###########################################################################/**
# @RdocClass Job
#
# @title "Class representing a batch job"
#
# \description{
#  @classhierarchy
#
#  @get "title".
#
#  A \code{Job} belongs to a @see "JobBatch".
# }
#
# @synopsis
#
# \arguments{
#   \item{jobPath}{The job path.}
#   \item{label}{An optional @character string specifying the label (name) 
#     of the job.}
#   \item{verbose}{If @TRUE, detailed information will be given while 
#     working on the job.}
# }
#
# \section{Fields and Methods}{
#  @allmethods  
# }
#
# @author
#
# @keyword programming
#*/###########################################################################
setConstructorS3("Job", function(jobPath=NULL, label=NULL, verbose=FALSE) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Assert arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'jobPath':
  if (!is.null(jobPath)) {
    jobPath <- Arguments$getReadablePath(jobPath, mustExist=TRUE);
  }

  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose);
  if (verbose) {
    pushState(verbose);
    on.exit(popState(verbose));
  }


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Create object
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  this <- extend(Object(), "Job",
    # Paths
    .jobPath = jobPath,

    # Verbose
    .verbose = verbose,

    # Status
    .status = "is not started",
  
    # Label
    .jobLabel = label,

    # Time stamps
    .jobStartTime = NA,
    .jobRunTime = NA,
    .jobInterruptTime = NA,
    .jobErrorTime = NA,
    .jobFinallyTime = NA,
    .jobStopTime = NA,

    # Log object
    log = NULL,

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # Default on*() functions
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    onStart = function(job) {
      log <- getLog(job);
      log && cat(log, "In default onStart().");
    },

    onRun = function(job) {
      log <- getLog(job);
      log && cat(log, "onRun() not defined.");
      throw("onRun() not defined. Define onRun <- function(job) { ... } ",
          "in, say, onRun.R, in the src/ directory: ", job$.jobPath);
    },

    onInterrupt = function(job, interrupt) {
      log <- getLog(job);
      log && cat(log, "In default onInterrupt().");
      log && cat(log, "Interrupt message: ", as.character(interrupt));
      log && enter(log, "Saving Job object.");
      saveImage(job, label="interrupted");
      log && exit(log);
      print(interrupt);
    },

    onError = function(job, error) {
      log <- getLog(job);
      log && cat(log, "In default onError().");
      log && enter(log, "Saving Job object");
      saveImage(job, label="error");
      log && exit(log);
      log && cat(log, "Error message: ", as.character(error));
      print(error);
      traceback();
    },

    onFinally = function(job) {
      log <- getLog(job);
      log && cat(log, "In default onFinally().");
      graphics.off();
      log && cat(log, "Closed all open devices.");
    },

    onReset = function(job) {
      log <- getLog(job);
      log && cat(log, "In default onReset().");
      log && cat(log, "Resetting current log file without backup.");
      resetLog(job, backup=FALSE);

      removeStoredImage(job);
    },

    onRestart = function(job, fields=NULL) {
      log <- getLog(job);
      log && cat(log, "In default onRestart().");
    }
  )

  # Define persistent fields
  if (isExisting(this)) {
    addPersistentField(this, c(".status", ".jobLabel", ".jobStartTime", ".jobRunTime", ".jobInterruptTime", ".jobErrorTime", ".jobFinallyTime", ".jobStopTime"));
  }

  this;
}) # Job()


#############################################################################
# Methods to support persistent fields
#############################################################################
setMethodS3("addPersistentField", "Job", function(this, names, update=TRUE, ...) {
  names <- as.character(names);

  # 1. Add field names to list of persistent field names
  if (is.null(this$.persistentFields)) {
    this$.persistentFields <- names;
  } else {
    this$.persistentFields <- unique(c(this$.persistentFields, names));
  }

  # Update all persistent fields both to memory and on persistant storage.
  if (update) {
    path <- getPersistentPath(this);
    for (name in names) {
      pathname <- filePath(path, name, expandLinks="any");
      if (file.exists(pathname)) {
        value <- NULL; rm(value); # To please R CMD check
        load(pathname);  # Loads object named 'value'
        this[[name]] <- value;
      } else {
        value <- this[[name]];
        save(value, file=pathname);
      }
    }
  }
}, protected=TRUE)



setMethodS3("moveOutputFilesTo", "Job", function(this, names, path=getPath(this), ...) {
  fromPath <- getOutputPath(this);
  pattern <- paste("^", getLabel(this), sep="");
  files <- list.files(pattern=pattern, path=fromPath);
  for (file in files) {
    from <- file.path(fromPath, file);
    dest <- file.path(path, file);
    file.rename(from, dest);
  }
})


setMethodS3("isPersistentField", "Job", function(this, names, ...) {
  if (is.null(getPath(this)))
    return(FALSE);

  names <- as.character(names);
  (names %in% this$.persistentFields);
}, protected=TRUE)



setMethodS3("getPersistentPath", "Job", function(this, ...) {
  path <- filePath(getPath(this), ".persistent", expandLinks="any");
  mkdirs(path);
  path;
}, protected=TRUE)



setMethodS3("setField", "Job", function(this, name, value, ...) {
  this[[name]] <- value;
  if (isPersistentField(this, name)) {
    pathname <- file.path(getPersistentPath(this), name);
    save(value, file=pathname);
  }
}, protected=TRUE)



setMethodS3("getField", "Job", function(this, name, ...) {
  if (isPersistentField(this, name)) {
    pathname <- file.path(getPersistentPath(this), name);
    if (file.exists(pathname)) {
      value <- NULL; rm(value); # To please R CMD check
      load(pathname);  # Loads object named 'value'
      this[[name]] <- value;
      value;
    } else {
      this[[name]];
    }
  } else {
    this[[name]];
  }
}, protected=TRUE)



setMethodS3("touch", "Job", function(this, ...) {
  file <- file.path(getPersistentPath(this), ".lastModified");
  cat(as.character(Sys.time()), file=file);
})



setMethodS3("untouch", "Job", function(this, ...) {
  file <- file.path(getPersistentPath(this), ".lastModified");
  if (file.exists(file))
    file.remove(file);
})



setMethodS3("lastModified", "Job", function(this, ...) {
  file <- file.path(getPersistentPath(this), ".lastModified");
  if (!file.exists(file))
    return(NA);
  lastModified(file);
})


setMethodS3("isNewer", "Job", function(this, other, ...) {
  if (!is.na(other) && !inherits(other, "Job"))
    throw("Argument 'other' is not a Job object: ", class(other));

  # A Job cannot be newer than itself.
  if (equals(this, other))
    return(FALSE);

  t1 <- lastModified(this);
  t2 <- lastModified(other);

  # If either Job has not been process, return NA.
  if (is.na(t1) || is.na(t2))
    return(NA);

  (t1 > t2);   
})


setMethodS3("getDependenciesRaw", "Job", function(this, ...) {
  pathname <- file.path(getPath(this), ".Dependencies");
  if (!file.exists(pathname))
    return(NULL);

  lines <- readLines(pathname);

  # Remove comments
  lines <- gsub("#.*$", "", lines);

  # Trim lines
  lines <- gsub("^ ", "", lines);
  lines <- gsub(" $", "", lines);

  # Remove empty lines
  lines <- lines[nchar(lines) > 0];

  # Split in to two columns; batch name and job name.
  res <- NULL;
  for (kk in seq(along=lines)) {
    line <- lines[kk];
    pos <- regexpr("/[^/]*$", line);
    if (pos == -1) {
      batch <- NA;
      job <- line;
    } else {
      batch <- substring(line, first=1, last=pos-1);
      job <- substring(line, first=pos+1);
    }
    row <- list(batch=batch, job=job);
    res <- rbind(res, row);
  }
  rownames(res) <- seq(length=nrow(res));

  res;
}, protected=TRUE)


setMethodS3("getDependencies", "Job", function(this, criteria=function(job) { !isFinished(job) || is.na(lastModified(job)) || (!is.na(lastModified(this)) && isNewer(job, this)) }, ...) {
  # Argument 'criteria':
  if (is.function(criteria)) {
  } else if (!is.null(criteria)) {
    throw("Argument 'criteria' must be a function or NULL: ", mode(criteria));
  }

  dep <- getDependenciesRaw(this);
  if (is.null(dep))
    return(list());

  thisBatchPath <- getRoot(this);

  jobs <- list();
  for (kk in seq(length=nrow(dep))) {
    batchPath <- unlist(dep[kk, "batch"]);
    if (is.na(batchPath))
      batchPath <- NULL;

    jobName <- unlist(dep[kk, "job"]);

    # FIX: Absolute paths
    batchPath <- filePath(thisBatchPath, batchPath, expandLinks="any");

    job <- list(NULL);
    if (file.exists(batchPath)) {
      batch <- JobBatch(batchPath);
      tryCatch({
        job <- findJobs(batch, jobName, regexpr=FALSE)[[1]];
      }, error=function(ex) {
      })
    }

    if (equals(this, job))
      throw("A job can not dependend on itself: ", as.character(job));

    if (is.function(criteria)) {
      if (!criteria(job))
        job <- NULL;
    }

    if (!is.null(job))
      jobs <- c(jobs, list(job));
  }

  jobs;
})


#########################################################################/**
# @RdocMethod equals
#
# @title "Checks if this job equals another"
# 
# \description{
#   @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{other}{Another Job.}
#  \item{...}{Not used.}
# }
#
# \value{
#   Returns @TRUE if the jobs are equal, otherwise @FALSE.
# }
#
# \details{
#  If the other object is not a Job object, this method returns @FALSE.
#  Otherwise, @seemethod "getPath" is called on both objects and these are
#  compared with @see "base::identical".
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/#########################################################################  
setMethodS3("equals", "Job", function(this, other, ...) {
  if (!inherits(other, "Job"))
    return(FALSE);
  if (identical(getPath(this), getPath(other)))
    return(TRUE);
  FALSE;
})



#########################################################################/**
# @RdocMethod showWarnings
#
# @title "Displays warning generated while running this job"
# 
# \description{
#   @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{reset}{If @TRUE, warnings are removed after being viewed, 
#    otherwise not.}
#  \item{show}{If @TRUE, warnings are displayed, otherwise not.}
#  \item{...}{Not used.}
# }
#
# \value{
#   Returns nothing.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/#########################################################################  
setMethodS3("showWarnings", "Job", function(this, reset=TRUE, show=TRUE, ...) {
  if (!exists("last.warning", envir=.GlobalEnv))
    return(invisible());

  last.warning <- get("last.warning", envir=.GlobalEnv);
  nbrOfWarnings <- length(last.warning);

  # Print and reset warnings 
  if (nbrOfWarnings > 0) {
    log <- getLog(this);
    log && cat(log, "Warnings detected: ", nbrOfWarnings);

    if (show)
      print(warnings());

    if (reset)
      rm("last.warning", envir=.GlobalEnv);
  }

  invisible();
}, private=TRUE)


########################################################################/**
# @RdocMethod saveImage
#
# @title "Save an image of the job"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{label}{A @character string to be used in the filename.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns nothing.
# }
#
# \seealso{
#   @seemethod "hasStoredImage".
#   @seemethod "loadStoredImage".
#   @seemethod "removeStoredImage".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("saveImage", "Job", function(this, label=getLabel(this), ...) {
  label <- as.character(label);
  save(this, file=paste(label, ".Job", sep=""));
})


########################################################################/**
# @RdocMethod hasStoredImage
#
# @title "Checks if a stored job image exists"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if a stored image exists, otherwise @FALSE.
# }
#
# \seealso{
#   @seemethod "saveImage".
#   @seemethod "loadStoredImage".
#   @seemethod "removeStoredImage".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("hasStoredImage", "Job", function(this, ...) {
  file.exists("interrupted.Job");
})


########################################################################/**
# @RdocMethod removeStoredImage
#
# @title "Removes stored job image"
#
# \description{
#  @get "title", if exists.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns nothing.
# }
#
# \seealso{
#   @seemethod "saveImage".
#   @seemethod "hasStoredImage".
#   @seemethod "loadStoredImage".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("removeStoredImage", "Job", function(this, ...) {
  if (hasStoredImage(this)) {
    log <- getLog(this);
    file.remove("interrupted.Job");
    log && cat(log, "Removed stored Job image file.");
  }
})



########################################################################/**
# @RdocMethod loadStoredImage
#
# @title "Reload a stored job image"
#
# \description{
#  @get "title", if exists.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character @vector with the names of the reloaded fields.
# }
#
# \seealso{
#   @seemethod "hasStoredImage".
#   @seemethod "removeStoredImage".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("loadStoredImage", "Job", function(this, cleanup=TRUE, ...) {
  if (!hasStoredImage(this))
    return(c());

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Setting up logging
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  log <- getLog(this);
  log && pushState(log);
  on.exit(popState(log), add=TRUE);

  log && cat(log, "Loading Job object from image file.");
  oldJob <- Object$load(file="interrupted.Job");
  log && cat(log, "Job object image file successfully read.");

  log && cat(log, "Restoring fields from old Job object.");

  # Fields in stored Job object
  fields <- as.character(ll(oldJob, private=FALSE)$member);

  # Do not overwrite current fields
  excl <- as.character(ll(this, private=TRUE)$member);
  fields <- setdiff(fields, excl);
  log && cat(log, "Restoring ", length(fields), " fields: ", 
                                       paste(fields, collapse=", "));
  # Copy field by field
  for (field in fields) {
    this[[field]] <- oldJob[[field]];
    oldJob[[field]] <- NULL;       # Save memory as soon as possible.
  }

  rm(oldJob);
  gc();

  if (cleanup) {
    file.remove("interrupted.Job");
    log && cat(log, "Removed old Job image file.");
  }

  log && cat(log, "Previous Job object restored.");

  fields;
})


########################################################################/**
# @RdocMethod finalize
#
# @title "Finalizes job"
#
# \description{
#  @get "title" by unlocking it, if locked.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns nothing.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("finalize", "Job", function(this, ...) {
  log <- getLog(this);

  if (isSinked(this))
    unsink(this);

  # In case the file connection for the stderr sink is still open...
  file <- this$.sink[["file"]];
  if (inherits(file, "connection") && isOpen(file))
    close(file);
  this$.sink[["file"]] <- NULL;

#  log && cat(log, "Finalizing Job object.");
  if (!is.null(getPath(this))) {
    if (isLocked(this))
      unlock(this);
#    log && cat(log, "Job object finalized. Bye bye ;)");
  }
})



########################################################################/**
# @RdocMethod as.character
#
# @title "Gets a character string representation of the job"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
# 
# @keyword programming
#**/#######################################################################
setMethodS3("as.character", "Job", function(x, ...) {
  # To please R CMD check
  this <- x;

  s <- paste(class(this)[1], ": ", getLabel(this), ":", sep="");
  s <- paste(s, " Job ", getStatus(this), " and is", sep="");
  if (!isLocked(this))
    s <- paste(s, " not", sep="");
  s <- paste(s, " locked.", sep="");
  if (isDone(this)) {
    startTime <- getField(this, ".jobStartTime");
    stopTime <- getField(this, ".jobStopTime");
    s <- paste(s, " It was started on ", as.character(startTime),
               " and stopped on ", as.character(stopTime),
               " (in total ", as.character(stopTime - startTime),
               " seconds).", sep="");
  }
  s <- paste(s, " Current job path is '", getPath(this), "'.", sep="");
  if (!isExisting(this)) {
    s <- paste(s, " The job does not exist.", sep="");
  }
  s;
})




########################################################################/**
# @RdocMethod getPath
# @aliasmethod setPath
#
# @title "Gets the path to the job"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
# 
# @keyword programming
#**/#######################################################################
setMethodS3("getPath", "Job", function(this, ...) {
  path <- this$.jobPath;
  if (is.null(path))
    return(NULL);
  getAbsolutePath(path);
})


setMethodS3("setPath", "Job", function(this, path, ...) {
  path <- Arguments$getReadablePath(path, mustExist=TRUE);
  path <- getAbsolutePath(path);
  this$.jobPath <- path;
}, private=TRUE)


setMethodS3("getRoot", "Job", function(this, ...) {
  filePath(getPath(this), "..", "..", expandLinks="any");
})



########################################################################/**
# @RdocMethod getOutputPath
#
# @title "Gets the output path of the job"
#
# \description{
#  @get "title".
#  It is recommended to write logs, store results etc. to this directory.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
# 
# @keyword programming
#**/#######################################################################
setMethodS3("getOutputPath", "Job", function(this, ...) {
  path <- this$outputPath;
  if (is.null(path))
    path <- filePath(getRoot(this), "output", expandLinks="any");
  getAbsolutePath(path);
})


setMethodS3("setOutputPath", "Job", function(this, path=NULL, ...) {
  oldPath <- this$outputPath;
  this$outputPath <- path;
  invisible(oldPath);
})

setMethodS3("setFigurePath", "Job", function(this, path=NULL, ...) {
  oldPath <- this$figurePath;
  this$figurePath <- path;
  invisible(oldPath);
})


setMethodS3("getFigurePath", "Job", function(this, ...) {
  path <- this$figurePath;
  if (is.null(path))
    path <- getOutputPath(this);
  if (!isAbsolutePath(path))
    path <- filePath(getPath(this), path, expandLinks="any");
  path <- filePath(path, expandLinks="any");
  getAbsolutePath(path);
})


setMethodS3("getResultPath", "Job", function(this, ...) {
  path <- this$resultPath;
  if (is.null(path))
    path <- getOutputPath(this);
  if (!isAbsolutePath(path))
    path <- filePath(getPath(this), path, expandLinks="any");
  path <- filePath(path, expandLinks="any");
  getAbsolutePath(path);
})


setMethodS3("getLogPath", "Job", function(this, ...) {
  path <- this$logPath;
  if (is.null(path))
    path <- getOutputPath(this);
  if (!isAbsolutePath(path))
    path <- filePath(getPath(this), path, expandLinks="any");
  path <- filePath(path, expandLinks="any");
  getAbsolutePath(path);
})


########################################################################/**
# @RdocMethod getInputPath
#
# @title "Gets the input path of the job"
#
# \description{
#  @get "title".
#  It is recommended to put data files here, which should be read
#  by the job. 
#
#  The input path should be named \code{"input/"}. In order to read data 
#  from two different directories, additional input paths may be
#  \code{"input2/"}, \code{"input3/"} etc. These are specified using the
#  \code{index} argument. This makes it possible to "import" data from
#  the output of various other batch jobs via links.
# }
#
# @synopsis
#
# \arguments{
#  \item{index}{An @integer specifying which input path to query.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
# 
# @keyword programming
#**/#######################################################################
setMethodS3("getInputPath", "Job", function(this, index=1, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'index'
  if (!is.numeric(index))
    throw("Argument 'index' must be numeric: ", mode(index));
  if (length(index) != 1)
    throw("Argument 'index' must be of length one: ", length(index));
  if (index < 1)
    throw("Argument 'index' must be a postive integer: ", index);

  path <- "input";
  if (index > 1)
    path <- paste(path, index, sep="");

  filePath(getRoot(this), path, expandLinks="any");
})



########################################################################/**
# @RdocMethod getName
#
# @title "Gets the name of the job"
#
# \description{
#  @get "title".
#
#  The name of a job is by definition equal to the name of the basename of
#  the job directory, that is, identical to \code{basename(getPath(job))}.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# \seealso{
#   @see "basename".
#   @seemethod "getLabel".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("getName", "Job", function(this, ...) {
  basename(getPath(this));
})



########################################################################/**
# @RdocMethod getLabel
#
# @title "Gets the label of the job"
#
# \description{
#  @get "title".
#
#  If the label is not set, a default string of format
#  \code{<jobname>_<user>@<host>} will be returned.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# \seealso{
#   @seemethod "getName".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("getLabel", "Job", function(this, ...) {
  label <- getField(this, ".jobLabel");
  if (is.null(label)) {
    label <- getName(this);
    label <- paste(label, "_", System$getUsername(), sep="");
    label <- paste(label, "@", System$getHostname(), sep="");
#    label <- paste(label, "_", getInternalAddress(this), sep="");
  }
  label;
})



########################################################################/**
# @RdocMethod setLabel
#
# @title "Sets the label of the job"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{label}{A @character string. If @NULL, label is reset.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns nothing.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("setLabel", "Job", function(this, label=NULL, ...) {
  setField(this, ".jobLabel", as.character(label));
})





########################################################################/**
# @RdocMethod isExisting
#
# @title "Checks if the job exists"
#
# \description{
#  @get "title". A job exists if the job directory exists.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if the job exists, otherwise @FALSE.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("isExisting", "Job", function(this, ...) {
  isDirectory(getPath(this));
})



########################################################################/**
# @RdocMethod isStarted
#
# @title "Checks if the job is started or not"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if the job is started, otherwise @FALSE.
# }
#
# \seealso{
#   @seemethod "run".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("isStarted", "Job", function(this, ...) {
  (getStatus(this) != "is not started")
})




########################################################################/**
# @RdocMethod wasSuccessful
#
# @title "Checks if the job was completed successfully"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if the job was successful, otherwise @FALSE.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("wasSuccessful", "Job", function(this, ...) {
  (getStatus(this) == "has finished");
})



########################################################################/**
# @RdocMethod hasFailed
#
# @title "Checks if the job failed"
#
# \description{
#  @get "title" either during its main loop or during it finalization.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if the job failed, otherwise @FALSE.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("hasFailed", "Job", function(this, ...) {
  (getStatus(this) %in% c("has failed", "failed while finalizing"));
})



########################################################################/**
# @RdocMethod isErroneous
#
# @title "Checks if the job is erroneous"
#
# \description{
#  @get "title". A job that fails during setup is erroneous. The most
#  common reason is that the source code in the src/ directory or the
#  job directory contains errors.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if the job is erroneous, otherwise @FALSE.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("isErroneous", "Job", function(this, ...) {
  (getStatus(this) == "is erroneous");
})




########################################################################/**
# @RdocMethod wasInterrupted
#
# @title "Checks if the job was interrupted"
#
# \description{
#  @get "title" either during its main loop or during it finalization.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if the job was interrupted, otherwise @FALSE.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("wasInterrupted", "Job", function(this, ...) {
  (getStatus(this) %in% c("was interrupt", 
                                      "was interrupted while finalizing"));
})




########################################################################/**
# @RdocMethod isDone
#
# @title "Checks if the job is done"
#
# \description{
#  @get "title". A job is done if it was sucessfully finished, or if an
#  error or interrupt was detected.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if the job is done, otherwise @FALSE.
# }
#
# \seealso{
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("isDone", "Job", function(this, ...) {
  isStarted(this) && (wasSuccessful(this) || wasInterrupted(this) || 
                                                          hasFailed(this));
})


setMethodS3("isFinished", "Job", function(this, ...) {
  (isDone(this) && wasSuccessful(this));
})


########################################################################/**
# @RdocMethod getStatus
#
# @title "Gets the status of the job"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# \seealso{
#   @seemethod "setStatus".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################s
setMethodS3("getStatus", "Job", function(this, ...) {
  getField(this, ".status");
}, protected=TRUE)



########################################################################/**
# @RdocMethod setStatus
#
# @title "Sets the status of the job"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#  \item{status}{A @character string.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns invisibly the previous status as a @character string.
# }
#
# \seealso{
#   @seemethod "getStatus".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################s
setMethodS3("setStatus", "Job", function(this, status, ...) {
  setField(this, ".status", status);
}, protected=TRUE)





########################################################################/**
# @RdocMethod lock
#
# @title "Locks the job"
#
# \description{
#  @get "title". When a job is locked, no other \code{Job} objects can 
#  lock and run the same job code.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if job is locked afterwards, otherwise @FALSE.
#  If job does not exist or is already locked, an exception is thrown.
# }
#
# \seealso{
#   @seemethod "isLocked" and @seemethod "unlock".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("lock", "Job", function(this, ...) {
  log <- getLog(this);

  log && cat(log, "Trying to lock job.");

  # Preparing as much as possible before trying to acquire the lock.
  s <- paste("This job was locked at ", as.character(date()), 
     " by process ", getLabel(this), 
     " running on host ", System$getHostname(), 
     " by user ", System$getUsername(), ".", sep="");
  s <- paste(s, " Software: ", base::R.version.string, ".", sep="");

  # Get the pathname of the lock file
  lockFile <- file.path(getPath(this), ".lock");

  if (isLocked(this))
    throw("Job is already locked.");

  if (!isExisting(this))
    throw("Job does not exist: ", getPath(this));

  # Create and open lock file without closing it in order
  # to prevent another process from deleting it
  this$.lock <- file(lockFile, open="w");
  # Write tracking info for debugging
  write(file=this$.lock, s);

  log && cat(log, "Job successfully locked.");

  TRUE;
})



########################################################################/**
# @RdocMethod isLocked
#
# @title "Checks if a job is locked"
#
# \description{
#   @get "title" either by this \code{Job} object or another.
#   A job is defined to be locked if an \emph{unremovable} lock file 
#   (\code{.lock}) exists. This function will try to delete the lock file
#   before checking in order to avoid forgotten or false lock files.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if job is locked, otherwise @FALSE.
# }
#
# \seealso{
#   @seemethod "lock" and @seemethod "unlock".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("isLocked", "Job", function(this, ...) {
  # If and only if lock file exists then the job is locked
  lockFile <- file.path(getPath(this), ".lock");
  if (!file.exists(lockFile))
    return(FALSE);

  # Lock file found, but try first to remove it...
  file.remove(lockFile);

  # ...and recheck.
  file.exists(lockFile);
})



########################################################################/**
# @RdocMethod unlock
#
# @title "Unlocks the job"
#
# \description{
#  @get "title".
#
#  This method is called by various methods. All methods that locks a
#  job will also unlock it. If a \code{Job} object is delete, it will
#  also be unlocked when deallocated (by the garbage collector), if locked.
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if job is unlocked afterwards, otherwise @FALSE.
#  If job does not exist, an exception is thrown.
# }
#
# \seealso{
#   @seemethod "isLocked" and @seemethod "lock".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("unlock", "Job", function(this, ...) {
  log <- getLog(this);

  log && cat(log, "Trying to unlock job.");
  if (!isExisting(this))
    throw("Job does not exist: ", getPath(this));

  # First, check if locked
  if (!isLocked(this)) {
    log && cat(log, "Job was not locked.");
    return(FALSE);
  }

  # Second, we own the lock file and it is open, close it first
  if (inherits(this$.lock, "connection") && isOpen(this$.lock)) {
    close(this$.lock);
    this$.lock <- NULL;
    force <- TRUE;
  }

  # Finally, try to remove the lock file. This will be accepted either if
  # we owned it and just closed it, or if the process that created it was
  # killed and failed to remove it, then another job can remove the file.
  lockFile <- file.path(getPath(this), ".lock");
  res <- file.remove(lockFile);
  if (res) {
    log && cat(log, "Job successfully unlocked.");
  } else {
    log && cat(log, "Job not unlocked.");
  }
  res;
})




########################################################################/**
# @RdocMethod sourceHotCode
#
# @title "Sources and removes code in the hot/ and src/hot/ directories"
#
# \description{
#  @get "title", that is, directories named hot/ in both the current
#  job directory as well as the common src/ directory, making it possible
#  either patch specific jobs or all jobs. If not put in a directory
#  named 'global', the code will be sourced into the calling environment, 
#  which typically is "inside" the \code{onRun()} function.
#
#  \emph{WARNING: By default, hot plugin files that were sourced, are 
#  removed afterward!}
#
#  By calling this method repetably in \code{onRun(job)}, 
#  say, in the main iteration loop, it is possible to update code while
#  a job is running. 
#  One situation where this has been found to be useful is when it takes
#  literally days to process a job and when almost done you have been
#  told that there will be a power-shut before you job finishes. By 
#  plugging in new code this way, you can save you current session and
#  shut it down nicely to be continued later. Note, there is currently
#  now methods provided by \code{R.batch} that does this for you; you
#  have to implement reloading etc. yourself.
#
#  Errors that occurs while sourcing the hot code, for instance syntax
#  errors but also evaluation errors, are \emph{skipped} with a warning
#  and recorded in the log file. This way you will not killa process by
#  misstake that have been running for days.
#
#  Note that code in hot/ and src/hot/ will also be source by
#  @seemethod "setup" on startup.
# }
#
# @synopsis
#
# \arguments{
#  \item{remove}{If @TRUE, hot patch files will be removed after being
#        read, otherwise not.}
#  \item{envir}{The @environment where the source code should be stored.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns (invisibly) a @vector of the files sourced.
# }
#
# \details{
#  All scripts files are evaluated with \code{source()} to the 
#  \emph{local} working environment of this job. That is, no global 
#  objects will be overwritten.
# }
#
# \seealso{
#   @seemethod "run".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("sourceHotCode", "Job", function(this, remove=TRUE, envir=getEnvironment(this), ...) {
  # Source the code in the src/hot/ directory.
  hotPath <- filePath(getRoot(this), "src", "hot", expandLinks="any");
  files1 <- sourceDirectoryWithPreprocessor(this, 
                            path=hotPath, envir=envir, onError="warning");
  # Source the code in the job's hot/ directory.
  files2 <- sourceDirectoryWithPreprocessor(this, 
                              path="hot", envir=envir, onError="warning");

  files <- c(files1, files2);

  if (remove) {
    tryCatch({
      file.remove(files);
    }, error = function(error) {
    })
  }

  invisible(files);
})


setMethodS3("sourceDirectoryWithPreprocessor", "Job", function(this, ...) {
  # Workaround: sourceDirectory() calls sourceTo() calls source() that call 
  # capabilities("iconv"), which may generate (non-catchable) message
  # 'Xlib: connection to "<host>:0.0" refused by server'; we do not 
  # need "iconv" here.
  # Not needed anymore.  See HISTORY.  /HB 2006-09-12
##  orgCapabilities <- base::capabilities;
##  assign("capabilities", function(...) FALSE, 
##                                    pos=which(search() == "package:base")); 
##  # Remove above workaround afterward
##  on.exit({
##    assign("capabilities", orgCapabilities, 
##                                    pos=which(search() == "package:base")); 
##  }, add=TRUE);

  log <- getLog(this);
  files <- NULL;
  tryCatch({
    # Set preprocessing hooks
    oldHooks <- getHook("sourceTo/onPreprocess");
    setHook("sourceTo/onPreprocess", function(lines, ...) { 
      tryCatch({
        lines <- LComments$compile(lines=lines);
        if (log) {
          cat(log, level=-80, "Source after pre-processing:");
          code <- displayCode(code=lines, pager="none");
          log$asGString <- FALSE;
          cat(log, level=-80, code);
          log$asGString <- TRUE;
        }
      }, error = function(ex) {
        log && cat(log, "Error when pre-compiling source code:"):
        log && print(log, ex);
        print(ex);
      })
      lines;
    }, action="replace")

    output <- capture.output({
      files <- sourceDirectory(..., verbose=log);
    });

    if (length(output) > 0 && any(nchar(output) > 0)) {
      log && cat(log, "Output detected while loading plugin source:");
      log && cat(log, paste(output, collapse="\n", sep="\n"));
    }
  }, finally = {
    # Reset hooks
    setHook("sourceTo/onPreprocess", oldHooks, action="replace");
  }) 

  invisible(files);
}, protected=TRUE)


########################################################################/**
# @RdocMethod setup
#
# @title "Initiates the job"
#
# \description{
#  @get "title" by evaluating script files in the source directory and
#  the job directory. 
#
#  This method is called by @seemethod "run".
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns (invisibly) a @vector of the files sourced.
# }
#
# \details{
#  All scripts files are evaluated with \code{source()} to the 
#  \emph{local} working environment of this job. That is, no global 
#  objects will be overwritten.
# }
#
# \seealso{
#   @seemethod "run".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("setup", "Job", function(this, ...) {
  envir <- getEnvironment(this);

  touch(this);

  log <- getLog(this);
  log && header(log, "Setting up job"); 

  # Source the code in the src/ directory
  srcPath <- filePath(getRoot(this), "src", expandLinks="any");

  files1 <- sourceDirectoryWithPreprocessor(this, path=srcPath, envir=envir);

  # Source the code in the job directory
  files2 <- sourceDirectoryWithPreprocessor(this, path=getPath(this), envir=envir);

  log && cat(log, "Job was successfully setup.");

  files <- c(files1, files2);

  touch(this);

  invisible(files);
})


setMethodS3("resetToRun", "Job", function(this, ...) {
  setField(this, ".status", "is not started");
  setField(this, ".jobStartTime", NA);
  setField(this, ".jobRunTime", NA);
  setField(this, ".jobInterruptTime", NA);
  setField(this, ".jobErrorTime", NA);
  setField(this, ".jobFinallyTime", NA);
  setField(this, ".jobStopTime", NA);
  untouch(this);
}, protected=TRUE)



########################################################################/**
# @RdocMethod run
#
# @title "Runs the job"
#
# \description{
#  @get "title". 
# }
#
# @synopsis
#
# \arguments{
#  \item{reset}{If @TRUE, job is first reset, otherwise not.}
#  \item{sink}{If @TRUE, all output is sinked to a file, otherwise not.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns a @TRUE if job finished successfully, otherwise @FALSE.
# }
# 
# \details{
#  First the job is locked. Then @seemethod "setup" is called, and the 
#  current working directory is set to the job path, that is, any script
#  or functions calls are evaluated within the job directory.
#  Then the handle method \code{onStart()} followed by \code{onRun()} are 
#  evaluated with this object as the first argument. 
#  If an error occurs while evaluating these, it is caught and
#  \code{onError()} is evaluated.
#  Similar, if an interrupt, that is Ctrl-C (\code{SIGINT}), occurs it is
#  caught and \code{onInterrupt()} is evaluated.
#  Finally, handle method \code{onFinally()} is (always) evaluated.
#  Errors or interrupts occuring while evaluating this latter method, will
#  \emph{not} call \code{onInterrupt()} and \code{onError()}, 
#  respectively.
#
#  Note also, that if errors or additional interrupts occurs while 
#  evaluating \code{onInterrupt()} or \code{onError()} these will 
#  \emph{not} be caught. This can be an issue if for instance the user
#  holds down Ctrl-C. Unfortunately, there is no solution to the problem
#  at the moment [1].  
# }
#
# \references{
#   [1] H. Bengtsson, \emph{Exception handling in R}, 2004.
#       \url{http://www.maths.lth.se/help/R/}
# }
#
# \seealso{
#   @seemethod "lock".
#   @seemethod "setup".
#   @seemethod "isExisting".
#   @seemethod "isStarted".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("run", "Job", function(this, reset=FALSE, sink=TRUE, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'reset'
  if (!is.logical(reset))
    throw("Argument 'reset' is not logical: ", mode(reset));

  # Argument 'sink'
  if (!is.logical(sink))
    throw("Argument 'sink' is not logical: ", mode(sink));


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Setting up logging
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  log <- getLog(this);
  if (log) {
    enter(log, "Called run(). Running job"); 
    on.exit(exit(log), add=TRUE);
  }

  log && pushState(log);
  on.exit(popState(log), add=TRUE);

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Assert that the job exists
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (!isDirectory(getPath(this))) {
    msg <- paste("Job directory does not exist:", as.character(getPath(this))):
    log && enter(log, msg);
    throw(msg);
  }


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Assert that job is not running
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (isStarted(this)) {
    msg <- "Cannot run job. Job is already started.";
    log && enter(log, msg);
    throw(msg);
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Lock job
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (!isLocked(this)) {
    lock(this);
    on.exit(unlock(this), add=TRUE);
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Assert that all dependencies are fulfilled and processed before this Job.
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#  log && cat(log, "Checking dependencies.");
#  deps <- getDependencies(this);
#  if (length(deps) > 0) {
#    throw("Cannot run job. Found unfinished or jobs that have be updated after this job, which need to be rerun: ", paste(unlist(lapply(deps, FUN=getName)), collapse=", "));
#  }
#  rm(deps);

  log && cat(log, "Touching job (updating last modified date).");
  touch(this);

  # Set job status
  setStatus(this, "is not started");


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Record the current directory to return to at the end and 
  # set working directory to job directory.
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  log && cat(log, "Set working directory to job directory: ", getPath(this));
  opwd <- getwd();
  on.exit(setwd(opwd), add=TRUE);
  setwd(getPath(this));
  log && cat(log, "Current working directory: ", getwd());


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Read all source and settings files
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  log && cat(log, "Sinking output.");
  # Sink? (Cannot be done from within tryCatch()! /HB 2005-03-02).
  if (sink && sink(this)) {
    on.exit(if (isSinked(this)) unsink(this), add=TRUE);
  }

  touch(this);
  tryCatch({
    setField(this, ".jobSetupTime", Sys.time());

    # Reset all warnings
    showWarnings(this, show=FALSE);

    # Print and reset warnings 
    showWarnings(this);

    setup(this);

    # Print and reset warnings 
    showWarnings(this);

  }, error=function(error) {
    log && cat(log, "Failed to setup job. ", as.character(error));
    print(error);
   setStatus(this, "is erroneous");
    setField(this, ".jobErrorTime", Sys.time());
    setField(this, ".jobStopTime", Sys.time());
    this$job <- NULL;
    gc();
    # NOTE: It is not possible to return() from a tryCatch()!!!!
  })

  touch(this);
  if (isErroneous(this))
    return(FALSE);

  # Add itself ('this') as a variable 'job' available to all job scripts.
  this$job <- this;

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Reset job
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  touch(this);
  tryCatch({
    if (reset) {
      setField(this, ".jobResetTime", Sys.time());
      log && header(log, "onReset()"); 
      log && enter(log, level=-20, "Calling onReset().");

      # Assure that the correct state of the Verbose object is 
      # retained afterwards.
      log && pushState(log); 

      # Call onReset() from within the local job environment
      eval(substitute(
        onReset(this), 
        list(this=this))
      , envir=getEnvironment(this));

      log && popState(log);
      log && warnings(log);
      log && exit(log); 

      # Print and reset warnings 
      showWarnings(this);
    }
  }, error=function(ex) {
    log && popState(log);
    log && print(log, ex);
    log && warnings(log);
    log && exit(log, suffix="...failed"); 
    print(ex);
    setStatus(this, "has failed");
    setField(this, ".jobErrorTime", Sys.time());
    setField(this, ".jobStopTime", Sys.time());
    this$job <- NULL;
    gc();
    # NOTE: It is not possible to return() from a tryCatch()!!!!
  })

  touch(this);
  if (hasFailed(this))
    return(FALSE);


  touch(this);
  tryCatch({
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # onRestart()
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    gc();                                 # Free as much memory as possible
    if (hasStoredImage(this)) {
      fields <- loadStoredImage(this);
      log && header(log, "onRestart()"); 
      log && enter(log, level=-20, "Calling onRestart().");

      # Assure that the correct state of the Verbose object is 
      # retained afterwards.
      log && pushState(log); 

      # Call onRestart() from within the local job environment
      eval(substitute(
        onRestart(this, fields=fields), 
        list(this=this))
      , envir=getEnvironment(this));

      log && popState(log);
      log && warnings(log);
      log && exit(log); 

      # Print and reset warnings 
      showWarnings(this);
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # onStart()
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    gc();                                 # Free as much memory as possible

    setStatus(this, "is started");
    setField(this, ".jobStartTime", Sys.time());
    log && header(log, "onStart()"); 
    log && enter(log, level=-20, "Calling onStart().");

    # Assure that the correct state of the Verbose object is 
    # retained afterwards.
    log && pushState(log); 

    # Call onStart() from within the local job environment
    eval(substitute(
      onStart(this), 
      list(this=this))
    , envir=getEnvironment(this));

    log && popState(log);
    log && warnings(log);
    log && exit(log); 

    # Print and reset warnings 
    showWarnings(this);

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # onRun()
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    gc();                                 # Free as much memory as possible
    setStatus(this, "is running");
    setField(this, ".jobRunTime", Sys.time());
    log && header(log, "onRun()"); 
    log && enter(log, level=-20, "Calling onRun().");

    # Assure that the correct state of the Verbose object is 
    # retained afterwards.
    log && pushState(log); 

    # Call onRun() from within the local job environment
    eval(substitute(
      onRun(this), 
      list(this=this))
    , envir=getEnvironment(this));

    log && popState(log);
    log && warnings(log);
    log && exit(log); 

    setStatus(this, "has finished");

    # Print and reset warnings 
    showWarnings(this);
  }, interrupt=function(interrupt) {
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # onInterrupt()
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    gc();                                 # Free as much memory as possible
    setStatus(this, "was interrupt");
    setField(this, ".jobInterruptTime", Sys.time());
    this$onInterrupt(this, interrupt);
    log && cat(log, "Job was interrupted.");
    log && header(log, "onInterrupt()"); 
    log && enter(log, level=-20, "Calling onInterrupt().");

    # Assure that the correct state of the Verbose object is 
    # retained afterwards.
    log && pushState(log); 

    # Call onInterrupt() from within the local job environment
    eval(substitute(
      onInterrupt(this, interrupt), 
      list(this=this, interrupt=interrupt))
    , envir=getEnvironment(this));

    log && popState(log);
    log && warnings(log);
    log && exit(log); 

    log && cat(log, "onInterrupt() done.");

    # Print and reset warnings 
    showWarnings(this);
  }, error=function(ex) {
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # onError()
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    gc();                                 # Free as much memory as possible
    setStatus(this, "has failed");
    setField(this, ".jobErrorTime", Sys.time());
    log && cat(log, "An error occured while processing job.");

    log && popState(log);
    log && print(log, ex);
    log && warnings(log);
    log && exit(log, suffix="...failed"); 
    print(ex);

    log && header(log, "onError()"); 
    log && enter(log, level=-20, "Calling onError().");

    # Assure that the correct state of the Verbose object is 
    # retained afterwards.
    log && pushState(log); 

    # Call onError() from within the local job environment
    eval(substitute(
      onError(this, error), 
      list(this=this, error=ex))
    , envir=getEnvironment(this));

    log && popState(log);
    log && warnings(log);
    log && exit(log); 

    # Print and reset warnings 
    showWarnings(this);
  }, finally={
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    # onFinally()
    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    gc();                                 # Free as much memory as possible
    setField(this, ".jobFinallyTime", Sys.time());
    log && header(log, "onFinally()"); 
    tryCatch({
      log && enter(log, level=-20, "Calling onFinally().");

      # Assure that the correct state of the Verbose object is 
      # retained afterwards.
      log && pushState(log); 

      # Call onFinally() from within the local job environment
      eval(substitute(
        onFinally(this), 
        list(this=this))
      , envir=getEnvironment(this));

      log && popState(log);
      log && warnings(log);
      log && exit(log); 
    }, interrupt=function(interrupt) {
      setStatus(this, "was interrupted while finalizing");
    }, error=function(ex) {
      log && popState(log);
      log && print(log, ex);
      log && warnings(log);
      log && exit(log, suffix="...failed"); 
      print(ex);
    })

    setField(this, ".jobStopTime", Sys.time());

    this$job <- NULL;
  })

  touch(this);

  gc();                                   # Free as much memory as possible
  res <- wasSuccessful(this);
  if (log) {
    if (res) {
      cat(log, "Job ran successfully.");
    } else {
      cat(log, "Job did not run successfully.");
    }
    dt <- getField(this, ".jobStopTime") - getField(this, ".jobStartTime");
    cat(log, "Total process time: ", as.character(dt), " seconds.");
  }

  res;
})





########################################################################/**
# @RdocMethod resetLog
#
# @title "Reset log by removing log file"
#
# \description{
#  @get "title". 
# }
#
# @synopsis
#
# \arguments{
#  \item{backup}{If @TRUE, log file is backuped before deleted.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if log file was reset, otherwise @FALSE.
# }
#
# \seealso{
#   @seemethod "writeToLog".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("resetLog", "Job", function(this, backup=TRUE, ...) {
  filename <- paste(getLabel(this), ".log", sep="");
  filename <- file.path(getOutputPath(this), filename);

  # Nothing to do?
  if (!isFile(filename))
    return(FALSE);

  # Create a backup?
  if (backup) {
    backupLog(this);
  } else {
    file.remove(filename);
  }

  TRUE;
}, protected=TRUE)


########################################################################/**
# @RdocMethod writeToLog
#
# @title "Writes to log file"
#
# \description{
#  @get "title". 
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Arguments passed to the @see "R.utils::cat.Verbose" method.}
#  \item{collapse}{A @character string to concatenate objects in a list.}
# }
#
# \value{
#  Returns nothing.
# }
#
# \seealso{
#   @seemethod "resetLog".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("writeToLog", "Job", function(this, ..., collapse=" ") {
  # Write to log file
  log <- getLog(this);
  log && cat(log, ..., collapse=collapse);

  # Write to verbose object too.
  verbose <- this$.verbose;
  verbose && cat(verbose, ..., collapse=collapse);
}, protected=TRUE)


setMethodS3("backupLog", "Job", function(this, ...) {
  filename <- paste(getLabel(this), ".log", sep="");
  path <- getOutputPath(this);
  filename <- file.path(path, filename);

  # Nothing to do?
  if (!isFile(filename))
    return(FALSE);

  pattern <- paste("^", filename, sep="");
  logs <- list.files(pattern=pattern, path=path);
  count <- gsub(pattern, "", logs);
  count <- gsub("[.]", "", count);
  if (identical(count, "")) {
    count <- 0;
  } else {
    count <- max(as.integer(count), na.rm=TRUE);
  }
  backup <- sprintf("%s.%03d", filename, as.integer(count+1));
  from <- file.path(path, filename);
  to <- file.path(path, backup);
  file.rename(from, to);

  TRUE;
}, protected=TRUE)


setMethodS3("getLog", "Job", function(this, ...) {
  log <- this$log;
  if (is.null(log)) {
    # If there is already a log file, back it up.
    backupLog(this);

    filename <- paste(getLabel(this), ".log", sep="");
    filename <- file.path(getLogPath(this), filename);
    threshold <- -1;
    if (inherits(this$.verbose, "Verbose"))
      threshold <- getThreshold(this$.verbose);
    log <- Verbose(filename, removeFile=TRUE, timestamp=TRUE, threshold=threshold);
    this$log <- log;
  }

  log;
})


setMethodS3("listDir", "Job", function(this, ...) {
  list.files(getPath(this), ...);
})





########################################################################/**
# @RdocMethod isSinked
#
# @title "Checks if job output is sinked to file"
#
# \description{
#  @get "title". 
# }
#
# @synopsis
#
# \arguments{
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns @TRUE if either output or message is sinked, otherwise @FALSE.
# }
#
# \seealso{
#   @seemethod "sink" and @seemethod "unsink".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("isSinked", "Job", function(this, ...) {
  if (is.null(this$.sink))
    this$.sink <- list(output=0, message=0, file=NULL);
  
  if (this$.sink[["output"]] > 0)
    return(TRUE);

  if (this$.sink[["message"]] > 0)
    return(TRUE);

  FALSE;
})


########################################################################/**
# @RdocMethod sink
#
# @title "Sinks job output"
#
# \description{
#  @get "title". 
# }
#
# @synopsis
#
# \arguments{
#  \item{output}{If @TRUE, standard output is sinked, otherwise not.}
#  \item{message}{If @TRUE, standard error is sinked, otherwise not.
#                \emph{Currently ignored!}}
#  \item{split}{If @TRUE, output will be sent to the sink and to the
#              current output stream. The standard error cannot be split.}
#  \item{path}{Path (directory) for the sink file. If @NULL, the current
#              (job) directory is used.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns nothing.
# }
#
# \seealso{
#   @seemethod "isSinked" and @seemethod "unsink".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("sink", "Job", function(this, output=TRUE, message=TRUE, split=TRUE, path=getOutputPath(this), ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'output'
  if (!is.logical(output))
    throw("Argument 'output' is not logical: ", mode(output));

  # Argument 'message'
  if (!is.logical(message))
    throw("Argument 'message' is not logical: ", mode(message));

  # Argument 'split'
  if (!is.logical(split))
    throw("Argument 'split' is not logical: ", mode(split));

  # Create internal sink record, if missing.
  if (is.null(this$.sink))
    this$.sink <- list(output=0, message=0);

  # Only sink, if not already done
  output <- (output && (this$.sink[["output"]] == 0));
  message <- (message && (this$.sink[["message"]] == 0));

  if (!output && !message) {
    # Nothing to do.
    return(FALSE);
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Assert that everything is ok, before trying to sink anything.
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  log <- getLog(this);
  if (output) {
    log && cat(log, "Trying to sink output.");
  }

  if (message) {
    log && cat(log, "Trying to sink message.");
  }

  file <- this$.sink[["file"]];
  if (is.null(file)) {
    # Create a sink file. Overwrite existing.
    filename <- paste(getLabel(this), ".out", sep="");
    filename <- file.path(path, filename);
    file <- file(filename, open="wt");
    this$.sink[["file"]] <- file;
  }

  if (!inherits(file, "connection") || !isOpen(file)) {
     throw("Sink 'file' is not a connection or is not opened.");
  }

  # Sink output
  if (output) {
    # Sink to file
    sink(file, append=TRUE, type="output", split=split);

    # Record the number of output diversions. If not the same
    # when trying to unsink(), then it is an error.
    this$.sink[["output"]] <- sink.number(type="output");

    log && cat(log, "Sinked output to file: ", filename);
  }

  # Sink message
  if (message) {
    # Sink to an already open file connection. See ?sink.
    sink(file, append=TRUE, type="message");

    # Record the connection number for the message sink.
    this$.sink[["message"]] <- sink.number(type="message");

    log && cat(log, "Sinked message to file: ", filename);
  }

  invisible(isSinked(this));
})


########################################################################/**
# @RdocMethod unsink
#
# @title "Unsinks job output"
#
# \description{
#  @get "title". 
# }
#
# @synopsis
#
# \arguments{
#  \item{output}{If @TRUE, standard output is unsinked, otherwise not.}
#  \item{message}{If @TRUE, standard error is unsinked, otherwise not.}
#  \item{...}{Not used.}
# }
#
# \value{
#  Returns nothing.
# }
#
# \seealso{
#   @seemethod "isSinked" and @seemethod "sink".
#   @seeclass
# }
#
# @author
#
# @keyword programming
#**/#######################################################################
setMethodS3("unsink", "Job", function(this, output=TRUE, message=TRUE, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'output'
  if (!is.logical(output))
    throw("Argument 'output' is not logical: ", mode(output));

  # Argument 'message'
  if (!is.logical(message))
    throw("Argument 'message' is not logical: ", mode(message));

  # Only unsink, if sinked...
  output <- (output && (this$.sink[["output"]] > 0));
  message <- (message && (this$.sink[["message"]] > 0));

  if (!output && !message) {
    # Nothing to do.
    return(FALSE);
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Assert that everything is ok, before trying to sink anything.
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  log <- getLog(this);
  if (message) {
    log && cat(log, "Trying to unsink message.");

    if (sink.number(type="message") == 0) {
      msg <- "Excepted message sink to be open, but it is not.";
      log && cat(log, msg);
      warning(msg);
      message <- FALSE;
    }
  }

  if (output) { 
    log && cat(log, "Trying to unsink output.");

    # Assert existance of output sinks
    if (sink.number(type="output") == 0) {
      msg <- "Cannot close Job sink. No output sink diversions exist.";
      log && cat(log, msg);
      throw(msg);
    }

    # Has "someone else" closed the sink before "us"?
    if (this$.sink[["output"]] > sink.number(type="output")) {
      msg <- paste("The Job sink was inappropriately closed by a call to sink(): ", this$.sink[["output"]], " > ", sink.number(type="output"), sep="");
      log && cat(log, msg);
      warning(msg);
    }

    # Assert that the same sink is closed as the one opened (recorded)
    if (this$.sink[["output"]] < sink.number(type="output")) {
      msg <- paste("Trying to unsink Job when succeeding sink is active: ", 
          this$.sink[["output"]], " > ", sink.number(type="output"), sep="");
      log && cat(log, msg);
      warning(msg);
    }
  }

  # Close sink output
  if (output) {
    # Close sink
    sink(type="output");

    this$.sink[["output"]] <- 0;

    log && cat(log, "Unsinked output.");
  }

  # Close sink message
  if (message) {
    sink(type="message");

    # Send messages to standard error.
    sink(file=stderr(), type="message");

    this$.sink[["message"]] <- 0; 

    log && cat(log, "Unsinked message.");
  }


  # If not sinked, close file connection...
  if (!isSinked(this)) {
    file <- this$.sink[["file"]];
    if (inherits(file, "connection") && isOpen(file))
      close(file);
    this$.sink[["file"]] <- NULL;
  }

  invisible(isSinked(this));
})


###########################################################################
# HISTORY: 
# 2012-05-16
# o ROBUSTNESS: Decreased the risk for lock() of Job getting a lock file
#   although it was just acquired by another node on the same file system.
# o Using getEnvironment(this) instead of this$.env for Object:s.
# 2009-06-06
# o BUG FIX: "Unnamed" argument 'list' in all substitute(..., list=...). 
# 2006-09-12
# o Removed the workaround that redefined capabilities() temporarily in
#   sourceDirectoryWithPreprocessor().  This was due to a temporary DNS
#   failure at my test site and should normally not be necessary.  The
#   reason for not leaving it in there is that it has become harder to
#   patch that function inside the namespace-protected base environment.
#   For more details on the problem I experienced, see my R-devel thread
#   "[Rd] capabilities() and non-catchable messages" on June 20-28, 2005.
# 2005-12-05
# o Starting to make more use of the log Verbose object; writeToLog()
#   should not be needed anymore.
# 2005-12-02
# o Remove all *use* of code for dependencies and requirements.
# o Now the log file is using path according to getLogPath().
# o Moving toward using the Verbose class for logging too.
# o Making more use of Arguments class.
# o Using throw() all over instead of stop().
# 2005-10-20
# o BUG FIX: Job() would generate an error. This prevented the Rdoc 
#   compiler to run etc.
# 2005-07-18
# o Now using sourceDirectory() of R.utils. Removed same method of Job.
# 2005-05-23
# o Added argument 'criteria' to getDependencies(). This makes it possible
#   to see if a Job dependends on other Job:s that have been updated so
#   that the Job has to be (re-)run.
# o Added isNewer().
# 2005-05-21
# o Added equals().
# o Added lastModified() and touch().
# o Added protected resetToRun().
# o Now getStatus() and setStatus() is persistent fields.
# o Added setStatus().
# o Added semi-generic support for persistent fields via protected methods
#   getField() and setField(), addPersistentField(), isPersistentField(),
#   and getPersistentPath().
# o Added getName().
# 2005-05-03
# o Added '...' to setLabel().
# 2005-03-14
# o Added optional argument 'index' to getInputPath().
# 2005-03-11
# o Added getFigurePath(), getResultPath(), and getLogPath().
# o Added setLabel().
# o Now an image is save also when an error occurs.
# o sourceHotCode() is using environment 'job' now and not the parent one.
# 2005-03-10
# o Added argument 'remove=TRUE' to sourceHotCode() to remove source code
#   files afterwards.
# o Now sourceDirectory() returns the files that were sourced.
# o Now only sourced hot code is written to log, otherwise the log file
#   would grow unnecessarily large when calling sourceHotCode() often
#   and when no hot code existed. Updated sourceDirectory() too.
# 2005-03-09
# o Added sourceHotCode() to provide hot-plugin of source code.
# o Added protected sourceDirectory(), which earlier for a local function
#   in setup().
# 2005-03-02
# o Removed resetLog() in run(), because it is called in getNextJob() in
#   the JobBatch class, and should not be called twice.
# o Now log files and sinks are sent to output/ by default. This will
#   make it much easier to get an overview of the status of all jobs.
#   This will lower the need for the user to open the job directory,
#   which in turn will lower the risk for the directory to be locked
#   when trying to move it.
# o Added private showWarnings() to dump and reset warnings when running.
# o Added sink() and unsink(). The methods checks for mistakes such as
#   if a sink is already, or a sink has been open but not closed.
# o Removed "internal address" from the defaults in getLabel().
# 2005-03-01
# o BUG FIX: saveImage() used a non-existing reference variable.
# o Added methods getOutputPath() and getInputPath() and removed 
#   "internal" ditto.
# o Added "basename" to getLabel().
# 2005-02-24
# o Added saveImage().
# 2005-02-20
# o Added writeToLog().
# o Added onReset() and onRestart().
# 2005-02-19
# o Now also "private" directories and files are sourced, e.g. '.dir'.
# o Now summariesJobs() warns and highlight duplicated jobs.
# o Duplicated jobs are ignore with a warning.
# o Added static getJobsSummary() and summariesJobs().
# o Phasing out the settings features. It is much easier to just do it
#   with plain R code.
# o Rename all .onNNN() functions to onNNN().
# o Added "job" functions getInputPath() and getOutputPath().
# 2005-02-18
# o Removed several 'verbose' arguments by making it a field of Job.
# o Added getSubDirectory() and validateSubdirectories().
# o Now the settings file should be names SETTINGS (captial letters), 
#   although on some file systems such as Windows, this is not required.
# o Added createJobsDirectoryStub() for conveniency.
# o BUG FIX: setup() only reads settings file, if it exists. Before, it
#   would generate an error.
# o Updated with Rdoc comments for all methods.
# o Added '...' to all methods to please R CMD check.
# 2004-08-13
# o Added the src/global directory which can contain source code that
#   should be source()'d into the global environment instead of the
#   local provided by the job. Note that this directory may also be a
#   Windows Shortcut link to an actual directory.
# o Now also Windows Shortcut files are sourced making it extremely 
#   convinient to reuse source code.
# 2004-08-12
# o Added require( R.lang ) to constructor.
# 2004-07-26
# o Moved getUsername() and getHostname() to R.lang::System.
# o Now run() checks for errors in setup() too, for instance if a parse
#   errors in source occurs, and sets the correct status such that, say,
#   getRunAndFinishJob() can recover correctly, i.e. move the job to
#   the "failed" directory and so on.
# o BUG FIX: Added a sep="" to stop().
# 2004-07-22
# o Added "is" to "...and is [not] locked" in as.character().
# 2004-07-21
# o Now getRunAndFinishJob() verifies the existance of all directories 
#   before starting.
# o Now getRunAndFinishJob() will also try to unlock the job if it can not
#   be moved to its final destination.
# o Added Rdoc comments for static getRunAndFinishJob().
# o BUG FIX: Used old 'job' instead of 'this' is getAsVector() etc.
# 2004-07-14
# o Added utility methods getAsIs(), getAsVector(), and getAsScalar().
# o Now detailed tracking information is written to the lock file.
# o Added wasSuccessful(), hasFailed(), wasInterrupted().
# 2004-07-13
# o Added static getRunAndFinishJob(), which does what it says.
# 2004-07-12
# o run() now returns result invisible().
# o Renamed getName() to getLabel(). If label is not set, that is, is NULL,
#   getLabel() returns "<username>@<host>_<object address>" in order to
#   be able to trace where the process is running if this is reported to
#   file.
# o Added verbose to static getJob().
# 2004-07-10
# o Added getHostname() and getUsername().
# o Added Rdoc comments for most methods.
# 2004-07-07
# o Added static getJob().
# 2004-06-29
# o Modified already existing readSettings() method. 
# o Re-created.
# 2004-06-09
# o First version of job function was created.
###########################################################################

Try the R.batch package in your browser

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

R.batch documentation built on May 2, 2019, 4:58 p.m.

R Package Documentation

rdrr.io home R language documentation Run R code online

Browse R Packages

CRAN packages Bioconductor packages R-Forge packages GitHub packages

We want your feedback!

Note that we can't provide technical support on individual packages. You should contact the package authors for that.
GitHub issue tracker
ian@mutexlabs.com
Personal blog

 
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.

Close