吴裕雄--天生自然 R语言开发学习：高级编程

运行的条件是一元逻辑向量（TRUE或FALSE）并且不能有缺失（NA）。else部分是可选的。如果
仅有一个语句，花括号也是可以省略的。
下面的代码片段是一个例子：
if(interactive()){
 plot(x, y)
} else {
 png("myplot.png")
 plot(x, y)
 dev.off()
}
如果代码交互运行，interactive()函数返回TRUE，同时输出一个曲线图。否则，曲线图被存
在磁盘里。你可以使用第21章中的if()函数。
. ifelse()
ifelse()是函数if()的量化版本。矢量化允许一个函数来处理没有明确循环的对象。
ifelse()的格式是：
ifelse(test, yes, no)
其中test是已强制为逻辑模式的对象，yes返回test元素为真时的值，no返回test元素为假时
的值。
比如你有一个p值向量，是从包含六个统计检验的统计分析中提取出来的，并且你想要标记
p<.05水平下的显著性检验。可以使用下面的代码：
> pvalues <- c(., ., ., ., ., .)
> results <- ifelse(pvalues <., "Significant", "Not Significant")
> results
[] "Not Significant" "Significant" "Significant"
[] "Not Significant" "Significant" "Not Significant"
ifelse()函数通过pvalues向量循环并返回一个包括"Significant"或"Not Significant"
的字符串。返回的结果依赖于pvalues返回的值是否大于0.。
同样的结果可以使用显式循环完成：
pvalues <- c(., ., ., ., ., .)
results <- vector(mode="character", length=length(pvalues))
for(i in :length(pvalues)){
 if (pvalues[i] < .) results[i] <- "Significant"
 else results[i] <- "Not Significant"
}
可以看出，向量化的版本更快且更有效。
有一些其他的控制结构，包括while()、repeat()和switch()，但是这里介绍的是最常用
的。有了数据结构和控制结构，我们就可以讨论创建函数了。

20.1. 创建函数
在R中处处是函数。算数运算符+、-、/和*实际上也是函数。例如， + 2等价于 "+"(, )。
本节将主要描述函数语法。语句环境将在20-2节描述。
. 函数语法
函数的语法格式是：
functionname <- function(parameters){
statements
 return(value)
}
如果函数中有多个参数，那么参数之间用逗号隔开。
参数可以通过关键字和/或位置来传递。另外，参数可以有默认值。请看下面的函数：
f <- function(x, y, z=){
 result <- x + (*y) + (*z)
 return(result)
}
> f(,,)
[]
> f(,)
[]
> f(x=, y=)
[]
> f(z=, y=, )
[]
在第一个例子中，参数是通过位置（x=，y=，z=）传递的。在第二个例子中，参数也是通过
位置传递的，并且z默认为1。在第三个例子中，参数是通过关键字传递的，z也默认为1。在最后
一个例子中，y和z是通过关键字传递的，并且x被假定为未明确指定的（这里x=）第一个参数。
参数是可选的，但即使没有值被传递也必须使用圆括号。return()函数返回函数产生的对
象。它也是可选的；如果缺失，函数中最后一条语句的结果也会被返回。
你可以使用args()函数来观测参数的名字和默认值：
> args(f)
 function (x, y, z = )
 NULL
args()被设计用于交互式观测。如果你需要以编程方式获取参数名称和默认值，可以使用
formals()函数。它返回含有必要信息的列表。
参数是按值传递的，而不是按地址传递。请看下面这个函数语句：
result <- lm(height ~ weight, data=women)
women数据集不是直接得到的。需要形成一个副本然后传递给函数。如果women数据集很大的话，
内存（RAM）可能被迅速用完。这可能成为处理大数据问题时的难题能需要使用特殊的技术（见

#--------------------------------------------------------------------#
# R in Action (2nd ed): Chapter                                    #
# Advanced R programming                                             #
# requires packages ggplot2, reshape2, foreach, doParallel           #
# install.packages(c("ggplot2", "reshap2e", "foreach", "doParallel"))#
#--------------------------------------------------------------------#

# Atomic vectors
passed <- c(TRUE, TRUE, FALSE, TRUE)
ages <- c(, , , , )
cmplxNums <- c(+2i, +1i, +3i, +2i)
names <- c("Bob", "Ted", "Carol", "Alice")

# Matrices
x <- c(,,,,,,,)
class(x)
print(x)
attr(x, "dim") <- c(,)
print(x)
class(x)
attributes(x)
attr(x, "dimnames") <- list(c("A1", "A2"),
                            c("B1", "B2", "B3", "B4"))
print(x)
attr(x, "dim") <- NULL
class(x)
print(x)

# Generic vectors (lists)
head(iris)
unclass(iris)
attributes(iris)

set.seed()
fit <- kmeans(iris[:], )
names(fit)
unclass(fit)
sapply(fit, class)

# Indexing atomic vectors
x <- c(, , )
x[]
x[c(,)]
x <- c(A=, B=, C=)
x[c(,)]
x[c("B", "C")]

