2011年3月3日木曜日

Rの勉強2

> DD

function (expr,name,order=1)

{

if(order<1){

stop("order' must be >= 1")}else if(order==1){

D(expr,name)}else{DD(D(expr,name),name,order -1)}



}

> f<- function(x) x^2-2*x

> uniroot(f,c(1,3))

$root

[1] 2.000000



$f.root

[1] -5.356504e-07



$iter

[1] 6



$estim.prec

[1] 6.535148e-05



> result<-uniroot(f,c(1,3))

> result$root

[1] 2.000000

> polyroot(c(-2,5,-4,1))

[1] 1-0i 1+0i 2+0i

> help(expression)

starting httpd help server ... done

> length(ex1 <- expression(1+ 0:9))

[1] 1

> ex1

expression(1 + 0:9)

> f<- function(x) x^2

> integrate(f,0,1)

0.3333333 with absolute error < 3.7e-15

> integrate(sin,0,pi)

2 with absolute error < 2.2e-14

> integrate(dnorm,-Inf,1.96)

0.9750021 with absolute error < 1.3e-06



ここから多次元の式をを解くためにpackage(adapt)を探すが、それはいまはもうなくなっているようで、hitしなかった。そのため、個々の部分は保留。本でとりあえず確認して次へ。



> f<-x^2+sin(x)

> f

[1] 1.841471 4.909297 NA 24.041076 64.989358 NA 49.656987

[8] 49.656987 49.656987 49.656987 49.656987 49.656987 49.656987 49.656987

[15] NA

> f<-expression(x^2+sin(x))

> f

expression(x^2 + sin(x))

> deriv(f,"x")

expression({

.value <- x^2 + sin(x)

.grad <- array(0, c(length(.value), 1L), list(NULL, c("x")))

.grad[, "x"] <- 2 * x + cos(x)

attr(.value, "gradient") <- .grad

.value

})

> D(f,"x")

2 * x + cos(x)

> ff<-deriv(f,"x")

> ff<-deriv(f,"x",func=T)

> ff

function (x)

{

.value <- x^2 + sin(x)

.grad <- array(0, c(length(.value), 1L), list(NULL, c("x")))

.grad[, "x"] <- 2 * x + cos(x)

attr(.value, "gradient") <- .grad

.value

}

> ff(0)

[1] 0

attr(,"gradient")

x

[1,] 1

> f<- function(x) exp(-x^2)

> f

function(x) exp(-x^2)



> integrate(f,0,1)

0.7468241 with absolute error < 8.3e-15

> integrate(f,0,Inf)

0.886227 with absolute error < 2.2e-06

> matrix(1:6,nrow=2,ncol=3)

[,1] [,2] [,3]

[1,] 1 3 5

[2,] 2 4 6

> matrix(1:6,nrow=2,ncol=3,byrow=T)

[,1] [,2] [,3]

[1,] 1 2 3

[2,] 4 5 6

> x<-matrix(1:6,nrow=2,ncol=3,byrow=T)

> x

[,1] [,2] [,3]

[1,] 1 2 3

[2,] 4 5 6

> x[1,2]

[1] 2

> x<-matrix(1:6,nrow=2,ncol=3,)

> x

[,1] [,2] [,3]

[1,] 1 3 5

[2,] 2 4 6

> x[1,2]

[1] 3

> x[c(1,2),2]

[1] 3 4

>

> x[-1,c(T,F,T)]

[1] 2 6

> x[-2,c(T,F,T)]

[1] 1 5

> x[2,c(T,F,T)]

[1] 2 6

> x[1,c(T,F,T)]

[1] 1 5

> x[0,c(T,F,T)]

[,1] [,2]

> x[0,c(T,F,T),drop=F]

[,1] [,2]

> x[1,c(T,F,T),drop=F]

[,1] [,2]

[1,] 1 5

> x[c(T,F),drop=F]

[1] 1 3 5

> x[c(T,F)]

[1] 1 3 5

> x[c(T,F),1,drop=F]

[,1]

[1,] 1

> x[,1,drop=F]

[,1]

[1,] 1

[2,] 2

> a<-matrix(1:4,2,2)

> a

[,1] [,2]

[1,] 1 3

[2,] 2 4

> b<-matrix(0:3,2,2)

> b

[,1] [,2]

[1,] 0 2

[2,] 1 3

> a+b

[,1] [,2]

[1,] 1 5

[2,] 3 7

> a*b

[,1] [,2]

[1,] 0 6

[2,] 2 12

> a%*%b

[,1] [,2]

[1,] 3 11

[2,] 4 16

> 1/a

[,1] [,2]

[1,] 1.0 0.3333333

[2,] 0.5 0.2500000

> a

[,1] [,2]

[1,] 1 3

[2,] 2 4

> a*(1:2)

[,1] [,2]

[1,] 1 3

[2,] 4 8

> matrix(0,2,3)

[,1] [,2] [,3]

[1,] 0 0 0

[2,] 0 0 0

> diag(0,3)

[,1] [,2] [,3]

[1,] 0 0 0

[2,] 0 0 0

[3,] 0 0 0

> x<-matrix(1:4,2,2)

> x

[,1] [,2]

[1,] 1 3

[2,] 2 4

> t(x)

[,1] [,2]

[1,] 1 2

[2,] 3 4

> x<-diag(2)

> x

[,1] [,2]

[1,] 1 0

[2,] 0 1

> diag(1,3

+ )

[,1] [,2] [,3]

[1,] 1 0 0

[2,] 0 1 0

[3,] 0 0 1

> diag(1,2,2,)

以下にエラー diag(1, 2, 2, ) : 使われていない引数 ()

> diag(1,2,2)

[,1] [,2]

[1,] 1 0

[2,] 0 1

> rep(1,3)

[1] 1 1 1

> diag(1:3)

[,1] [,2] [,3]

