r - 修改函数以便控制流构造使用 `{...}` 并在正确的位置保留注释

我想修改一个输入函数，让表达式总是调用 `{`()，并这样做，将注释放在正确的位置。

这是一个例子:

input_fun <- function(){

  if(TRUE)
    foo
  else
    # bar
    bar

  if(FALSE) {
    this
    # baz
    baz
    that
  }

  repeat
    while(condition)
      # qux
      qux
}

cat(deparse(input_fun, control = "useSource"),sep ="\n")
#> function(){
#>   
#>   if(TRUE)
#>     foo
#>   else
#>     # bar
#>     bar
#>   
#>   if(FALSE) {
#>     this
#>     # baz
#>     baz
#>     that
#>   }
#>   
#>   repeat
#>     while(condition)
#>       # qux
#>       qux
#> }

输出将是以下 output_fun 或类似的，其中类似的意思是在 { 或 } 之前/之后插入或删除新行并不重要，也不重要缩进。

我也不介意丢失不在自己行上的评论(尽管我稍微更好地保留它们)。

output_fun <- function(){
  if(TRUE){
    foo
  } else {
    # bar
    bar
  }

  if(FALSE) {
    this
    # baz
    baz
    that
  }

  repeat {
    while(condition){
    # qux
    qux
    }
  }
}

cat(deparse(output_fun, control = "useSource"),sep ="\n")
#> function(){
#>   if(TRUE){
#>     foo
#>   } else {
#>     # bar
#>     bar
#>   }
#>     
#>   if(FALSE) {
#>     this
#>     # baz
#>     baz
#>     that
#>   }
#>   
#>   repeat {
#>     while(condition){
#>     # qux
#>     qux
#>     }
#>   }
#> }

