[Rd] Correction to PR #9631 (PR#9632)

[jhallman at frb.gov]

Full_Name: Jeff Hallman
Version: 2.4.1
OS: Linux
Submission from: (NULL) (132.200.32.34)


When I filed this a few minutes ago, I left off the rewritten read.ssd().  I've
included it at the end this time.


read.ssd() invokes PROC COPY to create an xport file, but PROC COPY has some
annoying limitations that read.ssd() should deal with.  The first is that PROC
COPY doesn't work with member names (the sectionnames argument to read.ssd)
longer than 8 characters.  The second is that PROC COPY also fails if any of
the
columns in the dataset being copied are too long, unless you first set (in SAS)
"option validvarname = v6;".  

I'm including here a rewritten read.ssd() that deals with these two issues. 
The
sectionnames 8-character limitation is dealt with by creating symbolic links
with shorter names.  The problem with long column names is handled by adding
SAS
code to set "option validvarname = v6", which shortens column names that are
too
long while still keeping them unique within the dataset.  A further enhancement
might be to use PROC CONTENTS to retrieve the full-length column names and then
assign them as the column names of the returned data.frames, but that seems to
be more effort than its worth.

read.ssd <- function(libname,
                     sectionnames,
                     tmpXport = tempfile(),
                     tmpProgLoc = tempfile(), 
                     sascmd = "sas"){
  tmpFiles <- tmpXport
  on.exit(unlink(tmpFiles))
  logGuess <- function(x){
    expl <- strsplit(x, "")[[1]]
    rex <- rev(expl)
    br <- match("/", rex)[1]
    if(is.na(br)) 
      return(x)
    return(paste(rev(rex[1:(br - 1)]), sep = "", collapse = ""))
  }
  fileExtension <- function(string){
    n <- nchar(string)
    chars <- substring(string, 1:n, 1:n)
    lastDot <- n + 1 - match(".", rev(chars), nomatch = n + 1)
    substring(string, lastDot + 1, n)
  }
  sn <- sectionnames
  if(any(nchar(sn) > 8)){
    oldDir   <- libname
    libname  <- tempdir()
    allFiles <- list.files(oldDir)
    oldNames <- character(0)
    for(i in 1:length(sn)){
      fName <- grep(sn[i], allFiles, value = T)
      if(length(fName) == 0) stop(paste("sectionname", sn[i], "not found"))
      oldNames <- c(oldNames, fName)
    }
    sectionnames <- linkNames <- character(length(oldNames))
    for(i in 1:length(oldNames)){
      sectionnames[i] <- paste("sn", i, sep = "")
      linkNames[i] <- paste(sectionnames[i],
                            fileExtension(oldNames[i]),
                            sep = ".")
      oldPath  <- file.path(oldDir,  oldNames[i])
      linkPath <- file.path(libname, linkNames[i])
      file.symlink(oldPath, linkPath)

      tmpFiles <- c(tmpFiles, linkPath)
    }
  }
  st0 <- "option validvarname = v6;"
  st1 <- paste("libname src2rd '", libname, "';\n", sep = "")
  st2 <- paste("libname rd xport '", tmpXport, "';\n", sep = "")
  st3 <- paste("proc copy in=src2rd out=rd;\n")
  st4 <- paste("select", sectionnames, ";\n", sep = " ")
  tmpProg <- paste(tmpProgLoc, ".sas", sep = "")
  tmpProgLogBase <- logGuess(tmpProgLoc)
  tmpProgLog <- paste(tmpProgLogBase, ".log", sep = "")
  cat(st0, file = tmpProg)
  cat(st1, file = tmpProg, append = TRUE)
  cat(st2, file = tmpProg, append = TRUE)
  cat(st3, file = tmpProg, append = TRUE)
  cat(st4, file = tmpProg, append = TRUE)
  if(.Platform$OS.type == "windows") 
    sascmd <- paste(shQuote(sascmd), "-sysin")
  sasrun <- try(sysret <- system(paste(sascmd, tmpProg)))
  if(!inherits(sasrun, "try-error") & sysret == 0){
    unlink(tmpProg)
    unlink(tmpProgLog)
    if(length(sectionnames) == 1) return(foreign::read.xport(tmpXport))
    else {
      zz <- read.xport(tmpXport)
      names(zz) <- sn
      return(zz)
    }
  }
  else {
    cat("SAS failed.  SAS program at", tmpProg, "\n")
    if(.Platform$OS.type == "unix"){
      cat("a log and other error products should be in the vicinity\n")
      system(paste("ls -l ", tmpProgLog))
    }
    else {
      cat("The log file will be ", paste(basename(tmpProgLoc), 
                                         ".log", sep = ""), " in the current
directory\n", 
          sep = "")
    }
    warning("SAS return code was ", sysret)
    return(NULL)
  }
}