[1,] 1 0 0

[2,] 0 2 0

[3,] 0 0 3

> x<-matrix(1:9,3)

> x

[,1] [,2] [,3]

[1,] 1 4 7

[2,] 2 5 8

[3,] 3 6 9

> x[upper.tri(x)]

[1] 4 7 8

> x[upper.tri(x)]<-0

> x

[,1] [,2] [,3]

[1,] 1 0 0

[2,] 2 5 0

[3,] 3 6 9

> x

[,1] [,2] [,3]

[1,] 1 0 0

[2,] 2 5 0

[3,] 3 6 9

> y<- x+t(x)

> y

[,1] [,2] [,3]

[1,] 2 2 3

[2,] 2 10 6

[3,] 3 6 18

> diag(y)<-diag(y)/2

> y

[,1] [,2] [,3]

[1,] 1 2 3

[2,] 2 5 6

[3,] 3 6 9

> runif(8)

[1] 0.2102961 0.5498479 0.1946713 0.4265509 0.7986963 0.9163540 0.4940985

[8] 0.3358213



> x
以下にエラー x < array(runif(8), c(2, 4)) : 適切な配列ではありません

> x<-array(runif(8),c(2,4))

> x

[,1] [,2] [,3] [,4]

[1,] 0.3524423 0.3709228 0.8152475 0.646365478

[2,] 0.8233227 0.3436113 0.2020325 0.008344393

> x<-matrix(runif(8),c(2,4))

> x

[,1] [,2] [,3] [,4]

[1,] 0.02009867 0.06521131 0.789769377 0.8694130

[2,] 0.28265013 0.68312891 0.003968216 0.7271877

> sum(x^2)

[1] 2.459645

> sum(diag(t(x) %*% x)

+ )

[1] 2.459645

> a<-matrix(1:9,3,3)

> b<-matrix(c(1,0,-2))

> solve(a,b)

以下にエラー solve.default(a, b) :

Lapack routine dgesv: 線形方程式系は正確に特異です

> a

[,1] [,2] [,3]

[1,] 1 4 7

[2,] 2 5 8

[3,] 3 6 9

> a<-matrix(0:9,3,3)

警告メッセージ:

In matrix(0:9, 3, 3) :

データ長 [10] が行数 [3] を整数で割った、もしくは掛けた値ではありません

> a<-matrix(c(0,1,2,3,4,5,6,7,9,),3,3)

以下にエラー c(0, 1, 2, 3, 4, 5, 6, 7, 9, ) : 引数 10 が空です

> a<-matrix(c(0,1,2,3,4,5,6,7,9),3,3)

> solve(a,b)

[,1]

[1,] -2.333333

[2,] 2.333333

[3,] -1.000000

> r<- rbind(c(1,2,3),

+

+ c(1,1,1,)

+ c(1,1,2)

エラー: 予想外の シンボル です 以下の部分:

"c(1,1,1,)

c"

> r<- rbind(c(1,2,3),

+ c(1,1,1)

+ c(1,1,2)

エラー: 予想外の シンボル です 以下の部分:

"c(1,1,1)

c"

> r<- rbind(c(1,2,3),

+ c(1,1,1)

+ c(1,1,2))

エラー: 予想外の シンボル です 以下の部分:

"c(1,1,1)

c"

> r<- rbind(c(1,2,3),c(1,1,1),c(1,1,2))

> r

[,1] [,2] [,3]

[1,] 1 2 3

[2,] 1 1 1

[3,] 1 1 2

> y<- backsolve(r,x<-c(8,4,2))

> y

[1] -1 3 1

> r %*% y

[,1]

[1,] 8

[2,] 3

[3,] 4

> r

[,1] [,2] [,3]

[1,] 1 2 3

[2,] 1 1 1

[3,] 1 1 2

> y

[1] -1 3 1

> r %*% y

[,1]

[1,] 8

[2,] 3

[3,] 4

> y2<-backsolve(r,x,transpose=T))

エラー: 予想外の ')' です ( "y2<-backsolve(r,x,transpose=T))" の)

> y2<-backsolve(r,x,transpose=T)

> y2

[1] 8 -12 -5

> all(t(r) %*% y2 ==x)

[1] FALSE

> t(r)

[,1] [,2] [,3]

[1,] 1 1 1

[2,] 2 1 1

[3,] 3 1 2

> x

[1] 8 4 2

> t(r) %*% y2

[,1]

[1,] -9

[2,] -1

[3,] 2

> y2

[1] 8 -12 -5

> t(r) %*% y2

[,1]

[1,] -9

[2,] -1

[3,] 2

> all(y == backsolve(t(r),x,upper=F,transpase=T)

+

+ )

以下にエラー backsolve(t(r), x, upper = F, transpase = T) :

使われていない引数 (transpase = T)

> all(y == backsolve(t(r),x,upper=F,transpose=T)

+ )

[1] TRUE

> all(y2 == backsolve(t(r),x,upper=F,transpose=T)

+ )

[1] FALSE

> A<-array(runif(9),3)

> A

[1] 0.1308231 0.8341508 0.7267654

> A<-array(runif(9),3,3)

> A

[1] 0.6929881 0.7566792 0.7246731

> A<-array(runif(9),C(3,3))

以下にエラー C(3, 3) : object not interpretable as a factor

> A<-array(runif(9),c(3,3))

> A

[,1] [,2] [,3]

[1,] 0.89858561 0.1711188 0.2555592

[2,] 0.51269440 0.8835462 0.3082611

[3,] 0.04353683 0.6940356 0.6764354

> B<-solve(A)

> B

[,1] [,2] [,3]

[1,] 1.0402813 0.1670456 -0.4691462

[2,] -0.9038233 1.6177126 -0.3957473

[3,] 0.8603851 -1.6705552 1.9145772

> A%*%B

[,1] [,2] [,3]

[1,] 1.000000e+00 -5.393906e-18 -3.987153e-17

[2,] 2.474691e-17 1.000000e+00 4.656648e-17

[3,] -9.763241e-17 2.677979e-16 1.000000e+00

> A<-matrix(c(1,2,3,4,5,6,7,8,9),c(3,3))

> S

エラー: オブジェクト 'S' がありません

> A

[,1] [,2] [,3]

[1,] 1 4 7

[2,] 2 5 8

[3,] 3 6 9

> B<- solve(A)

以下にエラー solve.default(A) :

Lapack routine dgesv: 線形方程式系は正確に特異です

> library(MASS)

> B<-ginv(A)

> B

[,1] [,2] [,3]

[1,] -0.6388889 -5.555556e-02 0.5277778

[2,] -0.1666667 -9.384786e-17 0.1666667

[3,] 0.3055556 5.555556e-02 -0.1944444

> A

[,1] [,2] [,3]

[1,] 1 4 7

[2,] 2 5 8

[3,] 3 6 9

> crossprod(A)

[,1] [,2] [,3]

[1,] 14 32 50

[2,] 32 77 122

[3,] 50 122 194

> crossprod(A,B)

[,1] [,2] [,3]

[1,] -0.05555556 0.1111111 0.2777778

[2,] -1.55555556 0.1111111 1.7777778

[3,] -3.05555556 0.1111111 3.2777778

> crossprod(B,A)

[,1] [,2] [,3]

[1,] -0.05555556 -1.5555556 -3.0555556

[2,] 0.11111111 0.1111111 0.1111111

[3,] 0.27777778 1.7777778 3.2777778

>

> a

[,1] [,2] [,3]

[1,] 0 3 6

[2,] 1 4 7

[3,] 2 5 9

> eigen(a)

$values

[1] 13.985686 -1.169156 0.183470



$vectors

[,1] [,2] [,3]

[1,] -0.4263524 -0.9366202 0.2264150

[2,] -0.5474684 -0.2042614 -0.8684128

[3,] -0.7200708 0.2846399 0.4411298



> qr(a)

$qr

[,1] [,2] [,3]

[1,] -2.2360680 -6.2609903 -11.1803399

[2,] 0.4472136 3.2863353 6.3900965

[3,] 0.8944272 0.9990708 0.4082483



$rank

[1] 3



$qraux

[1] 1.0000000 1.0430999 0.4082483



$pivot

[1] 1 2 3



attr(,"class")

[1] "qr"

> help(qr)

> a

[,1] [,2] [,3]

[1,] 0 3 6

[2,] 1 4 7

[3,] 2 5 9

> svd(a)

$d

[1] 14.8234620 1.1098292 0.1823541



$u

[,1] [,2] [,3]

[1,] -0.4482373 0.82968720 0.3327199

[2,] -0.5479485 0.03906245 -0.8355995

[3,] -0.7062831 -0.55686020 0.4371166



$v

[,1] [,2] [,3]

[1,] -0.1322575 -0.9683093 0.2118607

[2,] -0.4768064 -0.1252351 -0.8700413

[3,] -0.8690015 0.2160861 0.4451328



> A<-matrix(c(2,1,1,1,2,1,1,1,2),3

+ 3)

エラー: 予想外の 数値定数 です 以下の部分:

"A<-matrix(c(2,1,1,1,2,1,1,1,2),3

3"

> A<-matrix(c(2,1,1,1,2,1,1,1,2),3,3)

> A

[,1] [,2] [,3]

[1,] 2 1 1

[2,] 1 2 1

[3,] 1 1 2

> svd(A)$u ->U

> V<- svd(A)$v

> D<-diag(svd(A)$d))

エラー: 予想外の ')' です ( "D<-diag(svd(A)$d))" の)

> D<-diag(svd(A)$d)

> B<-U%*% D %*% t(v)

以下にエラー t(v) : オブジェクト 'v' がありません

> B<-U%*% D %*% t(V)

> A

[,1] [,2] [,3]

[1,] 2 1 1

[2,] 1 2 1

[3,] 1 1 2

> B

[,1] [,2] [,3]

[1,] 2 1 1

[2,] 1 2 1

[3,] 1 1 2

> B%*%B

[,1] [,2] [,3]

[1,] 6 5 5

[2,] 5 6 5

[3,] 5 5 6

> A

[,1] [,2] [,3]

[1,] 2 1 1

[2,] 1 2 1

[3,] 1 1 2

> U

[,1] [,2] [,3]

[1,] -0.5773503 0.8164966 -4.534658e-17

[2,] -0.5773503 -0.4082483 -7.071068e-01

[3,] -0.5773503 -0.4082483 7.071068e-01

> svd(A)

$d

[1] 4 1 1



$u

[,1] [,2] [,3]

[1,] -0.5773503 0.8164966 -4.534658e-17

[2,] -0.5773503 -0.4082483 -7.071068e-01

[3,] -0.5773503 -0.4082483 7.071068e-01



$v

[,1] [,2] [,3]

[1,] -0.5773503 0.8164966 0.0000000

[2,] -0.5773503 -0.4082483 -0.7071068

[3,] -0.5773503 -0.4082483 0.7071068



> V

[,1] [,2] [,3]

[1,] -0.5773503 0.8164966 0.0000000

[2,] -0.5773503 -0.4082483 -0.7071068

[3,] -0.5773503 -0.4082483 0.7071068

> D

[,1] [,2] [,3]

[1,] 4 0 0

[2,] 0 1 0

[3,] 0 0 1

> D<-diag(sqrt(svd(A)$d))

> B<-U%*% D %*% t(V)

> A

[,1] [,2] [,3]

[1,] 2 1 1

[2,] 1 2 1

[3,] 1 1 2

> B

[,1] [,2] [,3]

[1,] 1.3333333 0.3333333 0.3333333

