1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
### This file is part of the 'foreign' package for R.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# A copy of the GNU General Public License is available at
# http://www.r-project.org/Licenses/
read.ssd <- function(libname, sectionnames, tmpXport=tempfile(),
tmpProgLoc=tempfile(), sascmd="sas")
{
##
## copyright 2002 VJ Carey <stvjc@channing.harvard.edu>
## 2004 R Development Core Team
##
## read.ssd -- 'read' a SAS v6 ssd format file by converting
## the data to sas xport format and then using R foreign:read.xport
## march 22 2002 -- works fine if the desired sas lib/section exist
## but cannot detect when sas 'fails' owing to nonexistence
##
## tries to clean up interim results
##
## works for sas v8
tmpFiles <- tmpXport
on.exit(unlink(tmpFiles))
logGuess <- function (x)
{
## guess the name of the log file by stripping all
## path to the sas program (log will lie in executing dir)
expl <- strsplit(x, "")[[1L]]
rex <- rev(expl)
br <- match("/", rex)[1L]
if (is.na(br))
return(x)
return(paste(rev(rex[1L:(br - 1L)]), sep = "", collapse = ""))
}
fileExtension <- function(string)
{
n <- nchar(string)
chars <- substring(string, 1L:n, 1L:n)
lastDot <- n + 1L - match(".", rev(chars), nomatch = n + 1L)
substring(string, lastDot + 1L, n)
}
sn <- sectionnames
if(any(nchar(sn) > 8L)) {
oldDir <- libname
libname <- tempdir()
allFiles <- list.files(oldDir)
oldNames <- character(0L)
for(i in 1L:length(sn)){
fName <- grep(sn[i], allFiles, value = TRUE)
if(length(fName) == 0L)
stop(gettextf("sectionname %s not found", sn[i]), domain = NA)
oldNames <- c(oldNames, fName)
}
sectionnames <- linkNames <- character(length(oldNames))
for(i in 1L: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 == 0L)
{
unlink( tmpProg )
unlink( tmpProgLog )
if(length(sectionnames) == 1L) return( 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)
}
}
|
