# CHAPTER 6
# 6.1.1 infinity
foo <- Inf
foo
## [1] Inf
bar <- c(3401,Inf,3.1,-555,Inf,43)
bar
## [1] 3401.0 Inf 3.1 -555.0 Inf 43.0
baz <- 90000^100
baz
## [1] Inf
qux <- c(-42,565,-Inf,-Inf,Inf,-45632.3)
qux
## [1] -42.0 565.0 -Inf -Inf Inf -45632.3
Inf*-9
## [1] -Inf
is.infinite(x=qux)
## [1] FALSE FALSE TRUE TRUE TRUE FALSE
is.finite(x=qux)
## [1] TRUE TRUE FALSE FALSE FALSE TRUE
qux==Inf
## [1] FALSE FALSE FALSE FALSE TRUE FALSE
# 6.1.2 NaN
foo <- NaN
foo
## [1] NaN
bar <- c(NaN,54.3,-2,NaN,90094.123,-Inf,55)
bar
## [1] NaN 54.30 -2.00 NaN 90094.12 -Inf 55.00
-Inf+Inf
## [1] NaN
2+6*(4-4)/0
## [1] NaN
3.5^(-Inf/Inf)
## [1] NaN
bar
## [1] NaN 54.30 -2.00 NaN 90094.12 -Inf 55.00
is.nan(bar)
## [1] TRUE FALSE FALSE TRUE FALSE FALSE FALSE
!is.nan(bar)
## [1] FALSE TRUE TRUE FALSE TRUE TRUE TRUE
is.nan(x=bar)|is.infinite(x=bar)
## [1] TRUE FALSE FALSE TRUE FALSE TRUE FALSE
bar[-(which(is.nan(x=bar)|is.infinite(x=bar)))]
## [1] 54.30 -2.00 90094.12 55.00
# exercise 6.1
foo <- c(13563,-14156,-14319,16981,12921,11979,9568,8833,-12968,
8133)
foo[ !is.infinite(foo^75) ]
## [1] 11979 9568 8833 8133
foo[ !(foo^75 == -Inf) ]
## [1] 13563 16981 12921 11979 9568 8833 8133
bar <- matrix(
c(77875.40,
27551.45, 23764.30, -36478.88,
-35466.25, -73333.85, 36599.69, -70585.69,
-39803.81, 55976.34, 76694.82, 47032.00),
nrow = 3,
ncol = 4,
byrow = TRUE
)
bar
## [,1] [,2] [,3] [,4]
## [1,] 77875.40 27551.45 23764.30 -36478.88
## [2,] -35466.25 -73333.85 36599.69 -70585.69
## [3,] -39803.81 55976.34 76694.82 47032.00
which(is.nan(bar^65 / Inf), arr.ind = TRUE)
## row col
## [1,] 1 1
## [2,] 2 2
## [3,] 3 2
## [4,] 3 3
## [5,] 2 4
bar[ !is.nan(bar^67 + Inf) ]
## [1] 77875.40 -35466.25 -39803.81 27551.45 55976.34 23764.30 36599.69
## [8] 76694.82 -36478.88 47032.00
bar[ bar^67 != -Inf ]
## [1] 77875.40 -35466.25 -39803.81 27551.45 55976.34 23764.30 36599.69
## [8] 76694.82 -36478.88 47032.00
bar[ (bar^67 == -Inf) | is.finite(bar^67) ]
## [1] -35466.25 -39803.81 27551.45 -73333.85 23764.30 36599.69 -36478.88
## [8] -70585.69
# 6.1.3
foo <- c("character","a",NA,"with","string",NA)
foo
## [1] "character" "a" NA "with" "string" NA
bar <- factor(c("blue",NA,NA,"blue","green","blue",NA,"red","red",NA,
"green"))
bar
## [1] blue <NA> <NA> blue green blue <NA> red red <NA> green
## Levels: blue green red
baz <- matrix(c(1:3,NA,5,6,NA,8,NA),nrow=3,ncol=3)
baz
## [,1] [,2] [,3]
## [1,] 1 NA NA
## [2,] 2 5 8
## [3,] 3 6 NA
qux <- c(NA,5.89,Inf,NA,9.43,-2.35,NaN,2.10,-8.53,-7.58,NA,-4.58,2.01,NaN)
qux
## [1] NA 5.89 Inf NA 9.43 -2.35 NaN 2.10 -8.53 -7.58 NA -4.58
## [13] 2.01 NaN
is.na(qux)
## [1] TRUE FALSE FALSE TRUE FALSE FALSE TRUE FALSE FALSE FALSE TRUE FALSE
## [13] FALSE TRUE
which(x=is.nan(x=qux))
## [1] 7 14
which(x=(is.na(x=qux)&!is.nan(x=qux)))
## [1] 1 4 11
quux <- na.omit(object=qux)
quux
## [1] 5.89 Inf 9.43 -2.35 2.10 -8.53 -7.58 -4.58 2.01
## attr(,"na.action")
## [1] 1 4 7 11 14
## attr(,"class")
## [1] "omit"
3+2.1*NA-4
## [1] NA
# NULL
foo <- NULL
foo
## NULL
bar <- NA
bar
## [1] NA
c(2,4,NA,8)
## [1] 2 4 NA 8
c(2,4,NULL,8)
## [1] 2 4 8
c(NA,NA,NA)
## [1] NA NA NA
c(NULL,NULL,NULL)
## NULL
opt.arg <- c("string1","string2","string3")
is.na(x=opt.arg)
## [1] FALSE FALSE FALSE
is.null(x=opt.arg)
## [1] FALSE
opt.arg <- c(NA,NA,NA)
is.na(opt.arg)
## [1] TRUE TRUE TRUE
opt.arg <- c(NULL,NULL,NULL)
NaN-NULL+NA/Inf
## numeric(0)
foo <- list(member1=c(33,1,5.2,7),member2="NA or NULL?")
foo
## $member1
## [1] 33.0 1.0 5.2 7.0
##
## $member2
## [1] "NA or NULL?"
foo$member1
## [1] 33.0 1.0 5.2 7.0
foo$member2
## [1] "NA or NULL?"
#exercise 6.2
foo <- c(4.3,2.2,NULL,2.4,NaN,3.3,3.1,NULL,3.4,NA)
length(foo)
## [1] 8
which(is.na(foo))
## [1] 4 8
is.null(foo)
## [1] FALSE
is.na(foo[8]) + 4/NULL
## numeric(0)
mylist <- list(c(7, 7, NA, 3, NA, 1, 1, 5, NA))
names(mylist) <- "alpha"
is.null(mylist$beta)
## [1] TRUE
mylist$beta <- which(is.na(mylist$alpha))
# 6.2 understanding types,classes,and coercion
#6.2.1 attributes
foo <- matrix(data=1:9,nrow=3,ncol=3)
foo
## [,1] [,2] [,3]
## [1,] 1 4 7
## [2,] 2 5 8
## [3,] 3 6 9
attributes(foo)
## $dim
## [1] 3 3
attr(x=foo,which="dim")
## [1] 3 3
bar <- matrix(data=1:9,nrow=3,ncol=3,dimnames=list(c("A","B","C"),
c("D","E","F")))
bar
## D E F
## A 1 4 7
## B 2 5 8
## C 3 6 9
attributes(bar)
## $dim
## [1] 3 3
##
## $dimnames
## $dimnames[[1]]
## [1] "A" "B" "C"
##
## $dimnames[[2]]
## [1] "D" "E" "F"
dimnames(foo) <- list(c("A","B","C"),c("D","E","F"))
foo
## D E F
## A 1 4 7
## B 2 5 8
## C 3 6 9
#6.2.2 object class
num.vec1 <- 1:4
num.vec2 <- seq(from=1,to=4,length=6)
char.vec <- c("a","few","strings","here")
logic.vec <- c(TRUE,FALSE,FALSE,FALSE,TRUE,FALSE,TRUE,TRUE)
fac.vec <- factor(c("Blue","Blue","Green","Red","Green","Yellow"))
class(num.vec1)
## [1] "integer"
class(num.vec2)
## [1] "numeric"
class(char.vec)
## [1] "character"
class(logic.vec)
## [1] "logical"
class(fac.vec)
## [1] "factor"
num.mat1 <- matrix(data=num.vec1,nrow=2,ncol=2)
ordfac.vec <- factor(x=c("Small","Large","Large","Regular","Small"),
levels=c("Small","Regular","Large"),
ordered=TRUE)
ordfac.vec
## [1] Small Large Large Regular Small
## Levels: Small < Regular < Large
class(ordfac.vec)
## [1] "ordered" "factor"
# 6.2.3 Is-Dot Object-Checking Function
num.vec1 <- 1:4
num.vec1
## [1] 1 2 3 4
is.integer(num.vec1)
## [1] TRUE
is.numeric(num.vec1)
## [1] TRUE
is.matrix(num.vec1)
## [1] FALSE
is.data.frame(num.vec1)
## [1] FALSE
is.vector(num.vec1)
## [1] TRUE
is.logical(num.vec1)
## [1] FALSE
#6.2.4 As-Dot Coercion Functions
1:4+c(T,F,F,T)
## [1] 2 2 3 5
foo <- 34
bar <- T
paste("Definitely foo: ",foo,"; definitely bar: ",bar,".",sep="")
## [1] "Definitely foo: 34; definitely bar: TRUE."
as.numeric(c(T,F,F,T))
## [1] 1 0 0 1
1:4+as.numeric(c(T,F,F,T))
## [1] 2 2 3 5
foo <- 34
foo.ch <- as.character(foo)
foo.ch
## [1] "34"
bar <- T
bar.ch <- as.character(bar)
bar.ch
## [1] "TRUE"
paste("Definitely foo: ",foo.ch,"; definitely bar: ",bar.ch,".",sep="")
## [1] "Definitely foo: 34; definitely bar: TRUE."
as.numeric("32.4")
## [1] 32.4
as.numeric("g'day mate")
## Warning: NAs introduced by coercion
## [1] NA
as.logical(c("1","0","1","0","0"))
## [1] NA NA NA NA NA
as.logical(as.numeric(c("1","0","1","0","0")))
## [1] TRUE FALSE TRUE FALSE FALSE
baz <- factor(x=c("male","male","female","male"))
baz
## [1] male male female male
## Levels: female male
as.numeric(baz)
## [1] 2 2 1 2
qux <- factor(x=c(2,2,3,5))
qux
## [1] 2 2 3 5
## Levels: 2 3 5
foo <- matrix(data=1:4,nrow=2,ncol=2)
foo
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
as.vector(foo)
## [1] 1 2 3 4
bar <- array(data=c(8,1,9,5,5,1,3,4,3,9,8,8),dim=c(2,3,2))
bar
## , , 1
##
## [,1] [,2] [,3]
## [1,] 8 9 5
## [2,] 1 5 1
##
## , , 2
##
## [,1] [,2] [,3]
## [1,] 3 3 8
## [2,] 4 9 8
as.matrix(bar)
## [,1]
## [1,] 8
## [2,] 1
## [3,] 9
## [4,] 5
## [5,] 5
## [6,] 1
## [7,] 3
## [8,] 4
## [9,] 3
## [10,] 9
## [11,] 8
## [12,] 8
as.vector(bar)
## [1] 8 1 9 5 5 1 3 4 3 9 8 8
baz<-list(var1=foo,var2=c(T,F,T),var3=factor(x=c(2,3,4,4,2)))
baz
## $var1
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## $var2
## [1] TRUE FALSE TRUE
##
## $var3
## [1] 2 3 4 4 2
## Levels: 2 3 4
qux<-list(var1=c(3,4,5,1),var2=c(TRUE,FALSE,TRUE,TRUE),var3=factor(x=c(4,4,2,1)))
qux
## $var1
## [1] 3 4 5 1
##
## $var2
## [1] TRUE FALSE TRUE TRUE
##
## $var3
## [1] 4 4 2 1
## Levels: 1 2 4
as.data.frame(qux)
## var1 var2 var3
## 1 3 TRUE 4
## 2 4 FALSE 4
## 3 5 TRUE 2
## 4 1 TRUE 1
# exercise 6.3
#(a)
foo <- array(data=1:36,dim=c(3,3,4))
class(foo)
## [1] "array"
bar <- as.vector(foo)
class(bar)
## [1] "integer"
baz <- as.character(bar)
class(baz)
## [1] "character"
qux <- as.factor(baz)
class(qux)
## [1] "factor"
quux <- bar+c(-0.1,0.1)
class(quux)
## [1] "numeric"
#(b)
sumfoo <- is.numeric(foo) + is.integer(foo)
sumbar <- is.numeric(bar) + is.integer(bar)
sumbaz <- is.numeric(baz) + is.integer(baz)
sumqux <- is.numeric(qux) + is.integer(qux)
sumquux <- is.numeric(quux) + is.integer(quux)
resultvector <- c(sumfoo,sumbar,sumbaz,sumqux,sumquux)
facresult <- factor(resultvector,levels=c(0,1,2))
numcoerced <- as.numeric(facresult)
numcoerced
## [1] 3 3 1 1 2
#(c)
matc <- matrix(c(2,3,4,5,6,7,8,9,10,11,12,13),nrow=3,ncol=4)
matc
## [,1] [,2] [,3] [,4]
## [1,] 2 5 8 11
## [2,] 3 6 9 12
## [3,] 4 7 10 13
finalvector <- as.character(t(matc))
finalvector
## [1] "2" "5" "8" "11" "3" "6" "9" "12" "4" "7" "10" "13"
#(d)
matd <- matrix(c(34,23,33,42,41,0,1,1,0,0,1,2,1,1,2),nrow=5,ncol=3)
matd
## [,1] [,2] [,3]
## [1,] 34 0 1
## [2,] 23 1 2
## [3,] 33 1 1
## [4,] 42 0 1
## [5,] 41 0 2
df <- as.data.frame(matd)
df[,2] <- as.logical(df[,2])
df[,3] <- as.factor(df[,3])
df
## V1 V2 V3
## 1 34 FALSE 1
## 2 23 TRUE 2
## 3 33 TRUE 1
## 4 42 FALSE 1
## 5 41 FALSE 2
df[,2]
## [1] FALSE TRUE TRUE FALSE FALSE
df[,3]
## [1] 1 2 1 1 2
## Levels: 1 2
# chapter7 basic plotting
# 7.1 Using plot with Coordinate Vectors
foo <- c(1.1,2,3.5,3.9,4.2)
bar <- c(2,2.2,-1.3,0,0.2)
plot(foo,bar)
baz <- cbind(foo,bar)
baz
## foo bar
## [1,] 1.1 2.0
## [2,] 2.0 2.2
## [3,] 3.5 -1.3
## [4,] 3.9 0.0
## [5,] 4.2 0.2
#7.2.1 Automatic Plot Types
plot(foo,bar,type="l")
#7.2.2 Title and Axis Labels
plot(foo,bar,type="b",main="My lovely plot",xlab="x axis label",
ylab="location y")
plot(foo,bar,type="b",main="My lovely plot\ntitle on two lines",xlab="",
ylab="")
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",col=2)
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",col="seagreen4")
#7.2.4 Line and Point Appearances
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",
col=4,pch=8,lty=2,cex=2.3,lwd=3.3)
colors()
## [1] "white" "aliceblue" "antiquewhite"
## [4] "antiquewhite1" "antiquewhite2" "antiquewhite3"
## [7] "antiquewhite4" "aquamarine" "aquamarine1"
## [10] "aquamarine2" "aquamarine3" "aquamarine4"
## [13] "azure" "azure1" "azure2"
## [16] "azure3" "azure4" "beige"
## [19] "bisque" "bisque1" "bisque2"
## [22] "bisque3" "bisque4" "black"
## [25] "blanchedalmond" "blue" "blue1"
## [28] "blue2" "blue3" "blue4"
## [31] "blueviolet" "brown" "brown1"
## [34] "brown2" "brown3" "brown4"
## [37] "burlywood" "burlywood1" "burlywood2"
## [40] "burlywood3" "burlywood4" "cadetblue"
## [43] "cadetblue1" "cadetblue2" "cadetblue3"
## [46] "cadetblue4" "chartreuse" "chartreuse1"
## [49] "chartreuse2" "chartreuse3" "chartreuse4"
## [52] "chocolate" "chocolate1" "chocolate2"
## [55] "chocolate3" "chocolate4" "coral"
## [58] "coral1" "coral2" "coral3"
## [61] "coral4" "cornflowerblue" "cornsilk"
## [64] "cornsilk1" "cornsilk2" "cornsilk3"
## [67] "cornsilk4" "cyan" "cyan1"
## [70] "cyan2" "cyan3" "cyan4"
## [73] "darkblue" "darkcyan" "darkgoldenrod"
## [76] "darkgoldenrod1" "darkgoldenrod2" "darkgoldenrod3"
## [79] "darkgoldenrod4" "darkgray" "darkgreen"
## [82] "darkgrey" "darkkhaki" "darkmagenta"
## [85] "darkolivegreen" "darkolivegreen1" "darkolivegreen2"
## [88] "darkolivegreen3" "darkolivegreen4" "darkorange"
## [91] "darkorange1" "darkorange2" "darkorange3"
## [94] "darkorange4" "darkorchid" "darkorchid1"
## [97] "darkorchid2" "darkorchid3" "darkorchid4"
## [100] "darkred" "darksalmon" "darkseagreen"
## [103] "darkseagreen1" "darkseagreen2" "darkseagreen3"
## [106] "darkseagreen4" "darkslateblue" "darkslategray"
## [109] "darkslategray1" "darkslategray2" "darkslategray3"
## [112] "darkslategray4" "darkslategrey" "darkturquoise"
## [115] "darkviolet" "deeppink" "deeppink1"
## [118] "deeppink2" "deeppink3" "deeppink4"
## [121] "deepskyblue" "deepskyblue1" "deepskyblue2"
## [124] "deepskyblue3" "deepskyblue4" "dimgray"
## [127] "dimgrey" "dodgerblue" "dodgerblue1"
## [130] "dodgerblue2" "dodgerblue3" "dodgerblue4"
## [133] "firebrick" "firebrick1" "firebrick2"
## [136] "firebrick3" "firebrick4" "floralwhite"
## [139] "forestgreen" "gainsboro" "ghostwhite"
## [142] "gold" "gold1" "gold2"
## [145] "gold3" "gold4" "goldenrod"
## [148] "goldenrod1" "goldenrod2" "goldenrod3"
## [151] "goldenrod4" "gray" "gray0"
## [154] "gray1" "gray2" "gray3"
## [157] "gray4" "gray5" "gray6"
## [160] "gray7" "gray8" "gray9"
## [163] "gray10" "gray11" "gray12"
## [166] "gray13" "gray14" "gray15"
## [169] "gray16" "gray17" "gray18"
## [172] "gray19" "gray20" "gray21"
## [175] "gray22" "gray23" "gray24"
## [178] "gray25" "gray26" "gray27"
## [181] "gray28" "gray29" "gray30"
## [184] "gray31" "gray32" "gray33"
## [187] "gray34" "gray35" "gray36"
## [190] "gray37" "gray38" "gray39"
## [193] "gray40" "gray41" "gray42"
## [196] "gray43" "gray44" "gray45"
## [199] "gray46" "gray47" "gray48"
## [202] "gray49" "gray50" "gray51"
## [205] "gray52" "gray53" "gray54"
## [208] "gray55" "gray56" "gray57"
## [211] "gray58" "gray59" "gray60"
## [214] "gray61" "gray62" "gray63"
## [217] "gray64" "gray65" "gray66"
## [220] "gray67" "gray68" "gray69"
## [223] "gray70" "gray71" "gray72"
## [226] "gray73" "gray74" "gray75"
## [229] "gray76" "gray77" "gray78"
## [232] "gray79" "gray80" "gray81"
## [235] "gray82" "gray83" "gray84"
## [238] "gray85" "gray86" "gray87"
## [241] "gray88" "gray89" "gray90"
## [244] "gray91" "gray92" "gray93"
## [247] "gray94" "gray95" "gray96"
## [250] "gray97" "gray98" "gray99"
## [253] "gray100" "green" "green1"
## [256] "green2" "green3" "green4"
## [259] "greenyellow" "grey" "grey0"
## [262] "grey1" "grey2" "grey3"
## [265] "grey4" "grey5" "grey6"
## [268] "grey7" "grey8" "grey9"
## [271] "grey10" "grey11" "grey12"
## [274] "grey13" "grey14" "grey15"
## [277] "grey16" "grey17" "grey18"
## [280] "grey19" "grey20" "grey21"
## [283] "grey22" "grey23" "grey24"
## [286] "grey25" "grey26" "grey27"
## [289] "grey28" "grey29" "grey30"
## [292] "grey31" "grey32" "grey33"
## [295] "grey34" "grey35" "grey36"
## [298] "grey37" "grey38" "grey39"
## [301] "grey40" "grey41" "grey42"
## [304] "grey43" "grey44" "grey45"
## [307] "grey46" "grey47" "grey48"
## [310] "grey49" "grey50" "grey51"
## [313] "grey52" "grey53" "grey54"
## [316] "grey55" "grey56" "grey57"
## [319] "grey58" "grey59" "grey60"
## [322] "grey61" "grey62" "grey63"
## [325] "grey64" "grey65" "grey66"
## [328] "grey67" "grey68" "grey69"
## [331] "grey70" "grey71" "grey72"
## [334] "grey73" "grey74" "grey75"
## [337] "grey76" "grey77" "grey78"
## [340] "grey79" "grey80" "grey81"
## [343] "grey82" "grey83" "grey84"
## [346] "grey85" "grey86" "grey87"
## [349] "grey88" "grey89" "grey90"
## [352] "grey91" "grey92" "grey93"
## [355] "grey94" "grey95" "grey96"
## [358] "grey97" "grey98" "grey99"
## [361] "grey100" "honeydew" "honeydew1"
## [364] "honeydew2" "honeydew3" "honeydew4"
## [367] "hotpink" "hotpink1" "hotpink2"
## [370] "hotpink3" "hotpink4" "indianred"
## [373] "indianred1" "indianred2" "indianred3"
## [376] "indianred4" "ivory" "ivory1"
## [379] "ivory2" "ivory3" "ivory4"
## [382] "khaki" "khaki1" "khaki2"
## [385] "khaki3" "khaki4" "lavender"
## [388] "lavenderblush" "lavenderblush1" "lavenderblush2"
## [391] "lavenderblush3" "lavenderblush4" "lawngreen"
## [394] "lemonchiffon" "lemonchiffon1" "lemonchiffon2"
## [397] "lemonchiffon3" "lemonchiffon4" "lightblue"
## [400] "lightblue1" "lightblue2" "lightblue3"
## [403] "lightblue4" "lightcoral" "lightcyan"
## [406] "lightcyan1" "lightcyan2" "lightcyan3"
## [409] "lightcyan4" "lightgoldenrod" "lightgoldenrod1"
## [412] "lightgoldenrod2" "lightgoldenrod3" "lightgoldenrod4"
## [415] "lightgoldenrodyellow" "lightgray" "lightgreen"
## [418] "lightgrey" "lightpink" "lightpink1"
## [421] "lightpink2" "lightpink3" "lightpink4"
## [424] "lightsalmon" "lightsalmon1" "lightsalmon2"
## [427] "lightsalmon3" "lightsalmon4" "lightseagreen"
## [430] "lightskyblue" "lightskyblue1" "lightskyblue2"
## [433] "lightskyblue3" "lightskyblue4" "lightslateblue"
## [436] "lightslategray" "lightslategrey" "lightsteelblue"
## [439] "lightsteelblue1" "lightsteelblue2" "lightsteelblue3"
## [442] "lightsteelblue4" "lightyellow" "lightyellow1"
## [445] "lightyellow2" "lightyellow3" "lightyellow4"
## [448] "limegreen" "linen" "magenta"
## [451] "magenta1" "magenta2" "magenta3"
## [454] "magenta4" "maroon" "maroon1"
## [457] "maroon2" "maroon3" "maroon4"
## [460] "mediumaquamarine" "mediumblue" "mediumorchid"
## [463] "mediumorchid1" "mediumorchid2" "mediumorchid3"
## [466] "mediumorchid4" "mediumpurple" "mediumpurple1"
## [469] "mediumpurple2" "mediumpurple3" "mediumpurple4"
## [472] "mediumseagreen" "mediumslateblue" "mediumspringgreen"
## [475] "mediumturquoise" "mediumvioletred" "midnightblue"
## [478] "mintcream" "mistyrose" "mistyrose1"
## [481] "mistyrose2" "mistyrose3" "mistyrose4"
## [484] "moccasin" "navajowhite" "navajowhite1"
## [487] "navajowhite2" "navajowhite3" "navajowhite4"
## [490] "navy" "navyblue" "oldlace"
## [493] "olivedrab" "olivedrab1" "olivedrab2"
## [496] "olivedrab3" "olivedrab4" "orange"
## [499] "orange1" "orange2" "orange3"
## [502] "orange4" "orangered" "orangered1"
## [505] "orangered2" "orangered3" "orangered4"
## [508] "orchid" "orchid1" "orchid2"
## [511] "orchid3" "orchid4" "palegoldenrod"
## [514] "palegreen" "palegreen1" "palegreen2"
## [517] "palegreen3" "palegreen4" "paleturquoise"
## [520] "paleturquoise1" "paleturquoise2" "paleturquoise3"
## [523] "paleturquoise4" "palevioletred" "palevioletred1"
## [526] "palevioletred2" "palevioletred3" "palevioletred4"
## [529] "papayawhip" "peachpuff" "peachpuff1"
## [532] "peachpuff2" "peachpuff3" "peachpuff4"
## [535] "peru" "pink" "pink1"
## [538] "pink2" "pink3" "pink4"
## [541] "plum" "plum1" "plum2"
## [544] "plum3" "plum4" "powderblue"
## [547] "purple" "purple1" "purple2"
## [550] "purple3" "purple4" "red"
## [553] "red1" "red2" "red3"
## [556] "red4" "rosybrown" "rosybrown1"
## [559] "rosybrown2" "rosybrown3" "rosybrown4"
## [562] "royalblue" "royalblue1" "royalblue2"
## [565] "royalblue3" "royalblue4" "saddlebrown"
## [568] "salmon" "salmon1" "salmon2"
## [571] "salmon3" "salmon4" "sandybrown"
## [574] "seagreen" "seagreen1" "seagreen2"
## [577] "seagreen3" "seagreen4" "seashell"
## [580] "seashell1" "seashell2" "seashell3"
## [583] "seashell4" "sienna" "sienna1"
## [586] "sienna2" "sienna3" "sienna4"
## [589] "skyblue" "skyblue1" "skyblue2"
## [592] "skyblue3" "skyblue4" "slateblue"
## [595] "slateblue1" "slateblue2" "slateblue3"
## [598] "slateblue4" "slategray" "slategray1"
## [601] "slategray2" "slategray3" "slategray4"
## [604] "slategrey" "snow" "snow1"
## [607] "snow2" "snow3" "snow4"
## [610] "springgreen" "springgreen1" "springgreen2"
## [613] "springgreen3" "springgreen4" "steelblue"
## [616] "steelblue1" "steelblue2" "steelblue3"
## [619] "steelblue4" "tan" "tan1"
## [622] "tan2" "tan3" "tan4"
## [625] "thistle" "thistle1" "thistle2"
## [628] "thistle3" "thistle4" "tomato"
## [631] "tomato1" "tomato2" "tomato3"
## [634] "tomato4" "turquoise" "turquoise1"
## [637] "turquoise2" "turquoise3" "turquoise4"
## [640] "violet" "violetred" "violetred1"
## [643] "violetred2" "violetred3" "violetred4"
## [646] "wheat" "wheat1" "wheat2"
## [649] "wheat3" "wheat4" "whitesmoke"
## [652] "yellow" "yellow1" "yellow2"
## [655] "yellow3" "yellow4" "yellowgreen"
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",
col=6,pch=15,lty=3,cex=0.7,lwd=2)
#7.2.5 Plotting Region Limits
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",
col=4,pch=8,lty=2,cex=2.3,lwd=3.3,xlim=c(-10,5),ylim=c(-3,3))
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",
col=6,pch=15,lty=3,cex=0.7,lwd=2,xlim=c(3,5),ylim=c(-0.5,0.2))
# basic plotting
#7.1 Using plot with Coordinate Vectors
foo <- c(1.1,2,3.5,3.9,4.2)
bar <- c(2,2.2,-1.3,0,0.2)
plot(foo,bar)
baz <- cbind(foo,bar)
baz
## foo bar
## [1,] 1.1 2.0
## [2,] 2.0 2.2
## [3,] 3.5 -1.3
## [4,] 3.9 0.0
## [5,] 4.2 0.2
#7.2.1 Automatic Plot Types
plot(foo,bar,type="l")
#7.2.2 Title and Axis Labels
plot(foo,bar,type="b",main="My lovely plot\ntitle on two lines",xlab="",
ylab="")
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",col=2)
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",col="seagreen4")
#Line and Point Appearances 7.2.4
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",
col=4,pch=8,lty=2,cex=2.3,lwd=3.3)
plot(foo,bar,type="b",main="My lovely plot",xlab="",ylab="",
col=6,pch=15,lty=3,cex=0.7,lwd=2)
x <- 1:20
y <- c(-1.49,3.37,2.59,-2.78,-3.94,-0.92,6.43,8.51,3.41,-8.23,-12.01,-6.58,2.87,14.12,9.63,-4.58,-14.78,-11.67,1.17,15.62)
library(ggplot2)
plot(x,y,type="n",main="")
abline(h=c(-5,5),col="red",lty=2,lwd=2)
segments(x0=c(5,15),y0=c(-5,-5),x1=c(5,15),y1=c(5,5),col="red",lty=3,
lwd=2)
points(x[y>=5],y[y>=5],pch=4,col="darkmagenta",cex=2)
points(x[y<=-5],y[y<=-5],pch=3,col="darkgreen",cex=2)
points(x[(x>=5&x<=15)&(y>-5&y<5)],y[(x>=5&x<=15)&(y>-5&y<5)],pch=19,
col="blue")
points(x[(x<5|x>15)&(y>-5&y<5)],y[(x<5|x>15)&(y>-5&y<5)])
lines(x,y,lty=4)
arrows(x0=8,y0=14,x1=11,y1=2.5)
text(x=8,y=15,labels="sweet spot")
legend("bottomleft",
legend=c("overall process","sweet","standard",
"too big","too small","sweet y range","sweet x range"),
pch=c(NA,19,1,4,3,NA,NA),lty=c(4,NA,NA,NA,NA,2,3),
col=c("black","blue","black","darkmagenta","darkgreen","red","red"),
lwd=c(1,NA,NA,NA,NA,2,2),pt.cex=c(NA,1,1,2,2,NA,NA))
anything <- qplot(x,y,color=ptype,shape=ptype) + geom_point(size=4) +
geom_line(mapping=aes(group=1),color="black",lty=2) +
geom_hline(mapping=aes(yintercept=c(-5,5)),color="red") +
geom_segment(mapping=aes(x=5,y=-5,xend=5,yend=5),color="red",lty=3) +
geom_segment(mapping=aes(x=15,y=-5,xend=15,yend=5),color="red",lty=3)
## Warning: `qplot()` was deprecated in ggplot2 3.4.0.
## This warning is displayed once per session.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.
#exercise 7.1
# create an empty plotting area
plot(xlim<- c(-3,3),ylim <- c(7,13),xlab="",ylab="",axes=FALSE)
# add axes
axis(1,at=-3:3)
axis(2,at=7:16,las=2)
#outer solid rectangle
rect(xleft=-3,ybottom=7,xright=3,ytop=16,ity=1)
## Warning in rect(xleft = -3, ybottom = 7, xright = 3, ytop = 16, ity = 1): "ity"
## is not a graphical parameter
# inner dashed rectangle
rect(xleft=-2.8,ybottom=7.3,xright=2.8,ytop=15.7,ity=2)
## Warning in rect(xleft = -2.8, ybottom = 7.3, xright = 2.8, ytop = 15.7, : "ity"
## is not a graphical parameter
# central text
text(x=0,y=11.3,labels="SOMETHING\nPROFOUND",font=2,cex=0.75)
#left-horizontal arrow
arrows(x0=-2.2,y0=11.3,x1=-0.8,y1=11.3,length=0.12)
#right horizontal arrow
arrows(x0=2.2,y0=11.3,x1=0.8,y1=11.3,length=0.12)
#upper-left diagonal arrow
arrows(x0=-2.1,y0=15.1,x1=-0.8,y1=12,length=0.12)
# upper-right diagonal arrow
arrows(x0=2.2,y0=7.8,x1=0.8,y1=10.6,length=0.12)
# add an outer box
box()
x <- 1:20
y <- c(-1.49,3.37,2.59,-2.78,-3.94,-0.92,6.43,8.51,3.41,-8.23,-12.01,-6.58,2.87,14.12,9.63,-4.58,-14.78,-11.67,1.17,15.62)
plot(x,y,type="n",main="")
abline(h=c(-5,5),col="red",lty=2,lwd=2)
segments(x0=c(5,15),y0=c(-5,-5),x1=c(5,15),y1=c(5,5),col="red",lty=3,
lwd=2)
points(x[y>=5],y[y>=5],pch=4,col="darkmagenta",cex=2)
points(x[y<=-5],y[y<=-5],pch=3,col="darkgreen",cex=2)
points(x[(x>=5&x<=15)&(y>-5&y<5)],y[(x>=5&x<=15)&(y>-5&y<5)],pch=19,
col="blue")
points(x[(x<5|x>15)&(y>-5&y<5)],y[(x<5|x>15)&(y>-5&y<5)])
lines(x,y,lty=4)
arrows(x0=8,y0=14,x1=11,y1=2.5)
text(x=8,y=15,labels="sweet spot")
legend("bottomleft",
legend=c("overall process","sweet","standard",
"too big","too small","sweet y range","sweet x range"),
pch=c(NA,19,1,4,3,NA,NA),lty=c(4,NA,NA,NA,NA,2,3),
col=c("black","blue","black","darkmagenta","darkgreen","red","red"),
lwd=c(1,NA,NA,NA,NA,2,2),pt.cex=c(NA,1,1,2,2,NA,NA))
# exercise 7.1 redo
#(a)
# Create an empty plotting area
plot(
NA,
xlim = c(-3, 3),
ylim = c(7, 16),
xlab = "",
ylab = "",
axes = FALSE
)
# Add axes
axis(1, at = -3:3)
axis(2, at = 7:16, las = 2)
# Outer solid rectangle
rect(
xleft = -3,
ybottom = 7,
xright = 3,
ytop = 16,
lty = 1
)
# Inner dashed rectangle
rect(
xleft = -2.8,
ybottom = 7.3,
xright = 2.8,
ytop = 15.7,
lty = 2
)
# Central text
text(
x = 0,
y = 11.3,
labels = "SOMETHING\nPROFOUND",
font = 2,
cex = 0.75
)
# Left horizontal arrow
arrows(
x0 = -2.2, y0 = 11.3,
x1 = -0.8, y1 = 11.3,
length = 0.12
)
# Right horizontal arrow
arrows(
x0 = 2.2, y0 = 11.3,
x1 = 0.8, y1 = 11.3,
length = 0.12
)
# Upper-left diagonal arrow
arrows(
x0 = -2.1, y0 = 15.1,
x1 = -0.8, y1 = 12,
length = 0.12
)
# Upper-right diagonal arrow
arrows(
x0 = 2.1, y0 = 15.1,
x1 = 0.8, y1 = 12,
length = 0.12
)
# Lower-left diagonal arrow
arrows(
x0 = -2.2, y0 = 7.8,
x1 = -0.8, y1 = 10.6,
length = 0.12
)
# Lower-right diagonal arrow
arrows(
x0 = 2.2, y0 = 7.8,
x1 = 0.8, y1 = 10.6,
length = 0.12
)
# Add an outer plotting box
box()
#(b)
people <- data.frame(
weight = c(55, 85, 75, 42, 93, 63, 58, 75, 89, 67),
height = c(161, 185, 174, 154, 188, 178, 170, 167, 181, 178),
sex = c(
"female", "male", "male", "female", "male",
"male", "female", "male", "male", "female"
)
)
plot(
people$weight,
people$height,
pch = ifelse(people$sex == "male", 16, 17),
col = ifelse(people$sex == "male", "blue", "red"),
xlab = "Weight (kg)",
ylab = "Height (cm)",
main = "Relationship Between Weight and Height",
cex = 1.3
)
legend(
"topleft",
legend = c("Male", "Female"),
pch = c(16, 17),
col = c("blue", "red"),
title = "Sex"
)
#chapter 8
ChickWeight[1:15,]
## weight Time Chick Diet
## 1 42 0 1 1
## 2 51 2 1 1
## 3 59 4 1 1
## 4 64 6 1 1
## 5 76 8 1 1
## 6 93 10 1 1
## 7 106 12 1 1
## 8 125 14 1 1
## 9 149 16 1 1
## 10 171 18 1 1
## 11 199 20 1 1
## 12 205 21 1 1
## 13 40 0 2 1
## 14 49 2 2 1
## 15 58 4 2 1
#install.packages("tseries")
library("tseries")
## Registered S3 method overwritten by 'quantmod':
## method from
## as.zoo.data.frame zoo
data(ice.river)
ice.river[1:5,]
## flow.vat flow.jok prec temp
## [1,] 16.1 30.2 8.1 0.9
## [2,] 19.2 29.0 4.4 1.6
## [3,] 14.5 28.4 7.0 0.1
## [4,] 11.0 27.8 0.0 0.6
## [5,] 13.6 27.8 0.0 2.0
#8.2 Reading in External Data Files
getwd()
## [1] "C:/Users/HP/Desktop/miracle"
mydatafile <- read.table(file="C:\\Users\\HP\\Desktop\\miracle\\mydata.txt",
header=TRUE,sep=" ",na.strings="*",
stringsAsFactors=FALSE)
mydatafile
## person sex ses funny age non
## 1 Peter M High 5 84 500
## 2 Lois F <NA> 4 80 480
## 3 Meg F Low 2 64 264
## 4 Chris M Med 1 68 168
## 5 Stewie M High NA NA NA
## 6 Brian M Med NA NA NA
list.files("C:/Users/user/Desktop/miracle")
## character(0)
mydatafile$sex <- as.factor(mydatafile$sex)
mydatafile$funny <- factor(x=mydatafile$funny,levels=c("Low","Med","High"))
spread <- read.csv(file.choose(),header=TRUE)
spread
## v1 v2 v3
## 1 55 161 female
## 2 85 185 male
## 3 75 174 male
## 4 42 154 female
## 5 93 188 male
## 6 63 178 male
## 7 58 170 female
## 8 75 167 male
## 9 89 181 male
## 10 67 178 female
# Ad hoc object Read/Write Operation
somelist <- list(foo=c(5,2,45),
bar=matrix(data=c(TRUE,TRUE,FALSE,FALSE,FALSE,FALSE,TRUE,FALSE,TRUE),nrow=3,ncol=3),
baz=factor(c(1,2,2,3,1,1,3),levels=1:3,ordered=TRUE))
somelist
## $foo
## [1] 5 2 45
##
## $bar
## [,1] [,2] [,3]
## [1,] TRUE FALSE TRUE
## [2,] TRUE FALSE FALSE
## [3,] FALSE FALSE TRUE
##
## $baz
## [1] 1 2 2 3 1 1 3
## Levels: 1 < 2 < 3
getwd()
## [1] "C:/Users/HP/Desktop/miracle"
dput(somelist,file="C:\\Users\\HP\\Desktop\\miracle\\somelist.txt")
newobject <- dget(file="C:/Users/HP/Desktop/miracle/somelist.txt")
newobject
## $foo
## [1] 5 2 45
##
## $bar
## [,1] [,2] [,3]
## [1,] TRUE FALSE TRUE
## [2,] TRUE FALSE FALSE
## [3,] FALSE FALSE TRUE
##
## $baz
## [1] 1 2 2 3 1 1 3
## Levels: 1 < 2 < 3
# Exercise 8.1(a)
data(quakes)
q5 <- subset(quakes, mag >= 5)
write.table(
q5,
file = "q5.txt",
sep = "!",
row.names = FALSE
)
q5.dframe <- read.table(
"q5.txt",
header = TRUE,
sep = "!"
)
q5.dframe
## lat long depth mag stations
## 1 -26.00 184.10 42 5.4 43
## 2 -20.70 169.92 139 6.1 94
## 3 -13.64 165.96 50 6.0 83
## 4 -19.66 180.28 431 5.4 57
## 5 -16.46 180.79 498 5.2 79
## 6 -18.97 185.25 129 5.1 73
## 7 -13.82 172.38 613 5.0 61
## 8 -21.96 179.62 627 5.0 45
## 9 -15.46 187.81 40 5.5 91
## 10 -23.74 179.99 506 5.2 75
## 11 -28.98 181.11 304 5.3 60
## 12 -34.02 180.21 75 5.2 65
## 13 -15.48 167.53 128 5.1 61
## 14 -20.64 182.02 497 5.2 64
## 15 -18.16 183.41 306 5.2 54
## 16 -13.66 166.54 50 5.1 45
## 17 -22.55 185.90 42 5.7 76
## 18 -36.95 177.81 146 5.0 35
## 19 -13.66 172.23 46 5.3 67
## 20 -17.93 167.89 49 5.1 43
## 21 -26.53 178.57 600 5.0 69
## 22 -16.14 187.32 42 5.1 68
## 23 -13.23 167.10 220 5.0 46
## 24 -23.58 180.17 462 5.3 63
## 25 -23.34 184.50 56 5.7 106
## 26 -15.56 167.62 127 6.4 122
## 27 -34.20 179.43 40 5.0 37
## 28 -26.00 182.12 205 5.6 98
## 29 -19.89 183.84 244 5.3 73
## 30 -32.22 180.20 216 5.7 90
## 31 -22.64 180.64 544 5.0 50
## 32 -20.02 184.09 234 5.3 71
## 33 -17.72 180.30 595 5.2 74
## 34 -21.96 180.54 603 5.2 66
## 35 -20.47 185.68 93 5.4 85
## 36 -23.73 182.53 232 5.0 55
## 37 -22.34 171.52 106 5.0 43
## 38 -21.68 180.63 617 5.0 63
## 39 -14.70 166.00 48 5.3 16
## 40 -16.65 185.51 218 5.0 52
## 41 -23.36 180.01 553 5.3 61
## 42 -17.80 181.38 587 5.1 47
## 43 -19.02 184.23 270 5.1 72
## 44 -22.13 180.38 577 5.7 104
## 45 -23.33 180.18 528 5.0 59
## 46 -19.13 182.51 579 5.2 56
## 47 -20.60 182.28 529 5.0 50
## 48 -18.48 181.49 641 5.0 49
## 49 -15.24 186.21 158 5.0 57
## 50 -16.40 185.86 148 5.0 47
## 51 -24.57 178.40 562 5.6 80
## 52 -12.93 169.63 641 5.1 57
## 53 -18.60 181.91 442 5.4 82
## 54 -18.77 169.24 218 5.3 53
## 55 -21.79 183.48 210 5.2 69
## 56 -11.41 166.24 83 5.3 55
## 57 -19.10 183.87 61 5.3 42
## 58 -12.25 166.60 219 5.0 28
## 59 -23.49 179.07 544 5.1 58
## 60 -27.19 182.18 69 5.4 68
## 61 -21.54 185.48 51 5.0 29
## 62 -30.17 182.02 56 5.5 68
## 63 -17.79 181.32 587 5.0 49
## 64 -22.19 171.40 150 5.1 49
## 65 -17.10 182.68 403 5.5 82
## 66 -21.98 179.60 583 5.4 67
## 67 -20.43 182.37 502 5.1 48
## 68 -23.73 179.99 527 5.1 49
## 69 -19.89 184.08 219 5.4 105
## 70 -17.59 181.09 536 5.1 61
## 71 -19.77 181.40 630 5.1 54
## 72 -15.33 186.75 48 5.7 123
## 73 -15.36 186.66 112 5.1 57
## 74 -15.36 186.71 130 5.5 95
## 75 -16.24 167.95 188 5.1 68
## 76 -25.50 182.82 124 5.0 25
## 77 -14.32 167.33 204 5.0 49
## 78 -20.04 182.01 605 5.1 49
## 79 -28.83 181.66 221 5.1 63
## 80 -17.72 181.42 565 5.3 89
## 81 -15.87 188.13 52 5.0 30
## 82 -17.84 181.30 535 5.7 112
## 83 -13.45 170.30 641 5.3 93
## 84 -26.18 178.59 548 5.4 65
## 85 -14.28 167.26 211 5.1 51
## 86 -22.10 179.71 579 5.1 58
## 87 -22.55 183.81 82 5.1 68
## 88 -20.85 181.59 499 5.1 91
## 89 -21.11 181.50 538 5.5 104
## 90 -23.53 179.99 538 5.4 87
## 91 -18.00 180.62 636 5.0 100
## 92 -18.08 180.70 628 5.2 72
## 93 -29.90 181.16 215 5.1 51
## 94 -10.79 166.06 142 5.0 40
## 95 -37.93 177.47 65 5.4 65
## 96 -23.58 183.40 94 5.2 79
## 97 -22.54 172.91 54 5.5 71
## 98 -20.90 184.28 58 5.5 92
## 99 -32.45 181.15 41 5.5 81
## 100 -13.26 167.01 213 5.1 70
## 101 -15.77 167.01 64 5.5 73
## 102 -15.95 167.34 47 5.4 87
## 103 -15.90 167.42 40 5.5 86
## 104 -11.54 166.18 89 5.4 80
## 105 -15.61 187.15 49 5.0 30
## 106 -22.91 183.95 64 5.9 118
## 107 -21.92 182.80 273 5.3 78
## 108 -17.71 181.18 574 5.2 67
## 109 -34.68 179.82 75 5.6 79
## 110 -14.46 167.26 195 5.2 87
## 111 -20.41 186.51 63 5.0 28
## 112 -18.51 182.64 405 5.2 74
## 113 -27.28 183.40 70 5.1 54
## 114 -11.25 166.36 130 5.1 55
## 115 -23.31 179.27 566 5.1 49
## 116 -27.98 181.96 53 5.2 89
## 117 -19.89 174.46 546 5.7 99
## 118 -15.65 186.26 64 5.1 54
## 119 -20.06 168.69 49 5.1 49
## 120 -24.18 179.02 550 5.3 86
## 121 -23.78 180.31 518 5.1 71
## 122 -22.87 172.65 56 5.1 50
## 123 -18.82 182.21 417 5.6 129
## 124 -12.05 167.39 332 5.0 36
## 125 -28.15 183.40 57 5.0 32
## 126 -37.03 177.52 153 5.6 87
## 127 -18.12 181.88 649 5.4 88
## 128 -11.40 166.07 93 5.6 94
## 129 -17.59 180.98 548 5.1 79
## 130 -18.14 180.87 624 5.5 105
## 131 -23.46 180.11 539 5.0 41
## 132 -18.21 180.87 631 5.2 69
## 133 -15.34 167.10 128 5.3 18
## 134 -18.92 169.37 248 5.3 60
## 135 -20.93 181.54 564 5.0 64
## 136 -18.80 182.41 385 5.2 67
## 137 -18.07 181.58 603 5.0 65
## 138 -18.04 181.57 587 5.0 51
## 139 -17.64 177.01 545 5.2 91
## 140 -17.98 181.51 586 5.2 68
## 141 -17.74 186.78 104 5.1 71
## 142 -15.93 167.91 183 5.6 109
## 143 -21.44 170.45 166 5.1 22
## 144 -26.50 178.29 609 5.0 50
## 145 -19.02 186.83 45 5.2 65
## 146 -19.30 183.00 302 5.0 65
## 147 -31.03 181.59 57 5.2 49
## 148 -21.29 185.77 57 5.3 69
## 149 -21.08 180.85 627 5.9 119
## 150 -17.10 185.90 127 5.4 75
## 151 -21.13 185.60 85 5.3 86
## 152 -12.34 167.43 50 5.1 47
## 153 -21.57 183.86 156 5.1 70
## 154 -13.70 166.75 46 5.3 71
## 155 -20.24 185.10 86 5.1 61
## 156 -24.04 184.85 70 5.0 48
## 157 -15.00 184.62 40 5.1 54
## 158 -14.12 166.64 63 5.3 69
## 159 -23.61 180.27 537 5.0 63
## 160 -21.19 181.58 490 5.0 77
## 161 -23.80 184.70 42 5.0 36
## 162 -19.34 186.59 56 5.2 49
## 163 -20.89 185.26 54 5.1 44
## 164 -18.97 169.44 242 5.0 41
## 165 -25.42 182.65 102 5.0 36
## 166 -21.60 169.90 43 5.2 56
## 167 -22.23 180.48 581 5.0 54
## 168 -21.55 181.39 513 5.1 81
## 169 -15.18 167.23 71 5.2 59
## 170 -21.14 174.21 40 5.7 78
## 171 -12.23 167.02 242 6.0 132
## 172 -12.00 166.20 94 5.0 31
## 173 -26.72 182.69 162 5.2 64
## 174 -21.35 170.04 56 5.0 22
## 175 -22.82 184.52 49 5.0 52
## 176 -38.28 177.10 100 5.4 71
## 177 -13.80 166.53 42 5.5 70
## 178 -19.30 185.86 48 5.0 40
## 179 -21.53 170.52 129 5.2 30
## 180 -28.05 182.39 117 5.1 43
## 181 -21.52 169.75 61 5.1 40
## 182 -17.85 181.44 589 5.6 115
## 183 -15.99 167.95 190 5.3 81
## 184 -20.56 184.41 138 5.0 82
## 185 -27.64 182.22 162 5.1 67
## 186 -29.33 182.72 57 5.4 61
## 187 -20.25 184.75 107 5.6 121
## 188 -19.33 186.16 44 5.4 110
## 189 -22.41 183.99 128 5.2 72
## 190 -23.60 183.99 118 5.4 88
## 191 -27.89 182.92 87 5.5 67
## 192 -35.94 178.52 138 5.5 78
## 193 -22.04 183.95 109 5.4 61
## 194 -23.95 184.64 43 5.4 45
## 195 -23.75 184.50 54 5.2 74
## 196 -20.82 181.67 577 5.0 67
## 197 -22.33 171.66 125 5.2 51
## 198 -21.59 170.56 165 6.0 119
# Exercise 8.1(b)
library(car)
## Loading required package: carData
data("Duncan", package = "car")
## Warning in data("Duncan", package = "car"): data set 'Duncan' not found
point_colors <- ifelse(
Duncan$prestige <= 80,
"black",
"blue"
)
point_symbols <- ifelse(
Duncan$prestige <= 80,
1,
16
)
png(
filename = "Duncan_plot.png",
width = 500,
height = 500
)
plot(
Duncan$education,
Duncan$income,
xlim = c(0, 100),
ylim = c(0, 100),
xlab = "Education",
ylab = "Income",
col = point_colors,
pch = point_symbols
)
legend(
"topright",
legend = c("Prestige <= 80", "Prestige > 80"),
col = c("black", "blue"),
pch = c(1, 16),
title = "Job prestige"
)
dev.off()
## png
## 2
# Exercise 8.1(c)
exer <- list(
quakes = quakes,
q5.dframe = q5.dframe,
Duncan = Duncan
)
dput(
exer,
file = "Exercise8-1.txt"
)
list.of.dataframes <- dget(
file = "Exercise8-1.txt"
)
names(list.of.dataframes)
## [1] "quakes" "q5.dframe" "Duncan"
str(list.of.dataframes)
## List of 3
## $ quakes :'data.frame': 1000 obs. of 5 variables:
## ..$ lat : num [1:1000] -20.4 -20.6 -26 -18 -20.4 ...
## ..$ long : num [1:1000] 182 181 184 182 182 ...
## ..$ depth : int [1:1000] 562 650 42 626 649 195 82 194 211 622 ...
## ..$ mag : num [1:1000] 4.8 4.2 5.4 4.1 4 4 4.8 4.4 4.7 4.3 ...
## ..$ stations: int [1:1000] 41 15 43 19 11 12 43 15 35 19 ...
## $ q5.dframe:'data.frame': 198 obs. of 5 variables:
## ..$ lat : num [1:198] -26 -20.7 -13.6 -19.7 -16.5 ...
## ..$ long : num [1:198] 184 170 166 180 181 ...
## ..$ depth : int [1:198] 42 139 50 431 498 129 613 627 40 506 ...
## ..$ mag : num [1:198] 5.4 6.1 6 5.4 5.2 5.1 5 5 5.5 5.2 ...
## ..$ stations: int [1:198] 43 94 83 57 79 73 61 45 91 75 ...
## $ Duncan :'data.frame': 45 obs. of 4 variables:
## ..$ type : Factor w/ 3 levels "bc","prof","wc": 2 2 2 2 2 2 2 2 3 2 ...
## ..$ income : int [1:45] 62 72 75 55 64 21 64 80 67 72 ...
## ..$ education: int [1:45] 86 76 92 90 86 84 93 100 87 86 ...
## ..$ prestige : int [1:45] 82 83 90 76 90 87 93 90 52 88 ...
# chapter9
foo <- 4+5
bar <- "stringtastic"
ls()
## [1] "anything" "bar" "bar.ch"
## [4] "baz" "char.vec" "df"
## [7] "exer" "fac.vec" "facresult"
## [10] "finalvector" "flow.jok" "flow.vat"
## [13] "foo" "foo.ch" "ice.river"
## [16] "list.of.dataframes" "logic.vec" "matc"
## [19] "matd" "mydatafile" "mylist"
## [22] "newobject" "num.mat1" "num.vec1"
## [25] "num.vec2" "numcoerced" "opt.arg"
## [28] "ordfac.vec" "people" "point_colors"
## [31] "point_symbols" "prec" "q5"
## [34] "q5.dframe" "quakes" "quux"
## [37] "qux" "resultvector" "somelist"
## [40] "spread" "sumbar" "sumbaz"
## [43] "sumfoo" "sumquux" "sumqux"
## [46] "temp" "x" "xlim"
## [49] "y" "ylim"
ls("package:graphics")
## [1] "abline" "arrows" "assocplot" "axis"
## [5] "Axis" "axis.Date" "axis.POSIXct" "axTicks"
## [9] "barplot" "barplot.default" "box" "boxplot"
## [13] "boxplot.default" "boxplot.matrix" "bxp" "cdplot"
## [17] "clip" "close.screen" "co.intervals" "contour"
## [21] "contour.default" "coplot" "curve" "dotchart"
## [25] "erase.screen" "filled.contour" "fourfoldplot" "frame"
## [29] "grconvertX" "grconvertY" "grid" "hist"
## [33] "hist.default" "identify" "image" "image.default"
## [37] "layout" "layout.show" "lcm" "legend"
## [41] "lines" "lines.default" "locator" "matlines"
## [45] "matplot" "matpoints" "mosaicplot" "mtext"
## [49] "pairs" "pairs.default" "panel.smooth" "par"
## [53] "persp" "pie" "plot" "plot.default"
## [57] "plot.design" "plot.function" "plot.new" "plot.window"
## [61] "plot.xy" "points" "points.default" "polygon"
## [65] "polypath" "rasterImage" "rect" "rug"
## [69] "screen" "segments" "smoothScatter" "spineplot"
## [73] "split.screen" "stars" "stem" "strheight"
## [77] "stripchart" "strwidth" "sunflowerplot" "symbols"
## [81] "text" "text.default" "title" "xinch"
## [85] "xspline" "xyinch" "yinch"
youthspeak <- matrix(data=c("OMG","LOL","WTF","YOLO"),nrow=2,ncol=2)
youthspeak
## [,1] [,2]
## [1,] "OMG" "WTF"
## [2,] "LOL" "YOLO"
#searchpaths
search()
## [1] ".GlobalEnv" "package:car" "package:carData"
## [4] "package:tseries" "package:ggplot2" "package:stats"
## [7] "package:graphics" "package:grDevices" "package:utils"
## [10] "package:datasets" "package:methods" "Autoloads"
## [13] "package:base"
baz <- seq(from=0,to=3,length.out=5)
baz
## [1] 0.00 0.75 1.50 2.25 3.00
environment(seq)
## <environment: namespace:base>
environment(arrows)
## <environment: namespace:graphics>
library("car")
bar <- matrix(data=1:9,nrow=3,ncol=3,dimnames=list(c("A","B","C"),
c("D","E","F")))
bar
## D E F
## A 1 4 7
## B 2 5 8
## C 3 6 9
bar <- matrix(nrow=3,dimnames=list(c("A","B","C"),c("D","E","F")),ncol=3,
data=1:9)
bar
## D E F
## A 1 4 7
## B 2 5 8
## C 3 6 9
bar <- matrix(nr=3,di=list(c("A","B","C"),c("D","E","F")),nc=3,dat=1:9)
bar
## D E F
## A 1 4 7
## B 2 5 8
## C 3 6 9
bar <- matrix(1:9,3,3,F,list(c("A","B","C"),c("D","E","F")))
bar
## D E F
## A 1 4 7
## B 2 5 8
## C 3 6 9
seq(-4, 4, 0.2)
## [1] -4.0 -3.8 -3.6 -3.4 -3.2 -3.0 -2.8 -2.6 -2.4 -2.2 -2.0 -1.8 -1.6 -1.4 -1.2
## [16] -1.0 -0.8 -0.6 -0.4 -0.2 0.0 0.2 0.4 0.6 0.8 1.0 1.2 1.4 1.6 1.8
## [31] 2.0 2.2 2.4 2.6 2.8 3.0 3.2 3.4 3.6 3.8 4.0
array(8:1, dim = c(2, 2, 2))
## , , 1
##
## [,1] [,2]
## [1,] 8 6
## [2,] 7 5
##
## , , 2
##
## [,1] [,2]
## [1,] 4 2
## [2,] 3 1
rep(1:2, 3)
## [1] 1 2 1 2 1 2
seq(from = 10, to = 8, length = 5)
## [1] 10.0 9.5 9.0 8.5 8.0
sort(decreasing = TRUE, x = c(2, 1, 1, 2, 0.3, 3, 1.3))
## [1] 3.0 2.0 2.0 1.3 1.0 1.0 0.3
which(matrix(c(TRUE, FALSE, TRUE, TRUE), 2, 2))
## [1] 1 3 4
which(matrix(c(TRUE, FALSE, TRUE, TRUE), 2, 2), arr = TRUE)
## row col
## [1,] 1 1
## [2,] 1 2
## [3,] 2 2
# the if statement
## the stand alone if
a <- 3
mynumber <- 4
if(a<=mynumber){
a <- a
}
a
## [1] 3
myvec <- c(2.73,5.40,2.15,5.29,1.36,2.16,1.41,6.97,7.99,9.52)
myvec
## [1] 2.73 5.40 2.15 5.29 1.36 2.16 1.41 6.97 7.99 9.52
mymat <- matrix(c(2,0,1,2,3,0,3,0,1,1),5,2)
mymat
## [,1] [,2]
## [1,] 2 0
## [2,] 0 3
## [3,] 1 0
## [4,] 2 1
## [5,] 3 1
if(any((myvec-1)>9)||matrix(myvec,2,5)[2,1]<=6){
cat("Condition satisfied--\n")
new.myvec <- myvec
new.myvec[seq(1,9,2)] <- NA
mylist <- list(aa=new.myvec,bb=mymat+0.5)
cat("-- a list with",length(mylist),"members now exists.")
}
## Condition satisfied--
## -- a list with 2 members now exists.
mylist
## $aa
## [1] NA 5.40 NA 5.29 NA 2.16 NA 6.97 NA 9.52
##
## $bb
## [,1] [,2]
## [1,] 2.5 0.5
## [2,] 0.5 3.5
## [3,] 1.5 0.5
## [4,] 2.5 1.5
## [5,] 3.5 1.5
any((myvec-1)>9)||matrix(myvec,2,5)[2,1]<=6
## [1] TRUE
# 10.1.2 else Statements
a <- 3
mynumber <- 4
if(a<=mynumber){
cat("Condition was",a<=mynumber)
a <- a^2
} else {
cat("Condition was",a<=mynumber)
a <- a-3.5
}
## Condition was TRUE
a
## [1] 9
a
## [1] 9
# 10.1.3 Using ifelse for Element-wise Checks
x <- 5
y <- -5:5
y
## [1] -5 -4 -3 -2 -1 0 1 2 3 4 5
y==0
## [1] FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE
result <- ifelse(test=y==0,yes=NA,no=x/y)
result
## [1] -1.000000 -1.250000 -1.666667 -2.500000 -5.000000 NA 5.000000
## [8] 2.500000 1.666667 1.250000 1.000000
# Exercise 10.1
#a
vec1 <- c(2,1,1,3,2,1,0)
vec2 <- c(3,8,2,2,0,0,0)
#i
if ((vec1[1] + vec2[2]) == 10) {
cat("Print me!")
}
## Print me!
# ii
if (vec1[1] >= 2 && vec2[1] >= 2) {
cat("Print me!")
}
## Print me!
#iii
if (all((vec2 - vec1)[c(2, 6)] < 7)) {
cat("Print me!")
}
#iv
if (!is.na(vec2[3])) {
cat("Print me!")
}
## Print me!
# b
ifelse(vec1 + vec2 > 3, vec1 * vec2, vec1 + vec2)
## [1] 6 8 3 6 2 1 0
# ci
diagonal <- diag(mymat)
positions <- which(grepl("^g", diagonal, ignore.case = TRUE))
if (length(positions) > 0) {
mymat[cbind(positions, positions)] <- "HERE"
} else {
mymat <- diag(nrow(mymat))
}
mymat
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
#i
mymat <- matrix(as.character(1:16), 4, 4)
diagonal <- diag(mymat)
positions <- which(grepl("^g", diagonal, ignore.case = TRUE))
if (length(positions) > 0) {
mymat[cbind(positions, positions)] <- "HERE"
} else {
mymat <- diag(nrow(mymat))
}
mymat
## [,1] [,2] [,3] [,4]
## [1,] 1 0 0 0
## [2,] 0 1 0 0
## [3,] 0 0 1 0
## [4,] 0 0 0 1
# ii
mymat <- matrix(
c(
"DANDELION", "Hyacinthus", "Gerbera",
"MARIGOLD", "geranium", "Ligularia",
"Pachysandra", "SNAPDRAGON", "GLADIOLUS"
),
3, 3
)
diagonal <- diag(mymat)
positions <- which(grepl("^g", diagonal, ignore.case = TRUE))
if (length(positions) > 0) {
mymat[cbind(positions, positions)] <- "HERE"
} else {
mymat <- diag(nrow(mymat))
}
mymat
## [,1] [,2] [,3]
## [1,] "DANDELION" "MARIGOLD" "Pachysandra"
## [2,] "Hyacinthus" "HERE" "SNAPDRAGON"
## [3,] "Gerbera" "Ligularia" "HERE"
#iii
mymat <- matrix(
c("GREAT", "exercises", "right", "here"),
2, 2,
byrow = TRUE
)
diagonal <- diag(mymat)
positions <- which(grepl("^g", diagonal, ignore.case = TRUE))
if (length(positions) > 0) {
mymat[cbind(positions, positions)] <- "HERE"
} else {
mymat <- diag(nrow(mymat))
}
mymat
## [,1] [,2]
## [1,] "HERE" "exercises"
## [2,] "right" "here"
# 10.1.4 Nesting and Stacking Statements
if(a<=mynumber){
cat("First condition was TRUE\n")
a <- a^2
if(mynumber>3){
cat("Second condition was TRUE")
b <- seq(1,a,length=mynumber)
} else {
cat("Second condition was FALSE")
b <- a*mynumber
}
} else {
cat("First condition was FALSE\n")
a <- a-3.5
if(mynumber>=4){
cat("Second condition was TRUE")
b <- a^(3-mynumber)
} else {
cat("Second condition was FALSE")
b <- rep(a+mynumber,times=3)
}
}
## First condition was FALSE
## Second condition was TRUE
a
## [1] 5.5
b
## [1] 0.1818182
a <- 3
mynumber <- 4
a
## [1] 3
b
## [1] 0.1818182
a <- 6
mynumber <- 4
a
## [1] 6
b
## [1] 0.1818182
if(a<=mynumber && mynumber>3){
cat("Same as 'first condition TRUE and second TRUE'")
a <- a^2
b <- seq(1,a,length=mynumber)
} else if(a<=mynumber && mynumber<=3){
cat("Same as 'first condition TRUE and second FALSE'")
a <- a^2
b <- a*mynumber
} else if(mynumber>=4){
cat("Same as 'first condition FALSE and second TRUE'")
a <- a-3.5
b <- a^(3-mynumber)
} else {
cat("Same as 'first condition FALSE and second FALSE'")
a <- a-3.5
b <- rep(a+mynumber,times=3)
}
## Same as 'first condition FALSE and second TRUE'
a
## [1] 2.5
b
## [1] 0.4
a<- 3
mynumber <- 4
a
## [1] 3
b
## [1] 0.4
a <- 6
mynumber <- 4
a
## [1] 6
b
## [1] 0.4
# 10.1.5 The switch Function
mystring <- "Homer"
if(mystring=="Homer"){
foo <- 12
} else if(mystring=="Marge"){
foo <- 34
} else if(mystring=="Bart"){
foo <- 56
} else if(mystring=="Lisa"){
foo <- 78
} else if(mystring=="Maggie"){
foo <- 90
} else {
foo <- NA
}
mystring <- "Lisa"
foo <- switch(EXPR=mystring,Homer=12,Marge=34,Bart=56,Lisa=78,Maggie=90,NA)
foo
## [1] 78
mystring <- "Peter"
foo <- switch(EXPR=mystring,Homer=12,Marge=34,Bart=56,Lisa=78,Maggie=90,NA)
foo
## [1] NA
mynum <- 3
foo <- switch(mynum,12,34,56,78,NA)
foo
## [1] 56
mynum <- 0
foo <- switch(mynum,12,34,56,78,NA)
foo
## NULL
# exercise 10.2
# a
mynum <- 3
if (mynum == 1) {
foo <- 12
} else if (mynum == 2) {
foo <- 34
} else if (mynum == 3) {
foo <- 56
} else if (mynum == 4) {
foo <- 78
} else if (mynum == 5) {
foo <- NA
} else {
foo <- NULL
}
foo
## [1] 56
# test with mynum = 0
mynum <- 0
if (mynum == 1) {
foo <- 12
} else if (mynum == 2) {
foo <- 34
} else if (mynum == 3) {
foo <- 56
} else if (mynum == 4) {
foo <- 78
} else if (mynum == 5) {
foo <- NA
} else {
foo <- NULL
}
foo
## NULL
# b
#i
lowdose <- 12.5
meddose <- 25.3
highdose <- 58.1
doselevel <- factor(
c("Low","High","High","High","Low","Med","Med"),
levels = c("Low","Med","High")
)
if (any(doselevel == "High")) {
if (lowdose >= 10) {
lowdose <- 10
} else {
lowdose <- lowdose / 2
}
if (meddose >= 26) {
meddose <- 26
}
if (highdose < 60) {
highdose <- 60
} else {
highdose <- highdose * 1.5
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Med"] <- meddose
dosage[doselevel == "High"] <- highdose
} else {
doselevel <- factor(
doselevel,
levels = c("Low","Med"),
labels = c("Small","Large")
)
if (lowdose < 15 && meddose < 35) {
lowdose <- lowdose * 2
meddose <- meddose + highdose
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Large"] <- meddose
}
dosage
## [1] 10.0 60.0 60.0 60.0 10.0 25.3 25.3
doselevel
## [1] Low High High High Low Med Med
## Levels: Low Med High
# ii
lowdose <- 12.5
meddose <- 25.3
highdose <- 58.1
doselevel <- factor(
c("Low","Low","Low","Med","Low","Med","Med"),
levels = c("Low","Med","High")
)
if (any(doselevel == "High")) {
if (lowdose >= 10) {
lowdose <- 10
} else {
lowdose <- lowdose / 2
}
if (meddose >= 26) {
meddose <- 26
}
if (highdose < 60) {
highdose <- 60
} else {
highdose <- highdose * 1.5
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Med"] <- meddose
dosage[doselevel == "High"] <- highdose
} else {
doselevel <- factor(
doselevel,
levels = c("Low","Med"),
labels = c("Small","Large")
)
if (lowdose < 15 && meddose < 35) {
lowdose <- lowdose * 2
meddose <- meddose + highdose
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Large"] <- meddose
}
dosage
## [1] 25.0 25.0 25.0 83.4 25.0 83.4 83.4
doselevel
## [1] Small Small Small Large Small Large Large
## Levels: Small Large
# iii
lowdose <- 9
meddose <- 49
highdose <- 61
doselevel <- factor(
c("Low","Med","Med"),
levels = c("Low","Med","High")
)
if (any(doselevel == "High")) {
if (lowdose >= 10) {
lowdose <- 10
} else {
lowdose <- lowdose / 2
}
if (meddose >= 26) {
meddose <- 26
}
if (highdose < 60) {
highdose <- 60
} else {
highdose <- highdose * 1.5
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Med"] <- meddose
dosage[doselevel == "High"] <- highdose
} else {
doselevel <- factor(
doselevel,
levels = c("Low","Med"),
labels = c("Small","Large")
)
if (lowdose < 15 && meddose < 35) {
lowdose <- lowdose * 2
meddose <- meddose + highdose
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Large"] <- meddose
}
dosage
## [1] 9 49 49
doselevel
## [1] Small Large Large
## Levels: Small Large
# iv
lowdose <- 9
meddose <- 49
highdose <- 61
doselevel <- factor(
c("Low","High","High","High","Low","Med","Med"),
levels = c("Low","Med","High")
)
if (any(doselevel == "High")) {
if (lowdose >= 10) {
lowdose <- 10
} else {
lowdose <- lowdose / 2
}
if (meddose >= 26) {
meddose <- 26
}
if (highdose < 60) {
highdose <- 60
} else {
highdose <- highdose * 1.5
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Med"] <- meddose
dosage[doselevel == "High"] <- highdose
} else {
doselevel <- factor(
doselevel,
levels = c("Low","Med"),
labels = c("Small","Large")
)
if (lowdose < 15 && meddose < 35) {
lowdose <- lowdose * 2
meddose <- meddose + highdose
}
dosage <- rep(lowdose, length(doselevel))
dosage[doselevel == "Large"] <- meddose
}
dosage
## [1] 4.5 91.5 91.5 91.5 4.5 26.0 26.0
doselevel
## [1] Low High High High Low Med Med
## Levels: Low Med High
# c
mynum <- 3
number_name <- ifelse(
mynum == 0,
"zero",
switch(
mynum,
"one",
"two",
"three",
"four",
"five",
"six",
"seven",
"eight",
"nine"
)
)
number_name
## [1] "three"
mynum <- 0
number_name <- ifelse(
mynum == 0,
"zero",
switch(
mynum,
"one",
"two",
"three",
"four",
"five",
"six",
"seven",
"eight",
"nine"
)
)
number_name
## [1] "zero"
# 10.2 Coding Loops
# 10.2.1 for Loops
for(myitem in 5:7){
cat("--BRACED AREA BEGINS--\n")
cat("the current item is",myitem,"\n")
cat("--BRACED AREA ENDS--\n\n")
}
## --BRACED AREA BEGINS--
## the current item is 5
## --BRACED AREA ENDS--
##
## --BRACED AREA BEGINS--
## the current item is 6
## --BRACED AREA ENDS--
##
## --BRACED AREA BEGINS--
## the current item is 7
## --BRACED AREA ENDS--
counter <- 0
for(myitem in 5:7){
counter <- counter+1
cat("The item in run",counter,"is",myitem,"\n")
}
## The item in run 1 is 5
## The item in run 2 is 6
## The item in run 3 is 7
# Looping via Index or Value
myvec <- c(0.4,1.1,0.34,0.55)
for(i in myvec){
print(2*i)
}
## [1] 0.8
## [1] 2.2
## [1] 0.68
## [1] 1.1
for(i in 1:length(myvec)){
print(2*myvec[i])
}
## [1] 0.8
## [1] 2.2
## [1] 0.68
## [1] 1.1
foo <- list(aa=c(3.4,1),bb=matrix(1:4,2,2),cc=matrix(c(T,T,F,T,F,F),3,2),
dd="string here",ee=matrix(c("red","green","blue","yellow")))
foo
## $aa
## [1] 3.4 1.0
##
## $bb
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## $cc
## [,1] [,2]
## [1,] TRUE TRUE
## [2,] TRUE FALSE
## [3,] FALSE FALSE
##
## $dd
## [1] "string here"
##
## $ee
## [,1]
## [1,] "red"
## [2,] "green"
## [3,] "blue"
## [4,] "yellow"
name <- names(foo)
name
## [1] "aa" "bb" "cc" "dd" "ee"
foo <- list(
matrix(1:4, nrow = 2),
c(1, 2, 3),
matrix(5:10, nrow = 2)
)
is.mat <- character(length(foo))
nr <- numeric(length(foo))
nc <- numeric(length(foo))
data.type <- character(length(foo))
for (i in 1:length(foo)) {
member <- foo[[i]]
if (is.matrix(member)) {
is.mat[i] <- "Yes"
nr[i] <- nrow(member)
nc[i] <- ncol(member)
data.type[i] <- class(as.vector(member))
} else {
is.mat[i] <- "No"
nr[i] <- NA
nc[i] <- NA
data.type[i] <- class(member)
}
}
result <- data.frame(
Is.Matrix = is.mat,
Rows = nr,
Columns = nc,
Data.Type = data.type
)
print(result)
## Is.Matrix Rows Columns Data.Type
## 1 Yes 2 2 integer
## 2 No NA NA numeric
## 3 Yes 2 3 integer
# nesting for loop
loopvec1 <- 5:7
loopvec1
## [1] 5 6 7
loopvec2 <- 9:6
loopvec2
## [1] 9 8 7 6
foo <- matrix(NA,length(loopvec1),length(loopvec2))
foo
## [,1] [,2] [,3] [,4]
## [1,] NA NA NA NA
## [2,] NA NA NA NA
## [3,] NA NA NA NA
for(i in 1:length(loopvec1)){
for(j in 1:length(loopvec2)){
foo[i,j] <- loopvec1[i]*loopvec2[j]
}
}
foo
## [,1] [,2] [,3] [,4]
## [1,] 45 40 35 30
## [2,] 54 48 42 36
## [3,] 63 56 49 42
foo <- matrix(NA,length(loopvec1),length(loopvec2))
foo
## [,1] [,2] [,3] [,4]
## [1,] NA NA NA NA
## [2,] NA NA NA NA
## [3,] NA NA NA NA
for(i in 1:length(loopvec1)){
for(j in 1:i){
foo[i,j] <- loopvec1[i]+loopvec2[j]
}
}
foo
## [,1] [,2] [,3] [,4]
## [1,] 14 NA NA NA
## [2,] 15 14 NA NA
## [3,] 16 15 14 NA
# exercise 10.3
#a
loopvec1 <- c(2,4,6)
loopvec2 <- c(3,5,7)
foo <- matrix(nrow = length(loopvec1), ncol = length(loopvec2))
for (k in 1:(length(loopvec1) * length(loopvec2))) {
i <- ((k - 1) %% length(loopvec1)) + 1
j <- ((k - 1) %/% length(loopvec1)) + 1
foo[i, j] <- loopvec1[i] * loopvec2[j]
}
foo
## [,1] [,2] [,3]
## [1,] 6 10 14
## [2,] 12 20 28
## [3,] 18 30 42
#b
mystring <- c("Peter","Homer","Lois","Stewie","Maggie","Bart")
answer <- numeric(length(mystring))
for (i in 1:length(mystring)) {
answer[i] <- switch(mystring[i],
Homer = 12,
Marge = 34,
Bart = 56,
Lisa = 78,
Maggie = 90,
NA)
}
answer
## [1] NA 12 NA NA 90 56
# counter <- 0
for (i in 1:length(mylist)) {
if (is.matrix(mylist[[i]])) {
counter <- counter + 1
} else if (is.list(mylist[[i]])) {
for (j in 1:length(mylist[[i]])) {
if (is.matrix(mylist[[i]][[j]])) {
counter <- counter + 1
}
}
}
}
counter
## [1] 4
# test 1
mylist <- list(
aa = c(3,4,1),
bb = matrix(1:4,2,2),
cc = matrix(c(T,T,F,T,F,F),3,2),
dd = "string here",
ee = list(c("hello","you"),
matrix(c("hello","there"))),
ff = matrix(c("red","green","blue","yellow"))
)
counter <- 0
for (i in 1:length(mylist)) {
if (is.matrix(mylist[[i]])) {
counter <- counter + 1
} else if (is.list(mylist[[i]])) {
for (j in 1:length(mylist[[i]])) {
if (is.matrix(mylist[[i]][[j]])) {
counter <- counter + 1
}
}
}
}
counter
## [1] 4
# test 2
mylist <- list("tricked you", as.vector(matrix(1:6,3,2)))
counter <- 0
for (i in 1:length(mylist)) {
if (is.matrix(mylist[[i]])) {
counter <- counter + 1
} else if (is.list(mylist[[i]])) {
for (j in 1:length(mylist[[i]])) {
if (is.matrix(mylist[[i]][[j]])) {
counter <- counter + 1
}
}
}
}
counter
## [1] 0
# test 3
mylist <- list(
list(1,2,3),
list(c(3,2),2),
list(c(1,2), matrix(c(1,2))),
rbind(1:10,100:91)
)
counter <- 0
for (i in 1:length(mylist)) {
if (is.matrix(mylist[[i]])) {
counter <- counter + 1
} else if (is.list(mylist[[i]])) {
for (j in 1:length(mylist[[i]])) {
if (is.matrix(mylist[[i]][[j]])) {
counter <- counter + 1
}
}
}
}
counter
## [1] 2
# 10.2.2 while Loops
myval <- 5
while(myval<20){
myval <- myval+1
cat("\n'myval' is now",myval,"\n")
cat("'mycondition' is now",myval<15,"\n")
}
##
## 'myval' is now 6
## 'mycondition' is now TRUE
##
## 'myval' is now 7
## 'mycondition' is now TRUE
##
## 'myval' is now 8
## 'mycondition' is now TRUE
##
## 'myval' is now 9
## 'mycondition' is now TRUE
##
## 'myval' is now 10
## 'mycondition' is now TRUE
##
## 'myval' is now 11
## 'mycondition' is now TRUE
##
## 'myval' is now 12
## 'mycondition' is now TRUE
##
## 'myval' is now 13
## 'mycondition' is now TRUE
##
## 'myval' is now 14
## 'mycondition' is now TRUE
##
## 'myval' is now 15
## 'mycondition' is now FALSE
##
## 'myval' is now 16
## 'mycondition' is now FALSE
##
## 'myval' is now 17
## 'mycondition' is now FALSE
##
## 'myval' is now 18
## 'mycondition' is now FALSE
##
## 'myval' is now 19
## 'mycondition' is now FALSE
##
## 'myval' is now 20
## 'mycondition' is now FALSE
mylist <- list()
counter <- 1
mynumbers <- c(4,5,1,2,6,2,4,6,6,2)
mycondition <- mynumbers[counter]<=5
while(mycondition){
mylist[[counter]]<-diag(mynumbers[counter])
counter<-counter+1
if(counter<=length(mynumbers)){
mycondition<-mynumbers[counter]<=5
}else{
mycondition<-FALSE
}
}
mylist
## [[1]]
## [,1] [,2] [,3] [,4]
## [1,] 1 0 0 0
## [2,] 0 1 0 0
## [3,] 0 0 1 0
## [4,] 0 0 0 1
##
## [[2]]
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## [[3]]
## [,1]
## [1,] 1
##
## [[4]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
# EXERCISE 10.4(a)(i)
mynumbers <- c(2, 2, 3, 2, 3, 5, 2)
mylist <- list()
counter <- 1
mycondition <- TRUE
while (mycondition && counter <= length(mynumbers)) {
if (mynumbers[counter] > 5) {
mycondition <- FALSE
} else {
mylist[[counter]] <- diag(mynumbers[counter])
counter <- counter + 1
}
}
mylist
## [[1]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
##
## [[2]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
##
## [[3]]
## [,1] [,2] [,3]
## [1,] 1 0 0
## [2,] 0 1 0
## [3,] 0 0 1
##
## [[4]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
##
## [[5]]
## [,1] [,2] [,3]
## [1,] 1 0 0
## [2,] 0 1 0
## [3,] 0 0 1
##
## [[6]]
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## [[7]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
# EXERCISE 10.4(a)(ii)
mynumbers <- 2:20
mylist <- list()
counter <- 1
mycondition <- TRUE
while (mycondition && counter <= length(mynumbers)) {
if (mynumbers[counter] > 5) {
mycondition <- FALSE
} else {
mylist[[counter]] <- diag(mynumbers[counter])
counter <- counter + 1
}
}
mylist
## [[1]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
##
## [[2]]
## [,1] [,2] [,3]
## [1,] 1 0 0
## [2,] 0 1 0
## [3,] 0 0 1
##
## [[3]]
## [,1] [,2] [,3] [,4]
## [1,] 1 0 0 0
## [2,] 0 1 0 0
## [3,] 0 0 1 0
## [4,] 0 0 0 1
##
## [[4]]
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
# EXERCISE 10.4(a)(iii)
mynumbers <- c(10, 1, 10, 1, 2)
mylist <- list()
counter <- 1
mycondition <- TRUE
while (mycondition && counter <= length(mynumbers)) {
if (mynumbers[counter] > 5) {
mycondition <- FALSE
} else {
mylist[[counter]] <- diag(mynumbers[counter])
counter <- counter + 1
}
}
mylist
## list()
# EXERCISE 10.4(b)
# Factorial using a while loop
mynum <- 5
factorial_result <- 1
while (mynum > 0) {
factorial_result <- factorial_result * mynum
mynum <- mynum - 1
}
factorial_result
## [1] 120
# Confirm 5! = 120
mynum <- 5
factorial_result <- 1
while (mynum > 0) {
factorial_result <- factorial_result * mynum
mynum <- mynum - 1
}
factorial_result
## [1] 120
# Confirm 12! = 479001600
mynum <- 12
factorial_result <- 1
while (mynum > 0) {
factorial_result <- factorial_result * mynum
mynum <- mynum - 1
}
factorial_result
## [1] 479001600
# Confirm 0! = 1
mynum <- 0
factorial_result <- 1
while (mynum > 0) {
factorial_result <- factorial_result * mynum
mynum <- mynum - 1
}
factorial_result
## [1] 1
# EXERCISE 10.4(c)
mystring <- "R fever"
index <- 1
ecount <- 0
result <- mystring
while (ecount < 2 && index <= nchar(mystring)) {
current_character <- substr(mystring, index, index)
if (current_character == "e" || current_character == "E") {
ecount <- ecount + 1
}
if (ecount == 2) {
result <- substr(mystring, 1, index - 1)
}
index <- index + 1
}
result
## [1] "R fev"
# Test with "beautiful"
mystring <- "beautiful"
index <- 1
ecount <- 0
result <- mystring
while (ecount < 2 && index <= nchar(mystring)) {
current_character <- substr(mystring, index, index)
if (current_character == "e" || current_character == "E") {
ecount <- ecount + 1
}
if (ecount == 2) {
result <- substr(mystring, 1, index - 1)
}
index <- index + 1
}
result
## [1] "beautiful"
# Test with "ECCENTRIC"
mystring <- "ECCENTRIC"
index <- 1
ecount <- 0
result <- mystring
while (ecount < 2 && index <= nchar(mystring)) {
current_character <- substr(mystring, index, index)
if (current_character == "e" || current_character == "E") {
ecount <- ecount + 1
}
if (ecount == 2) {
result <- substr(mystring, 1, index - 1)
}
index <- index + 1
}
result
## [1] "ECC"
# Test with "ElAbOrAtE"
mystring <- "ElAbOrAtE"
index <- 1
ecount <- 0
result <- mystring
while (ecount < 2 && index <= nchar(mystring)) {
current_character <- substr(mystring, index, index)
if (current_character == "e" || current_character == "E") {
ecount <- ecount + 1
}
if (ecount == 2) {
result <- substr(mystring, 1, index - 1)
}
index <- index + 1
}
result
## [1] "ElAbOrAt"
# Test with "eeeeek!"
mystring <- "eeeeek!"
index <- 1
ecount <- 0
result <- mystring
while (ecount < 2 && index <= nchar(mystring)) {
current_character <- substr(mystring, index, index)
if (current_character == "e" || current_character == "E") {
ecount <- ecount + 1
}
if (ecount == 2) {
result <- substr(mystring, 1, index - 1)
}
index <- index + 1
}
result
## [1] "e"
# Implicit Looping with apply
foo <- matrix(1:12,4,3)
foo
## [,1] [,2] [,3]
## [1,] 1 5 9
## [2,] 2 6 10
## [3,] 3 7 11
## [4,] 4 8 12
sum(foo)
## [1] 78
row.totals <- rep(NA,times=nrow(foo))
for(i in 1:nrow(foo)){
row.totals[i] <- sum(foo[i,])
}
row.totals
## [1] 15 18 21 24
row.totals2 <- apply(X=foo,MARGIN=1,FUN=sum)
row.totals2
## [1] 15 18 21 24
apply(X=foo,MARGIN=2,FUN=sum)
## [1] 10 26 42
bar <- array(1:18,dim=c(3,3,2))
bar
## , , 1
##
## [,1] [,2] [,3]
## [1,] 1 4 7
## [2,] 2 5 8
## [3,] 3 6 9
##
## , , 2
##
## [,1] [,2] [,3]
## [1,] 10 13 16
## [2,] 11 14 17
## [3,] 12 15 18
apply(bar,3,FUN=diag)
## [,1] [,2]
## [1,] 1 10
## [2,] 5 14
## [3,] 9 18
baz <- list(aa=c(3.4,1),bb=matrix(1:4,2,2),cc=matrix(c(T,T,F,T,F,F),3,2),
dd="string here",ee=matrix(c("red","green","blue","yellow")))
baz
## $aa
## [1] 3.4 1.0
##
## $bb
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## $cc
## [,1] [,2]
## [1,] TRUE TRUE
## [2,] TRUE FALSE
## [3,] FALSE FALSE
##
## $dd
## [1] "string here"
##
## $ee
## [,1]
## [1,] "red"
## [2,] "green"
## [3,] "blue"
## [4,] "yellow"
lapply(baz,FUN=is.matrix)
## $aa
## [1] FALSE
##
## $bb
## [1] TRUE
##
## $cc
## [1] TRUE
##
## $dd
## [1] FALSE
##
## $ee
## [1] TRUE
sapply(baz,FUN=is.matrix)
## aa bb cc dd ee
## FALSE TRUE TRUE FALSE TRUE
apply(foo,1,sort,decreasing=TRUE)
## [,1] [,2] [,3] [,4]
## [1,] 9 10 11 12
## [2,] 5 6 7 8
## [3,] 1 2 3 4
# Exercise 10.5
#a
result_a <- apply(
apply(foo, 1, sort, decreasing = TRUE),
2,
prod
)
result_a
## [1] 45 120 231 384
# b
matlist <- list(
matrix(c(TRUE, FALSE, FALSE, TRUE), 2, 2),
matrix(c("a", "c", "b", "z", "p", "q"), 3, 2),
matrix(1:8, 2, 4)
)
matlist <- lapply(matlist, t)
matlist
## [[1]]
## [,1] [,2]
## [1,] TRUE FALSE
## [2,] FALSE TRUE
##
## [[2]]
## [,1] [,2] [,3]
## [1,] "a" "c" "b"
## [2,] "z" "p" "q"
##
## [[3]]
## [,1] [,2]
## [1,] 1 2
## [2,] 3 4
## [3,] 5 6
## [4,] 7 8
# c
qux <- array(96:1, dim = c(4, 4, 2, 3))
qux
## , , 1, 1
##
## [,1] [,2] [,3] [,4]
## [1,] 96 92 88 84
## [2,] 95 91 87 83
## [3,] 94 90 86 82
## [4,] 93 89 85 81
##
## , , 2, 1
##
## [,1] [,2] [,3] [,4]
## [1,] 80 76 72 68
## [2,] 79 75 71 67
## [3,] 78 74 70 66
## [4,] 77 73 69 65
##
## , , 1, 2
##
## [,1] [,2] [,3] [,4]
## [1,] 64 60 56 52
## [2,] 63 59 55 51
## [3,] 62 58 54 50
## [4,] 61 57 53 49
##
## , , 2, 2
##
## [,1] [,2] [,3] [,4]
## [1,] 48 44 40 36
## [2,] 47 43 39 35
## [3,] 46 42 38 34
## [4,] 45 41 37 33
##
## , , 1, 3
##
## [,1] [,2] [,3] [,4]
## [1,] 32 28 24 20
## [2,] 31 27 23 19
## [3,] 30 26 22 18
## [4,] 29 25 21 17
##
## , , 2, 3
##
## [,1] [,2] [,3] [,4]
## [1,] 16 12 8 4
## [2,] 15 11 7 3
## [3,] 14 10 6 2
## [4,] 13 9 5 1
# c(i)
result_c1 <- apply(qux[, , 2, ], 3, diag)
result_c1
## [,1] [,2] [,3]
## [1,] 80 48 16
## [2,] 75 43 11
## [3,] 70 38 6
## [4,] 65 33 1
# c(ii)
result_c2 <- apply(
apply(qux[, 4, , ], 3, dim),
1,
sum
)
result_c2
## [1] 12 6
# 10.3 Other Control Flow Mechanisms
# 10.3.1 Declaring break or next
foo <- 5
bar <- c(2,3,1.1,4,0,4.1,3)
loop1.result <- rep(NA,length(bar))
loop1.result
## [1] NA NA NA NA NA NA NA
for(i in 1:length(bar)){
temp <- foo/bar[i]
if(is.finite(temp)){
loop1.result[i] <- temp
} else {
break
}
}
loop1.result
## [1] 2.500000 1.666667 4.545455 1.250000 NA NA NA
loop2.result <- rep(NA,length(bar))
loop2.result
## [1] NA NA NA NA NA NA NA
for(i in 1:length(bar)){
if(bar[i]==0){
next
}
loop2.result[i] <- foo/bar[i]
}
loop2.result
## [1] 2.500000 1.666667 4.545455 1.250000 NA 1.219512 1.666667
loopvec1 <- 5:7
loopvec1
## [1] 5 6 7
loopvec2 <- 9:6
loopvec2
## [1] 9 8 7 6
baz <- matrix(NA,length(loopvec1),length(loopvec2))
baz
## [,1] [,2] [,3] [,4]
## [1,] NA NA NA NA
## [2,] NA NA NA NA
## [3,] NA NA NA NA
for(i in 1:length(loopvec1)){
for(j in 1:length(loopvec2)){
temp <- loopvec1[i]*loopvec2[j]
if(temp>=54){
next
}
baz[i,j] <- temp
}
}
baz
## [,1] [,2] [,3] [,4]
## [1,] 45 40 35 30
## [2,] NA 48 42 36
## [3,] NA NA 49 42
# 10.3.2 The repeat Statement
fib.a <- 1
fib.b <- 1
repeat{
temp <- fib.a+fib.b
fib.a <- fib.b
fib.b <- temp
cat(fib.b,", ",sep="")
if(fib.b>150){
cat("BREAK NOW...\n")
break
}
}
## 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, BREAK NOW...
#
# Create the number that will be divided
foo <- 5
# Create the vector containing the divisors
bar <- c(2, 3, 1.1, 4, 0, 4.1, 3)
# Create an empty result vector filled with NA
loop2.result <- rep(NA, length(bar))
# Start the counter from the first position
i <- 1
# Continue while the end of bar has not been reached
# and the current element is not zero
while (i <= length(bar) && bar[i] != 0) {
# Divide foo by the current element of bar
loop2.result[i] <- foo / bar[i]
# Move to the next position
i <- i + 1
}
# Display the final result
loop2.result
## [1] 2.500000 1.666667 4.545455 1.250000 NA NA NA
#
# Create the number that will be divided
foo <- 5
# Create the vector containing the divisors
bar <- c(2, 3, 1.1, 4, 0, 4.1, 3)
# Check every element of bar
# If an element is zero, return NA
# Otherwise, divide foo by that element
loop3.result <- ifelse(
test = bar == 0,
yes = NA,
no = foo / bar
)
# Display the final result
loop3.result
## [1] 2.500000 1.666667 4.545455 1.250000 NA 1.219512 1.666667
# b
# Create the vector containing the matrix dimensions
mynumbers <- c(4, 5, 1, 2, 6, 2, 4, 6, 6, 2)
# B(i):
# Create an empty list for storing the identity matrices
mylist_for <- list()
# Move through each position in mynumbers
for (i in seq_along(mynumbers)) {
# Stop the loop when the current number is greater than 5
if (mynumbers[i] > 5) {
break
}
# Create an identity matrix using the current number
mylist_for[[i]] <- diag(mynumbers[i])
}
# Display the result from the for loop
mylist_for
## [[1]]
## [,1] [,2] [,3] [,4]
## [1,] 1 0 0 0
## [2,] 0 1 0 0
## [3,] 0 0 1 0
## [4,] 0 0 0 1
##
## [[2]]
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## [[3]]
## [,1]
## [1,] 1
##
## [[4]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
# B(ii): REPEAT LOOP
# Create another empty list for storing the identity matrices
mylist_repeat <- list()
# Start the counter from the first position
i <- 1
# Begin the repeat loop
repeat {
# Stop if the counter has passed the end of mynumbers
if (i > length(mynumbers)) {
break
}
# Stop when the current number is greater than 5
if (mynumbers[i] > 5) {
break
}
# Create an identity matrix using the current number
mylist_repeat[[i]] <- diag(mynumbers[i])
# Move to the next position
i <- i + 1
}
# Display the result from the repeat loop
mylist_repeat
## [[1]]
## [,1] [,2] [,3] [,4]
## [1,] 1 0 0 0
## [2,] 0 1 0 0
## [3,] 0 0 1 0
## [4,] 0 0 0 1
##
## [[2]]
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 0 0 0 0
## [2,] 0 1 0 0 0
## [3,] 0 0 1 0 0
## [4,] 0 0 0 1 0
## [5,] 0 0 0 0 1
##
## [[3]]
## [,1]
## [1,] 1
##
## [[4]]
## [,1] [,2]
## [1,] 1 0
## [2,] 0 1
# COMPARE THE TWO RESULTS
# Check whether both methods produced the same result
identical(mylist_for, mylist_repeat)
## [1] TRUE
# c
# Create the first list of matrices
matlist1 <- list(
matrix(1:4, 2, 2),
matrix(1:4),
matrix(1:8, 4, 2)
)
# Make matlist2 identical to matlist1
matlist2 <- matlist1
# Create a result list with 3 × 3 = 9 positions
reslist <- vector(
mode = "list",
length = length(matlist1) * length(matlist2)
)
# Start the result-position counter
counter <- 0
# Search through the matrices in matlist1
for (i in seq_along(matlist1)) {
# Compare each matrix with every matrix in matlist2
for (j in seq_along(matlist2)) {
# Move to the next position in reslist
counter <- counter + 1
# Check whether the number of columns of the first matrix
# matches the number of rows of the second matrix
if (ncol(matlist1[[i]]) != nrow(matlist2[[j]])) {
# Store a message when multiplication is impossible
reslist[[counter]] <- "not possible"
# Move directly to the next matrix comparison
next
}
# Perform matrix multiplication
reslist[[counter]] <- matlist1[[i]] %*% matlist2[[j]]
}
}
# Display the result list
reslist
## [[1]]
## [,1] [,2]
## [1,] 7 15
## [2,] 10 22
##
## [[2]]
## [1] "not possible"
##
## [[3]]
## [1] "not possible"
##
## [[4]]
## [1] "not possible"
##
## [[5]]
## [1] "not possible"
##
## [[6]]
## [1] "not possible"
##
## [[7]]
## [,1] [,2]
## [1,] 11 23
## [2,] 14 30
## [3,] 17 37
## [4,] 20 44
##
## [[8]]
## [1] "not possible"
##
## [[9]]
## [1] "not possible"
# cii
# Create the first list of matrices
matlist1 <- list(
matrix(1:4, 2, 2),
matrix(2:5, 2, 2),
matrix(1:16, 4, 4)
)
# Create the second list of matrices
matlist2 <- list(
matrix(1:8, 2, 4),
matrix(10:7, 2, 2),
matrix(9:2, 4, 2)
)
# Create a result list with 3 × 3 = 9 positions
reslist <- vector(
mode = "list",
length = length(matlist1) * length(matlist2)
)
# Start the result-position counter
counter <- 0
# Search through matlist1 using the outer loop
for (i in seq_along(matlist1)) {
# Search through matlist2 using the inner loop
for (j in seq_along(matlist2)) {
# Move to the next position in reslist
counter <- counter + 1
# Test whether the two matrices can be multiplied
if (ncol(matlist1[[i]]) != nrow(matlist2[[j]])) {
# Save this message when multiplication is impossible
reslist[[counter]] <- "not possible"
# Skip directly to the next comparison
next
}
# Multiply the matrices when dimensions agree
reslist[[counter]] <- matlist1[[i]] %*% matlist2[[j]]
}
}
# Display the completed result list
reslist
## [[1]]
## [,1] [,2] [,3] [,4]
## [1,] 7 15 23 31
## [2,] 10 22 34 46
##
## [[2]]
## [,1] [,2]
## [1,] 37 29
## [2,] 56 44
##
## [[3]]
## [1] "not possible"
##
## [[4]]
## [,1] [,2] [,3] [,4]
## [1,] 10 22 34 46
## [2,] 13 29 45 61
##
## [[5]]
## [,1] [,2]
## [1,] 56 44
## [2,] 75 59
##
## [[6]]
## [1] "not possible"
##
## [[7]]
## [1] "not possible"
##
## [[8]]
## [1] "not possible"
##
## [[9]]
## [,1] [,2]
## [1,] 190 78
## [2,] 220 92
## [3,] 250 106
## [4,] 280 120
reslist[[3]]
## [1] "not possible"
reslist[[6]]
## [1] "not possible"
reslist[[9]]
## [,1] [,2]
## [1,] 190 78
## [2,] 220 92
## [3,] 250 106
## [4,] 280 120
# WRITING FUNCTIONS
#11.1.1 Function Creation
myfib <- function(){
fib.a <- 1
fib.b <- 2
cat(fib.a,",",fib.b,",",sep="")
repeat{
temp <- fib.a+fib.b
fib.a <- fib.b
fib.b <- temp
cat(fib.b,",",sep="")
if(fib.b>150){
cat("BREAK NOW...")
break
}
}
}
myfib()
## 1,2,3,5,8,13,21,34,55,89,144,233,BREAK NOW...
# Adding Arguments
myfib2 <- function(thresh){
fib.a <- 1
fib.b <- 1
cat(fib.a,",",fib.b,",",sep="")
repeat{
temp <- fib.a+fib.b
fib.a <- fib.b
fib.b <- temp
cat(fib.b,",",sep="")
if(fib.b>thresh){
cat("BREAK NOW.....")
break
}
}
}
myfib2(thresh=200)
## 1,1,2,3,5,8,13,21,34,55,89,144,233,BREAK NOW.....
myfib2(thresh=5000000)
## 1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181,6765,10946,17711,28657,46368,75025,121393,196418,317811,514229,832040,1346269,2178309,3524578,5702887,BREAK NOW.....
# Returning Results
myfib3 <- function(thresh){
fibseq <- c(1,1)
counter <- 2
repeat{
fibseq <- c(fibseq,fibseq[counter-1]+fibseq[counter])
counter <- counter+1
if(fibseq[counter]>thresh){
break
}
}
return(fibseq)
}
myfib3(150)
## [1] 1 1 2 3 5 8 13 21 34 55 89 144 233
foo <- myfib3(10000)
foo
## [1] 1 1 2 3 5 8 13 21 34 55 89 144
## [13] 233 377 610 987 1597 2584 4181 6765 10946
bar <- foo[1:5]
bar
## [1] 1 1 2 3 5
# 11.1.2 Using return
dummy1 <- function(){
aa <- 2.5
bb <- "string me along"
cc <- "string 'em up"
dd <- 4:8
}
dummy2 <- function(){
aa <- 2.5
bb <- "string me along"
cc <- "string 'em up"
dd <- 4:8
return(dd)
}
foo <- dummy1()
foo
## [1] 4 5 6 7 8
bar <- dummy2()
bar
## [1] 4 5 6 7 8
dummy3 <- function(){
aa <- 2.5
bb <- "string me along"
return(aa)
cc <- "string 'em up"
dd <- 4:8
return(bb)
}
baz <- dummy3()
baz
## [1] 2.5
#Exercise 11.1
# a
# Create a function named myfib4
myfib4 <- function(thresh, printme) {
# Start the Fibonacci sequence with 0 and 1
fib <- c(0, 1)
# Continue generating numbers while the next number
# does not exceed the threshold
while (sum(tail(fib, 2)) <= thresh) {
# Add the next Fibonacci number to the vector
fib <- c(fib, sum(tail(fib, 2)))
}
# Check whether printme is TRUE
if (printme == TRUE) {
# Print the Fibonacci sequence to the console
print(fib)
} else {
# Return the Fibonacci sequence as a vector
return(fib)
}
}
# Print the Fibonacci sequence up to 150
myfib4(thresh = 150, printme = TRUE)
## [1] 0 1 1 2 3 5 8 13 21 34 55 89 144
# Print the Fibonacci sequence up to 1,000,000
myfib4(1000000, TRUE)
## [1] 0 1 1 2 3 5 8 13 21 34
## [11] 55 89 144 233 377 610 987 1597 2584 4181
## [21] 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229
## [31] 832040
# Return the Fibonacci sequence up to 150 as a vector
result1 <- myfib4(150, FALSE)
# Display the returned vector
result1
## [1] 0 1 1 2 3 5 8 13 21 34 55 89 144
# Return the Fibonacci sequence up to 1,000,000 as a vector
result2 <- myfib4(1000000, printme = FALSE)
# Display the returned vector
result2
## [1] 0 1 1 2 3 5 8 13 21 34
## [11] 55 89 144 233 377 610 987 1597 2584 4181
## [21] 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229
## [31] 832040
# b
# Create a factorial function named myfac
myfac <- function(int) {
# Set the factorial result initially to 1
result <- 1
# Start the counter from 1
counter <- 1
# Continue multiplying until the counter reaches int
while (counter <= int) {
# Multiply the current result by the counter
result <- result * counter
# Increase the counter by 1
counter <- counter + 1
}
# Return the factorial result
return(result)
}
# Calculate 5 factorial
myfac(5)
## [1] 120
# Calculate 12 factorial
myfac(12)
## [1] 479001600
# Calculate 0 factorial
myfac(0)
## [1] 1
# bii
# Create another factorial function named myfac2
myfac2 <- function(int) {
# Check whether the supplied integer is negative
if (int < 0) {
# Return NaN for a negative integer
return(NaN)
}
# Set the factorial result initially to 1
result <- 1
# Start the counter from 1
counter <- 1
# Continue multiplying until the counter reaches int
while (counter <= int) {
# Multiply the current result by the counter
result <- result * counter
# Increase the counter by 1
counter <- counter + 1
}
# Return the factorial result
return(result)
}
# to test
# Calculate 5 factorial
myfac2(5)
## [1] 120
# Calculate 12 factorial
myfac2(12)
## [1] 479001600
# Calculate 0 factorial
myfac2(0)
## [1] 1
# Test the function with a negative integer
myfac2(-6)
## [1] NaN
# 11.2 Arguments
#11.2.1 Lazy Evaluation
multiples1 <- function(x,mat,str1,str2){
matrix.flags <- sapply(x,FUN=is.matrix)
if(!any(matrix.flags)){
return(str1)
}
indexes <- which(matrix.flags)
counter <- 0
result <- list()
for(i in indexes){
temp <- x[[i]]
if(ncol(temp)==nrow(mat)){
counter <- counter+1
result[[counter]] <- temp%*%mat
}
}
if(counter==0){
return(str2)
} else {
return(result)
}
}
foo <- list(matrix(1:4,2,2),"not a matrix",
"definitely not a matrix",matrix(1:8,2,4),matrix(1:8,4,2))
bar <- list(1:4,"not a matrix",c(F,T,T,T),"??")
baz <- list(1:4,"not a matrix",c(F,T,T,T),"??",matrix(1:8,2,4))
multiples1(x=foo,mat=diag(2),str1="no matrices in 'x'",
str2="matrices in 'x' but none of appropriate dimensions given
'mat'")
## [[1]]
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## [[2]]
## [,1] [,2]
## [1,] 1 5
## [2,] 2 6
## [3,] 3 7
## [4,] 4 8
foo
## [[1]]
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## [[2]]
## [1] "not a matrix"
##
## [[3]]
## [1] "definitely not a matrix"
##
## [[4]]
## [,1] [,2] [,3] [,4]
## [1,] 1 3 5 7
## [2,] 2 4 6 8
##
## [[5]]
## [,1] [,2]
## [1,] 1 5
## [2,] 2 6
## [3,] 3 7
## [4,] 4 8
multiples1(x=foo,mat=diag(2),str1="no matrices in 'x'",
str2="matrices in 'x' but none of appropriate dimensions given
'mat'")
## [[1]]
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## [[2]]
## [,1] [,2]
## [1,] 1 5
## [2,] 2 6
## [3,] 3 7
## [4,] 4 8
multiples1(x=bar,mat=diag(2),str1="no matrices in 'x'",
str2="matrices in 'x' but none of appropriate dimensions given
'mat'")
## [1] "no matrices in 'x'"
multiples1(x=baz,mat=diag(2),str1="no matrices in 'x'",
str2="matrices in 'x' but none of appropriate dimensions given
'mat'")
## [1] "matrices in 'x' but none of appropriate dimensions given\n'mat'"
multiples1(x=foo,mat=diag(2))
## [[1]]
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## [[2]]
## [,1] [,2]
## [1,] 1 5
## [2,] 2 6
## [3,] 3 7
## [4,] 4 8
# 11.2.2 Setting Defaults
multiples2 <- function(x,mat,str1="no valid matrices",str2=str1){
matrix.flags <- sapply(x,FUN=is.matrix)
if(!any(matrix.flags)){
return(str1)
}
indexes <- which(matrix.flags)
counter <- 0
result <- list()
for(i in indexes){
temp <- x[[i]]
if(ncol(temp)==nrow(mat)){
counter <- counter+1
result[[counter]] <- temp%*%mat
}
}
if(counter==0){
return(str2)
} else {
return(result)
}
}
multiples2(foo,mat=diag(2))
## [[1]]
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## [[2]]
## [,1] [,2]
## [1,] 1 5
## [2,] 2 6
## [3,] 3 7
## [4,] 4 8
multiples2(bar,mat=diag(2))
## [1] "no valid matrices"
multiples2(baz,mat=diag(2))
## [1] "no valid matrices"
# 11.2.3 Checking for Missing Arguments
multiples3 <- function(x,mat,str1,str2){
matrix.flags <- sapply(x,FUN=is.matrix)
if(!any(matrix.flags)){
if(missing(str1)){
return("'str1' was missing, so this is the message")
} else {
return(str1)
}
}
indexes <- which(matrix.flags)
counter <- 0
result <- list()
for(i in indexes){
temp <- x[[i]]
if(ncol(temp)==nrow(mat)){
counter <- counter+1
result[[counter]] <- temp%*%mat
}
}
if(counter==0){
if(missing(str2)){
return("'str2' was missing, so this is the message")
} else {
return(str2)
}
} else {
return(result)
}
}
multiples3(foo,diag(2))
## [[1]]
## [,1] [,2]
## [1,] 1 3
## [2,] 2 4
##
## [[2]]
## [,1] [,2]
## [1,] 1 5
## [2,] 2 6
## [3,] 3 7
## [4,] 4 8
multiples3(bar,diag(2))
## [1] "'str1' was missing, so this is the message"
multiples3(baz,diag(2))
## [1] "'str2' was missing, so this is the message"
# 11.2.4 Dealing with Ellipses
myfibplot <- function(thresh,plotit=TRUE,...){
fibseq <- c(1,1)
counter <- 2
repeat{
fibseq <- c(fibseq,fibseq[counter-1]+fibseq[counter])
counter <- counter+1
if(fibseq[counter]>thresh){
break
}
}
if(plotit){
plot(1:length(fibseq),fibseq,...)
} else {
return(fibseq)
}
}
myfibplot(150)
myfibplot(150,type="b",pch=4,lty=2,main="Terms of the Fibonacci sequence",
ylab="Fibonacci number",xlab="Term (n)")
unpackme <- function(...){
x <- list(...)
cat("Here is ... in its entirety as a list:\n")
print(x)
cat("\nThe names of ... are:",names(x),"\n\n")
cat("\nThe classes of ... are:",sapply(x,class))
}
# Exercise 11.2
# a
# Create a function for calculating compound interest
compound_interest <- function(P, i, t = 12, y, plotit = TRUE, ...) {
# Create the integer years from 1 up to y
years <- 1:y
# Calculate the investment amount for each year
F <- P * (1 + i / (100 * t))^(t * years)
# Check whether the result should be plotted
if (plotit == TRUE) {
# Produce a step plot of the investment amounts
plot(
years,
F,
type = "s",
...
)
} else {
# Return the investment amounts as a numeric vector
return(F)
}
}
# ai
# Calculate the investment amount for each of the 10 years
investment1 <- compound_interest(
P = 5000,
i = 4.4,
t = 12,
y = 10,
plotit = FALSE
)
# Display all the yearly investment amounts
investment1
## [1] 5224.491 5459.062 5704.164 5960.271 6227.877 6507.498 6799.674 7104.967
## [9] 7423.968 7757.291
# Display only the final amount after 10 years
investment1[10]
## [1] 7757.291
# aii
# Create the monthly compound-interest step plot
compound_interest(
P = 100,
i = 22.9,
t = 12,
y = 20,
plotit = TRUE,
main = "Compound Interest Calculator",
xlab = "Year (y)",
ylab = "Balance (F)",
xlim = c(1, 20)
)
# B
# Create a function for solving quadratic equations
quadratic_solver <- function(k1, k2, k3) {
# Check whether any required argument is missing
if (missing(k1) || missing(k2) || missing(k3)) {
# Return a message when an argument is missing
return("Calculation is not possible because an argument is missing.")
}
# Check that the coefficient of x squared is not zero
if (k1 == 0) {
# Return a message because the equation is not quadratic
return("k1 cannot be zero for a quadratic equation.")
}
# Calculate the discriminant
discriminant <- k2^2 - 4 * k1 * k3
# Check whether the discriminant is negative
if (discriminant < 0) {
# Print a message because there are no real roots
print("This equation has no real roots.")
# Return an empty numeric vector
return(numeric(0))
} else if (discriminant == 0) {
# Calculate the single repeated root
root <- -k2 / (2 * k1)
# Return the root as a numeric vector
return(root)
} else {
# Calculate the first real root
root1 <- (-k2 - sqrt(discriminant)) / (2 * k1)
# Calculate the second real root
root2 <- (-k2 + sqrt(discriminant)) / (2 * k1)
# Return both roots as a numeric vector
return(c(root1, root2))
}
}
#Bi
# Solve 2x² - x - 5 = 0
quadratic_solver(
k1 = 2,
k2 = -1,
k3 = -5
)
## [1] -1.350781 1.850781
# Attempt to solve x² + x + 1 = 0
quadratic_solver(
k1 = 1,
k2 = 1,
k3 = 1
)
## [1] "This equation has no real roots."
## numeric(0)
# Bii
# Solve 1.3x² - 8x - 3.13 = 0
quadratic_solver(
k1 = 1.3,
k2 = -8,
k3 = -3.13
)
## [1] -0.3691106 6.5229567
# Solve 2.25x² - 3x + 1 = 0
quadratic_solver(
k1 = 2.25,
k2 = -3,
k3 = 1
)
## [1] 0.6666667
# Solve 1.4x² - 2.2x - 5.1 = 0
quadratic_solver(
k1 = 1.4,
k2 = -2.2,
k3 = -5.1
)
## [1] -1.278312 2.849740
# Attempt to solve -5x² + 10.11x - 9.9 = 0
quadratic_solver(
k1 = -5,
k2 = 10.11,
k3 = -9.9
)
## [1] "This equation has no real roots."
## numeric(0)
#Biii
# Leave out k3 to test the missing-argument response
quadratic_solver(
k1 = 2,
k2 = -1
)
## [1] "Calculation is not possible because an argument is missing."
# 11.3 Specialized Functions
# 11.3.1 Helper Functions
# Externally Defined
multiples_helper_ext <- function(x,matrix.flags,mat){
indexes <- which(matrix.flags)
counter <- 0
result <- list()
for(i in indexes){
temp <- x[[i]]
if(ncol(temp)==nrow(mat)){
counter <- counter+1
result[[counter]] <- temp%*%mat
}
}
return(list(result,counter))
}
multiples4 <- function(x,mat,str1="no valid matrices",str2=str1){
matrix.flags <- sapply(x,FUN=is.matrix)
if(!any(matrix.flags)){
return(str1)
}
helper.call <- multiples_helper_ext(x,matrix.flags,mat)
result <- helper.call[[1]]
counter <- helper.call[[2]]
if(counter==0){
return(str2)
} else {
return(result)
}
}
# internally Defined
multiples5 <- function(x,mat,str1="no valid matrices",str2=str1){
matrix.flags <- sapply(x,FUN=is.matrix)
if(!any(matrix.flags)){
return(str1)
}
multiples_helper_int <- function(x,matrix.flags,mat){
indexes <- which(matrix.flags)
counter <- 0
result <- list()
for(i in indexes){
temp <- x[[i]]
if(ncol(temp)==nrow(mat)){
counter <- counter+1
result[[counter]] <- temp%*%mat
}
}
return(list(result,counter))
}
helper.call <- multiples_helper_int(x,matrix.flags,mat)
result <- helper.call[[1]]
counter <- helper.call[[2]]
if(counter==0){
return(str2)
} else {
return(result)
}
}
# 11.3.2 Disposable Functions
foo <- matrix(c(2,3,3,4,2,4,7,3,3,6,7,2),3,4)
foo
## [,1] [,2] [,3] [,4]
## [1,] 2 4 7 6
## [2,] 3 2 3 7
## [3,] 3 4 3 2
apply(foo,MARGIN=2,FUN=function(x){sort(rep(x,2))})
## [,1] [,2] [,3] [,4]
## [1,] 2 2 3 2
## [2,] 2 2 3 2
## [3,] 3 4 3 6
## [4,] 3 4 3 6
## [5,] 3 4 7 7
## [6,] 3 4 7 7
# 11.3.3 Recursive Functions
myfibrec <- function(n){
if(n==1||n==2){
return(1)
} else {
return(myfibrec(n-1)+myfibrec(n-2))
}
}
myfibrec(5)
## [1] 5
# Exercise 11.3
# A
# Create the given list of character vectors
foo <- list(
"a",
c("b", "c", "d", "e"),
"f",
c("g", "h", "i")
)
# Apply a temporary function to every member of the list
# paste0() adds "!" to each individual character without a separator
result_a <- lapply(foo, function(x) {
paste0(x, "!")
})
# Display the result
result_a
## [[1]]
## [1] "a!"
##
## [[2]]
## [1] "b!" "c!" "d!" "e!"
##
## [[3]]
## [1] "f!"
##
## [[4]]
## [1] "g!" "h!" "i!"
# B
# Create a recursive function for calculating factorial
recursive_factorial <- function(n) {
# Stop if the supplied value is not a single non-negative integer
if (length(n) != 1 || n < 0 || n != floor(n)) {
stop("n must be a single non-negative integer")
}
# Stopping rule:
# The factorial of 0 is 1
if (n == 0) {
return(1)
}
# Recursive rule:
# n! = n × (n - 1)!
return(n * recursive_factorial(n - 1))
}
# Calculate 5 factorial
recursive_factorial(5)
## [1] 120
# Calculate 12 factorial
recursive_factorial(12)
## [1] 479001600
# Calculate 0 factorial
recursive_factorial(0)
## [1] 1
# C
# Create a function that calculates geometric means
# for numeric vectors and matrices contained in a list
geolist <- function(x) {
# Internal helper function for calculating
# the geometric mean of a numeric vector
geo_mean <- function(values) {
# Calculate the product of all values
# and raise it to the power of 1 divided by the number of values
prod(values)^(1 / length(values))
}
# Loop through every member of the supplied list
for (i in seq_along(x)) {
# Check whether the current member is a matrix
if (is.matrix(x[[i]])) {
# Calculate the geometric mean of every row
# and replace the matrix with the results
x[[i]] <- apply(
x[[i]],
MARGIN = 1,
FUN = geo_mean
)
} else {
# If the member is a vector,
# calculate one geometric mean for the entire vector
x[[i]] <- geo_mean(x[[i]])
}
}
# Return the modified list
return(x)
}
# C first test
# Create the first test list
foo <- list(
1:3,
# Create a matrix with 4 rows and 2 columns
matrix(
c(3.3, 3.2, 2.8, 2.1, 4.6, 4.5, 3.1, 9.4),
nrow = 4,
ncol = 2
),
# Create a matrix with 2 rows and 4 columns
matrix(
c(3.3, 3.2, 2.8, 2.1, 4.6, 4.5, 3.1, 9.4),
nrow = 2,
ncol = 4
)
)
# Calculate the geometric means
geolist(foo)
## [[1]]
## [1] 1.817121
##
## [[2]]
## [1] 3.896152 3.794733 2.946184 4.442972
##
## [[3]]
## [1] 3.388035 4.106080
#C second test
# Create the second test list
bar <- list(
# Numeric vector from 1 to 9
1:9,
# Matrix with 1 row and 9 columns
matrix(1:9, nrow = 1, ncol = 9),
# Matrix with 9 rows and 1 column
matrix(1:9, nrow = 9, ncol = 1),
# Matrix with 3 rows and 3 columns
matrix(1:9, nrow = 3, ncol = 3)
)
# Calculate the geometric means
geolist(bar)
## [[1]]
## [1] 4.147166
##
## [[2]]
## [1] 4.147166
##
## [[3]]
## [1] 1 2 3 4 5 6 7 8 9
##
## [[4]]
## [1] 3.036589 4.308869 5.451362
# 12
#EXCEPTIONS, TIMINGS,ANDVISIBILITY
# 12.1.1 Formal Notifications: Errors and Warnings
warn_test <- function(x){
if(x<=0){
warning("'x' is less than or equal to 0 but setting it to 1 and
continuing")
x <- 1
}
return(5/x)
}
x==0.7
## [1] FALSE
error_test <- function(x){
if(x<=0){
stop("'x' is less than or equal to 0... TERMINATE")
}
return(5/x)
}
x==0
## [1] FALSE
warn_test(0)
## Warning in warn_test(0): 'x' is less than or equal to 0 but setting it to 1 and
## continuing
## [1] 5
myfibrec2 <- function(n){
if(n<0){
warning("Assuming you meant 'n' to be positive-- doing that instead")
n <- n*-1
} else if(n==0){
stop("'n' is uninterpretable at 0")
}
if(n==1||n==2){
return(1)
} else {
return(myfibrec2(n-1)+myfibrec2(n-2))
}
}
myfibrec2(6)
## [1] 8
myfibrec2(-3)
## Warning in myfibrec2(-3): Assuming you meant 'n' to be positive-- doing that
## instead
## [1] 2
#12.1.2 Catching Errors with try Statements
attempt1 <- try(myfibrec2(0),silent=TRUE)
attempt1
## [1] "Error in myfibrec2(0) : 'n' is uninterpretable at 0\n"
## attr(,"class")
## [1] "try-error"
## attr(,"condition")
## <simpleError in myfibrec2(0): 'n' is uninterpretable at 0>
attempt2 <- try(myfibrec2(6),silent=TRUE)
# Using try in the Body of a Function
myfibvector <- function(nvec){
nterms <- length(nvec)
result <- rep(0,nterms)
for(i in 1:nterms){
result[i] <- myfibrec2(nvec[i])
}
return(result)
}
foo <- myfibvector(nvec=c(1,2,10,8))
foo
## [1] 1 1 55 21
myfibvectorTRY <- function(nvec){
nterms <- length(nvec)
result <- rep(0,nterms)
for(i in 1:nterms){
attempt <- try(myfibrec2(nvec[i]),silent=T)
if(class(attempt)=="try-error"){
result[i] <- NA
} else {
result[i] <- attempt
}
}
return(result)
}
#Suppressing Warning Messages
attempt3 <- try(myfibrec2(-3),silent=TRUE)
## Warning in myfibrec2(-3): Assuming you meant 'n' to be positive-- doing that
## instead
attempt3
## [1] 2
attempt4 <- suppressWarnings(myfibrec2(-3))
attempt4
## [1] 2
# exercise 12.1
# A
# Create a recursive factorial function
myfactorial <- function(x) {
# Stop the function if x is negative
if (x < 0) {
stop("x must be a non-negative integer")
}
# Stopping condition:
# The factorial of 0 is equal to 1
if (x == 0) {
return(1)
}
# Recursive calculation:
# x! = x multiplied by (x - 1)!
return(x * myfactorial(x - 1))
}
# to test
# Test with x equal to 5
myfactorial(5)
## [1] 120
# Test with x equal to 8
myfactorial(8)
## [1] 40320
# B
# Create a function that attempts to invert matrices in a list
invertlist <- function(x,
noninv = NA,
nonmat = "not a matrix",
silent = TRUE) {
# Check whether x is a list
if (!is.list(x)) {
stop("x must be a list")
}
# Check whether the list contains at least one member
if (length(x) == 0) {
stop("x must contain at least one member")
}
# Check whether nonmat is a character string
if (!is.character(nonmat)) {
# Convert nonmat to a character value
nonmat <- as.character(nonmat)
# Produce a warning to inform the user
warning("nonmat was not a character string and has been converted")
}
# Loop through every member of the list
for (i in seq_along(x)) {
# Check whether the current list member is a matrix
if (is.matrix(x[[i]])) {
# Attempt to calculate the inverse of the matrix
attempted_inverse <- try(
solve(x[[i]]),
silent = silent
)
# Check whether solve() produced an error
if (inherits(attempted_inverse, "try-error")) {
# Replace a non-invertible matrix with noninv
x[[i]] <- noninv
} else {
# Replace an invertible matrix with its inverse
x[[i]] <- attempted_inverse
}
} else {
# Replace a non-matrix member with nonmat
x[[i]] <- nonmat
}
}
# Return the modified list
return(x)
}
# test 1
# Create the first test list
test_x <- list(
1:4,
matrix(1:4, 1, 4),
matrix(1:4, 4, 1),
matrix(1:4, 2, 2)
)
# Run the function using the default arguments
invertlist(test_x)
## [[1]]
## [1] "not a matrix"
##
## [[2]]
## [1] NA
##
## [[3]]
## [1] NA
##
## [[4]]
## [,1] [,2]
## [1,] -2 1.5
## [2,] 1 -0.5
# test 2
# Use Inf for matrices that cannot be inverted
# Use 666 for members that are not matrices
# silent remains TRUE
invertlist(
x = test_x,
noninv = Inf,
nonmat = 666
)
## Warning in invertlist(x = test_x, noninv = Inf, nonmat = 666): nonmat was not a
## character string and has been converted
## [[1]]
## [1] "666"
##
## [[2]]
## [1] Inf
##
## [[3]]
## [1] Inf
##
## [[4]]
## [,1] [,2]
## [1,] -2 1.5
## [2,] 1 -0.5
#test 3
# Display the errors generated by solve()
invertlist(
x = test_x,
noninv = Inf,
nonmat = 666,
silent = FALSE
)
## Warning in invertlist(x = test_x, noninv = Inf, nonmat = 666, silent = FALSE):
## nonmat was not a character string and has been converted
## Error in solve.default(x[[i]]) : 'a' (1 x 4) must be square
## Error in solve.default(x[[i]]) : 'a' (4 x 1) must be square
## [[1]]
## [1] "666"
##
## [[2]]
## [1] Inf
##
## [[3]]
## [1] Inf
##
## [[4]]
## [,1] [,2]
## [1,] -2 1.5
## [2,] 1 -0.5
# test 4
# Create the second test list
test_x2 <- list(
# A 9 by 9 identity matrix
diag(9),
# A 3 by 3 matrix
matrix(
c(0.2, 0.4, 0.2,
0.1, 0.1, 0.2,
0.1, 0.1, 0.2),
3,
3
),
# A matrix created by combining vectors as rows
rbind(
c(5, 5, 1, 2),
c(2, 2, 1, 8),
c(6, 1, 5, 5),
c(1, 0, 2, 0)
),
# A 2 by 3 matrix
matrix(1:6, 2, 3),
# A matrix created by combining vectors as columns
cbind(
c(3, 5),
c(6, 5)
),
# A numeric vector, not a matrix
as.vector(diag(2))
)
# Replace matrices that cannot be inverted
# with the message "unsuitable matrix"
invertlist(
x = test_x2,
noninv = "unsuitable matrix"
)
## [[1]]
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
## [1,] 1 0 0 0 0 0 0 0 0
## [2,] 0 1 0 0 0 0 0 0 0
## [3,] 0 0 1 0 0 0 0 0 0
## [4,] 0 0 0 1 0 0 0 0 0
## [5,] 0 0 0 0 1 0 0 0 0
## [6,] 0 0 0 0 0 1 0 0 0
## [7,] 0 0 0 0 0 0 1 0 0
## [8,] 0 0 0 0 0 0 0 1 0
## [9,] 0 0 0 0 0 0 0 0 1
##
## [[2]]
## [1] "unsuitable matrix"
##
## [[3]]
## [,1] [,2] [,3] [,4]
## [1,] 0.019900498 -0.2288557 0.35820896 -0.79104478
## [2,] 0.203980100 0.1542289 -0.32835821 0.64179104
## [3,] -0.009950249 0.1144279 -0.17910448 0.89552239
## [4,] -0.054726368 0.1293532 0.01492537 -0.07462687
##
## [[4]]
## [1] "unsuitable matrix"
##
## [[5]]
## [,1] [,2]
## [1,] -0.3333333 0.4
## [2,] 0.3333333 -0.2
##
## [[6]]
## [1] "not a matrix"
# test 5 and 6 produce error
# PROGRESS AND TIMING
# 12.2.1 Textual Progress Bars: Are We There Yet?
Sys.sleep(3)
sleep_test <- function(n){
result <- 0
for(i in 1:n){
result <- result + 1
Sys.sleep(0.5)
}
return(result)
}
sleep_test(8)
## [1] 8
prog_test <- function(n){
result <- 0
progbar <- txtProgressBar(min=0,max=n,style=3,char="=")
for(i in 1:n){
result <- result + 1
Sys.sleep(0.5)
setTxtProgressBar(progbar,value=i)
}
close(progbar)
return(result)
}
prog_test(8)
## | | | 0% | |========= | 12% | |================== | 25% | |========================== | 38% | |=================================== | 50% | |============================================ | 62% | |==================================================== | 75% | |============================================================= | 88% | |======================================================================| 100%
## [1] 8
# 12.2.2 Measuring Completion Time: How Long Did It Take?
Sys.time()
## [1] "2026-10-02 17:47:33 WAT"
t1 <- Sys.time()
Sys.sleep(3)
t2 <- Sys.time()
t2-t1
## Time difference of 3.053498 secs
# a
# Create a function that displays a text progress bar
# The ellipsis (...) accepts extra arguments for txtProgressBar()
prog_test_fancy <- function(n, ...) {
# Create a progress bar starting at 0 and ending at n
progress_bar <- txtProgressBar(
min = 0,
max = n,
initial = 0,
...
)
# Run the loop from 1 up to n
for (i in 1:n) {
# Pause briefly so that the progress can be seen
Sys.sleep(0.1)
# Update the progress bar during every loop
setTxtProgressBar(progress_bar, i)
}
# Close the progress bar after the loop finishes
close(progress_bar)
}
# Measure how long the function takes to run
system.time(
prog_test_fancy(
n = 50,
style = 3,
char = "x"
)
)
## | | | 0% | |x | 2% | |xxx | 4% | |xxxx | 6% | |xxxxxx | 8% | |xxxxxxx | 10% | |xxxxxxxx | 12% | |xxxxxxxxxx | 14% | |xxxxxxxxxxx | 16% | |xxxxxxxxxxxxx | 18% | |xxxxxxxxxxxxxx | 20% | |xxxxxxxxxxxxxxx | 22% | |xxxxxxxxxxxxxxxxx | 24% | |xxxxxxxxxxxxxxxxxx | 26% | |xxxxxxxxxxxxxxxxxxxx | 28% | |xxxxxxxxxxxxxxxxxxxxx | 30% | |xxxxxxxxxxxxxxxxxxxxxx | 32% | |xxxxxxxxxxxxxxxxxxxxxxxx | 34% | |xxxxxxxxxxxxxxxxxxxxxxxxx | 36% | |xxxxxxxxxxxxxxxxxxxxxxxxxxx | 38% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxx | 40% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 42% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 44% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 46% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 48% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 50% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 52% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 54% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 56% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 58% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 60% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 62% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 64% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 66% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 68% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 70% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 72% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 74% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 76% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 78% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 80% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 82% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 84% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 86% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 88% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 90% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 92% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 94% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 96% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx | 98% | |xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx| 100%
## user system elapsed
## 0.01 0.00 5.61
# b
# Create a recursive function that calculates
# one Fibonacci number
myfib2 <- function(n) {
# Stop the function for invalid input
if (length(n) != 1 || n < 1 || n != floor(n)) {
stop("n must be a positive integer")
}
# The first two Fibonacci numbers are both 1
if (n == 1 || n == 2) {
return(1)
}
# Recursive rule
return(myfib2(n - 1) + myfib2(n - 2))
}
# Create a function that calculates several Fibonacci terms
# and displays a progress bar
myfibvectorTRY_progress <- function(nvec, char = "=") {
# Check that nvec is numeric
if (!is.numeric(nvec)) {
stop("nvec must be a numeric vector")
}
# Create an empty numeric vector for the answers
result <- numeric(length(nvec))
# Create a style-3 progress bar
progress_bar <- txtProgressBar(
min = 0,
max = length(nvec),
initial = 0,
style = 3,
char = char
)
# Loop through every value in nvec
for (i in seq_along(nvec)) {
# try() prevents the whole function from stopping
# when one Fibonacci calculation produces an error
attempt <- try(
myfib2(nvec[i]),
silent = TRUE
)
# Check whether an error occurred
if (inherits(attempt, "try-error")) {
# Store NA when the calculation fails
result[i] <- NA
} else {
# Store the calculated Fibonacci number
result[i] <- attempt
}
# Update the progress bar after each calculation
setTxtProgressBar(progress_bar, i)
}
# Close the progress bar
close(progress_bar)
# Return the calculated values
return(result)
}
#test 1
# Supply the term numbers given in the exercise
nvec <- c(3, 2, 7, 0, 9, 13)
# Calculate the corresponding Fibonacci numbers
myfibvectorTRY_progress(
nvec = nvec,
char = "#"
)
## | | | 0% | |############ | 17% | |####################### | 33% | |################################### | 50% | |############################################### | 67% | |########################################################## | 83% | |######################################################################| 100%
## [1] 2 1 13 NA 34 233
# Test (ii): Calculate the first 35 Fibonacci terms
# Create a vector containing term numbers 1 to 35
first_35 <- 1:35
# Measure the time taken by the recursive function
recursive_time <- system.time(
recursive_result <- myfibvectorTRY_progress(
nvec = first_35,
char = "*"
)
)
## | | | 0% | |** | 3% | |**** | 6% | |****** | 9% | |******** | 11% | |********** | 14% | |************ | 17% | |************** | 20% | |**************** | 23% | |****************** | 26% | |******************** | 29% | |********************** | 31% | |************************ | 34% | |************************** | 37% | |**************************** | 40% | |****************************** | 43% | |******************************** | 46% | |********************************** | 49% | |************************************ | 51% | |************************************** | 54% | |**************************************** | 57% | |****************************************** | 60% | |******************************************** | 63% | |********************************************** | 66% | |************************************************ | 69% | |************************************************** | 71% | |**************************************************** | 74% | |****************************************************** | 77% | |******************************************************** | 80% | |********************************************************** | 83% | |************************************************************ | 86% | |************************************************************** | 89% | |**************************************************************** | 91% | |****************************************************************** | 94% | |******************************************************************** | 97% | |**********************************************************************| 100%
# Display the Fibonacci values
recursive_result
## [1] 1 1 2 3 5 8 13 21 34
## [10] 55 89 144 233 377 610 987 1597 2584
## [19] 4181 6765 10946 17711 28657 46368 75025 121393 196418
## [28] 317811 514229 832040 1346269 2178309 3524578 5702887 9227465
# Display the execution time
recursive_time
## user system elapsed
## 74.65 0.28 98.73
# c
# Set the number of Fibonacci terms required
n <- 35
# Create a numeric vector with space for 35 values
fib_loop <- numeric(n)
# Set the first Fibonacci number
fib_loop[1] <- 1
# Set the second Fibonacci number
fib_loop[2] <- 1
# Measure the time taken by the loop
loop_time <- system.time({
# Calculate terms 3 through 35
for (i in 3:n) {
# Each term is the sum of the previous two terms
fib_loop[i] <- fib_loop[i - 1] + fib_loop[i - 2]
}
})
# Display the first 35 Fibonacci numbers
fib_loop
## [1] 1 1 2 3 5 8 13 21 34
## [10] 55 89 144 233 377 610 987 1597 2584
## [19] 4181 6765 10946 17711 28657 46368 75025 121393 196418
## [28] 317811 514229 832040 1346269 2178309 3524578 5702887 9227465
# Display the execution time
loop_time
## user system elapsed
## 0 0 0
# Time the recursive approach
recursive_time <- system.time(
recursive_result <- myfibvectorTRY_progress(
1:35,
char = "*"
)
)
## | | | 0% | |** | 3% | |**** | 6% | |****** | 9% | |******** | 11% | |********** | 14% | |************ | 17% | |************** | 20% | |**************** | 23% | |****************** | 26% | |******************** | 29% | |********************** | 31% | |************************ | 34% | |************************** | 37% | |**************************** | 40% | |****************************** | 43% | |******************************** | 46% | |********************************** | 49% | |************************************ | 51% | |************************************** | 54% | |**************************************** | 57% | |****************************************** | 60% | |******************************************** | 63% | |********************************************** | 66% | |************************************************ | 69% | |************************************************** | 71% | |**************************************************** | 74% | |****************************************************** | 77% | |******************************************************** | 80% | |********************************************************** | 83% | |************************************************************ | 86% | |************************************************************** | 89% | |**************************************************************** | 91% | |****************************************************************** | 94% | |******************************************************************** | 97% | |**********************************************************************| 100%
# Time the loop approach
loop_time <- system.time({
fib_loop <- numeric(35)
fib_loop[1:2] <- c(1, 1)
for (i in 3:35) {
fib_loop[i] <- fib_loop[i - 1] + fib_loop[i - 2]
}
})
# Display both execution times
recursive_time
## user system elapsed
## 61.93 0.24 72.12
loop_time
## user system elapsed
## 0.01 0.00 0.03