[2,] 0.3333333 1.3333333 0.3333333

[3,] 0.3333333 0.3333333 1.3333333

> B%*%B

[,1] [,2] [,3]

[1,] 2 1 1

[2,] 1 2 1

[3,] 1 1 2

> x<-matrix(rep(0:1,81)9,9)

エラー: 予想外の 数値定数 です ( "x<-matrix(rep(0:1,81)9" の)

> x<-matrix(rep(0:1,81),9,9)

> image(x)

> image(a)

> runif(1)

[1] 0.01557919

> runif(1)

[1] 0.4673159

> runif(1)

[1] 0.01364200

> runif(1)

[1] 0.6551826

> runif(1)

[1] 0.6137373

> runif(1)

[1] 0.8678323

> runif(1)

[1] 0.09098834

> runif(1)

[1] 0.2472403

> runif(1)

[1] 0.1474482

> runif(10)

[1] 0.8207151 0.3485508 0.7243420 0.3453443 0.9215907 0.8703834 0.7705085

[8] 0.4919202 0.1120248 0.4600092

> skin(coin)

エラー: 関数 "skin" を見つけることができませんでした

> skincoin<-function(){(coin)

+ x<- runif(1)

+ if(x<= 1/2) men<- 1

+ else men<- 0

+ return(men)

+ }

> coin()

エラー: 関数 "coin" を見つけることができませんでした

> coin

エラー: オブジェクト 'coin' がありません

> coin<-function(){

+ x<- runif(1)

+ if(x<= 1/2) men<- 1

+ else men<- 0

+ return(men)

+ }

> coin

function(){

x<- runif(1)

if(x<= 1/2) men<- 1

else men<- 0

return(men)

}

> coin()

[1] 0

> coin()

[1] 1

> coin()

[1] 1

> coin()

[1] 0

> coin()

[1] 1

> coin()

[1] 0

> coin()

[1] 1

> coin()

[1] 0

> coin()

[1] 1

> coin()

[1] 1

> skin(coin)

エラー: 関数 "skin" を見つけることができませんでした

> fix(coin)

