£ÒÈ÷˺Ͽ - µ»ö°ìÍ÷
- Åê¹Æ¼Ô¡§ ¤ß¤å
- ¥«¥Æ¥´¥ê¡§ ¤Ê¤·
- Í¥ÀèÅÙ¡§ ÉáÄÌ
- ¾õÂÖ¡§ ´°Î»
- Æü»þ¡§ 2010ǯ01·î23Æü 20»þ41ʬ35ÉÃ
- ¡Ö¤Á¤ç¤Ã¤È¤·¤¿¥³¥Ä¡×½¸
- ´ÉÍý¿Í¤ß¤å¤ÎÈ÷˺Ͽ¡Ê¾Ð
- ¤³¤³¤«¤éÀè¤Ï¡¢BugTrack-£ÒÈ÷˺Ͽ/56¤ÎC¤Î¥½¡¼¥¹¤Ë¤É¤ó¤É¤óÄɲ䷤Ƥ¤¤¯¤À¤±¤Ç¡¢Æ°¤¯¤Ï¤º¤Ç¤¹¡¥
- ¥½¡¼¥¹ ¢ª test.c(107)
- ¥Ð¥°Êó¹ð¤ä¼ÁÌä¤ÏÊ̴ۤǤª´ê¤¤¤·¤Þ¤¹¡¥
- GET_DIM
- ¹ÔÎó¤Ê¤ó¤«¤òÅϤ¹¤È¤¤Ë¡¢¤½¤Î¥Ç¥£¥á¥ó¥¸¥ç¥ó¤ò¤¤¤Á¤¤¤ÁÀ°¿ô¤ÇÅϤµ¤Ê¤¯¤Æ¤è¤¤¡¥C¤ÎÃæ¤Ç¼èÆÀ¤Ç¤¤ë¡¥
- C¥µ¥ó¥×¥ë
SEXP test001(SEXP a){
int n, m;
n = INTEGER(GET_DIM(a))[0];
m = INTEGER(GET_DIM(a))[1];
printf("nrow of a : %d\n", n);
printf("ncol of a : %d\n", m);
return a;
}
> a <- matrix(double(1), 3,5)
> .Call("test001", a)
nrow of a : 3
ncol of a : 5
[,1] [,2] [,3] [,4] [,5]
[1,] 0 0 0 0 0
[2,] 0 0 0 0 0
[3,] 0 0 0 0 0
- Solves a general system of linear equations AX=B.
- http://www.netlib.org/lapack/double/dgesv.f
- ¤³¤ó¤Ê·×»»¤ÏR¤Ç¤Á¤ç¤Á¤ç¤¤¤Î¤Á¤ç¤¤¤Ê¤ó¤Ç¤¹¤¬¡¢¥¹¥Ô¡¼¥É¥¢¥Ã¥×¤òÁÀ¤Ã¤ÆC¤Çµ½Ò¤·¤¿¤¤¤È¤¤Ë¡¢¤³¤ó¤Ê·×»»¤ò¤¹¤ë¤¿¤á¤Ë¤¤¤Á¤¤¤ÁR¤ËÌá¤Ã¤Æ·×»»¤µ¤»¤Æ¤¤¤Æ¤Ï¡¢¤½¤ì¤³¤½¥Ñ¥Õ¥©¡¼¥Þ¥ó¥¹¤¬½Ð¤Ê¤¤¤Î¤Ç¡¦¡¦¡¦¡¥¤³¤ó¤Ê·×»»¤Ç¤âC¤ÎÃæ¤Ç¤ä¤é¤»¤¿¤Û¤¦¤¬¤è¤¤¤Ç¤¹¡¥¤Ç¤¹¤Î¤Ç¡¢blas¤È¤«lapack¤Ïɬ¿Ü¤À¤Ã¤¿¤ê¤·¤Þ¤¹¡¥
- C¸À¸ì
SEXP Rdgesv01(SEXP A, SEXP b, SEXP info)
{
int i;
long int n = INTEGER(GET_DIM(A))[0];
long int nrhs=1;
long int piv[n]; // ¤³¤ó¤Ê½ñ¤Êý¤Ç¤¤¿¤Ã¤±¡©¡©¡©
printf("N = %ld\n", n);
dgesv_(&n, &nrhs, REAL(A), &n, piv, REAL(b), &n, INTEGER(info));
for(i=0; i<n; ++i) printf("%lf\n", REAL(b)[i]);
return(b);
}
A <- cbind(c(1, 3, 1), c(1, 1, -2), c(1, -3, -5))
b <- c(3,1,-6)
solve(A, b)
> solve(A, b)
[1] 1 1 1 # R¤Ë¤è¤ë²ò
> info <- integer(1)
> .Call("Rdgesv01", A, b, info)
N = 3 #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
1.000000 #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
1.000000 #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
1.000000 #C¤ÎÃæ¤Çɽ¼¨¤µ¤»¤Æ¤¤¤ë
[1] 1 1 1 #¡Ö.Call¡×¤ÎÌá¤êÃÍ
- ¤¿¤À¤·º£¤ÎC¤Î½ñ¤Êý¤À¤È¡¢°ú¿ô¤Ë¤·¤¿¡Ö£â¡×¼«ÂΤÎÃæ¿È¤â½ñ¤´¹¤ï¤Ã¤Æ¤·¤Þ¤Ã¤Æ¤¤¤Þ¤¹¡¥dgesv¤Î»ÅÍͤʤΤǻÅÊý¤¢¤ê¤Þ¤»¤ó¡¥¡Ê¤Ä¤¤¤Ç¤Ë¸À¤¦¤ÈA¤â½ñ¤´¹¤ï¤ë¡¦¡¦¡¦¡Ë
> b
[1] 1 1 1
- ¤³¤ì¤ò¡¢Ëɤ°¤Ë¤Ï·ë²Ì¤òÆþ¤ì¤ë¾ì½ê¤òÍÑ°Õ¤·¤Æ¡¢¤½¤³¤Ë·ë²Ì¤ò¥»¥Ã¥È¤·¤ÆÊÖ¤¹¤·¤«¤¢¤ê¤Þ¤»¤ó¡¥
- R¤Ç¤³¤ì¤ò¼Â¸½¤¹¤ë¤Î¤Ï´Êñ¤Ç¤¹¡¥¡ÖA¡×¡Ö£â¡×¤¬´û¤Ë¥»¥Ã¥È¤µ¤ì¤Æ¤¤¤ë¤È²¾Äꤹ¤ë¤È
tmpA <- A
tmpb <- b
.Call("Rdgesv01", tmpA, tmpb, info)
- Ê̤ÎÆþ¤ìʪ¤òºî¤Ã¤Æ¤½¤ì¤Ç·×»»¤µ¤»¤ì¤Ð¤¤¤¤¤À¤±¤Ç¤¹¡¦¡¦¡¦
- ¤Ç¤â¤³¤ì¤À¤È¡¢R¤ÇÂå¤ï¤ê¤ÎÆþ¤ìʪ¤òÍÑ°Õ¤·¤Æ¤¤¤ë¤Î¤Ç¡¢C¤ÎÃæ¤Ç°ìÏ¢¤Î½èÍý¤ò¤µ¤»¤¿¤¤¾ì¹ç¤Ë¤Ï»È¤¨¤Þ¤»¤ó¡¥¤½¤³¤Ç¤³¤ì¤òC¤ÎÃæ¤Ç¤Á¤ã¤ó¤ÈÍÑ°Õ¤¹¤ë¤è¤¦¤Ë¤·¤Þ¤¹¡¥
SEXP Rdgesv01(SEXP A, SEXP b, SEXP info)
{
int i;
long int n = INTEGER(GET_DIM(A))[0];
long int nrhs=1;
long int incx=1;
long int incy=1;
long int piv[n];
SEXP tmpA, tmpb;
PROTECT(tmpA = allocMatrix(REALSXP, n, n));
PROTECT(tmpb = allocVector(REALSXP, n));
long int nn = n*n;
dcopy_(&nn, REAL(A), &incx, REAL(tmpA), &incy);
dcopy_(&n, REAL(b), &incx, REAL(tmpb), &incy);
printf("N = %ld\n", n);
dgesv_(&n, &nrhs, REAL(tmpA), &n, piv, REAL(tmpb), &n, INTEGER(info));
for(i=0; i<n; ++i) printf("%lf\n", REAL(b)[i]);
UNPROTECT(2);
return(tmpb);
}
- R¤ÎAPI¤òC¤Ç»È¤¦¤È¤¤Î¤ªºîË¡¤Ê¤Î¤Ç¤¹¤¬¡¢¿·¤¿¤Ë¥á¥â¥ê¤ò³ÎÊݤ¹¤ë¾ì¹ç¤ÏPROTECT¤È¤¤¤¦¥Þ¥¯¥í¤ò»È¤ï¤Í¤Ð¤Ê¤ê¤Þ¤»¤ó¡¥¾¡¼ê¤Ë¥¬¥Ù¡¼¥¸¥³¥ì¥¯¥·¥ç¥ó¤µ¤ì¤ë¤Î¤òËɤ°¤¿¤á¤Î¤è¤¦¤Ç¤¹¡¥¤½¤·¤Æ¡¢¤½¤ì¤ò¤É¤³¤«¤ÇUNPROTECT¤¹¤ëɬÍפ¬¤¢¤ê¤Þ¤¹¡¥
- ¡Ödcopy_¡×¤Ïblas¤Î´Ø¿ô¤Ç¡¢ÊÑ¿ô¤ÎÃæ¿È¤ò¥³¥Ô¡¼¤·¤Æ¤¯¤ì¤Þ¤¹¡¥A¤Ï£î¡ß£î¤Ê¤Î¤Ç¡¢Æó¾è¤·¤Æ¤¤¤Þ¤¹¡¥
- R¤«¤é¸Æ¤Ö
> A <- cbind(c(1, 3, 1), c(1, 1, -2), c(1, -3, -5))
> b <- c(3,1,-6)
> solve(A, b)
[1] 1 1 1
> info <- integer(1)
> .Call("Rdgesv01", A, b, info)
N = 3
3.000000 #¸µ¤Î£â¤òɽ¼¨¤·¤Æ¤¤¤ë¡¥
1.000000 #¸µ¤Î£â¤òɽ¼¨¤·¤Æ¤¤¤ë¡¥
-6.000000 #¸µ¤Î£â¤òɽ¼¨¤·¤Æ¤¤¤ë¡¥
[1] 1 1 1 # ·ë²Ì¤Ï¤³¤ÎÄ̤ê
> A #½ñ¤´¹¤ï¤Ã¤Æ¤¤¤Ê¤¤
[,1] [,2] [,3]
[1,] 1 1 1
[2,] 3 1 -3
[3,] 1 -2 -5
> b #½ñ¤´¹¤ï¤Ã¤Æ¤¤¤Ê¤¤
[1] 3 1 -6
print(x, digits=3)
SEXP eval_fun01(SEXP a, SEXP rho)
{
SEXP s, t;
SEXP ret;
PROTECT(t = s = allocList(3));
// Setting the type to LANGSXP makes this a call which can be evaluated
SET_TYPEOF(s, LANGSXP);
// set a symbol (pointing to the function to be called)
SETCAR(t, install("print")); t = CDR(t);
// set the first unnamed
SETCAR(t, a); t = CDR(t);
// set the second named
SETCAR(t, allocVector(INTSXP, 1));
INTEGER(CAR(t))[0] = 3;
SET_TAG(t, install("digits"));
PROTECT(ret = eval(s, rho));
//PrintValue(ret);
UNPROTECT(2);
return R_NilValue;
}
> print("Hello", digits=3)
[1] "Hello"
> .Call("eval_fun01", "Hello", .GlobalEnv)
[1] "Hello"
NULL
> print(3.123456789, digits=3)
[1] 3.12
> .Call("eval_fun01", 3.123456789, .GlobalEnv)
[1] 3.12
NULL
- °ú¿ô¤¬£±¤Ä¤À¤±¤Ê¤é¡Ölang2¡×¤¬»È¤¨¤Þ¤¹¡¥
- ¡Öprint("Hello")¡×¤ò¼Â¸½
SEXP eval_fun02(SEXP a, SEXP rho)
{
SEXP call;
SEXP ret;
PROTECT(call = lang2(install("print"), a));
eval(call, rho);
UNPROTECT(1);
return R_NilValue;
}
> .Call("eval_fun02", "Hello", .GlobalEnv)
[1] "Hello"
NULL
- ɾ²Á¤·¤¿¤¤expression¤ò¡Öquote¡×¤Ç¤ï¤¿¤¹¡¥
SEXP eval_fun03(SEXP fr, SEXP env)
{
SEXP ans;
if(!isEnvironment(env)) error(" 'env' should be an environment");
PROTECT(ans = eval(fr, env));
UNPROTECT(1);
return(ans);
}
> f <- function(x) x^2
> .Call("eval_fun03", quote(f(x)), new.env())
°Ê²¼¤Ë¥¨¥é¡¼ f(x) : ¥ª¥Ö¥¸¥§¥¯¥È 'x' ¤¬¤¢¤ê¤Þ¤»¤ó
- ¡Öf(x)¡×¤ò·×»»¤·¤¿¤¤¤Î¤Ç¤¹¤¬¡¢¡Önew.env()¡×¤Ç»ØÄꤷ¤¿´Ä¶¡©¤Ë£ø¤¬¤Ê¤¤¤Î¤Ç¡¢£ø¤¬¸«¤Ä¤«¤é¤Ê¤¤¤È¤¤¤ï¤ì¤Þ¤¹¡¥¥°¥í¡¼¥Ð¥ë´Ä¶¤Ç£ø¤òºî¤Ã¤Æ¤¢¤²¤ë¤È¡¢¡Önew.env()¡×¤Ë£ø¤¬¤Ê¤¤¾ì¹ç¤Ë¤Ï¥°¥í¡¼¥Ð¥ë´Ä¶¤Þ¤Çõ¤·¤Ë¤¤Æ¤¯¤ì¤Þ¤¹¡¥
> f <- function(x) x^2
> .Call("eval_fun03", quote(f(x)), new.env())
°Ê²¼¤Ë¥¨¥é¡¼ f(x) : ¥ª¥Ö¥¸¥§¥¯¥È 'x' ¤¬¤¢¤ê¤Þ¤»¤ó
> x <- 2
> .Call("eval_fun03", quote(f(x)), new.env())
[1] 4
> x <- pi
> .Call("eval_fun03", quote(f(x)), new.env())
[1] 9.869604
- £¤ò¤â¤¦¤Á¤ç¤Ã¤È°ìÈÌŪ¤Ë¤ä¤í¤¦¤È¤¹¤ë¤È¤³¤ó¤Ê´¶¤¸¤Ë¤Ê¤ë¤Ç¤·¤ç¤¦¤«¡©
SEXP eval_fun04(SEXP fr, SEXP x, SEXP env)
{
SEXP ans;
if(!isEnvironment(env)) error(" 'env' should be an environment");
defineVar(install("x"), x, env);
PROTECT(ans = eval(fr, env));
UNPROTECT(1);
return(ans);
}
- ¤³¤ì¤ÏC¤ÎÃæ¤Ç¡¢ÅϤµ¤ì¤¿¿·´Ä¶¤Ç£ø¤òÄêµÁ¤·¤Æ¤¤¤Þ¤¹¤«¤é¡¢¥°¥í¡¼¥Ð¥ë´Ä¶¤Ë£ø¤¬¤Ê¤¯¤Æ¤â¥¨¥é¡¼¤Ï¤Ç¤Þ¤»¤ó¡¥
> .Call("eval_fun03", quote(f(x)), new.env())
[1] 9.869604 #£¤ÎÎã
> f <- function(x) x^3
> .Call("eval_fun04", quote(f(x)), 2, new.env())
[1] 8
> .Call("eval_fun04", quote(f(x1)), 2, new.env())
°Ê²¼¤Ë¥¨¥é¡¼ f(x1) : ¥ª¥Ö¥¸¥§¥¯¥È 'x1' ¤¬¤¢¤ê¤Þ¤»¤ó
- ʸ»úÎó¤ò¤½¤Î¤Þ¤Þɾ²Á¤·¤¿¤¤¤È¤¤¤¦¤½¤ó¤Ê¤¢¤Ê¤¿¤Ë¤Ï¡¦¡¦¡¦
- C¤Î¥½¡¼¥¹
- ¡Ú#include <R_ext/Parse.h>¡Û¤ÎÄɲä¬É¬ÍפǤ¹¡¥
SEXP eval_fun05(SEXP a, SEXP env)
{
SEXP cv, call, call2;
SEXP ans;
int i;
ParseStatus status;
char *cmd1 = "print(a)"; //¤Ê¤ó¤Ç¤âOK¡¥Ê¸»úÎó¤ò½àÈ÷
PROTECT(cv = allocVector(STRSXP, 1)); //ʸ»úÎóÍѤΥª¥Ö¥¸¥§¥¯¥È¤òÍÑ°Õ
SET_STRING_ELT(cv, 0, mkChar(cmd1)); //ʸ»úÎóÊÑ¿ô¤ËÆþ¤ì¤ë
PROTECT(call = R_ParseVector(cv, 1, &status, R_NilValue)); //¤ªºîË¡¤Ç¤¹¡¥
PROTECT(call2 = lang2(install("eval"), call)); //eval´Ø¿ô¤Ë¥»¥Ã¥È¤¹¤ë
for(i=0; i<5; i++){
INTEGER(a)[0] = INTEGER(a)[0] + i;
defineVar(install("a"), a, env);
PROTECT(ans = eval(call2, env));
UNPROTECT(1);
}
UNPROTECT(3);
return ans;
}
> dyn.load("test.so")
> is.loaded("eval_fun05")
[1] TRUE
> .Call("eval_fun05", as.integer(2), new.env())
[1] 2
[1] 3
[1] 5
[1] 8
[1] 12
- ¡Öcall2¡×¤È¤¤¤¦¥ª¥Ö¥¸¥§¥¯¥È¡Ê̾Á°¤Ï¤Ê¤ó¤Ç¤âÎɤ¤¡Ë¤òÍÑ°Õ¤·¤Æ¤ª¤±¤Ð¡¢Î㤨¤Ð¥ë¡¼¥×¤ÎÃæ¤Ç²¿ÅÙ¤âɾ²Á¤Ç¤¤ë¡¥
- ɾ²Á¤¹¤ëÁ°¤Ë¡¢¡Ê¤³¤ÎÎã¤Ç¤Ï¡Ëɽ¼¨¤µ¤»¤ë¡Öa¡×¤È¤¤¤¦¥ª¥Ö¥¸¥§¥¯¥È¤ò¡ÖR_env¡×´Ä¶¤Ç¤¤Á¤ó¤ÈÄêµÁ¤·¤Æ¤ª¤¯É¬Íפ¬¤¢¤ë¡¥¤½¤¦¤Ç¤Ê¤±¤ì¤Ð¡¢²¿ÅÙɾ²Á¤·¤Æ¤â¡¢Æ±¤¸Ãͤ·¤«É½¼¨¤µ¤ì¤Þ¤»¤ó¡Ê¾Ð
- ʸ»úÎó¤òR¤«¤éÅϤ¹¤Ê¤ê¡¢C¤Ë¥Ï¡¼¥É¥³¡¼¥Ç¥£¥ó¥°¤¹¤ë¤Ê¤ê¡¢¤ª¹¥¤¤Ë¤É¤¦¤¾¡¥
- ´ÉÍý¿Í¤ß¤å¤â¤³¤ì¤ò¿ÍÍ¡¥
£ÒÈ÷˺Ͽ /¾õÂÖ¶õ´Ö¥â¥Ç¥ê¥ó¥°/donlp2/¤½¤Î¾¤Î¥á¥â