# ------------------------------------------------------------------------------ # a function to adjust the returned column names, since Stata doesn't accept # multi-words names # ============================================================================== adj.names = function(x) { for (i in 1:length(x)) { word = unlist(strsplit(x[i], " ")) if (length(word) >= 2) { newWord = NULL for (j in 1:(length(word)-1)) { last = substr(word[j], nchar(word[j]), nchar(word[j])) Next = substr(word[j+1], 1, 1) # if there is a sign in between, combine the words. otherwise add # a dash if (last == "." | last == ":" | last == ";" | last == "~" | last == "+" | last == "-" | last == "*" | last == "$" | last == "|" | last == "[" | last == "(" | last == "%" | last == "!" | last == "@" | last == "#" | last == "{" | last == "&" | last == "=" | last == "?") { word[j+1] = paste0(word[j], word[j+1]) } else if (Next == "." | Next == ":" | Next == ";" | Next == "~" | Next == "+" | Next == "-" | Next == "*" | Next == "_" | Next == "$" | Next == "|" | Next == "[" | Next == "(" | Next == "%" | Next == "!" | Next == "@" | Next == "#" | Next == "{" | Next == "&" | Next == "=" | Next == "?") { word[j+1] = paste0(word[j], word[j+1]) } else { word[j+1] = paste0(word[j], "-", word[j+1]) } newWord = word[j+1] # Avoid these characters in the names! yet another limit... # - dot newWord = gsub(".", "-", newWord, fixed = T) } if (!is.null(newWord)) { x[i] = newWord } } } return(x) } # ------------------------------------------------------------------------------ # a function to return values from R to Stata # ============================================================================== stata.output <- function(plusR, Vanilla="") { # -------------------------------------------------------------------------- # CREATE FILE # ========================================================================== stata.output <- file.path(getwd(), "stata.output") file.create(stata.output) # -------------------------------------------------------------------------- # IF NO ERROR HAS OCCURED, PREPARE COMMUNICATION # ========================================================================== if (rc == 0) { # erase the error marker suppressWarnings(rm(rc)) if (exists("st.return") == TRUE) { lst <- st.return } else { lst <- ls(globalenv()) #list global env } # NUMERIC (numeric AND integer) # ------------------------------------ numeric <- lst[sapply(lst,function(var) any(class(get(var))=='numeric'))] integer <- lst[sapply(lst,function(var) any(class(get(var))=='integer'))] numeric <- c(numeric, integer) # STRING (character AND logical AND complex) # ------------------------------------ string <- lst[sapply(lst,function(var) any(class(get(var))=='character'))] logical <- lst[sapply(lst,function(var) any(class(get(var))=='logical'))] complex <- lst[sapply(lst,function(var) any(class(get(var))=='complex'))] RAW <- lst[sapply(lst,function(var) any(class(get(var))=='raw'))] #string <- c(string, logical, complex, RAW) # LOGICAL # ------------------------------------ # change NA to . for (St.NA in logical) { iget <- get(St.NA) St.NA[is.na(St.NA)] <- "." } string <- c(string, logical) #string <- c(string, logical, complex, RAW) # NULL # ------------------------------------ null <- lst[sapply(lst,function(var) any(class(get(var))=='NULL'))] # LIST # ------------------------------------ LIST <- lst[sapply(lst,function(var) any(class(get(var))=='list'))] # MATRIX # ------------------------------------ matrix <- lst[sapply(lst,function(var) any(class(get(var))=='matrix'))] # ---------------------------------------------------------------------- # PREPARE OUTPUT EXPORTATION # ====================================================================== # NUMERIC (numeric AND integer) # ------------------------------------ for (St.Scalar in numeric) { iget <- get(St.Scalar) if (length(iget) == 1) { content <- paste("//SCALAR", St.Scalar) write(content, file=stata.output, append=TRUE) write(iget, file=stata.output, append=TRUE) } if (length(iget) > 1) { content <- paste("//NUMERICLIST", St.Scalar) write(content, file=stata.output, append=TRUE) write(iget, file=stata.output, append=TRUE , ncolumns = if(is.character(iget)) 1 else 21) } } # NULL # ------------------------------------ for (i in null) { write(paste("//NULL", i), file=stata.output, append=TRUE) #write(iget, file=stata.output, append=TRUE) } # STRING # ------------------------------------ string = string[string!= "stata.output"] #remove stata.output from the list for (i in string) { iget <- get(i) content <- paste("//STRING", i) write(content, file=stata.output, append=TRUE) #Watch out for Vector strings if (length(iget) == 1) { write(iget, file=stata.output, append=TRUE) } else { content <- paste('"',iget,'"', sep = "") write(paste(content, " "), file=stata.output, append=TRUE) } } # LIST # ------------------------------------ for (i in LIST) { iget <- get(i) inames <- names(iget) #Create an object for the list name #write(paste("//LIST", i), file=stata.output, append=TRUE) #write(inames, file=stata.output, append=TRUE) for (j in inames) { name <- paste(i,"$",j, sep = "") if (class(iget[[j]]) == "character") { content <- paste("//CLIST", name) write(content, file=stata.output, append=TRUE) if (length(iget) == 1) { write(iget[[j]], file=stata.output, append=TRUE , ncolumns = if(is.character(iget[[j]])) 1 else 21) } else { content <- paste('"',iget[[j]],'"', sep = "") write(paste(content, " "), file=stata.output, append=TRUE) } } else { content <- paste("//LIST", name) write(content, file=stata.output, append=TRUE) #print(class(iget[[j]])) write(iget[[j]], file=stata.output, append=TRUE , ncolumns = if(is.character(iget[[j]])) 1 else 21) } } } # MATRIX # ------------------------------------ for (i in matrix) { iget <- get(i) rows <- dim(iget) content <- paste("//MATRIX", i) # adjust the names for Stata colnames = adj.names(colnames(iget)) rownames = adj.names(rownames(iget)) write(content, file=stata.output, append=TRUE) write(paste("rownumber:", rows[1]), file=stata.output, append=TRUE) if (!is.null(colnames)) { write(paste("colnames:", paste(as.vector(t(colnames)), collapse=" "), collapse=" "), file=stata.output, append=TRUE) } if (!is.null(rownames)) { write(paste("rownames:", paste(as.vector(t(rownames)), collapse=" "), collapse=" "), file=stata.output, append=TRUE) } #Add comma write(paste(as.vector(t(iget)), collapse=", "), file=stata.output, append=TRUE , ncolumns = if(is.character(iget)) 1 else 21) } } # -------------------------------------------------------------------------- # IF ERROR HAS OCCURED, STOP STATA # ========================================================================== else { content <- paste("//SCALAR", "rc") write(content, file=stata.output, append=TRUE) write(1, file=stata.output, append=TRUE) content <- paste("//STRING", "error") write(content, file=stata.output, append=TRUE) write(error, file=stata.output, append=TRUE) suppressWarnings(rm(rc, error)) } # -------------------------------------------------------------------------- # Save the loaded libraries in interactive modes # ========================================================================== if (Vanilla == "") { packageList <- unique(search()) #avoid duplicates packageList <- packageList[packageList != ".GlobalEnv" & packageList != "package:stats" & packageList != "package:graphics" & packageList != "package:grDevices" & packageList != "package:utils" & packageList != "package:datasets" & packageList != "package:methods" & packageList != "Autoloads" & packageList != "package:base" ] RProfile <- file.path(plusR, "RProfile.R") #Get RProfile from global file.create(RProfile) for (i in 1:length(packageList)) { # Attach packages if (substr(packageList[i], 1, 8) == "package:") { name <- substr(packageList[i], 9, nchar(packageList[i])) write(paste("library(", name, ")", sep = ""), file=RProfile, append=TRUE) } # Attach variables and data else { name <- packageList[i] write(paste("attach(", name, ")", sep = ""), file=RProfile, append=TRUE) } } } }