> saikoro()<-function(){

+ x<- runif(1)

+ if (x<= 1/6) men<- 1

+ if else(x<= 2/6) men<- 2

エラー: 予想外の 'else' です 以下の部分:

"if (x<= 1/6) men<- 1

if else"

> if else(x<= 3/6) men<- 3

エラー: 予想外の 'else' です ( "if else" の)

> if else(x<= 4/6) men<- 4

エラー: 予想外の 'else' です ( "if else" の)

> if else(x<= 5/6) men<- 5

エラー: 予想外の 'else' です ( "if else" の)

> else men<- 6

エラー: 予想外の 'else' です ( " else" の)

> return(men)

エラー: オブジェクト 'men' がありません

> saikoro<-function(){

+ x<- runif(1)

+ if (x<= 1/6) men<- 1

+ if else(1/6
エラー: 予想外の 'else' です 以下の部分:

"if (x<= 1/6) men<- 1

if else"

> if else(2/6
エラー: 予想外の 'else' です ( "if else" の)

> if else(3/6
エラー: 予想外の 'else' です ( "if else" の)

> if else(4/6
エラー: 予想外の 'else' です ( "if else" の)

> else men<- 6

エラー: 予想外の 'else' です ( " else" の)

> return(men)

エラー: オブジェクト 'men' がありません

> saikoro<-function(){

+ x<- runif(1)

+ if (x<= 1/6) men<- 1

+ else if(1/6
エラー: 予想外の '<=' です 以下の部分:

"if (x<= 1/6) men<- 1

else if(1/6
> else if(2/6
エラー: 予想外の 'else' です ( "else" の)

> else if(3/6
エラー: 予想外の 'else' です ( "else" の)

> else if(4/6
エラー: 予想外の 'else' です ( "else" の)

> else men<- 6

エラー: 予想外の 'else' です ( "else" の)

> return(men)

エラー: オブジェクト 'men' がありません

> }

エラー: 予想外の '}' です ( "}" の)

> saikoro<-function(){

+ x<- runif(1)

+ if (x<= 1/6) men<- 1

+ else if(1/6
エラー: 予想外の '<=' です 以下の部分:

"if (x<= 1/6) men<- 1

else if(1/6
> else if(2/6
エラー: 予想外の 'else' です ( "else" の)

> else if(3/6
エラー: 予想外の 'else' です ( "else" の)

> else if(4/6
エラー: 予想外の 'else' です ( "else" の)

> else men<- 6

エラー: 予想外の 'else' です ( "else" の)

> return(men)

エラー: オブジェクト 'men' がありません

> }

エラー: 予想外の '}' です ( "}" の)

> saikoro<-function(){

+ x<- runif(1)

+ if (x<= 1/6) men<- 1

+ else if(1/6 < x <= 2/6) men<- 2

エラー: 予想外の '<=' です 以下の部分:

"if (x<= 1/6) men<- 1

else if(1/6 < x <="

> else if(2/6 < x <= 3/6) men<- 3

エラー: 予想外の 'else' です ( "else" の)

> else if(3/6 < x <= 4/6) men<- 4

エラー: 予想外の 'else' です ( "else" の)

> else if(4/6 < x <= 5/6) men<- 5

エラー: 予想外の 'else' です ( "else" の)

> else men<- 6

エラー: 予想外の 'else' です ( "else" の)

> return(men)

エラー: オブジェクト 'men' がありません

> }

エラー: 予想外の '}' です ( "}" の)

> saikoro<-function(){

+ x<- runif(1)

+ if (x<= 1/6) men<- 1

+ else if(x <= 2/6) men<- 2

+ else if(x <= 3/6) men<- 3

+ else if(x <= 4/6) men<- 4

+ else if(x <= 5/6) men<- 5

+ else men<- 6

+ return(men)

+ }

> saikoro()

[1] 6

> saikoro()

[1] 3

> saikoro()

[1] 6

> saikoro()

[1] 6

> saikoro()

[1] 4

> saikoro()

[1] 3

> saikoro()

[1] 6

> saikoro()

[1] 4

> saikoro()

[1] 3

> saikoro()

[1] 1

> saikoro()

[1] 2

> saikoro()

[1] 2

> saikoro()

[1] 3

> saikoro()

[1] 1

> saikoro()

[1] 5

> tenki<-function(){

+ x<- runif(1)

+ if (x<= 7/10) men<- "hare"

+ else if(x <= 9/10) men<- "kumori"

+ else men<- "ame"

+ return(men)

+ }

> tenki()

[1] "ame"

> tenki()

[1] "ame"

> tenki()

[1] "hare"

> tenki()

[1] "hare"

> tenki()

[1] "kumori"

> tenki()

[1] "kumori"

> tenki()

[1] "hare"

> tenki()

[1] "hare"

> tenki()

[1] "hare"

> tenki()

[1] "hare"

> tenki()

[1] "hare"

> tenki()

[1] "hare"

> tenki()

[1] "hare"

> tenki()

[1] "kumori"

> tenki()

[1] "hare"

> tenki()

[1] "kumori"

> tenki()

[1] "kumori"

> mycointoss<-function(n){

+ count<-0

+ for(i 1:n){

エラー: 予想外の 数値定数 です 以下の部分:

"count<-0

for(i 1"

> x<-coin()

> if(x==1) count<- count+1

> }

エラー: 予想外の '}' です ( "}" の)

> return(count)

エラー: オブジェクト 'count' がありません

> }mycointoss<-function(n){

エラー: 予想外の '}' です ( "}" の)

> count<-0

> for(i 1:n){

エラー: 予想外の 数値定数 です ( "for(i 1" の)

> x<-coin()

> if(x==1) count<- count+1

> }

エラー: 予想外の '}' です ( "}" の)

> return(count)

エラー: 戻るための関数がありません,トップレベルへジャンプします

> }

エラー: 予想外の '}' です ( "}" の)

> mycointoss<-function(n){

+ count<-0

+ for(i 1:n){

エラー: 予想外の 数値定数 です 以下の部分:

"count<-0

for(i 1"

> x<-coin()

> if(x==1) count<- count+1

> }

エラー: 予想外の '}' です ( "}" の)

> return(count)

エラー: 戻るための関数がありません,トップレベルへジャンプします

> }

エラー: 予想外の '}' です ( "}" の)

> }

エラー: 予想外の '}' です ( "}" の)

> mycointoss<-function(n){

+ count<-0

+ for(i 1:n){

エラー: 予想外の 数値定数 です 以下の部分:

"count<-0

for(i 1"

> x<-coin()

> if(x==1) count <- count+1

> }

エラー: 予想外の '}' です ( " }" の)

> return(count)

エラー: 戻るための関数がありません,トップレベルへジャンプします

> mycointoss <- function(n) {

+ count<-0

+ for(i 1:n){

エラー: 予想外の 数値定数 です 以下の部分:

"count<-0

for(i 1"

> x<-coin()

> if(x==1) count <- count+1

> }

エラー: 予想外の '}' です ( " }" の)

> return(count)

エラー: 戻るための関数がありません,トップレベルへジャンプします

> mycointoss <- function(n) {

+ count<- 0

+ for(i 1:n){

エラー: 予想外の 数値定数 です 以下の部分:

"count<- 0

for(i 1"

> x<-coin()

> if(x==1) count <- count+1

> }

エラー: 予想外の '}' です ( " }" の)

> return(count)

エラー: 戻るための関数がありません,トップレベルへジャンプします

> mycointoss <- function(n) {

+ count<- 0

+ for(i in 1:n){

+ x<-coin()

+ if(x==1) count <- count+1

+ }

+ return(count)

+ }

> mycointoss(10)

[1] 6

> mycointoss(100)

[1] 52

> mycointoss(1000)

[1] 489

> mycointoss(10000)

[1] 4963

> mycointoss(100000)

[1] 50030

> mycointoss <- function(n) {

+ count<- 0

+ for(i in 1:n){

+ x<-coin()

+ if(x==1) count <- count+1

+ }

+ return(count)

+ }

> fit(saikoro)

エラー: 関数 "fit" を見つけることができませんでした

> saikoro

function(){

x<- runif(1)

if (x<= 1/6) men<- 1

else if(x <= 2/6) men<- 2

else if(x <= 3/6) men<- 3

else if(x <= 4/6) men<- 4

else if(x <= 5/6) men<- 5

else men<- 6

return(men)

}

> saikoro2<-function(n){

+ count<-0

+ for (i in 1:n){

+ x<- runif(1)

+ if (x<= 1/6) count<- count+1

+ else

+ }

エラー: 予想外の '}' です 以下の部分:

"else

}"

> return(count)

エラー: 戻るための関数がありません,トップレベルへジャンプします

> }

エラー: 予想外の '}' です ( "}" の)

> saikoro2<-function(n){

+ count<-0

+ for (i in 1:n){

+ x<- runif(1)

+ if (x <= 1/6) count<- count+1

+ else count<-count

+ }

+ return(count)

+ }

> saikoro2(10)

[1] 1

> saikoro2(100)

[1] 11

> saikoro2(1000)

[1] 156

> saikoro2(10000)

[1] 1598

> saikoro2(100000)

[1] 16642

> saikoro2(1000000)

[1] 166749

> saikoro2<-function(n){

+ count<-0

+ for (i in 1:n){

+ x<- runif(1)

+ if (x <= 1/6) count<- count+1

+ else

+ }

エラー: 予想外の '}' です 以下の部分:

"else

}"

> return(count)

エラー: 戻るための関数がありません,トップレベルへジャンプします

> }

エラー: 予想外の '}' です ( "}" の)

> saikoro2<-function(n){

+ count<-0

+ for (i in 1:n){

+ x<- runif(1)

+ if (x <= 1/6) count<- count+1

+ else count<-count

+ }

+ return(count)

+ }

> tenki

function(){

x<- runif(1)

if (x<= 7/10) men<- "hare"

else if(x <= 9/10) men<- "kumori"

else men<- "ame"

return(men)

}

> tenki2<-function(n){

+ count <- 0

+ for(i in 1:n){

+ x<- runif(1)

+ if (x<= 7/10) count<- count+1

+ else count<- count

+ }

+ return(count)

+ }

> tenki2(10)

[1] 9

> tenki2(100)

[1] 65

> tenki2(1000)

[1] 697

> tenki2(10000)

[1] 7073

> tenki2(100000)

[1] 70067

> tenki2(1000000)

[1] 700737

> tenki2(30)

[1] 20

> tenki2(30)

[1] 21

> tenki2(30)

[1] 18

> tenki2(30)

[1] 22

> tenki2(30)

[1] 24

> tenki2(30)

[1] 21

> tenki2(30)

[1] 20

> tenki2(30)

[1] 20

> tenki2(30)

[1] 23

> tenki2(30)

[1] 20

> tenki2(30)

[1] 18

> tenki2(30)

[1] 20

> saikoro

function(){

x<- runif(1)

if (x<= 1/6) men<- 1

else if(x <= 2/6) men<- 2

else if(x <= 3/6) men<- 3

else if(x <= 4/6) men<- 4

else if(x <= 5/6) men<- 5

else men<- 6

return(men)

}

> saikoro2

function(n){

count<-0

for (i in 1:n){

x<- runif(1)

if (x <= 1/6) count<- count+1

else count<-count

}

return(count)

}

> saikoro3<-function(){

+ function(n){

+ count<-c()

+ for (i in 1:n){

+ x<- runif(1)

+ if (x <= 1/6) count<- c(count,1)

+ else if(x <= 2/6) count<- c(count,2)

+ else if(x <= 3/6) count<- c(count,3)

+ else if(x <= 4/6) count<- c(count,4)

+ else if(x <= 5/6) count<- c(count,5)

+ else count<- c(count,6)

+ return(count)

+ }

+ saikoro3(10)



+ > saikoro3<-function(){

+ function(n){

+ count<-c()

+ for (i in 1:n){

+ x<- runif(1)

+ if (x <= 1/6) count<- c(count,1)

+ else if(x <= 2/6) count<- c(count,2)

+ else if(x <= 3/6) count<- c(count,3)

+ else if(x <= 4/6) count<- c(count,4)

+ else if(x <= 5/6) count<- c(count,5)

+ else count<- c(count,6)

+ }

+ return(count)

+ }

+ }

> saikoro3(10)

以下にエラー saikoro3(10) : 使われていない引数 (10)

> saikoro3<-function(n){

+ count<-c()

+ for (i in 1:n){

+ x<- runif(1)

+ if (x <= 1/6) count<- c(count,1)

+ else if(x <= 2/6) count<- c(count,2)

+ else if(x <= 3/6) count<- c(count,3)

+ else if(x <= 4/6) count<- c(count,4)

+ else if(x <= 5/6) count<- c(count,5)

+ else count<- c(count,6)

+ }

+ return(count)

+ }

> saikoro3(10)

[1] 6 3 3 5 3 6 6 1 6 1

> saikoro3(100)

[1] 6 2 2 6 2 3 4 6 1 3 4 4 5 2 1 1 5 6 4 1 1 2 2 5 3 4 6 6 5 4 6 5 3 4 6 2

[37] 3 3 1 5 2 1 1 3 4 4 1 5 5 6 5 6 1 1 6 5 4 3 6 6 1 2 2 2 3 5 1 5 1 3 6 4

[73] 5 4 1 4 6 1 5 3 4 1 4 3 4 6 2 1 4 4 3 5 1 6 1 6 4 4 5 4

> saikoro3(1000)

[1] 6 1 2 6 5 5 5 3 5 1 1 3 5 2 3 1 3 6 6 5 2 1 2 5 4 5 5 6 3 6 6 6 4 4 5

[36] 6 3 2 1 3 2 2 2 5 6 5 6 3 2 5 5 4 4 1 3 5 2 5 2 5 6 4 1 6 1 4 3 5 6 6

[71] 4 5 6 5 2 6 4 4 6 2 4 5 2 4 2 2 4 6 5 6 6 1 6 3 5 1 4 2 3 4 6 6 4 1 6

[106] 5 6 2 6 3 2 4 1 1 2 6 2 6 3 1 1 1 6 2 4 4 4 2 3 5 1 3 3 3 1 2 5 1 5 3

[141] 4 6 3 3 2 2 1 3 1 6 1 3 2 5 6 1 2 3 6 2 3 6 1 1 6 2 4 2 5 1 2 4 1 2 4

[176] 3 4 3 1 2 6 3 4 4 5 5 5 2 1 1 6 5 3 3 3 4 3 5 1 1 5 2 1 2 2 2 5 1 1 5

[211] 3 5 2 2 1 2 1 6 1 4 5 2 5 6 5 2 4 2 6 1 3 4 5 4 2 4 1 3 6 5 1 4 6 1 2

[246] 3 5 2 5 5 4 3 3 1 1 1 3 1 4 3 6 1 4 5 4 5 4 1 6 4 6 2 4 3 4 6 4 4 2 2

[281] 4 5 3 4 3 2 4 6 4 5 6 6 4 6 2 5 4 1 1 5 3 5 5 3 3 5 1 4 2 1 5 2 2 5 1

[316] 4 4 3 1 2 2 6 3 1 1 3 3 1 2 1 6 3 2 2 6 3 2 4 1 5 5 6 1 1 2 3 6 5 4 1

[351] 3 1 2 1 4 1 5 1 6 4 3 3 3 5 3 3 5 6 6 3 3 6 5 1 5 4 6 3 3 4 3 6 6 5 4

[386] 1 4 5 2 1 3 6 6 2 3 5 2 3 1 5 6 3 1 1 1 5 1 3 1 4 1 3 1 6 1 2 5 3 4 4

[421] 3 3 5 2 4 4 5 4 3 4 4 2 5 4 2 3 4 3 6 1 5 2 3 6 4 6 3 5 6 4 5 4 6 4 2

[456] 5 2 2 4 1 5 4 6 6 4 3 1 6 1 2 3 4 6 4 6 6 4 3 5 1 4 2 4 1 2 2 4 4 2 3

[491] 4 2 5 6 6 6 1 4 4 1 4 5 1 2 2 5 6 3 6 6 2 4 3 2 1 5 4 4 1 4 3 4 2 3 3

[526] 4 4 4 3 5 3 2 1 4 3 1 3 4 5 1 5 4 3 3 2 6 1 3 2 2 6 4 3 6 5 4 5 5 3 1

[561] 3 4 3 3 4 2 2 4 3 1 5 3 4 6 4 1 4 4 4 1 4 3 2 6 4 1 5 2 4 3 4 6 2 5 2

[596] 2 4 3 3 5 6 2 2 3 6 5 4 5 3 4 6 5 2 4 4 5 4 4 6 1 1 4 6 2 1 3 5 6 4 3

[631] 6 3 6 3 3 1 2 1 4 1 3 4 6 4 1 5 3 2 5 3 5 4 1 4 4 1 2 5 6 3 1 1 4 1 3

[666] 1 4 3 2 6 5 4 4 2 4 1 5 6 1 6 1 1 6 1 4 4 2 1 5 6 6 4 6 4 3 5 1 5 1 3

[701] 1 2 4 5 1 3 6 3 4 1 6 1 4 3 6 1 6 4 5 4 3 2 1 1 2 4 5 6 4 2 5 3 4 3 5

[736] 6 6 3 2 5 3 3 4 3 6 2 4 4 3 5 3 2 3 4 5 2 5 1 6 4 4 6 1 3 2 1 2 2 5 4

[771] 4 4 3 1 3 1 6 6 1 5 6 4 1 4 3 1 4 3 3 1 1 2 6 1 3 2 1 6 5 4 5 2 2 2 4

[806] 2 2 5 6 5 2 6 6 3 2 4 5 5 2 1 4 2 2 3 1 3 6 5 5 3 2 4 3 6 5 3 1 6 2 5

[841] 3 1 1 1 1 2 3 3 2 2 4 4 1 1 3 3 5 1 4 2 2 2 1 1 3 3 6 5 2 5 6 6 5 6 5

[876] 1 1 3 1 4 3 2 6 4 3 6 1 2 3 4 3 1 5 2 6 1 1 6 3 4 6 3 4 3 2 5 2 2 4 2

[911] 6 1 6 2 1 2 4 3 5 1 5 2 4 3 1 1 4 5 4 6 3 3 1 6 2 2 1 5 4 2 6 1 6 2 4

[946] 1 5 3 6 6 2 5 1 6 6 5 2 1 3 1 4 5 3 4 5 4 3 3 6 4 1 3 3 3 4 2 5 3 4 2

[981] 3 4 4 3 4 5 1 2 6 1 2 6 2 5 6 3 5 4 2 4

> hist(saikoro3(1000))

> table(saikoro3(1000))



1 2 3 4 5 6

152 171 154 175 175 173

> tenki2

function(n){

count <- 0

for(i in 1:n){

x<- runif(1)

if (x<= 7/10) count<- count+1

else count<- count

}

return(count)

}

> tenki3<-function(n){

+ count <- 0

+ for(i in 1:n){

+ x<- runif(1)

+ if (x<= 1/10) count<- count+1

+ else count<- count

+ }

+ if(count==0) return(1)

+ else return(0)

+ }

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 1

> tenki3(7)

[1] 0

> tenki3(7)

[1] 1

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 1

> tenki3(7)

[1] 1

> tenki3(7)

[1] 1

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> tenki3(7)

[1] 0

> weather.week<-function(){

+ count <- 0

+ for(i in 1:7){

+ x<- runif(1)

+ if (x<= 1/10) count<- count+1

+ else count<- count

+ }

+ if(count==0) return(1)

+ else return(0)

+ }

> wether.week()

エラー: 関数 "wether.week" を見つけることができませんでした

> weather.week()

[1] 1

> weather.week()

[1] 0

> weather.week()

[1] 0

> weather.week()

[1] 1

> weather.week()

[1] 0

> weather.week()

[1] 0

> weather.week()

[1] 0

> weather.week()

[1] 1

> weather.week()

[1] 0

> weather.montecarlo<-function(){

+ count <- 0

+ count2<-0

+ for(j in 1:52){

+

+

+ for(i in 1:7){

+ x<- runif(1)

+ if (x<= 1/10) count<- count+1

+ else count<- count

+ }

+

+

+ if(count==0) count2<-count2+1

+ else count2<-count2

+ }

+ return(count2)

+ }

> weather.montecarlo()

[1] 4

> weather.montecarlo()

[1] 4

> weather.montecarlo()

[1] 1

> weather.montecarlo()

[1] 1

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 3

> weather.montecarlo()

[1] 1

> weather.montecarlo()

[1] 1

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 3

> weather.montecarlo()

[1] 1

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 2

> weather.montecarlo()

[1] 0

> weather.montecarlo()

[1] 1

> weather.montecarlo()

[1] 5

> weather.montecarlo()

[1] 4

> weather.montecarlo()

[1] 0

> ls()

[1] "a" "A" "aaa"

[4] "b" "B" "coin"

[7] "count" "D" "DD"

[10] "ex1" "f" "ff"

[13] "g" "i" "myabs"

[16] "mycointoss" "mydouble" "myeven"

[19] "myloop" "myplus" "mypower02"

[22] "mypower2" "mysqrtlog" "r"

[25] "result" "saikoro" "saikoro2"

[28] "saikoro3" "skincoin" "sum"

[31] "tenki" "tenki2" "tenki3"

[34] "U" "V" "weather.montecarlo"

[37] "weather.week" "x" "xxx"

[40] "y" "y2" "z"

> coin

function(){

x<- runif(1)

if(x<= 1/2) men<- 1

else men<- 0

return(men)

}

> saikoro

function(){

x<- runif(1)

if (x<= 1/6) men<- 1

else if(x <= 2/6) men<- 2

else if(x <= 3/6) men<- 3

else if(x <= 4/6) men<- 4

else if(x <= 5/6) men<- 5

else men<- 6

return(men)

}

> saikoro2

function(n){

count<-0

for (i in 1:n){

x<- runif(1)

if (x <= 1/6) count<- count+1

else count<-count

}

return(count)

}

> saikoro3

function(n){

count<-c()

for (i in 1:n){

x<- runif(1)

if (x <= 1/6) count<- c(count,1)

else if(x <= 2/6) count<- c(count,2)

else if(x <= 3/6) count<- c(count,3)

else if(x <= 4/6) count<- c(count,4)

else if(x <= 5/6) count<- c(count,5)

else count<- c(count,6)

}

return(count)

}

>





2011年3月1日火曜日

Rの勉強1

最近は4月からの研究のためにRを勉強しなおしています。というより、勉強しています。正直恥ずかしくなるようなことですが、書いておきます。

今読んでいる本は、The R Tips―データ解析環境Rの基本技・グラフィックス活用集という本でありまして、この中に練習問題を解きつつ、分からなかったらその章をよく読むという形で進めております。

で、今日は数値計算と微積についてやりました。この辺はRではあまりやったことがなかったので。

> f<-function(x){exp(x)-2}
> f
function(x){exp(x)-2}
> f<-function(x) exp(x)-2
> f
function(x) exp(x)-2
> result<-uniroot(f,c(0,1))
> result
$root
[1] 0.6931457

$f.root
[1] -2.943424e-06

$iter
[1] 5

$estim.prec
[1] 6.103516e-05

> result$root
[1] 0.6931457
> polyroot(c(2,3,1))
[1] -1+0i -2-0i
> round
function (x, digits = 0) .Primitive("round")
> help(round)
starting httpd help server ... done
> polyroot(c(1,1,1))
[1] -0.5+0.8660254i -0.5-0.8660254i
> round(polyroot(c(1,1,1)),digits=3)
[1] -0.5+0.866i -0.5-0.866i
> round(polyroot(c(1,1,1)),digits=2)
[1] -0.5+0.87i -0.5-0.87i
> round(polyroot(c(1,1,1)),digits=1)
[1] -0.5+0.9i -0.5-0.9i
> round(polyroot(c(1,1,1)),digits=8)
[1] -0.5+0.8660254i -0.5-0.8660254i
> round(polyroot(c(1,1,1)),digits=9)
[1] -0.5+0.8660254i -0.5-0.8660254i
> f<- function(x) x^2-2*x
> f
function(x) x^2-2*x
> uniroot(f,c(1,3))
$root
[1] 2.000000

$f.root
[1] -5.356504e-07

$iter
[1] 6

$estim.prec
[1] 6.535148e-05

> polyroot(c(-2,5,-4,1))
[1] 1-0i 1+0i 2+0i
> f<- expression(a*x^4)
> f
expression(a * x^4)
> D(f,"x")
a * (4 * x^3)
> fix(DD)
>
> function (expr,name,order=1)
+ {
+ if(order<1){
+ stop("order' must be >= 1")}else if(order==1){
+ D(expr,name)}else{DD(D(expr,name),name,order -1)}
+
+ }
function (expr,name,order=1)
{
if(order<1){
stop("order' must be >= 1")}else if(order==1){
D(expr,name)}else{DD(D(expr,name),name,order -1)}

}
>
> DD(f,"x",3)
a * (4 * (3 * (2 * x)))
> deriv(~x^2,"x",func=T)
function (x)
{
.value <- x^2
.grad <- array(0, c(length(.value), 1L), list(NULL, c("x")))
.grad[, "x"] <- 2 * x
attr(.value, "gradient") <- .grad
.value
}
> f<-deriv(~x^2,"x",func=T)
> f
function (x)
{
.value <- x^2
.grad <- array(0, c(length(.value), 1L), list(NULL, c("x")))
.grad[, "x"] <- 2 * x
attr(.value, "gradient") <- .grad
.value
}
> f(-2)
[1] 4
attr(,"gradient")
x
[1,] -4
> g<- deriv(~x^2*y,c("x","y"),func=T)
> g(2,3)
[1] 12
attr(,"gradient")
x y
[1,] 12 4
> help(deriv)
> f<-deriv(~x^2,"x",func=F)
> f
expression({
.value <- x^2
.grad <- array(0, c(length(.value), 1L), list(NULL, c("x")))
.grad[, "x"] <- 2 * x
attr(.value, "gradient") <- .grad
.value
})
> f<-deriv(~x^2,"x",func=T)
> f
function (x)
{
.value <- x^2
.grad <- array(0, c(length(.value), 1L), list(NULL, c("x")))
.grad[, "x"] <- 2 * x
attr(.value, "gradient") <- .grad
.value
}
>

あと、これまでメモ帳を使って関数を作っていたのですが、fixという関数でRのエディタが立ち上がることが分かったので、これでやっていくべきなのかなぁと…。

本当にどうってことないことばかりですが、以上。