也许可以通过保持控制流结构和左括号的计数来完成某些事情，或者也许我们应该遍历输入函数的解析树，编辑以添加 { 并找到一种方法在正确的位置插入原始 srcref 的评论，但我有点卡住了，任何方法都可以。

编辑:

我们也许可以使用这个:

repair <- function(call){
  if(!is.call(call)) {
    return(call)
  }

  # if
  if(call[[1]] == quote(`if`)) {
    if(!is.call(call[[3]]) || call[[3]][[1]] != quote(`{`)){
      call[[3]] <- as.call(list(quote(`{`), call[[3]]))
    } 
    if(length(call) == 4 && (!is.call(call[[4]]) || call[[4]][[1]] != quote(`{`))){
      call[[4]] <- as.call(list(quote(`{`), call[[4]]))
    }
    call[-1] <- lapply(as.list(call[-1]), repair)
    return(call)
  } 

  # for
  if(call[[1]] == quote(`for`)) {
    if(!is.call(call[[4]]) || call[[4]][[1]] != quote(`{`)){
      call[[4]] <- as.call(list(quote(`{`), call[[4]]))
    } 
    call[-1] <- lapply(as.list(call[-1]), repair)
    return(call)
  } 

  # repeat
  if(call[[1]] == quote(`repeat`)) {
    if(!is.call(call[[2]]) || call[[2]][[1]] != quote(`{`)){
      call[[2]] <- as.call(list(quote(`{`), call[[2]]))
    } 
    call[-1] <- lapply(as.list(call[-1]), repair)
    return(call)
  } 

  # while
  if(call[[1]] == quote(`while`)) {
    if(!is.call(call[[3]]) || call[[3]][[1]] != quote(`{`)){
      call[[3]] <- as.call(list(quote(`{`), call[[3]]))
    } 
    call[-1] <- lapply(as.list(call[-1]), repair)
    return(call)
  } 

  #
  call[] <- lapply(call, repair)
  call  
}

output_fun0 <- input_fun
body(output_fun0) <- repair(body(input_fun))
output_fun0
#> function () 
#> {
#>     if (TRUE) {
#>         foo
#>     }
#>     else {
#>         bar
#>     }
#>     if (FALSE) {
#>         this
#>         baz
#>         that
#>     }
#>     repeat {
#>         while (condition) {
#>             qux
#>         }
#>     }
#> }

最佳答案

免责声明:这将是漫长而曲折的

我在这里提供了一个改进的例子，包括极端情况，并展示了主要步骤。

我使用的功能在底部。它们的评论不是很好，所以如果您需要对它们进行澄清编辑，请拍摄。

数据

input_fun <- function(){

  if(TRUE)
    foo
  else
    # bar_com1
    # bar_com2
    bar({
      x({y})
    }) %in% z

  # if
  if(
    FALSE) {
    this
    # baz_com
    baz
    that
  }

  repeat
    while(condition)
      # qux_com
      qux
}

解决方案

我们在代码中嵌套注释，将它们隐藏在下一次调用中作为 `#`() 函数的第一个参数

output_fun <- nest_comments(input_fun)
output_fun
#> function () 
#> {
#>     if (TRUE) 
#>         foo
#>     else `#`("    # bar_com1\n    # bar_com2", bar)({
#>         x({
#>             y
#>         })
#>     }) %in% z
#>     `#`("  # if", if (FALSE) {
#>         this
#>         `#`("    # baz_com", baz)
#>         that
#>     })
#>     repeat while (condition) `#`("      # qux_com", qux)
#> }

我们“修复”了该函数，在控制流构造中缺少的地方添加显式 { 调用

body(output_fun) <- repair_call(body(output_fun))
output_fun
#> function () 
#> {
#>     if (TRUE) {
#>         foo
#>     }
#>     else {
#>         `#`("    # bar_com1\n    # bar_com2", bar)({
#>             x({
#>                 y
#>             })
#>         }) %in% z
#>     }
#>     `#`("  # if", if (FALSE) {
#>         this
#>         `#`("    # baz_com", baz)
#>         that
#>     })
#>     repeat {
#>         while (condition) {
#>             `#`("      # qux_com", qux)
#>         }
#>     }
#> }

我们回到新的解析树并将 #() 调用提取到独立的在“主机”调用之上调用

body(output_fun) <- unnest_comments(body(output_fun))
output_fun
#> function () 
#> {
#>     if (TRUE) {
#>         foo
#>     }
#>     else {
#>         `#`("    # bar_com1\n    # bar_com2")
#>         bar({
#>             x({
#>                 y
#>             })
#>         }) %in% z
#>     }
#>     `#`("  # if")
#>     if (FALSE) {
#>         this
#>         `#`("    # baz_com")
#>         baz
#>         that
#>     }
#>     repeat {
#>         while (condition) {
#>             `#`("      # qux_com")
#>             qux
#>         }
#>     }
#> }

现在我们可以使用正则表达式将评论设置回它们的标准形式。

output_fun <- regularize_comments(output_fun)
output_fun
#> function () 
#> {
#>     if (TRUE) {
#>         foo
#>     }
#>     else {
#>         # bar_com1
#>     # bar_com2
#>         bar({
#>             x({
#>                 y
#>             })
#>         }) %in% z
#>     }
#>     # if
#>     if (FALSE) {
#>         this
#>         # baz_com
#>         baz
#>         that
#>     }
#>     repeat {
#>         while (condition) {
#>             # qux_com
#>             qux
#>         }
#>     }
#> }

函数

regularize_comments <- function(fun) {
  env <- environment(fun)
  fun <- deparse(fun)
  #fun <- gsub("(\\s*`#`\\(\")(.*?)\\\"\\)$","\\2", fun)
  fun <- gsub("(\\s*)`#`\\(\"(\\s*)(.*?)\\\"\\)$","\\1\\3", fun)
  fun <- gsub("\\\\n","\n",fun)
  eval(parse(text=paste(fun, collapse = "\n"))[[1]],envir = env)
}

unnest_comments <- function(call) {
  if(!is.call(call)) {
    return(call)
  }

  call0 <- lapply(call, function(x) {
    call_str <- paste(deparse(x), collapse ="\n")
    if(startsWith(call_str, "`#`(")){
      #is.call(x) && x[[1]] == quote(`#`) && length(x) == 3){
      # browser()
      x <- list(extract_comment(x),
                clean_call(x))
    }
    x
  })
  call <- as.call(unlist(call0))
  call[] <- lapply(call, unnest_comments)
  call
}

# helper for unnest_comments
extract_comment <- function(call){
  if(!is.call(call)) {
    return(NULL)
  }
  if(identical(call[[1]], quote(`#`))){
    return(call[1:2])
  }
  unlist(lapply(call, extract_comment))[[1]]
}

# helper for unnest_comments
clean_call <- function(call){
  if(!is.call(call)) {
    return(call)
  }
  if(identical(call[[1]], quote(`#`))){
    return(call[[3]])
  }
  call[] <- lapply(call, clean_call)
  call
}

is_syntactic <- function(x){
  tryCatch({str2lang(x); TRUE},
           error = function(e) FALSE)
}

nest_comments <- function(fun){
  src <- deparse(fun, control = "useSource")
  # positions of comments
  commented_lgl <- grepl("^\\s*#",src)
  # positions of 1st comments of comment blocks
  first_comments_lgl <- diff(c(FALSE, commented_lgl)) == 1
  # ids of comment blocks along the lines
  comment_ids <- cumsum(first_comments_lgl) * commented_lgl
  # positions of 1st lines after comment blocks
  first_lines_lgl <- diff(!c(FALSE, commented_lgl)) == 1
  first_lines_ids <- cumsum(first_lines_lgl) * first_lines_lgl

  # we iterate through these ids, taking max from lines so if code ends with a
  # comment it will be ignored
  for(i in seq(max(first_lines_ids))){
    comments <- src[comment_ids == i]
    line_num <- which(first_lines_ids == i)
    line <- src[line_num]
    # we move forward character by character until we get a syntactic replacement
    # the code replacement starts with "`#`(" and we try all positions of 2nd
    # parenthese until something works, then deal with next code block

    j <- 0
    repeat {
      break_ <- FALSE
      j <- j+1
      line <- src[line_num]
      if(j == 1) code <- paste0("`#`('", paste(comments,collapse="\n"),"', ") else code[j] <- ""
      for(n_chr in seq(nchar(src[line_num]))){
        code[j] <- paste0(code[j], substr(line, n_chr, n_chr))
        if (n_chr < nchar(line))
          code_last_line <- paste0(code[j],")", substr(line, n_chr+1, nchar(line)))
        else
          code_last_line <- paste0(code[j],")")
        #print(code_last_line)
        src_copy <- src
        src_copy[(line_num-j+1):line_num] <- c(head(code,-1), code_last_line)
        if (is_syntactic(paste(src_copy,collapse="\n"))){
          src <- src_copy
          break_ <- TRUE
          break}
      }
      if(break_ || j == 7) break
      line_num <- line_num + 1
    }
  }
  eval(str2lang(paste(src, collapse = "\n")),envir = environment(fun))
}

repair_call <- function(call){
  if(!is.call(call)) {
    return(call)
  }
  # if
  if(call[[1]] == quote(`if`)) {
    if(!is.call(call[[3]]) || call[[3]][[1]] != quote(`{`))
      call[[3]] <- as.call(list(quote(`{`), call[[3]]))
    if(length(call) == 4 && (!is.call(call[[4]]) || call[[4]][[1]] != quote(`{`)))
      call[[4]] <- as.call(list(quote(`{`), call[[4]]))
    call[-1] <- lapply(as.list(call[-1]), repair_call)
    return(call)}
  # for
  if(call[[1]] == quote(`for`)) {
    if(!is.call(call[[4]]) || call[[4]][[1]] != quote(`{`))
      call[[4]] <- as.call(list(quote(`{`), call[[4]]))
    call[-1] <- lapply(as.list(call[-1]), repair_call)
    return(call)}
  # repeat
  if(call[[1]] == quote(`repeat`)) {
    if(!is.call(call[[2]]) || call[[2]][[1]] != quote(`{`))
      call[[2]] <- as.call(list(quote(`{`), call[[2]]))
    call[-1] <- lapply(as.list(call[-1]), repair_call)
    return(call)}
  # while
  if(call[[1]] == quote(`while`)) {
    if(!is.call(call[[3]]) || call[[3]][[1]] != quote(`{`)){
      call[[3]] <- as.call(list(quote(`{`), call[[3]]))
    }
    call[-1] <- lapply(as.list(call[-1]), repair_call)
    return(call)}
  call[] <- lapply(call, repair_call)
  call
}

关于r - 修改函数以便控制流构造使用 `{...}` 并在正确的位置保留注释，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/58449758/

r - 修改函数以便控制流构造使用 `{...}` 并在正确的位置保留注释

上一篇：大数据 reshape

下一篇：qt - 如何为一行设置图像？