智能整理、美化R代码（征求解决方案）

yihui

由于平时自己写代码并不会刻意去注意把代码写得非常整齐，例如我很少敲空格、用引号的时候都是单引号、赋值符号都是用=而不是<-、循环和条件选择语句不注意缩进对齐，等等，相信很多人都一样，因为代码写出来只要能执行就可以了，懒得费那些事去美化。

很久以前我写过一个简单的函数tidy.source()放在animation包中，就是为了整理R源代码，把空格、引号、缩进等等东西都加到代码中，函数源代码很简单（利用R自身的parse()和deparse()去整理）：

tidy.source <- function (source = "clipboard", ...) <br />
{<br />
    exprs = parse(source)<br />
    n = length(exprs)<br />
    res = character(n)<br />
    for (i in 1:n) {<br />
        dep = paste(deparse(exprs[i]), collapse = "\n")<br />
        res[i] = substring(dep, 12, nchar(dep) - 1)<br />
    }<br />
    cat(paste(res, collapse = "\n"), "\n", ...)<br />
}

默认参数"clipboard"是为了在复制R代码之后，直接运行tidy.source()输出整理后的代码。

这个函数最大的问题就是不能保留注释语句（即#），因此我想稍微扩展一下它的功能，使之保留注释语句，初步想法是：先用readLines()读源代码，分析是否以#开头，记下注释的位置，然后把注释行之间的R代码进行parse()和deparse()再嵌进来，这样就可以保留注释语句了。这个工作首先要去除首尾的空格，这个好办，用正则表达式就可以了：

txt = gsub('^[[:space:]]+|[[:space:]]+$','',txt)

中间的工作可能需要用循环，结合一些判断就完成了。因为我自己没空去细想，所以把想法贴在这里，有兴趣的朋友可以补充。谢谢！

vampire530

呵呵，writing code还是一开始就保持好习惯比较好啦，不过LZ的这个点子很interesting~~支持一下

Ihavenothing

我发布一个tidy.source v1.1 alpha。

<br />
##明明感觉是很简单的程序，为什么会写出这么多？？？<br />
<br />
tidy.source=function(source="clipboard")<br />
{tidy.block=function(block.text)<br />
{        exprs=parse(text=block.text);<br />
n=length(exprs);<br />
        res=character(n);<br />
    for(i in 1:n)<br />
{    dep=paste(deparse(exprs[i]),collapse="\n");<br />
res[i]=substring(dep,12,nchar(dep)-1);}<br />
        return(paste(res,collapse="\n"));}<br />
    text.lines=readLines(con=file(source),warn=FALSE);<br />
    text.lines=gsub('^[[:space:]]+|[[:space:]]+$','',text.lines);<br />
    lines.head=substring(text.lines,1,1);<br />
flag=FALSE;<br />
if(lines.head[1]=="#"){<br />
    lines.head=c("f",lines.head);<br />
        text.lines=c("first=NULL",text.lines);flag=TRUE;<br />
    }<br />
sharp.index=(lines.head=="#");<br />
    if(all(sharp.index==FALSE)==TRUE){<br />
content=tidy.block(paste(text.lines,collapse="\n"));return(cat(content));<br />
                              }<br />
index.diff=diff(sharp.index);<br />
if(min(index.diff)>-1){<br />
    pos.n=1;              neg.n=0;block.n=2;<br />
        posneg=1;<br />
    }<br />
    else<br />
{<br />
index.neg=which(index.diff==-1);<br />
    neg.n=length(index.neg);<br />
        index.pos=which(index.diff==1);<br />
    pos.n=length(index.pos);<br />
block.n=pos.n+neg.n+1;<br />
posneg=rep(index.pos,rep(2,length(index.pos)));<br />
                posneg[2*1:neg.n]=index.neg;<br />
posneg=posneg[1:(pos.n+neg.n)];<br />
}<br />
    block.begin=c(1,posneg+1);block.end=c(posneg,length(sharp.index));<br />
block.iscomment=rep(c(0,1),pos.n+1,length.out=block.n);<br />
block=data.frame(begin=block.begin,end=block.end,iscomment=block.iscomment);<br />
    content=NULL;<br />
    for(i in 1:block.n)<br />
    {<br />
content[i]=paste(text.lines[block[i,1]:block[i,2]],collapse='\n');<br />
                            if(block[i,3]==0)<br />
        {content[i]=tidy.block(content[i]);<br />
        }}<br />
if(flag){content=content[-1];}<br />
content=ifelse(content=="NULL","",content);<br />
text.content=paste(content,collapse="\n");<br />
cat(text.content);}<br />
<br />
######################<br />
##　　　　　　　　　　　　　　　##<br />
## 如果你阅读起来很痛苦，就请用 ##<br />
## 函数本身优化一下这段代码吧。 ##<br />
##　　　　　　　　　　　　　　　##<br />
######################<br />

