RCaller 无法返回复杂数据的研究以及解决方案

在 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 found

但是获取 ss 是没有问题的，能正确取得值，只能进入 RCaller 里面调试源码了。大致得出下面 3点：

1. RCaller 把R代码写入文件中，调用Rscript执行；

2. 执行之后RCaller通过试图把R结果转成xml格式，返回给Java；我们的R代码没有问题，问题出在转xml的部分；

3. RCaller转xml的时候，它默认每个数据（包括list），每一列都要有名字，而我们java代码里边的out变量，没有名字，所以objnames<-names(obj)为空，导致运行出错；

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)将转型和对 out 里面的每个返回值赋予一个名字，终于出结果了。但是发现了另外一个问题，具体描述见 difference between as.data.frame and read.csv in
R
其实，真正写程序的时候，是页面传变量的ID/Name, 后台查询数据库得出值，因为不知道变量返回值的类型，我统一使用 String 接收，然后放入 RCaller 的 RCode里，生成 R 的完整程序里，可以看到每个变量的值都是字符串。把程序抓出来放到 RGui 里面，打印data.frame并不能看出其类型，但是可以通过 sapply 函数得知：

> sapply(df, class)
PERSON_ID OUTCOME tnb gxy AGE1
"factor" "factor" "factor" "factor" "factor"由于是 factor 类型，表示是离散值，非数字， matchit 不会把他们当数字处理，只罗列所有离散值。
解决办法有两个，一个就是在输入 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 里面的元素都必须有一个名字