R-alpha: S/R & OS

Paul Gilbert (la-jassine@aix.pacwan.net)
Wed, 05 Feb 1997 04:45:56 -0400


Date: Wed, 05 Feb 1997 04:45:56 -0400
To: R-testers@stat.math.ethz.ch
From: Paul Gilbert <la-jassine@aix.pacwan.net>
Subject: R-alpha: S/R & OS

Below is a short set of functions which I have been using to try to protect 
the rest of my code from differences among operating systems and 
between S and R. The MSwindows versions are not done and the Splus 
and Sun versions are done largely from memory (and old code) and have 
not yet been checked.

I think it would be useful to have a standard set of functions like this which 
everyone can use, and hopefully this will provide a start. Comments, 
suggestions, additions, and corrections are appreciated.

Paul Gilbert

##############################################################################

# 
# The following functions are attempted:
#   For S/R differences:
#      global.assign, system.info, exists.graphics.device, tmpfile
#   For OS differences: 
#     system.call, sleep, present.working.directory, whoami, file.copy, 
#     file.date.info, date, mail, unlink, local.host.netname, 

# Also a number of is.xx functions are defined to identify systems.

# The variable  .SPAWN is also set to be used to identify if Splus "For" loops
#    should be used. (It is sometimes better not to use these even in Splus.)

##############################################################################

# there is a bit of a bootstrap problem first. 
# S:
if( is.null(version$language))system.call<- function(cmd){unix(cmd) }   
# R:
if(!is.null(version$language))system.call<- function(cmd){system(cmd, intern=T)}



system.info <- function() 
  {r <-version
   r$minor <- as.numeric(r$minor)
   r$major <- as.numeric(r$major)
   if (is.null(r$language))  r$language <- "S"
   r$OSversion <- paste(system.call("uname -s"), 
                        system.call("uname -r | sed -e 's/\\.\.\*//'"), sep="")
   r
  }

is.R <- function(){system.info()$language == "R"}
is.S <- function(){is.Splus() | (system.info()$language == "S")}
is.Splus <- function(){system.info()$language == "Splus"}
is.Splus.pre3.3 <- function()
 {# <= 3.2 
  is.Splus() &&  ((system.info()$major+.1*system.info()$minor) < 3.3)
 }
is.Linux <- function(){system.info()$os == "linux"} 
is.unix <- function(){is.Linux() | (system.info()$os == "Unix")}  # ???
is.MSwindows <- function(){system.info()$os == "MS Windows"}
is.Sun4 <- function(){"SunOS4" == system.info()$system }
is.Sun5 <- function(){"SunOS5" == system.info()$system }

if(is.unix())
  {if(is.R()) unix <- function(cmd) system(cmd, intern=T)
   sleep <- function(n) {unix(paste("sleep ", n))} # pause for n seconds
   present.working.directory <- function(){unix("pwd")} # present directory
   whoami <- function(){unix("whoami")} # return user id (for mail)
   local.host.netname <-function() {unix("uname -n")}
   date <-function() {unix("date")}

   mail <- function(to, subject="", text="")
    {# If to is null then mail is not sent (useful for testing).
     file <- tmpfile()
     write(text, file=file)
   if(!is.null(to)) unix(paste("cat ",file, " | mail  -s '", subject, "' ", to))
     unlink(file)
     invisible()
    }

   file.copy <- function(from, to)unix(paste("cp ", from, to)) # copy file

   file.date.info <- function(file.name)
     {mo <- (1:12)[c("Jan","Feb","Mar","Apr","May", "Jun","Jul","Aug", "Sep",
         "Oct","Nov","Dec") ==substring(unix(paste("ls -l ",file)),33,35)]
      day <- as.integer(substring(unix(paste("ls -l ",file.name)),37,38))
      hr  <- as.integer(substring(unix(paste("ls -l ",file.name)),40,41))
      sec <- as.integer(substring(unix(paste("ls -l ",file.name)),43,44))
      c(mo,day,hr,sec)
     }
  }

if(is.MSwindows())
  {system.call  <- function(cmd) 
         {stop("system calls must be modified for this operating system.")}
   sleep <- system.call # probably never any need to slow down MSwindows
   present.working.directory <- system.call
   whoami <- system.call
   file.copy <- system.call
   file.date.info <- system.call
  }


if(is.S())
   {tmpfile <- tempfile
      if(is.unix())system  <- unix   
      global.assign <- function(name, value) {assign(name,value, where = 1)}
      .SPAWN <- TRUE
      exists.graphics.device <- function(){exists(".Device")} # or dev.cur() ==1
   }
    
        
if(is.R()) 
     {tmpfile <- function(f)
        {# Requires C code also from Friedrich Leisch not in version 0.15 of R.
         d<-"This is simply a string long enough to hold the name of a tmpfile";
         .C("tmpf", as.character(d))[[1]]
        }
      unlink <- function(file) system.call(paste("rm -fr ", file))
      global.assign <- function(name, value) 
                            {assign(name,value, envir=.GlobalEnv)}
      .SPAWN <- FALSE
      exists.graphics.device <- function(){T} # needs to be better
     }


##############################################################################


=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-testers mailing list -- For info or help, send "info" or "help",
To [un]subscribe, send "[un]subscribe"
(in the "body", not the subject !)  To: r-testers-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-