几点说明：

这段程序事实上还没有完成，因为还有以下一些问题：

1、如果某一行中有“<命令>##<注释>”这种情况，那么这样的注释没有办法保留；

2、注释与注释之间如果有空行，那么空行会被保留，但命令之间的空行，以及命令与注释之间的空行会被删除；我不确定规范上是不是应该删掉所有的空行，但实现起来是很简单的。

3、最要命的一点，如果注释出现在域结构内（大括号中），那么程序就会出错；感觉这一点我很难实现。

jah_et

那个……我说个比较白痴的……

（基于Eclipse和StatET）

1.赋值号可以用编辑器的查找替换

2.缩进：一方面编辑器会自动缩进，已经写好的混乱代码只需全选，复制，再粘贴一下，代码格式就会自动整理好了

汗一个，我觉着这样就不错了

cloud_wei

debug一下，代码似乎也排整齐了

bjt

R-exts 里关于tidying R code 那部分，结果也没注释。

如果只是排整齐了，还是比较好办得。

yihui

谢谢Ihavenothing，本函数稍作更改，收录到animation包中了：http://r-forge.r-project.org/plugins/scmsvn/viewcvs.php/pkg/?root=animation

Ihavenothing

还是觉得我编得太罗嗦了，可能一直以来就没养成简洁的编程习惯。

另外感觉域结构内的注释是个最大的问题，因为用parse()的话，域结构是被当作一个整体进行读取的，注释很自然地就被无视掉了。

我有空的时候再多想想吧。

Ihavenothing

傻了傻了，有一个超简单的算法居然没想到。之前的那一大团代码，说白了就是分以下几步：

1.读取每一行的命令，判断该行是不是注释；

2.将全文分成一个个连续的区域，每一个区域中要么全是注释，要么全是命令；

3.提取是命令的区域，进行代码美化；

4.将注释区域和美化后的代码区域进行合并。

这样做的话就会出现之前说的那些问题，而且会使得程序看起来很冗长。

今天突然想到了另一种方式，感觉是简单了很多，而且可以读取域结构中的注释。想法很简单，首先依然是读取行和判断是否为注释，接下来将注释改装成一句命令，这样在parse的时候这句话就不会被删掉。然后全文进行代码美化，再通过一些标志性的字眼将注释还原。具体是这样的：

如果有一行注释是

#### 这是注释

那么就把它改成

headOfComment="####这是注释endOfComment"

这样一来，注释就成了一句命令，是可以被读取的。经过代码美化后，将多加的这些字符删除，就可以把注释还原了。

当然这样稍微有些违背编程的原则，就是多加的这些字符可能是代码命令中的一部分，你无法区分哪些是原来代码就有的，哪些是你自己加的。不过我个人感觉出现这种情况的几率不大，除非刻意去抓这个bug。

新的代码如下：

