Last active
August 29, 2015 14:04
Star
You must be signed in to star a gist
共立出版usefulRシリーズ第10巻『Rのパッケージおよびツールの作成と応用』 サンプルコード
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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); | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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 ); | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
int fib(const int x){ | |
if(x==0)return(0); | |
if(x==1)return(1); | |
return fib(x-1)+fib(x-2); | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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); | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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); | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
## 金 明哲編・石田 基広・神田 善伸・樋口 耕一・永井 達大・鈴木 了太著 | |
## シリーズ名 シリーズ 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", "すもももももももものうち" ) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
/* 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; | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
/* 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; | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment