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 里面的元素都必须有一个名字