tidy.source <- function(source = "clipboard", ...) {<br />
    tidy.block <- function(block.text) {<br />
        exprs = parse(text = block.text)<br />
        n = length(exprs)<br />
        res = character(n)<br />
        for (i in 1:n) {<br />
            dep = paste(deparse(exprs[i]), collapse = "\n")<br />
            res[i] = substring(dep, 12, nchar(dep) - 1)<br />
        }<br />
        return(paste(res, collapse = "\n"))<br />
    }<br />
    text.lines = readLines(con = file(source), warn = FALSE)<br />
    text.lines = gsub("^[[:space:]]+|[[:space:]]+$", "", text.lines)<br />
    lines.head = substring(text.lines, 1, 1)<br />
    text.lines[lines.head == "#"] = paste("headOfComment=\"", <br />
        text.lines[lines.head == "#"], "endOfComment\"", sep = "")<br />
    text.tidy = tidy.block(text.lines)<br />
    text.tidy = gsub("headOfComment = \"|endOfComment\"", "", <br />
        text.tidy)<br />
    cat(text.tidy, ...)<br />
}

下一步的任务就是解决行尾的注释了。

yihui

妙！！！

1、关于你说的bug，可以让用户自己解决，例如让用户自定义添加在注释首尾的字符串，这两个字符串可以由你作为参数给出默认值，如c("headOfComment", "endOfComment")；

2、关于行尾的注释，你可以这样处理：在它们前面加上"\n"，使得它们变成新的一行，然后用你上面的函数处理；只是判断#是否是注释还稍微有点麻烦，因为#不一定是注释，还有可能是字符串，如"#"或"12#34"就不是注释，switch('#', `#`=1)中的`#`也不是注释，不过我能想到的情况只有这两种情况（在引号""或''和``中）。所以你可以再试试改进吧：）

yihui

这个函数Ihavenothing还有空完善一下么？

Ihavenothing

嗯，好的，昨天睡觉前就在想这个问题。

Ihavenothing

拖了这么多天，今天总算是有点成果了，目前应该解决了行尾注释的问题。先说一下我的思路：

依然是读取代码的每一行，现在的关键就是想办法把行尾的注释给标记出来。我的做法是，先将读取的行“粉碎”成单个字符组成的向量，获取其中所有“#”符号的坐标并计算其个数（代码中就是nsharp），然后用parse()的方法分析这一行，看其中有多少个非注释性质的“#”符号（代码中是nsharp.tidy），比较这两个数值的差距，就可以获取这一行中起到注释作用的“#”符号的位置，然后对其加上标记（代码中是delEnter="*******endOfComment"），之后的工作就与前面的类似了。

我个人感觉最麻烦的部分是用parse()分析非注释性质的“#”的个数，因为很多行可能本身不是完整的语句，不能直接用parse()读取，比如下面些情况：

{#

所以就需要把这些字符转成可以被parse()读取的语句。最初的想法是用一个简单的语句，比如brace;来替换掉“{”和“}”，但因为一些诡异的原因（后面会再说，比如else），最终选择的语句是“if(1){}”。而又考虑到下面的情形，

a=function(x)  #123<br />
{<br />
}<br />

在读取第一行时，function(x)后面没有语句，会报错，所以还得在每行的最后及“#”之前加上“{}”以“欺骗”parse()函数。举个例子来说，为了计算每一行非注释性“#”的个数，下面这一行

}a="123#" #这里是注释

会被转换成

if(1){}a=\"123\n{}#\" \n{}#这里是注释\n{}

才能被parse()识别出非注释“#”的个数是1，而这一行总共的“#”的个数是2，所以可以判断，第二个“#”是起到注释作用的符号，需要加上标记。

这样基本就可以应付大部分的语句，但遇到一些R中的关键字，比如“else”，就可能遇到麻烦，比如parse()要求else附近要有完整的if...else结构，所以我前面才会把大括号转换成“if(1){}”这样诡异的语句。

下面是整个函数的代码：

