From pgilbert@bank-banque-canada.ca  Mon Aug 31 22:18:27 1998
From: pgilbert@bank-banque-canada.ca (Paul Gilbert)
Date: Mon, 31 Aug 1998 17:18:27 -0400
Subject: isolating R/S and operating system
 differences
Message-ID: <98Aug31.172601edt.13446@mailgate.bank-banque-canada.ca>

Below is a revised version of my kernel of functions for isolating R/S and
operating system  differences. The main change is "date" which I've renamed
"date.parsed" to avoid conflicts with the R and S date functions. The R call now
uses system() rather than unix() to avoid warning messages in R 0.62.3.

Paul Gilbert

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


# This file has code which contains operating system and S/R specific
#   functions. They are intended to be used as a kernel to help
#   protect other code from these problems.

# The MSwindows versions are not done.

# The following functions are attempted:
#   For S/R differences:
#      global.assign, system.info, exists.graphics.device, unlink,
#      synchronize,  list.add for [["new.element"]]<-
#   For OS differences:
#     system.call, sleep, present.working.directory, whoami, file.copy,
#     file.date.info, date.parsed, mail, unlink, local.host.netname,

# Also a number of is.xxx 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.)

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

#            General Logic and organization of these functions

# 1/ The first group of functions are for identifying S or R and flavours.
# 2/ The second group of functions are for identifying the operating system.
# 3/ The third group specify a few functions which depend only on the
#         differences between S and R.
# 4/ The fourth group specify functions which depend only on the
#         differences among operating system.
# 5/ The fifth group specify a few functions which depend on both R/S and the
#         differences among operating system.

#  >>> I would very much like any input WRT  MS Windows / Win95 / NT / Mac <<<

# The function system.call is defined in order to provide a generic way to
#  make a call to the operating system. When the calls are specific
#  to Unix then the function unix() might be used (though that is now
#  deprecated in R and produces a warning messsage). However, in general the
#  purpose of these functions is not to give a generic way to call the operating

#  system, but rather a generic way to do things that require a call to the
#  operating system (like date, mail, sleep, whoami).


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

system.info <- function()
     {if( !exists("version"))
         { #-- `Vanilla' S (i.e. here "S version 4")
           #- this now works for  S version 4  (this is not S-plus 4.0, maybe
           #             part of S-plus 5.0 !):
           lv <- nchar(Sv <- Sversion())
           r <- list(
       major = substring(Sv, 1,1),
       minor = substring(Sv, lv,lv))
         }
   else
     {r <- version
      r$minor <- as.numeric(r$minor)
      r$major <- as.numeric(r$major)
     }
   if      (is.Splus())    r$language <- "Splus"
   else if (is.Svanilla()) r$language <- "S"
   r$OSversion <- OSversion()
   r$OStype    <- OStype()
   r
  }


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

#    1/  Functions are for identifying S or R and flavours.

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

#Note It is tempting to use system.info as defined above, but there is a
#        bootstrapping problem to solve.

if (! exists("is.R"))
 {is.R <- function()
     {exists("version") && !is.null(vl <- version$language) && vl == "R" }
 }

is.R.pre0.60 <- function()
  {is.R() && ((as.numeric(version$major)+.01*as.numeric(version$minor)) <0.60) }

is.R.pre0.63.2 <- function()
  {is.R() && ((as.numeric(version$major)+.01*as.numeric(version$minor)) <0.623)}



is.S <- function(){is.Svanilla() | is.Splus() }
is.Svanilla <- function(){!exists("version")}
is.Splus <- function(){exists("version") && is.null(version$language)}
is.Splus.pre3.3 <- function()
   { ## <= 3.2
    is.Splus() &&  ((system.info()$major+.1*system.info()$minor) < 3.3)
   }

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

#    2/  Functions are for identifying the operating system.

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

if (is.R())
   {OStype <- function()
      {if("Win32"== machine())          return("MS Windows")
       else if("Macintosh"== machine()) return("Macintosh") #needs to be checked

       else if("Unix"== machine())      return ("Unix")
      }
   }

if (is.S())
   {OStype <- function()
      {if(charmatch("MS Windows", version$os, nomatch=0))
                                return("MS Windows")
       else if(charmatch("Macintosh",  version$os, nomatch=0))
                                return("Macintosh") # needs to be checked
       else if(exists("unix"))  return ("Unix")
      }
   }


is.MSwindows <- function(){OStype() == "MS Windows"}
is.Mac       <- function(){OStype() == "Macintosh" }
is.unix      <- function(){OStype() == "Unix" }

{
if (is.unix())
  {OSversion <- function()
    {paste(system.call("uname -s"),
           system.call("uname -r | sed -e 's/\\.\.\*//'"), sep="") }
  }
else if(is.MSwindows())
  {if (is.R())
     {OSversion <- function()
        {# This is not great since NT is not distinguished but
         #    is.Win32() below will work ok
         if("Win32"== machine()) return("MS Windows 95")
         else return ("unkown")
        }
     }
   if (is.S())
     {OSversion <- function()
        {if("MS Windows 3.1"==version$os) return("MS Windows 3.1")
         if("MS Windows 95" ==version$os) return("MS Windows 95")
         if("MS Windows 98" ==version$os) return("MS Windows 98")
         if("MS Windows NT" ==version$os) return("MS Windows NT")
         else return ("unkown")
        }
     }
  }
else OSversion <- function() "unknown"
}


# Other is.xxx() should be added here.

