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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