tidy.source<-function(source="clipboard",nullline=TRUE,...)<br />
{<br />
    tidy.block<-function(block.text)<br />
    {<br />
        exprs=parse(text=block.text);<br />
        n=length(exprs);<br />
        res=character(n);<br />
        for(i in 1:n)<br />
        {<br />
            dep=paste(deparse(exprs[i]),collapse="\n");<br />
            res[i]=substring(dep,12,nchar(dep)-1);<br />
        }<br />
        return(paste(res,collapse="\n"));<br />
    }<br />
    line.convert<-function(line)<br />
    {<br />
        line.ch=unlist(strsplit(line,""));<br />
        sharp.index=which(line.ch=="#");<br />
        nsharp=length(sharp.index);<br />
        line2=gsub("[{}]","if(1){}",line);<br />
        line2=gsub("#","\n{}#",line2);<br />
        line2=paste(line2,"\n{}",collapse="");<br />
        line.tidy.ch=unlist(strsplit(tidy.block(line2),""));<br />
        nsharp.tidy=length(which(line.tidy.ch=="#"));<br />
        if(nsharp==nsharp.tidy)<br />
        {<br />
            return(line);<br />
        }else<br />
        {<br />
            line.ch[sharp.index[nsharp.tidy+1]]="\ndelEnter=\"#";<br />
            line.ch=c(line.ch,"endOfComment\"");<br />
        }<br />
        return(paste(line.ch,sep="",collapse=""));<br />
    }<br />
    text.lines=readLines(con=file(source),warn=FALSE);<br />
    text.lines=gsub('^[[:space:]]+|[[:space:]]+$','',text.lines);<br />
    if(nullline)<br />
    {<br />
        text.lines=ifelse(text.lines=="","isNullLine",text.lines);        <br />
    }    <br />
    lines.head=substring(text.lines,1,1);<br />
    text.lines[lines.head=="#"]=paste("headOfComment=\"",text.lines[lines.head=="#"],"endOfComment\"",sep="");<br />
    text.lines[lines.head!="#"]=sapply(text.lines[lines.head!="#"],line.convert);<br />
    text.tidy=tidy.block(text.lines);<br />
    text.tidy=gsub("headOfComment = \"|endOfComment\"|isNullLine","",text.tidy);<br />
    text.tidy=gsub("\n[ ]+delEnter = \"|delEnter = \"|\ndelEnter = \""," ",text.tidy);<br />
    cat(text.tidy,...);<br />
}

下面的代码供测试用：

#### Test ####<br />
#### Yihui Xie ####<br />
<br />
tidy.source<- function (source = "clipboard", ...)#这里有注释 <br />
#这里有注释<br />
{#这里也有注释<br />
    exprs = parse(source) #这里依然有注释<br />
    n = length(exprs)<br />
    res = character(n)<br />
    for(i in 1:n){<br />
        dep = paste(deparse(exprs[i]), collapse = "\n")<br />
        res[i] = substring(dep, 12, nchar(dep) - 1)<br />
    }#这里也加上一个注释<br />
    cat(paste(res, collapse = "\n"), "\n", ...)<br />
}<br />
###################

此外还需要交代一个bug，就是下面这种结构会报错：

if(...)<br />
{<br />
...<br />
}<br />
else<br />
{<br />
...<br />
}

也就是}与else之间不能有换行，要改成成

if(...)<br />
{<br />
...<br />
}else<br />
{<br />
...<br />
}

才行。事实上，这是R里面我感觉一个比较奇怪的规定，因为这种结构放在函数体内不会报错，但单独运行却会，不知何故……

依cloud_wei的建议，加入了参数nullline，为真时保留空行，为假时删除空行。

cloud_wei

两个问题：

1. 测试例子中的中文注释在代码整理后有时全变为"?"？不知别人的机子上有没有这个问题。我的是R-2.8.1，WIN-XP.

2. 程序中的空行是否应该考虑恰当保留，写代码时时常刻意留空行以增强可读性的。当然，可以设置一个阈值，比如2，意思是2行以内的空行不做处理，而超过2行的空行则删至2行。这个可以作为函数参数。

Ihavenothing

[quote]引用第13楼cloud_wei于2009-03-25 13:43发表的“”:

两个问题：