# determining Unix flavours doesn't seem to be too important but ...
is.Sun4 <- function() {is.unix() && OSversion() == "SunOS4" }
is.Sun5 <- function() {is.unix() && OSversion() == "SunOS5" }
is.Linux <- function(){is.unix() && OSversion() == "linux"}

# Windows flavours may be more important but these are untested !!!
is.Win3.1 <- function(){is.MSwindows() && OSversion() == "MS Windows 3.1"}
is.Win95  <- function(){is.MSwindows() && OSversion() == "MS Windows 95"}
is.WinNT  <- function(){is.MSwindows() && OSversion() == "MS Windows NT"}
is.Win32  <- function(){is.Win95() | is.WinNT() }





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

#    3/  Functions depending only on the
#         differences between S and R

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

if(is.S())
   {if(is.unix())system.call  <- unix
    global.assign <- function(name, value) {assign(name,value, where = 1)}
    .SPAWN <- TRUE
    exists.graphics.device <- function(){dev.cur() !=1 }
    open.graphics.device  <- function(display=getenv("DISPLAY"))
                                 {openlook(display) }
    #                            {motif(display) }
    close.graphics.device <- function(){dev.off() }
    if (!exists("set.seed.Splus")) set.seed.Splus <- set.seed
    set.seed <- function(seed=NULL)
      {if (is.null(seed))
          seed <-.Random.seed
       else
         {if (1==length(seed)) set.seed.Splus(seed)
          else global.assign(".Random.seed", seed)
         }
       seed
      }

    "list.add<-" <- function(x, replace, value)
       {# replace or add elements to a list.
        x[replace] <- value
        # x[[replace]] <- value  would be more logical but doesn't work
        x
       }
   }

if(is.R())
   {#tempfile <- 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]]
    #    }

    if (is.R.pre0.60())
        {tempfile <- function(pattern = "file")
                {system(paste("for p in", paste(pattern, collapse = " "), ";",
                       "do echo /tmp/$p$$; done"),
                 intern = TRUE)
                }
        }

#    unlink <- function(file) system.call(paste("rm -fr ", file))
    global.assign <- function(name, value)
                          {assign(name,value, envir=.GlobalEnv)}
    synchronize<- function(x){NULL} # perhaps this should do something?
    .SPAWN <- FALSE
    dev.ask <- function(ask=T){par(ask=ask)}
    if (is.R.pre0.63.2())
         exists.graphics.device <- function(){exists(".Device")}
    else exists.graphics.device <- function(){dev.cur() !=1 }
    open.graphics.device  <- function(display=getenv("DISPLAY")) {x11(display)}
    close.graphics.device <- function(){F} # how do I do this?
    set.seed <- function(seed=NULL)
      {if (is.null(seed))
         {if (!exists(".Random.seed")) zzz <- runif(1) # seed may not yet exist
          seed <-.Random.seed
         }
       else
         {if (1==length(seed))
             global.assign(".Random.seed",round(runif(3,min=seed,max=1e5*seed)))

          else global.assign(".Random.seed", seed)
         }
       seed
      }

   "list.add<-" <- function(x, replace, value)
     {# replace or add elements to a list.
      if (is.numeric(replace))
        {# x<- do.call("default.[[<-", list(x,replace,value))   # use default
         x[[replace]] <- value
         return(x)
        }
      if (is.null(value))  value <- list(NULL)
      if (!is.list(value)) value <- list(value)
      if (1 == length(value))
       {for (i in seq(length(replace)))
          x<- do.call("$<-", list(x,replace[i],value[[1]]))
       }
      else
        {if(length(value) != length(replace) )
         stop("number of replacement values != number of elements to replace")
         for (i in seq(length(replace)))
            x<- do.call("$<-", list(x,replace[i],value[[i]]))
        }
      x
     }
 }


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

#    4/  Functions depending only on the
#         differences among operating system.

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

if(is.unix())
  {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")}

   mail <- function(to, subject="", text="")
    {# If to is null then mail is not sent (useful for testing).
     file <- tempfile()
     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)
     {# This could be a lot better. It will fail for files older than a year.
      # Also, a returned format like date() below would be better.
      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
   present.working.directory <- system.call
   whoami <- system.call
   file.copy <- system.call
   file.date.info <- system.call
  }



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

#    5/  Functions depending on both R/S and the
#         differences among operating system.

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

if(is.unix())
  {if(is.R())
     {#unix <- function(cmd) system(cmd, intern=T)
      # unix() is now a function in R but deprecated in favour of system()
      # (This is a bit dangerous, as these calls may be system dependent.)

      system.call <- function(cmd) system(cmd, intern=T)

  # the following date function might be made system independent as a C call.
      date.parsed <-function()
        {d<-parse(text=strsplit(
              system.call("date \'+%Y %m %d %H %M %S\'")," ")[[1]])
         list(y=  eval(d[1]),
              m=eval(d[2]),
              d= eval(d[3]),
              h= eval(d[4]),
              m= eval(d[5]),
              s= eval(d[6]),
              tz=system.call("date '+%Z'"))
        }
     }
   if(is.S())
     {system.call <- function(cmd) unix(cmd)

      date.parsed <-function()
        {d <- parse(text=unix("date '+%Y %m %d %H %M %S'"),white=T)
         list(y=  eval(d[1]),
              m=eval(d[2]),
              d= eval(d[3]),
              h= eval(d[4]),
              m= eval(d[5]),
              s= eval(d[6]),
              tz=unix("date '+%Z'"))
        }
     }
  }




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



-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._


isolating R/S and operating system differences
Paul Gilbert