<p>Welcome to the second post in rambling random R recommendation series, or <span>R4</span> for short.</p>
<p>Two days ago I posted the <a href="http://dirk.eddelbuettel.com/blog/2017/03/29#001_easy_package_registration">initial (actual) post</a>. It provided context for why we need package registration entries (tl;dr: because <code>R CMD check</code> now tests for it, and because it The Right Thing to do, see documentation in the posts). I also showed how generating such a file <code>src/init.c</code> was essentially free as all it took was single call to a new helper function added to R-devel by Brian Ripley and Kurt Hornik.</p>
<p>Now, to actually use R-devel you obviously need to have it accessible. There are a myriad of ways to achieve that: just compile it locally as I have done for years, use a Docker image as I showed in the post -- or be creative with eg <a href="https://www.travis-ci.org/">Travis</a> or <a href="https://win-builder.r-project.org/">win-builder</a> both of which give you access to R-devel if you're clever about it.</p>
<p>But as no good deed goes unpunished, I was of course told off today for showing a Docker example as <a href="http://lists.r-forge.r-project.org/pipermail/rcpp-devel/2017-March/009569.html">Docker was not &quot;Easy&quot;</a>. I think the formal answer to that is baloney. But we leave that aside, and promise to discuss setting up Docker at another time.</p>
<p>R is after all ... just R. So below please find a script you can save as, say, <code>~/bin/pnrrs.r</code>. And calling it---even with R-release---will generate the same code snippet as I showed via Docker. Call it a one-off backport of the new helper function -- with a half-life of a few weeks at best as we will have R 3.4.0 as default in just a few weeks. The script will then reduce to just the final line as the code will be present with R 3.4.0.</p>
<div><pre><code><span>#!/usr/bin/r</span>

<span>library</span>(tools)

.find_calls_in_package_code &lt;-<span> </span>tools:::.find_calls_in_package_code
.read_description &lt;-<span> </span>tools:::.read_description

## all what follows is from R-devel aka R 3.4.0 to be

package_ff_call_db &lt;-<span> </span>function(dir) {
    ## A few packages such as CDM use base::.Call
    ff_call_names &lt;-<span> </span><span>c</span>(<span>&quot;.C&quot;</span>, <span>&quot;.Call&quot;</span>, <span>&quot;.Fortran&quot;</span>, <span>&quot;.External&quot;</span>,
                       <span>&quot;base::.C&quot;</span>, <span>&quot;base::.Call&quot;</span>,
                       <span>&quot;base::.Fortran&quot;</span>, <span>&quot;base::.External&quot;</span>)

    predicate &lt;-<span> </span>function(e) {
        (<span>length</span>(e) ><span> </span>1L) &amp;&amp;
<span> </span>!<span>is.na</span>(<span>match</span>(<span>deparse</span>(e[[1L]]), ff_call_names))
    }

    calls &lt;-<span> </span><span>.find_calls_in_package_code</span>(dir,
                                         <span>predicate =</span> predicate,
                                         <span>recursive =</span> <span>TRUE</span>)
    calls &lt;-<span> </span><span>unlist</span>(<span>Filter</span>(length, calls))

    if(!<span>length</span>(calls)) <span>return</span>(<span>NULL</span>)

    <span>attr</span>(calls, <span>&quot;dir&quot;</span>) &lt;-<span> </span>dir
    calls
}