1. 测试例子中的中文注释在代码整理后有时全变为"?"？不知别人的机子上有没有这个问题。我的是R-2.8.1，WIN-XP.

2. 程序中的空行是否应该考虑恰当保留，写代码时时常刻意留空行以增强可读性的。当然，可以设置一个阈值，比如2，意思是2行以内的空行不做处理，而超过2行的空行则删至2行。这个可以作为函数参数。[/quote]

第一个我猜是中文编码的问题，这个不太懂，等谢老大来看看吧。

第二个应该好办，我找时间改改。

yihui

上面的函数对于不完整的行还是没法处理啊

想了想，与其写函数的人折腾得死去活来，不如让用户自觉遵守规范，不把注释写在行末算了

我最终决定不管那些写在行末的注释，并添加了几个参数，让用户可以控制是否保留注释（keep.comment）、是否保留空行（keep.blank.line）、注释首尾的标记，并保证这两个标记与原始代码没有冲突：

tidy.source <- function(source = "clipboard", keep.comment = TRUE, <br />
    keep.blank.line = FALSE, begin.comment, end.comment, ...) {<br />
    # parse and deparse the code<br />
    tidy.block = function(block.text) {<br />
        exprs = parse(text = block.text)<br />
        n = length(exprs)<br />
        res = character(n)<br />
        for (i in 1:n) {<br />
            dep = paste(deparse(exprs[i]), collapse = "\n")<br />
            res[i] = substring(dep, 12, nchar(dep) - 1)<br />
        }<br />
        return(res)<br />
    }<br />
    text.lines = readLines(source, warn = FALSE)<br />
    if (keep.comment) {<br />
        # identifier for comments<br />
        identifier = function() paste(sample(LETTERS), collapse = "")<br />
        if (missing(begin.comment)) <br />
            begin.comment = identifier()<br />
        if (missing(end.comment)) <br />
            end.comment = identifier()<br />
        # remove leading and trailing white spaces<br />
        text.lines = gsub("^[[:space:]]+|[[:space:]]+$", "", <br />
            text.lines)<br />
        # make sure the identifiers are not in the code<br />
        # or the original code might be modified<br />
        while (length(grep(sprintf("%s|%s", begin.comment, end.comment), <br />
            text.lines))) {<br />
            begin.comment = identifier()<br />
            end.comment = identifier()<br />
        }<br />
        head.comment = substring(text.lines, 1, 1) == "#"<br />
        # add identifiers to comment lines to cheat R parser<br />
        if (any(head.comment)) {<br />
            text.lines[head.comment] = gsub("\"", "\'", text.lines[head.comment])<br />
            text.lines[head.comment] = sprintf("%s=\"%s%s\"", <br />
                begin.comment, text.lines[head.comment], end.comment)<br />
        }<br />
        # keep blank lines?<br />
        blank.line = text.lines == ""<br />
        if (any(blank.line) & keep.blank.line) <br />
            text.lines[blank.line] = sprintf("%s=\"%s\"", begin.comment, <br />
                end.comment)<br />
        text.tidy = tidy.block(text.lines)<br />
        # remove the identifiers<br />
        text.tidy = gsub(sprintf("%s = \"|%s\"", begin.comment, <br />
            end.comment), "", text.tidy)<br />
    }<br />
    else {<br />
        text.tidy = tidy.block(text.lines)<br />
    }<br />
    cat(paste(text.tidy, collapse = "\n"), "\n", ...)<br />
    invisible(text.tidy)<br />
} <br />

测试：

