RCaller 無法返回複雜資料的研究以及解決方案
阿新 • • 發佈：2018-11-30
在 Java呼叫基於 R 的 One-Way ANOVA檢測 文章裡，通過 cbind 我們可以返回多個數據，但是裡面的資料都是簡單型別，所有能正常工作，但是我在做 Propensity Score Match 的時候呼叫 MatchIt 函式，我需要將分析結果資料全部返回，下面是資料在 RGui 裡面的樣子：
獲取各個 Matrix 的函式：
我的程式是這樣的：
RCaller caller = initRCaller(new RCallerTemplate() { @Override public void addRCode(RCode code) { code.addRCode("df <- read.csv('C:/Users/Lenovo/Desktop/ccc.csv', header=TRUE)"); code.addRCode("library(MatchIt)"); code.addRCode("fm <- matchit(censor ~ covariate1 + covariate2, method='nearest', data=df)"); code.addRCode("result <- summary(fm)"); code.addRCode("sa <- result$sum.all"); code.addRCode("mat <- result$sum.matched"); code.addRCode("red <- result$reduction"); code.addRCode("ss <- result$nn"); code.addRCode("mData <- match.data(fm)"); code.addRCode("out <- list(sum, mat, red, ss, mData)"); } }); caller.runAndReturnResult("out"); double[] result = caller.getParser().getAsDoubleArray("out");
程式執行時，RCaller 報 Rcaller Error in strsplit(names, "\\.") 錯誤，逐行註釋除錯，如果直接獲取 sa , 報
com.github.rcaller.exception.ParseException: Variable sa not found1. RCaller 把R程式碼寫入檔案中，呼叫Rscript執行；
2. 執行之後RCaller通過試圖把R結果轉成xml格式，返回給Java；我們的R程式碼沒有問題，問題出在轉xml的部分；
3.
makexml<-function(obj,name=""){ xmlcode<-"<?xml version=\"1.0\"?>\n<root>\n" if(!is.list(obj)){ print( cat( "not list:", name ) ) xmlcode<-makevectorxml(xmlcode,obj,name) }else{ objnames<-names(obj) for (i in 1:length(obj)){ print( cat( "not list:", objnames[[i]] ) ) xmlcode<-makevectorxml(xmlcode,obj[[i]],cleanNames(objnames[[i]])) } } xmlcode<-paste(xmlcode,"</root>\n",sep="") return(xmlcode) }
嘗試著給每個列都取名字， 把Java程式碼寫成這樣：
output <- list( o1=sa, o2=mat, o3=red, o4=ss, o5=mData ) 又會遇到 RCaller 的第二個問題，資料型別支援不全：
makevectorxml<-function(code,objt,name=""){
xmlcode<-code
if(name==""){
varname<-cleanNames(deparse(substitute(obj)))
}else{
varname<-name
}
obj<-objt
n <- 0; m <- 0
mydim <- dim(obj)
if(!is.null(mydim)){
n <- mydim[1]; m <- mydim[2]
}else{
n <- length(obj); m <- 1
}
if(is.matrix(obj)) obj<-as.vector(obj)
if(typeof(obj)=="language") obj<-toString(obj)
if(typeof(obj)=="logical") obj<-as.character(obj)
if(is.vector(obj) && is.numeric(obj)){
xmlcode<-paste(xmlcode,"<variable name=\"",varname,"\" type=\"numeric\" n=\"", n, "\" m=\"", m, "\">",sep="")
for (i in obj){
xmlcode<-paste(xmlcode,"<v>", toString(i), "</v>",sep="")
}
xmlcode<-paste(xmlcode,"</variable>\n",sep="")
}
if(is.vector(obj) && is.character(obj)){
xmlcode<-paste(xmlcode,"<variable name=\"",varname,"\" type=\"character\">\n",sep="")
for (i in obj){
xmlcode<-paste(xmlcode,"<v>",toString(i),"</v>",sep="")
}
xmlcode<-paste(xmlcode,"</variable>\n")
}
return(xmlcode)
}
因為 sa, mat 的型別都是 list，而 ss 是其支援的型別，不然根本進入不了 if 語句裡，原樣返回了xmlcode而已，所以Java裡只能看到ss，呼叫獲取別的都出錯。
> is.matrix( mat )
[1] FALSE
> is.numeric( mat )
[1] FALSE
> is.vector( mat )
[1] FALSE
> is.character(mat)
[1] FALSE
> typeof(mat)
[1] "list"所以，對於複雜的型別返回，就不要使用 RCaller, 但是 RCaller 的 API 友好性真的不錯，如果分析的結果比較簡單，還是喜歡使用這個工具。
=================更新 @ 2017/09/26=====================
既然 RCaller 支援的型別比較有限，那麼為了返回結果能夠進入這些 if 語句塊，我們是不是可以對結果資料進行轉型，比如 mat 是一個 list 型別，我們是否有辦法將其轉型為 vector, 這樣不就可以了。google 了下，發現了 Better way to convert list to vector? 裡面提到了
unlist(myList, use.names=FALSE)其實，真正寫程式的時候，是頁面傳變數的ID/Name, 後臺查詢資料庫得出值，因為不知道變數返回值的型別，我統一使用 String 接收，然後放入 RCaller 的 RCode裡，生成 R 的完整程式裡，可以看到每個變數的值都是字串。把程式抓出來放到 RGui 裡面，列印data.frame並不能看出其型別，但是可以通過 sapply 函式得知：
> sapply(df, class)
PERSON_ID OUTCOME tnb gxy AGE1
"factor" "factor" "factor" "factor" "factor"解決辦法有兩個，一個就是在輸入 RCode 之前，就將變數值轉成數字型。另一個就是在 R 執行 matchit 之前，對 data.frame 的列進行轉型：
newdf = transform( df, tnb = as.numeric( tnb ), AGE1=as.numeric( AGE1 ) )
sapply( newdf, class )
PERSON_ID OUTCOME tnb gxy AGE1
"factor" "factor" "numeric" "factor" "numeric" 最終，我採取了在傳入 RCode 之前，就對資料轉型成數字，然後傳入 RCode。首先我的 R 程式的生成檔案在 C:\Users\Lenovo\AppData\Local\Temp 路徑下 （Lenovo是我的機器名），完整程式碼如下：
cleanNames<-function(names){
cln<-paste(unlist(strsplit(names,"\\.")),collapse="_")
cln<-paste(unlist(strsplit(cln,"<")),collapse="")
cln<-paste(unlist(strsplit(cln,">")),collapse="")
cln<-paste(unlist(strsplit(cln," ")),collapse="")
cln<-paste(unlist(strsplit(cln,"\\(")),collapse="")
cln<-paste(unlist(strsplit(cln,"\\)")),collapse="")
cln<-paste(unlist(strsplit(cln,"\\[")),collapse="")
cln<-paste(unlist(strsplit(cln,"\\]")),collapse="")
cln<-paste(unlist(strsplit(cln,"\\*")),collapse="")
cln<-paste(unlist(strsplit(cln,"&")),collapse="")
return(cln)
}
replaceXMLchars <- function(aStr){
cln <-paste(unlist(strsplit(aStr,"&")),collapse="&")
cln <-paste(unlist(strsplit(cln,"<")),collapse="<")
cln <-paste(unlist(strsplit(cln,">")),collapse=">")
cln <-paste(unlist(strsplit(cln,"'")),collapse="'")
return(cln)
}
makevectorxml<-function(code,objt,name=""){
xmlcode<-code
if(name==""){
varname<-cleanNames(deparse(substitute(obj)))
}else{
varname<-name
}
obj<-objt
n <- 0; m <- 0
mydim <- dim(obj)
if(!is.null(mydim)){
n <- mydim[1]; m <- mydim[2]
}else{
n <- length(obj); m <- 1
}
if(is.matrix(obj)) obj<-as.vector(obj)
if(typeof(obj)=="language") obj<-toString(obj)
if(typeof(obj)=="logical") obj<-as.character(obj)
if(class(obj)=="factor") obj<-as.vector(obj)
if(is.vector(obj) && is.numeric(obj)){
xmlcode<-paste(xmlcode,"<variable name=\"",varname,"\" type=\"numeric\" n=\"", n, "\" m=\"", m, "\">",sep="")
s <- sapply(X=obj, function(str){
return(
paste("<v>",iconv(replaceXMLchars(toString(str)), to="UTF-8"),"</v>",sep="")
)})
xmlcode<-paste(xmlcode,paste(s, collapse=""),"</variable>\n")
}
if(is.vector(obj) && is.character(obj)){
xmlcode<-paste(xmlcode,"<variable name=\"",varname,"\" type=\"character\">\n",sep="")
s <- sapply(X=obj, function(str){
return(
paste("<v>",iconv(replaceXMLchars(toString(str)), to="UTF-8"),"</v>",sep="")
)})
xmlcode<-paste(xmlcode,paste(s, collapse=""),"</variable>\n")
}
return(xmlcode)
}
makexml<-function(obj,name=""){
xmlcode<-"<?xml version=\"1.0\"?>\n<root>\n"
if(!is.list(obj)){
xmlcode<-makevectorxml(xmlcode,obj,cleanNames(name))
}else{
objnames<-names(obj)
for (i in 1:length(obj)){
xmlcode<-makevectorxml(xmlcode,obj[[i]],cleanNames(objnames[[i]]))
}
}
xmlcode<-paste(xmlcode,"</root>\n",sep="")
return(xmlcode)
}
PERSON_ID<-c(166532, 166551, 166640, 166651, 166668, 166705, 166736, 166745, 166806, 166822);
OUTCOME<-c(1, 1, 1, 1, 1, 0, 0, 0, 0, 0);
tnb<-c(48.0, 48.0, 49.0, 48.0, 48.0, 49.0, 48.0, 48.0, 49.0, 48.0);
gxy<-c(48.0, 48.0, 49.0, 49.0, 48.0, 49.0, 49.0, 48.0, 49.0, 48.0);
AGE1<-c(76.0, 81.0, 74.0, 72.0, 73.0, 73.0, 81.0, 74.0, 74.0, 85.0);
matrix <- cbind(PERSON_ID,OUTCOME,tnb,gxy,AGE1)
df <- as.data.frame(matrix)
library(MatchIt)
fm <- matchit(OUTCOME ~ tnb + gxy + AGE1, data = df, method = "nearest", replace = TRUE, ratio = 1)
result <- summary(fm)
sum <- result$sum.all
sa_0_distance <- unlist(sum[1, 1:7], use.names=FALSE)
sa_1_tnb <- unlist(sum[2, 1:7], use.names=FALSE)
sa_2_gxy <- unlist(sum[3, 1:7], use.names=FALSE)
sa_3_AGE1 <- unlist(sum[4, 1:7], use.names=FALSE)
mat <- result$sum.matched
mat_0_distance <- unlist(mat[1, 1:7], use.names=FALSE)
mat_1_tnb <- unlist(mat[2, 1:7], use.names=FALSE)
mat_2_gxy <- unlist(mat[3, 1:7], use.names=FALSE)
mat_3_AGE1 <- unlist(mat[4, 1:7], use.names=FALSE)
red <- result$reduction
red_0_distance <- unlist(red[1, 1:4], use.names=FALSE)
red_1_tnb <- unlist(red[2, 1:4], use.names=FALSE)
red_2_gxy <- unlist(red[3, 1:4], use.names=FALSE)
red_3_AGE1 <- unlist(red[4, 1:4], use.names=FALSE)
ss <- result$nn
mData <- unlist(match.data(fm)[1], use.names=FALSE)
out <- list(sa_distance = sa_0_distance, mat_distance = mat_0_distance, red_distance = red_0_distance, sa_tnb = sa_1_tnb, mat_tnb = mat_1_tnb, red_tnb = red_1_tnb, sa_gxy = sa_2_gxy, mat_gxy = mat_2_gxy, red_gxy = red_2_gxy, sa_AGE1 = sa_3_AGE1, mat_AGE1 = mat_3_AGE1, red_AGE1 = red_3_AGE1, size = ss, ids = mData)
cat(makexml(obj=out, name="out"), file="C:/Users/Lenovo/AppData/Local/Temp/ROutput8334329596424358515")
為了方便顯示，對每個變數我只截取了十個元素。從上面可以看到，我幹了四件事：
1. 傳入的資料必須根據實際情況轉型成需要的型別，比如這裡所有的變數值都是數字
2. 將每個變數的值陣列直接傳入 R 的數組裡，然後使用 as.data.frame 轉成 data.frame, 這樣就省去了些 CSV 檔案的麻煩，這個在之前的一個文章裡提到了
3. 將需要返回的複雜型別（比如 list）轉成 vector，使用 unlist 函式
4. 所有放入最終返回型別的 out 裡面的元素都必須有一個名字