From pgilbert@bank-banque-canada.ca  Mon Aug 25 17:43:55 1997
From: pgilbert@bank-banque-canada.ca (Paul Gilbert)
Date: Mon, 25 Aug 1997 12:43:55 -0400
Subject: R-alpha: Re: missing' BB functions
Message-ID: <97Aug25.124604edt.26509@mailgate.bank-banque-canada.ca>

Kurt

The function tempfile is available based on some C code from Friedrich
Leisch. The function unlink is fairly simple in unix but I haven't
experimented elsewhere. In this regard, I have put together a small
kernel set of functions to try to handle cross platform and R vs S
issues. This is appended below and I would certainly appreciate
feedback. The purpose of this kernel is so that I can write my code in
a way which will work in Splus or R and on most platforms.

I believe the function sort.list is just a special case of the function
order, which works in R.

Included with the kernel functions below is a set.seed function which I
have modified slightly (both in Splus and in R) so that it returns the
new value of the seed rather than returning NULL. There is a bit of a
kludge to make set.seed work with the single integer argument suggested
in the BB. It also works with the more realistic argument, a
previous setting of the seed.

I have working versions of tsmatrix and tsplot, but I'm not sure to
what extent they can be separated from a small "tframe library" I have
built to separate out (improve) the handling of the time dimension in
both Splus and R. I'll take a look at this shortly.

Also, if anyone has coded the functions acf and/or ar I would certainly
appreciate having them.


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 Splus and Sun versions are done
# largely from memory (and old code) and have not yet been checked.

# The following functions are attempted:
#   For S/R differences:
#      global.assign, system.info, exists.graphics.device, tmpfile, unlink,
#      synchronize,  list.add for [["new.element"]]<-
#   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 untested !!!
if (!exists("version")) 
                 {version <- list(language="S", major=1, minor=1) 
                  system.call<- function(cmd){unix(cmd) }   
                 }
# Splus
if( is.null(version$language))
                  system.call<- function(cmd){unix(cmd) }   
# R:
if(!is.null(version$language) && (version$language=="R"))
                  system.call<- function(cmd){system(cmd, intern=T)}
 
#  end of bootstrap

system.info <- function() 
  {r <-unclass(version)
   r$minor <- as.numeric(r$minor)
   r$major <- as.numeric(r$major)
   if (is.null(r$language))  r$language <- "Splus"
   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.MSwindows <- function(){system.info()$os == "MS Windows"}
is.Sun4 <- function(){"SunOS4" == system.info()$OSversion }
is.Sun5 <- function(){"SunOS5" == system.info()$OSversion }
is.unix <- function(){is.Linux() | is.Sun5() | is.Sun4() | 
                      (system.info()$os == "Unix")}  # ???

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 
   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(){dev.cur() !=1 }
    open.graphics.device  <- function(display=getenv("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()) 
   {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)}
    synchronize<- function(x){NULL} # perhaps this should do something?
    .SPAWN <- FALSE
    exists.graphics.device <- function(){exists(".Device")}
    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
     }
 }



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

=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
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
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-


R-alpha: Re: missing' BB functions
Paul Gilbert