> tidy.source('http://addictedtor.free.fr/graphiques/sources/source_152.R')<br />
#' Represents Correlation circles<br />
#'<br />
#' @author Taiyun Wei<br />
#' @param corr Correlation matrix to represent<br />
#' @param col vector the fill color of circles from 1 to -1<br />
#'        the length of it may not be 2, eg rainbow(50)<br />
#' @param bg background color of graph<br />
#' @param cex numeric, for the variable names<br />
#' @param order whether reorder the variables using principal<br />
#'         component analysis of the correlation matrix<br />
#' @param title title of the graph<br />
#' @param ... extra parameters, currenlty ignored<br />
circle.corr <- function(corr, col = c("black", "white"), <br />
    bg = "white", cex = 1, order = FALSE, title = "", ...) {<br />
    if (is.null(corr)) <br />
        return(invisible())<br />
    if ((!is.matrix(corr)) || (round(min(corr, na.rm = TRUE), <br />
        6) < -1) || (round(max(corr, na.rm = TRUE), 6) > 1)) <br />
        stop("Need a correlation matrix!")<br />
    n <- nrow(corr)<br />
    m <- ncol(corr)<br />
    ## reorder the variables using principal component analysis<br />
    if (order) {<br />
        if (!n == m) {<br />
            stop("The matrix must be squre if order is TRUE!")<br />
        }<br />
        x.eigen <- eigen(corr)$vectors[, 1:2]<br />
        e1 <- x.eigen[, 1]<br />
        e2 <- x.eigen[, 2]<br />
        alpha <- ifelse(e1 > 0, atan(e2/e1), atan(e2/e1) + pi)<br />
        corr <- corr[order(alpha), order(alpha)]<br />
    }<br />
    ## set up variable names<br />
    rname <- rownames(corr)<br />
    cname <- colnames(corr)<br />
    if (is.null(rname)) <br />
        rname <- 1:n<br />
    if (is.null(cname)) <br />
        cname <- 1:m<br />
    rname <- as.character(rname)<br />
    cname <- as.character(cname)<br />
    ## calculate label-text width approximately<br />
    par(mar = c(0, 0, 2, 0), bg = "white")<br />
    plot.new()<br />
    plot.window(c(0, m), c(0, n), asp = 1)<br />
    xlabwidth <- max(strwidth(rname, cex = cex))<br />
    ylabwidth <- max(strwidth(cname, cex = cex))<br />
    ## set up an empty plot with the appropriate dimensions<br />
    plot.window(c(-xlabwidth + 0.5, m + 0.5), c(0, n + 1 + ylabwidth), <br />
        asp = 1, xlab = "", ylab = "")<br />
    rect(0.5, 0.5, m + 0.5, n + 0.5, col = bg)<br />
    ## add variable names and title<br />
    text(rep(-xlabwidth/2, n), n:1, rname, col = "red", cex = cex)<br />
    text(1:m, rep(n + 1 + ylabwidth/2, m), cname, srt = 90, col = "red", <br />
        cex = cex)<br />
    title(title)<br />
    ## add grid<br />
    segments(rep(0.5, n + 1), 0.5 + 0:n, rep(m + 0.5, n + 1), <br />
        0.5 + 0:n, col = "gray")<br />
    segments(0.5 + 0:m, rep(0.5, m + 1), 0.5 + 0:m, rep(n + 0.5, <br />
        m), col = "gray")<br />
    ## assign circles' fill color<br />
    nc <- length(col)<br />
    if (nc == 1) <br />
        bg <- rep(col, n * m)<br />
    else {<br />
        ff <- seq(-1, 1, length = nc + 1)<br />
        bg2 = rep(0, n * m)<br />
        for (i in 1:(n * m)) {<br />
            bg2[i] <- rank(c(ff[2:nc], as.vector(corr)[i]), ties.method = "random")[nc]<br />
        }<br />
        bg <- (col[nc:1])[bg2]<br />
    }<br />
    ## plot n*m circles using vector language, suggested by Yihui Xie<br />
    ## the area of circles denotes the absolute value of coefficient<br />
    symbols(rep(1:m, each = n), rep(n:1, m), add = TRUE, inches = F, <br />
        circles = as.vector(sqrt(abs(corr))/2), bg = as.vector(bg))<br />
}<br />
## examples<br />
data(mtcars)<br />
circle.corr(cor(mtcars), order = TRUE, bg = "gray50", <br />
    col = colorRampPalette(c("blue", "white", "red"))(100))