native_routine_registration_db_from_ff_call_db &lt;-<span> </span>function(calls, <span>dir =</span> <span>NULL</span>, <span>character_only =</span> <span>TRUE</span>) {
    if(!<span>length</span>(calls)) <span>return</span>(<span>NULL</span>)

    ff_call_names &lt;-<span> </span><span>c</span>(<span>&quot;.C&quot;</span>, <span>&quot;.Call&quot;</span>, <span>&quot;.Fortran&quot;</span>, <span>&quot;.External&quot;</span>)
    ff_call_args &lt;-<span> </span><span>lapply</span>(ff_call_names,
                           function(e) <span>args</span>(<span>get</span>(e, <span>baseenv</span>())))
    <span>names</span>(ff_call_args) &lt;-<span> </span>ff_call_names
    ff_call_args_names &lt;-
<span> </span><span>lapply</span>(<span>lapply</span>(ff_call_args,
                      function(e) <span>names</span>(<span>formals</span>(e))), setdiff,
               <span>&quot;...&quot;</span>)

    if(<span>is.null</span>(dir))
        dir &lt;-<span> </span><span>attr</span>(calls, <span>&quot;dir&quot;</span>)

    package &lt;-<span> </span><span># drop name</span>
<span> </span><span>as.vector</span>(<span>.read_description</span>(<span>file.path</span>(dir, <span>&quot;DESCRIPTION&quot;</span>))[<span>&quot;Package&quot;</span>])

    symbols &lt;-<span> </span><span>character</span>()
    nrdb &lt;-
<span> </span><span>lapply</span>(calls,
               function(e) {
                   if (<span>startsWith</span>(<span>deparse</span>(e[[1L]]), <span>&quot;base::&quot;</span>))
                       e[[1L]] &lt;-<span> </span>e[[1L]][3L]
                   ## First figure out whether ff calls had '...'.
                   pos &lt;-<span> </span><span>which</span>(<span>unlist</span>(<span>Map</span>(identical,
                                           <span>lapply</span>(e, as.character),
                                           <span>&quot;...&quot;</span>)))
                   ## Then match the call with '...' dropped.
                   ## Note that only .NAME could be given by name or
                   ## positionally (the other ff interface named
                   ## arguments come after '...').
                   if(<span>length</span>(pos)) e &lt;-<span> </span>e[-pos]
                   ## drop calls with only ...
                   if(<span>length</span>(e) &lt;<span> </span>2L) <span>return</span>(<span>NULL</span>)
                   cname &lt;-<span> </span><span>as.character</span>(e[[1L]])
                   ## The help says
                   ##
                   ## '.NAME' is always matched to the first argument
                   ## supplied (which should not be named).
                   ##
                   ## But some people do (Geneland ...).
                   nm &lt;-<span> </span><span>names</span>(e); nm[2L] &lt;-<span> &quot;&quot;</span>; <span>names</span>(e) &lt;-<span> </span>nm
                   e &lt;-<span> </span><span>match.call</span>(ff_call_args[[cname]], e)
                   ## Only keep ff calls where .NAME is character
                   ## or (optionally) a name.
                   s &lt;-<span> </span>e[[<span>&quot;.NAME&quot;</span>]]
                   if(<span>is.name</span>(s)) {
                       s &lt;-<span> </span><span>deparse</span>(s)[1L]
                       if(character_only) {
                           symbols &lt;&lt;-<span> </span><span>c</span>(symbols, s)
                           <span>return</span>(<span>NULL</span>)
                       }
                   } else if(<span>is.character</span>(s)) {
                       s &lt;-<span> </span>s[1L]
                   } else { ## expressions
                       symbols &lt;&lt;-<span> </span><span>c</span>(symbols, <span>deparse</span>(s))
                       <span>return</span>(<span>NULL</span>)
                   }
                   ## Drop the ones where PACKAGE gives a different
                   ## package. Ignore those which are not char strings.
                   if(!<span>is.null</span>(p &lt;-<span> </span>e[[<span>&quot;PACKAGE&quot;</span>]]) &amp;&amp;
<span> </span><span>is.character</span>(p) &amp;&amp;<span> </span>!<span>identical</span>(p, package))
                       <span>return</span>(<span>NULL</span>)
                   n &lt;-<span> </span>if(<span>length</span>(pos)) {
                            ## Cannot determine the number of args: use
                            ## -1 which might be ok for .External().
                            -1L
                        } else {
                            <span>sum</span>(<span>is.na</span>(<span>match</span>(<span>names</span>(e),
                                            ff_call_args_names[[cname]]))) -<span> </span>1L
                        }
                   ## Could perhaps also record whether 's' was a symbol
                   ## or a character string ...
                   <span>cbind</span>(cname, s, n)
               })
    nrdb &lt;-<span> </span><span>do.call</span>(rbind, nrdb)
    nrdb &lt;-<span> </span><span>as.data.frame</span>(<span>unique</span>(nrdb), <span>stringsAsFactors =</span> <span>FALSE</span>)

    if(<span>NROW</span>(nrdb) ==<span> </span>0L ||<span> </span><span>length</span>(nrdb) !=<span> </span>3L)
        <span>stop</span>(<span>&quot;no native symbols were extracted&quot;</span>)
    nrdb[, 3L] &lt;-<span> </span><span>as.numeric</span>(nrdb[, 3L])
    nrdb &lt;-<span> </span>nrdb[<span>order</span>(nrdb[, 1L], nrdb[, 2L], nrdb[, 3L]), ]
    nms &lt;-<span> </span>nrdb[, <span>&quot;s&quot;</span>]
    dups &lt;-<span> </span><span>unique</span>(nms[<span>duplicated</span>(nms)])

    ## Now get the namespace info for the package.
    info &lt;-<span> </span><span>parseNamespaceFile</span>(<span>basename</span>(dir), <span>dirname</span>(dir))
    ## Could have ff calls with symbols imported from other packages:
    ## try dropping these eventually.
    imports &lt;-<span> </span>info$imports
    imports &lt;-<span> </span>imports[<span>lengths</span>(imports) ==<span> </span>2L]
    imports &lt;-<span> </span><span>unlist</span>(<span>lapply</span>(imports, <span>`</span><span>[[</span><span>`</span>, 2L))

    info &lt;-<span> </span>info$nativeRoutines[[package]]
    ## Adjust native routine names for explicit remapping or
    ## namespace .fixes.
    if(<span>length</span>(symnames &lt;-<span> </span>info$symbolNames)) {
        ind &lt;-<span> </span><span>match</span>(nrdb[, 2L], <span>names</span>(symnames), <span>nomatch =</span> 0L)
        nrdb[ind ><span> </span>0L, 2L] &lt;-<span> </span>symnames[ind]
    } else if(!character_only &amp;&amp;
<span> </span><span>any</span>((fixes &lt;-<span> </span>info$registrationFixes) !=<span> &quot;&quot;</span>)) {
        ## There are packages which have not used the fixes, e.g. utf8latex
        ## fixes[1L] is a prefix, fixes[2L] is an undocumented suffix
        nrdb[, 2L] &lt;-<span> </span><span>sub</span>(<span>paste0</span>(<span>&quot;^&quot;</span>, fixes[1L]), <span>&quot;&quot;</span>, nrdb[, 2L])
        if(<span>nzchar</span>(fixes[2L]))
            nrdb[, 2L] &lt;-<span> </span><span>sub</span>(<span>paste0</span>(fixes[2L]), <span>&quot;$&quot;</span>, <span>&quot;&quot;</span>, nrdb[, 2L])
    }
    ## See above.
    if(<span>any</span>(ind &lt;-<span> </span>!<span>is.na</span>(<span>match</span>(nrdb[, 2L], imports))))
        nrdb &lt;-<span> </span>nrdb[!ind, , drop =<span> </span><span>FALSE</span>]

    ## Fortran entry points are mapped to l/case
    dotF &lt;-<span> </span>nrdb$cname ==<span> &quot;.Fortran&quot;</span>
    nrdb[dotF, <span>&quot;s&quot;</span>] &lt;-<span> </span><span>tolower</span>(nrdb[dotF, <span>&quot;s&quot;</span>])

    <span>attr</span>(nrdb, <span>&quot;package&quot;</span>) &lt;-<span> </span>package
    <span>attr</span>(nrdb, <span>&quot;duplicates&quot;</span>) &lt;-<span> </span>dups
    <span>attr</span>(nrdb, <span>&quot;symbols&quot;</span>) &lt;-<span> </span><span>unique</span>(symbols)
    nrdb
}