# Indexing lists
fit[c(,)]
fit[]
fit[[]]
fit$centers
fit[[]][,]
fit$centers$Petal.Width  # should give an error

# Listing 20.1 - Plotting the centroides from a k-mean cluster analysis
fit <- kmeans(iris[:], )
means <- fit$centers
library(reshape2)
dfm <- melt(means)
names(dfm) <- c("Cluster", "Measurement", "Centimeters")
dfm$Cluster <- factor(dfm$Cluster)
head(dfm)
library(ggplot2)
ggplot(data=dfm,
       aes(x=Measurement, y=Centimeters, group=Cluster)) +
  geom_point(size=, aes(shape=Cluster, color=Cluster)) +
  geom_line(size=, aes(color=Cluster)) +
  ggtitle("Profiles for Iris Clusters") 

# for loops
for(i in :) print(:i)
for(i in :)print(:i)

# ifelse
pvalues <- c(., ., ., ., ., .)
results <- ifelse(pvalues <., "Significant", "Not Significant")
results

pvalues <- c(., ., ., ., ., .)
results <- vector(mode="character", length=length(pvalues))
for(i in :length(pvalues)){
  if (pvalues[i] < .) results[i] <- "Significant"
  else results[i] <- "Not Significant"
}
results

# Creating functions
f <- function(x, y, z=){
  result <- x + (*y) + (*z)
  return(result)
}

f(,,)
f(,)
f(x=, y=)
f(z=, y=, )
args(f)

# object scope
x <-
y <-
z <-
f <- function(w){
  z <-
  x <- w*y*z
  return(x)
}
f(x)
x
y
z

# Working with environments
x <-
myenv <- new.env()
assign("x", "Homer", env=myenv)
ls()
ls(myenv)
x
get("x", env=myenv)

myenv <- new.env()
myenv$x <- "Homer"
myenv$x

parent.env(myenv)

# function closures
trim <- function(p){
  trimit <- function(x){
    n <- length(x)
    lo <- floor(n*p) +
    hi <- n +  - lo
    x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
  }
  trimit
}
x <- :
trim10pct <- trim(.)
y <- trim10pct(x)
y
trim20pct <- trim(.)
y <- trim20pct(x)
y

ls(environment(trim10pct))
get("p", env=environment(trim10pct))

makeFunction <- function(k){
  f <- function(x){
    print(x + k)
  }
}

g <- makeFunction()
g ()
k <-
g ()

ls(environment(g))
environment(g)$k

# Generic functions
summary(women)
fit <- lm(weight ~ height, data=women)
summary(fit)

class(women)
class(fit)
methods(summary)

# Listing 20.2 - An example of a generic function
mymethod <- function(x, ...) UseMethod("mymethod")
mymethod.a <- function(x) print("Using A")
mymethod.b <- function(x) print("Using B")
mymethod.default <- function(x) print("Using Default")

x <- :
y <- :
z <- :
class(x) <- "a"
class(y) <- "b"

mymethod(x)
mymethod(y)
mymethod(z)

class(z) <- c("a", "b")
mymethod(z)
class(z) <- c("c", "a", "b")
mymethod(z)

# Vectorization and efficient code
set.seed()
mymatrix <- matrix(rnorm(), ncol=)
accum <- function(x){
  sums <- numeric(ncol(x))
  for (i in :ncol(x)){
    for(j in :nrow(x)){
      sums[i] <- sums[i] + x[j,i]
    }
  }
}
system.time(accum(mymatrix))   # using loops
system.time(colSums(mymatrix)) # using vectorization

# Correctly size objects
set.seed()
k <-
x <- rnorm(k)

y <-
system.time(for (i in :length(x)) y[i] <- x[i]^)

y <- numeric(k)
system.time(for (i in :k) y[i] <- x[i]^)

y <- numeric(k)
system.time(y <- x^)

# Listing 20.3 - Parallelization with foreach and doParallel
library(foreach)
library(doParallel)
registerDoParallel(cores=)

eig <- function(n, p){
  x <- matrix(rnorm(), ncol=)
  r <- cor(x)
  eigen(r)$values
}
n <-
p <-
k <- 

system.time(
  x <- foreach(i=:k, .combine=rbind) %do% eig(n, p)
)

system.time(
  x <- foreach(i=:k, .combine=rbind) %dopar% eig(n, p)
)

# Finding common errors
mtcars$Transmission <- factor(mtcars$a,
                              levels=c(,),
                              labels=c("Automatic", "Manual"))
aov(mpg ~ Transmission, data=mtcars) # generates error
head(mtcars[c("mpg", "Transmission")])
table(mtcars$Transmission) # here is the source of the error

# Listing 20.4 - A sample debugging session
args(mad)
debug(mad)
mad(:)
# enters debugging mode
# Q to quit - see text
undebug(mad)

# Listing 20.5 - Sample debugging session with recover()
f <- function(x, y){
  z <- x + y
  g(z)
}
g <- function(x){
  z <- round(x)
  h(z)
}

h <- function(x){
  set.seed()
  z <- rnorm(x)
  print(z)
}
options(error=recover)

f(,)
f(, -) # enters debugging mode at this point