共立出版usefulRシリーズ第10巻『Rのパッケージおよびツールの作成と応用』 サンプルコード

dfmake.c

#include <R.h>
#include <Rinternals.h>

SEXP dfmake(SEXP x, SEXP y, SEXP z){
  int pc=0;
  SEXP df, varlabels, tmp, row_names;//DataTypes;
  const char* xx = CHAR(STRING_ELT(x, 0));
  const char* yy = CHAR(STRING_ELT(y, 0));
  const char* zz = CHAR(STRING_ELT(z, 0));
  PROTECT(df = allocVector(VECSXP, 2));pc++;// ベクトル要素を二つ持つ data.frame
  // df内第一ベクトルは三つの要素からなる 文字ベクトル
  SET_VECTOR_ELT(df, 0, allocVector(STRSXP, 3));
  SET_STRING_ELT(VECTOR_ELT(df,0), 0, mkChar(xx));
  SET_STRING_ELT(VECTOR_ELT(df,0), 1, mkChar(yy));
  SET_STRING_ELT(VECTOR_ELT(df,0), 2, mkChar(zz));    
  // df内第二ベクトルは三つの要素からなる 整数ベクトル
  SET_VECTOR_ELT(df, 1, allocVector(INTSXP, 3));
  INTEGER(VECTOR_ELT(df,1))[0] = 10;
  INTEGER(VECTOR_ELT(df,1))[1] = 20;
  INTEGER(VECTOR_ELT(df,1))[2] = 30;
  //データフレームの属性などを設定
  PROTECT(varlabels = allocVector(STRSXP, 2));pc++;//df 内ベクトルの名前を用意
  SET_STRING_ELT(varlabels, 0, mkChar("Name"));
  SET_STRING_ELT(varlabels, 1, mkChar("Age"));        
  PROTECT(tmp = mkString("data.frame")); pc++;
  PROTECT(row_names = allocVector(STRSXP, 3)); pc++;
  SET_STRING_ELT(row_names, 0, mkChar("1"));
  SET_STRING_ELT(row_names, 1, mkChar("2"));
  SET_STRING_ELT(row_names, 2, mkChar("3"));  
  setAttrib(df, R_ClassSymbol, tmp);
  setAttrib(df, R_NamesSymbol, varlabels);
  setAttrib(df, R_RowNamesSymbol, row_names);
  UNPROTECT(pc);
  return(df);
}

dfmake2.cpp

#include "Rcpp.h"
using namespace Rcpp;

RcppExport SEXP dfMake2 (SEXP x, SEXP y, SEXP z){
  CharacterVector cv = CharacterVector::create(as<std::string>(x), 
                                               as<std::string>(y), 
                                               as<std::string>(z));
  IntegerVector nv = IntegerVector::create(10,20,30);
  return DataFrame::create(Named("Name") =  cv,  
                           Named ("Age") =  nv,
                           Named("stringsAsFactors") = false );
}

fib.cpp

int fib(const int x){
  if(x==0)return(0);
  if(x==1)return(1);
  return fib(x-1)+fib(x-2);
}

fibonacci.cpp

#include<Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
int fibonacci(const int x){
  if(x < 2)
    return x;
  else
    return(fibonacci(x - 1))+fibonacci(x-2);
}

fibWrapepr.cpp

#include <Rcpp.h>
extern int fib(const int x);

extern "C" SEXP fibWrapper (SEXP xs ) {
  int x = Rcpp::as<int>(xs);
  int z = fib (x);
  return Rcpp::wrap(z);
}

Rcpp_sample.R

##  金 明哲編・石田 基広・神田 善伸・樋口 耕一・永井 達大・鈴木 了太著
## シリーズ名	シリーズ Useful R　全10巻 【10】巻
## ISBN	978-4-320-12373-1
## 判型	B5
## ページ数	212ページ
## 発売日	2014年12月10日
## 本体価格	3,400円
##  http://www.kyoritsu-pub.co.jp/bookdetail/9784320123731


### 第1章

#### 1.1

f <- function(x){
    tmp <- 0.0
    for (i in x) tmp <- tmp + i
    return (tmp)
}

f(1:10)

system.time(f(1:10^6))

library(compiler)

f2 <- cmpfun(f)

system.time(f2(1:10^6))


# install.packages ("rbenchmark")

fib1 <- function(n){
   if (n == 0) return (0)
   if (n == 1) return (1)
   return (fib1 (n - 1) + fib1 (n - 2))
}

system.time(fib1(30))

fib2 <- cmpfun(fib1)

library(rbenchmark)

benchmark(
    res1 = fib1(30),
    res2 = fib2(30),
    replications = 3,
    order = c('replications', 'elapsed')
    )




txt  <- '
 int fibonacci(const int x) {
 if (x == 0) return(0);
 if (x == 1) return(1);
 return fibonacci(x-1) + fibonacci(x-2);
}'


library(Rcpp)
library(inline)


fibRcpp <- cxxfunction(signature(xs = "int" ),
                       plugin = "Rcpp",
                       incl = txt,
                       body = '
                       int x = Rcpp::as<int>(xs);
                       return Rcpp::wrap(fibonacci(x));
                       ')


benchmark(
    res1 = fib1(30),
    res2 = fib2(30),
    res3 = fibRcpp(30),
    replications = 3,
    order = c('replications', 'elapsed')
    )



### 第2章

#### 2.2
/* twice.c */
#include <R.h>
#include <Rinternals.h>

SEXP twice (SEXP input) {
  long x = asReal (input);
  SEXP res = PROTECT (allocVector(REALSXP, 1));
  REAL (res)[0] = x * 2;
  UNPROTECT(1);
  return res;
}

dyn.load("twice.so")
.Call("twice", 6)
dyn.unload("twice.so")


/* setChar.c */
#include <R.h>
#include <Rinternals.h>
extern int utf8locale;

SEXP setChar (SEXP x){
  const char* xx = CHAR(STRING_ELT(x, 0));
  SEXP res = PROTECT(allocVector(STRSXP, 2));
  SET_STRING_ELT(res, 0, mkChar(xx));
  SET_STRING_ELT(res, 1, mkChar("さん"));
  UNPROTECT(1);
  return res;
}

dyn.load("setChar.so")
.Call("setChar", "山田")
dyn.unload("setChar.so")


/* to make a data frame */
#include <R.h>
#include <Rinternals.h>
extern int utf8locale;

SEXP dfmake(SEXP x, SEXP y, SEXP z){
  int pc=0;
  SEXP df, varlabels, tmp, row_names;//DataTypes;
  const char* xx = CHAR(STRING_ELT(x, 0));
  const char* yy = CHAR(STRING_ELT(y, 0));
  const char* zz = CHAR(STRING_ELT(z, 0));
  PROTECT(df = allocVector(VECSXP, 2));pc++;// ベクトル要素を二つ持つ data.frame
  // df内第一ベクトルは三つの要素からなる 文字ベクトル
  SET_VECTOR_ELT(df, 0, allocVector(STRSXP, 3));
  SET_STRING_ELT(VECTOR_ELT(df,0), 0, mkCharCE(xx, (utf8locale)?CE_UTF8:CE_NATIVE));
  SET_STRING_ELT(VECTOR_ELT(df,0), 1, mkCharCE(yy, (utf8locale)?CE_UTF8:CE_NATIVE));
  SET_STRING_ELT(VECTOR_ELT(df,0), 2, mkCharCE(zz, (utf8locale)?CE_UTF8:CE_NATIVE));	
  // df内第二ベクトルは三つの要素からなる 整数ベクトル
  SET_VECTOR_ELT(df, 1, allocVector(INTSXP, 3));
  INTEGER(VECTOR_ELT(df,1))[0] = 10;
  INTEGER(VECTOR_ELT(df,1))[1] = 20;
  INTEGER(VECTOR_ELT(df,1))[2] = 30;
  //データフレームの属性などを設定
  PROTECT(varlabels = allocVector(STRSXP, 2));pc++;//df 内ベクトルの名前を用意
  SET_STRING_ELT(varlabels, 0, mkCharCE("Name", (utf8locale)?CE_UTF8:CE_NATIVE));
  SET_STRING_ELT(varlabels, 1, mkCharCE("Age", (utf8locale)?CE_UTF8:CE_NATIVE));	
  PROTECT(tmp = mkString("data.frame")); pc++;
  PROTECT(row_names = allocVector(STRSXP, 3)); pc++;
  SET_STRING_ELT(row_names, 0, mkCharCE("1", (utf8locale)?CE_UTF8:CE_NATIVE));
  SET_STRING_ELT(row_names, 1, mkCharCE("2", (utf8locale)?CE_UTF8:CE_NATIVE));
  SET_STRING_ELT(row_names, 2, mkCharCE("3", (utf8locale)?CE_UTF8:CE_NATIVE));	
  setAttrib(df, R_ClassSymbol, tmp);
  setAttrib(df, R_NamesSymbol, varlabels);
  setAttrib(df, R_RowNamesSymbol, row_names);
  UNPROTECT(pc);
  return(df);
}

/* to make a dataframe 2  */ 
 #include "Rcpp.h"
 using namespace Rcpp;
 
 RcppExport SEXP dfMake2 (SEXP x, SEXP y, SEXP z){
   CharacterVector cv = CharacterVector::create(as<std::string>(x), 
                                                as<std::string>(y), 
                                                as<std::string>(z));
   IntegerVector nv = IntegerVector::create(10,20,30);
   return DataFrame::create(Named("Name") =  cv,  
                            Named ("Age") =  nv,
                            Named("stringsAsFactors") = false );
 }

#### 2.3 
install.packages(c("inline", "Rcpp"))

#### 2.4
library(inline)

fx <- cxxfunction( signature(x = "integer", y = "numeric" ) ,
                  body = 'return ScalarReal( INTEGER(x)[0] * REAL(y)[0] ) ;'
                  )

fx(2L, 5)

#is.null.cxxfun(fx)


### 2.5

/* fib.cpp*/

int fib(const int x){
  if(x==0)return(0);
  if(x==1)return(1);
  return fib(x-1)+fib(x-2);
}

/* fibWrapepr.cpp */

#include <Rcpp.h>
extern int fib(const int x);

extern "C" SEXP fibWrapper (SEXP xs ) {
  int x = Rcpp::as<int>(xs);
  int z = fib (x);
  return Rcpp::wrap(z);
}


export PKG_CPPFLAGS="-I/home/ishida/R/3.1/Rcpp/include"
R CMD SHLIB fib.cpp fibWrapper.cpp

system.file(package = "Rcpp")

dyn.load ("fib.so")
.Call ("fibWrapper", 10)

dyn.unload ("fib.so")


#### 2.5.2
/* fibonacci.cpp */
#include<Rcpp.h>
using namespace Rcpp;

// [[Rcpp::export]]
int fibonacci(const int x){
  if(x < 2)
    return x;
  else
    return(fibonacci(x - 1))+fibonacci(x-2);
}

sourceCpp("fibonacci.cpp")
fibonacci(10)

fibonacci


#### 2.5.3

src  <- "
  int fibonacci(const int x) {
  if (x == 0) return(0);
  if (x == 1) return(1);
  return fibonacci(x-1) + fibonacci(x-2);
}"

fibRcpp <- cxxfunction(signature(xs = "int" ),
                         plugin = "Rcpp",
                         incl = src,
                         body = "
                         int x = Rcpp::as<int>(xs);
                         return Rcpp::wrap(fibonacci(x));
                         ")
fibRcpp(10)

#### 2.5.4
src2 <- '
 using namespace std;
 vector< string > sortR (vector< string > strings ) {
   int len = strings.size();
   for( int i=0; i < len; i++ ) {
     sort( strings[i].begin(), strings[i].end() );
   }
   return strings;
}'


fun <- cppFunction(src2)
str <- c("Apple", "Microsoft")
fun (str)


#### 2.6.1
src <- "
  Rcpp::IntegerVector vec(4);
  vec[0] = 1;
  vec[1] = 2;
  vec[2] = 3;
  vec[3] = 4;
  return vec;
"

fun <- cxxfunction (signature(), src, plugin = "Rcpp")
fun()

src <- '
   Rcpp::NumericVector vec(x);
   double sum = 0.0;
   for (int i = 0; i < vec.size(); i++) {
      sum += vec[i];
   }
   return Rcpp::wrap(sum);
'

fun <- cxxfunction (signature(x="numeric"), src, plugin = "Rcpp")
x <- c(1.1, 2.2, 3.3)
fun (x)

src <- '
  double x = Rcpp::as<double> (vec);
  x = x * x;
  return Rcpp::wrap(x);
'
fun <- cxxfunction (signature(vec ="numeric"), src, plugin = "Rcpp")
fun(5.0)

src <- '
 using namespace Rcpp;
 CharacterVector strVec  = 
      CharacterVector::create(Named ("Japanese") = "日本語",
                              _["English"] = "英語");
 return strVec;
'

fun <- cxxfunction (signature(), src, plugin = "Rcpp")
fun()


#### 2.6.2
src <- '
 using namespace std;
 using namespace Rcpp;
 vector<int> num{1,2,3};
 vector<string> str {"山田","加藤","佐藤"};
 return DataFrame::create(Named("id") = num,
                          Named("name") = str);
'

settings <- getPlugin("Rcpp")
settings$env$PKG_CXXFLAGS='-std=c++11'
fun <- cxxfunction (signature(), src, plugin = "Rcpp",settings = settings)
fun()


#### 2.6.3
src <- '
 using namespace std;
 using namespace Rcpp;
 vector<int> num{1,2, 3,4, 5,6};
 NumericMatrix mat (2,3, num.begin());
 return mat;
'
fun <- cxxfunction (signature(), src, plugin = "Rcpp",settings=settings)
fun()


#### 2.6.4

src <- '
 Rcpp::NumericVector vec(x);
 int n = vec.size();
 Rcpp::NumericVector res (n);
 for (int i = 0; i < n; i++) {
     if(vec[i] > 0) {
       res[i] = 100/ vec[i];
     } else{
       res[i] = vec[i] * 100;
     }
   }
 return res;
'

fun <- cxxfunction(signature(x = "numeric" ),  body = src, plugin = "Rcpp")
x <- c(-2:2)
x
fun(x)


src <- '
 NumericVector vec(x);
 return wrap (ifelse (vec > 0, 100 / vec, 100 * vec ) ); 
'

fun <- cxxfunction(signature(x = "numeric"),  body = src, plugin = "Rcpp")
fun(x)

### 第3章

#### 3.1

//' @useDynLib myFib

//' Calcuate Fibonacchi number
//'
//' This simple function calcuate Fibonacci numbers
//' @name fibonacchi
//' @param x integer
//' @return Fibonacchi number
//' @keywords Fibonacchi


#include<Rcpp.h>
using namespace Rcpp;


//' @export
// [[Rcpp::export]]

int fibonacci(const int x){
  if (x < 0)
    return -99;
  else  if(x < 2)
    return x;
  else
    return(fibonacci(x - 1))+fibonacci(x-2);
}



Rcpp.package.skeleton("myFib", example_code = FALSE, cpp_files = "myFib.cpp") #'

roxygen2::upgradeRoxygen ('myFib')
roxygen2::roxygenize ('myFib')

install.packages ("myFib", repos = NULL)
library(myFib)
fibonacci (10)

#### 3.2
install.packages("devtools")

library(devtools)

load_all ("myFib")

fibonacci(10)


int fibonacci(const int x){
  if (x < 0) 
    return -999;//0未満は-999を返す
  else if(x < 2)
    return x;
  else
    return(fibonacci(x - 1)) + fibonacci(x-2);
}

fibonacci(-1)
load_all ("myFib", recompile = TRUE)
fibonacci(-1)
dev_mode()

install ("myFib")
ibonacci(-3)
dev_mode()


#### 3.3

test_that("test",{
    x <- fibonacci(10)
    expect_equal(x, 53)
})

load_all ("myFib", recompile = TRUE)
test_package("myFib")

### 第4章
https://github.com/IshidaMotohiro/R2MeCab/
を利用してください
################################################## 

library(Rcpp)


Rcpp.package.skeleton("R2MeCab",
                      author = "Motohiro ISHIDA", maintainer = "Motohiro ISHIDA",
                      email = "ishida-m@ias.tokushima-u.ac.jp", 
                      example_code = FALSE,
                      cpp_files = c("Makevars", "mecab_test.cpp","setMap.cpp", "util.cpp",
                                    "mecab_test.h", "setMap.h", "util.h"),
                      code_files = "mecab_test.R")


roxygen2::upgradeRoxygen('R2MeCab')

roxygen2::roxygenize("R2MeCab", roclets = "rd")

library(devtools)

load_all ("R2MeCab", recompile = TRUE)

mecab_test("すもももももももものうち")

dyn.load ("R2MeCab/src/R2MeCab.so")

.Call("mecab_test", "すもももももももものうち")

.Call("R2MeCab_mecab_test", PACKAGE = "R2MeCab", "すもももももももものうち" )

setChar.c

/* setChar.c */

#include <R.h>
#include <Rinternals.h>
extern int utf8locale;

SEXP setChar (SEXP x){
  const char* xx = CHAR(STRING_ELT(x, 0));
  SEXP res = PROTECT(allocVector(STRSXP, 2));
  SET_STRING_ELT(res, 0, mkChar(xx));
  SET_STRING_ELT(res, 1, mkChar("さん"));
  UNPROTECT(1);
  return res;
}

twice.c

/* twice.c */

#include <R.h>
#include <Rinternals.h>

SEXP twice (SEXP input) {
  long x = asReal (input );
  SEXP res = PROTECT (allocVector(REALSXP, 1));
  REAL (res)[0] = x * 2;
  UNPROTECT(1);
  return res;
}