format_native_routine_registration_db_for_skeleton &lt;-<span> </span>function(nrdb, <span>align =</span> <span>TRUE</span>, <span>include_declarations =</span> <span>FALSE</span>) {
    if(!<span>length</span>(nrdb))
        <span>return</span>(<span>character</span>())

    fmt1 &lt;-<span> </span>function(x, n) {
        <span>c</span>(if(align) {
              <span>paste</span>(<span>format</span>(<span>sprintf</span>(<span>&quot; {</span><span>\&quot;</span><span>%s</span><span>\&quot;</span><span>,&quot;</span>, x[, 1L])),
                    <span>format</span>(<span>sprintf</span>(if(n ==<span> &quot;Fortran&quot;</span>)
                                       <span>&quot;(DL_FUNC) &amp;F77_NAME(%s),&quot;</span>
                                   else
                                       <span>&quot;(DL_FUNC) &amp;%s,&quot;</span>,
                                   x[, 1L])),
                    <span>format</span>(<span>sprintf</span>(<span>&quot;%d},&quot;</span>, x[, 2L]),
                           <span>justify =</span> <span>&quot;right&quot;</span>))
          } else {
              <span>sprintf</span>(if(n ==<span> &quot;Fortran&quot;</span>)
                          <span>&quot; {</span><span>\&quot;</span><span>%s</span><span>\&quot;</span><span>, (DL_FUNC) &amp;F77_NAME(%s), %d},&quot;</span>
                      else
                          <span>&quot; {</span><span>\&quot;</span><span>%s</span><span>\&quot;</span><span>, (DL_FUNC) &amp;%s, %d},&quot;</span>,
                      x[, 1L],
                      x[, 1L],
                      x[, 2L])
          },
          <span>&quot; {NULL, NULL, 0}&quot;</span>)
    }

    package &lt;-<span> </span><span>attr</span>(nrdb, <span>&quot;package&quot;</span>)
    dups &lt;-<span> </span><span>attr</span>(nrdb, <span>&quot;duplicates&quot;</span>)
    symbols &lt;-<span> </span><span>attr</span>(nrdb, <span>&quot;symbols&quot;</span>)

    nrdb &lt;-<span> </span><span>split</span>(nrdb[, -1L, <span>drop =</span> <span>FALSE</span>],
                  <span>factor</span>(nrdb[, 1L],
                         <span>levels =</span>
                             <span>c</span>(<span>&quot;.C&quot;</span>, <span>&quot;.Call&quot;</span>, <span>&quot;.Fortran&quot;</span>, <span>&quot;.External&quot;</span>)))

    has &lt;-<span> </span><span>vapply</span>(nrdb, NROW, 0L) ><span> </span>0L
    nms &lt;-<span> </span><span>names</span>(nrdb)
    entries &lt;-<span> </span><span>substring</span>(nms, 2L)
    blocks &lt;-<span> </span><span>Map</span>(function(x, n) {
                      <span>c</span>(<span>sprintf</span>(<span>&quot;static const R_%sMethodDef %sEntries[] = {&quot;</span>,
                                n, n),
                        <span>fmt1</span>(x, n),
                        <span>&quot;};&quot;</span>,
                        <span>&quot;&quot;</span>)
                  },
                  nrdb[has],
                  entries[has])

    decls &lt;-<span> </span><span>c</span>(
        <span>&quot;/* FIXME: &quot;</span>,
        <span>&quot; Add declarations for the native routines registered below.&quot;</span>,
        <span>&quot;*/&quot;</span>)

    if(include_declarations) {
        decls &lt;-<span> </span><span>c</span>(
            <span>&quot;/* FIXME: &quot;</span>,
            <span>&quot; Check these declarations against the C/Fortran source code.&quot;</span>,
            <span>&quot;*/&quot;</span>,
            if(<span>NROW</span>(y &lt;-<span> </span>nrdb$.C)) {
                 args &lt;-<span> </span><span>sapply</span>(y$n, function(n) if(n >=<span> </span><span>0</span>)
                                <span>paste</span>(<span>rep</span>(<span>&quot;void *&quot;</span>, n), <span>collapse=</span><span>&quot;, &quot;</span>)
                                else <span>&quot;/* FIXME */&quot;</span>)
                <span>c</span>(<span>&quot;&quot;</span>, <span>&quot;/* .C calls */&quot;</span>,
                  <span>paste0</span>(<span>&quot;extern void &quot;</span>, y$s, <span>&quot;(&quot;</span>, args, <span>&quot;);&quot;</span>))
           },
            if(<span>NROW</span>(y &lt;-<span> </span>nrdb$.Call)) {
                args &lt;-<span> </span><span>sapply</span>(y$n, function(n) if(n >=<span> </span><span>0</span>)
                               <span>paste</span>(<span>rep</span>(<span>&quot;SEXP&quot;</span>, n), <span>collapse=</span><span>&quot;, &quot;</span>)
                               else <span>&quot;/* FIXME */&quot;</span>)
               <span>c</span>(<span>&quot;&quot;</span>, <span>&quot;/* .Call calls */&quot;</span>,
                  <span>paste0</span>(<span>&quot;extern SEXP &quot;</span>, y$s, <span>&quot;(&quot;</span>, args, <span>&quot;);&quot;</span>))
            },
            if(<span>NROW</span>(y &lt;-<span> </span>nrdb$.Fortran)) {
                 args &lt;-<span> </span><span>sapply</span>(y$n, function(n) if(n >=<span> </span><span>0</span>)
                                <span>paste</span>(<span>rep</span>(<span>&quot;void *&quot;</span>, n), <span>collapse=</span><span>&quot;, &quot;</span>)
                                else <span>&quot;/* FIXME */&quot;</span>)
                <span>c</span>(<span>&quot;&quot;</span>, <span>&quot;/* .Fortran calls */&quot;</span>,
                  <span>paste0</span>(<span>&quot;extern void F77_NAME(&quot;</span>, y$s, <span>&quot;)(&quot;</span>, args, <span>&quot;);&quot;</span>))
            },
            if(<span>NROW</span>(y &lt;-<span> </span>nrdb$.External))
                <span>c</span>(<span>&quot;&quot;</span>, <span>&quot;/* .External calls */&quot;</span>,
                  <span>paste0</span>(<span>&quot;extern SEXP &quot;</span>, y$s, <span>&quot;(SEXP);&quot;</span>))
            )
    }

    headers &lt;-<span> </span>if(<span>NROW</span>(nrdb$.Call) ||<span> </span><span>NROW</span>(nrdb$.External))
        <span>c</span>(<span>&quot;#include &lt;R.h>&quot;</span>, <span>&quot;#include &lt;Rinternals.h>&quot;</span>)
    else if(<span>NROW</span>(nrdb$.Fortran)) <span>&quot;#include &lt;R_ext/RS.h>&quot;</span>
    else <span>character</span>()

    <span>c</span>(headers,
      <span>&quot;#include &lt;stdlib.h> // for NULL&quot;</span>,
      <span>&quot;#include &lt;R_ext/Rdynload.h>&quot;</span>,
      <span>&quot;&quot;</span>,
      if(<span>length</span>(symbols)) {
          <span>c</span>(<span>&quot;/*&quot;</span>,
            <span>&quot; The following symbols/expresssions for .NAME have been omitted&quot;</span>,
            <span>&quot;&quot;</span>, <span>strwrap</span>(symbols, <span>indent =</span> <span>4</span>, <span>exdent =</span> <span>4</span>), <span>&quot;&quot;</span>,
            <span>&quot; Most likely possible values need to be added below.&quot;</span>,
            <span>&quot;*/&quot;</span>, <span>&quot;&quot;</span>)
      },
      if(<span>length</span>(dups)) {
          <span>c</span>(<span>&quot;/*&quot;</span>,
            <span>&quot; The following name(s) appear with different usages&quot;</span>,
            <span>&quot; e.g., with different numbers of arguments:&quot;</span>,
            <span>&quot;&quot;</span>, <span>strwrap</span>(dups, <span>indent =</span> <span>4</span>, <span>exdent =</span> <span>4</span>), <span>&quot;&quot;</span>,
            <span>&quot; This needs to be resolved in the tables and any declarations.&quot;</span>,
            <span>&quot;*/&quot;</span>, <span>&quot;&quot;</span>)
      },
      decls,
      <span>&quot;&quot;</span>,
      <span>unlist</span>(blocks, <span>use.names =</span> <span>FALSE</span>),
      ## We cannot use names with '.' in: WRE mentions replacing with &quot;_&quot;
      <span>sprintf</span>(<span>&quot;void R_init_%s(DllInfo *dll)&quot;</span>,
              <span>gsub</span>(<span>&quot;.&quot;</span>, <span>&quot;_&quot;</span>, package, <span>fixed =</span> <span>TRUE</span>)),
      <span>&quot;{&quot;</span>,
      <span>sprintf</span>(<span>&quot; R_registerRoutines(dll, %s);&quot;</span>,
              <span>paste0</span>(<span>ifelse</span>(has,
                            <span>paste0</span>(entries, <span>&quot;Entries&quot;</span>),
                            <span>&quot;NULL&quot;</span>),
                     <span>collapse =</span> <span>&quot;, &quot;</span>)),
      <span>&quot; R_useDynamicSymbols(dll, FALSE);&quot;</span>,
      <span>&quot;}&quot;</span>)
}

package_native_routine_registration_db &lt;-<span> </span>function(dir, <span>character_only =</span> <span>TRUE</span>) {
    calls &lt;-<span> </span><span>package_ff_call_db</span>(dir)
    <span>native_routine_registration_db_from_ff_call_db</span>(calls, dir, character_only)
}

package_native_routine_registration_db &lt;-<span> </span>function(dir, <span>character_only =</span> <span>TRUE</span>) {
    calls &lt;-<span> </span><span>package_ff_call_db</span>(dir)
    <span>native_routine_registration_db_from_ff_call_db</span>(calls, dir, character_only)
}

package_native_routine_registration_skeleton &lt;-<span> </span>function(dir, <span>con =</span> <span>stdout</span>(), <span>align =</span> <span>TRUE</span>,
                                                         <span>character_only =</span> <span>TRUE</span>, <span>include_declarations =</span> <span>TRUE</span>) {
    nrdb &lt;-<span> </span><span>package_native_routine_registration_db</span>(dir, character_only)
    <span>writeLines</span>(<span>format_native_routine_registration_db_for_skeleton</span>(nrdb,
                align, include_declarations),
               con)
}

<span>package_native_routine_registration_skeleton</span>(<span>&quot;.&quot;</span>)  ## when R 3.4.0 is out you only need this line</code></pre></div>
<p>Here I use <code>/usr/bin/r</code> as I happen to like <a href="http://dirk.eddelbuettel.com/code/littler.html">littler</a> a lot, but you can use <code>Rscript</code> the same way.</p>
<p>Easy enough now?</p>
<p>
This post by <a href="http://dirk.eddelbuettel.com/">Dirk Eddelbuettel</a> originated on his <a href="http://dirk.eddelbuettel.com/blog/">Thinking inside the box</a> blog. Please report excessive re-aggregation in third-party for-profit settings.
</p><p>