R语言基础编程技巧汇编 - 24

1. 按列的值合并数据

原始数据：

Date Hour1 Hour2Hour3 Hour4 Hour5 ... Hour15

9-15 0 0 0 1 1 ... 0

9-15 0 1 1 1 1 ... 0

9-16 0 1 1 1 0 ... 0

9-16 0 0 0 0 0 ... 1

9-16 1 1 0 0 0 ... 1

9-18 0 1 0 1 1 ... 0

.

.

.

11-7 0 1 1 1 0 ... 0

需要的结果：

Hour1 Hour2 Hour3 Hour4 Hour5 ... Hour15

9-15 5 10 15 25 45 ... 20

9-16 5 6 25 28 15 ... 11

9-17 3 45 42 6 17 ... 32

9-18 5 10 15 25 45 ... 20

.

.

.

11-7 12 36 84 9 7 ... 21

df <-structure(list(Date = structure(c(2L, 2L, 3L, 3L, 3L, 4L, 1L), .Label =c("11-7", "9-15", "9-16", "9-18"),class = "factor"), Hour1 = c(0L, 0L, 0L, 0L, 1L, 0L, 0L), Hour2 =c(0L, 1L, 1L, 0L, 1L, 1L, 1L),
Hour3 = c(0L, 1L, 1L, 0L, 0L, 0L, 1L), Hour4 =c(1L, 1L, 1L, 0L, 0L, 1L, 1L), Hour5 = c(1L, 1L, 0L, 0L, 0L, 1L, 0L), Hour15 =c(0L, 0L, 0L, 1L, 1L, 0L, 0L)), .Names = c("Date", "Hour1","Hour2", "Hour3", "Hour4", "Hour5","Hour15"), class = "data.frame", row.names
= c(NA, -7L))

require(dplyr)

df %>% group_by(Date) %>% summarise_each(funs(sum))

2.
“[[.data.frame”函数源代码中“..1”的含义

以下是“[[.data.frame”函数的代码部分：

> body('[[.data.frame')

{

na <- nargs() - (!missing(exact))

if (!all(names(sys.call()) %in% c("", "exact")))

warning("named arguments other than 'exact' are discouraged")

if (na < 3L)

(function(x, i, exact) if (is.matrix(i))

as.matrix(x)[[i]]

else .subset2(x, i, exact = exact))(x, ..., exact = exact)

else {

col <- .subset2(x, ..2, exact = exact)

i <- if (is.character(..1))

pmatch(..1, row.names(x), duplicates.ok = TRUE)

else ..1

col[[i, exact = exact]]

}

}

可以看见里面有..1，..2这样的字符，它们是用于引用…中的参数的，..1表示…中第一个参数，..2表示…中第二个参数，以此类推。

3. curve3d绘制三维曲线

library(emdbook)

# bivariate normal density with emdbook::curve3d

curve3d(expr = dmvnorm(x=c(x,y), mu = c(0,0), Sigma= diag(2)),

from =c(-3,-3), to = c(3,3), n = 100, sys3d = "wireframe")

4. 绘制Venn维恩图（集合图）

require(venneuler)

#here I replicateyour data

#because it'srepeatable, you can use `rep` function to generate it

c1 <-rep(c(0,1),each=8)

c2 <-rep(c(0,1),each=4,times=2)

c3 <-rep(c(0,1),each=2,times=4)

c4 <-rep(c(0,1),times=8)

#put your datainto matrix

m <-as.matrix(data.frame(C1=c1,C2=c2,C3=c3,C4=c4))

#plot it

v = venneuler(m)

plot(v)

5. 按照一定比例生成采样数据

set.seed(1); x<- sample(0:1, 100, replace=TRUE, prob=c(.3, .7)); table(x)

# x

# 0 1

# 32 68

set.seed(2); x <-sample(0:1, 100, replace=TRUE, prob=c(.3, .7)); table(x)

# x

# 0 1

# 31 69

set.seed(1); x<- sample(0:1, 100, replace=TRUE, prob=c(.2, .8)); table(x)

# x

# 0 1

# 17 83

set.seed(2); x<- sample(0:1, 100, replace=TRUE, prob=c(.2, .8)); table(x)

# x

# 0 1

# 23 77

6. 设置高维数组的名字

ar <-array(data = 1:27,

dim = c(3, 3, 3),

dimnames = list(c("a","b", "c"),

c("d","e", "f"),

c("g","h", "i")))

或者

dimnames(ar)[[3]]<- c("G", "H", "I")

7. 实现有运动效果的图

#basic plot

plot(NULL, ann =F, xlim = c(-10,20), ylim = c(-10,20))

abline(h = -10:20,col = grey(0.75), lty = 2)

abline(v = -10:20,col = grey(0.75), lty = 2)

#startingcoordinates

A_coords = c(0,0)

B_coords = c(10,0)

text(A_coords[1],A_coords[2], "A", col = "red")

text(B_coords[1],B_coords[2], "B", col = "blue")

for(i in 1:15000)

{

Sys.sleep(1)

text(A_coords[1], A_coords[2], "A",col = "white")

text(B_coords[1], B_coords[2], "B",col = "white")

#used jonas's idea

A <- A_coords + unlist(sample(list(c(0,1), c(1, 0), c(-1, 0), c(0, -1)), 1))

B <- B_coords + unlist(sample(list(c(0,1), c(1, 0), c(-1, 0), c(0, -1)), 1))

lines(c(A_coords[1], A[1]), c(A_coords[2],A[2]), col = "red")

lines(c(B_coords[1], B[1]), c(B_coords[2],B[2]), col = "blue")

A_coords <- A

B_coords <- B

text(A_coords[1], A_coords[2], "A",col = "red")

text(B_coords[1], B_coords[2], "B",col = "blue")

if(all(abs(A_coords - B_coords) <= 1))break

}

list(steps = i,A_coordinates = A_coords, B_coordinates = B_coords)



plot_robots <-function(rob1, rob2){

plot(1, xlim = c(-20, 20), ylim =c(-20, 20),type = "n", xaxs = "i", yaxs = "i")

abline(h =-20:20, v = -20:20)

points(c(rob1[1], rob2[1]), c(rob2[2],rob2[2]), pch = 21, cex = 2, bg = c("red", "blue"))

}

rob1 <- c(0, 0)

rob2 <- c(10,0)

plot_robots(rob1,rob2)

for(i in 1:15000){

rob1 <- rob1 + sample(list(c(0, 1), c(1,0), c(-1, 0), c(0, -1)), 1)[[1]]

rob2 <- rob2 + sample(list(c(0, 1), c(1,0), c(-1, 0), c(0, -1)), 1)[[1]]

plot_robots(rob1, rob2)

Sys.sleep(.1)

}

8. 得到R的安装路径

.libPaths()

[1]"C:/Program Files/R/R-3.1.2/library"

9. 利用match函数对数据框的行排序

df <-data.frame(name=letters[1:4], value=c(rep(TRUE, 2), rep(FALSE, 2)))

target <-c("b", "c", "a", "d")

df[match(target,df$name),]

name value

2 b TRUE

3 c FALSE

1 a TRUE

4 d FALSE

10. 利用rapply函数递归地在list中应用函数

( x <-list(list(a = c("a,b,c", "d,e,f"), b =c("1,2,a,b,c,d", "3,4,e,f,g,h"))) )

rapply(x,function(y) do.call(rbind, strsplit(y, ",", TRUE)), how = "replace")

# [[1]]

# [[1]]$a

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

# [1,]"a" "b" "c"

# [2,]"d" "e" "f"

#

# [[1]]$b

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

# [1,]"1" "2" "a" "b" "c" "d"

# [2,]"3" "4" "e" "f" "g" "h"

11. 利用bc包显示1000位的Pi值

library(bc)

bc("4 * a(1)",scale = 1000)

[1]"3.1415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116094330572703657595919530921861173819326117931051185480744623799627495673518857527248912279381830119491298336733624406566430860213949463952247371907021798609437027705392171762931767523846748184676694051320005681271452635608277857713427577896091736371787214684409012249534301465495853710507922796892589235420199561121290219608640344181598136297747713099605187072113499999983729780499510597317328160963185950244594553469083026425223082533446850352619311881710100031378387528865875332083814206171776691473035982534904287554687311595628638823537875937519577818577805321712268066130019278766111959092164201988"

12. 把所有的list元素转化为原子向量示例

flatten.list <- function(x){

y<- list()

while(is.list(x)){

id <- sapply(x,is.atomic)

y<- c(y,x[id])

x<- unlist(x[!id],recursive=FALSE)

}

y

}

x <- list(

list(1:3, 4:6),

7:8,

list( list( list(9:11, 12:15), 16:20 ), 21:24 )

)

> flatten.list(x)

[[1]]

[1] 7 8

[[2]]

[1] 1 2 3

[[3]]

[1] 4 5 6

[[4]]

[1] 21 22 23 24

13. 得到包的作者列表

getauthors <- function(package){

db <- tools::Rd_db(package)

authors <- lapply(db,function(x) {

tags <- tools:::RdTags(x)

if("\\author" %in% tags){

# return a crazy list of results

#out <- x[which(tmp=="\\author")]

# return something a little cleaner

out <-paste(unlist(x[which(tags=="\\author")]),collapse="")

}

else

out <- NULL

invisible(out)

})

gsub("\n","",unlist(authors)) # further cleanup

}

getauthors('base')

得到以下输出：

agrep.Rd

" Original version in < 2.10.0 by David Meyer. Current version by Brian Ripley and KurtHornik."

aperm.Rd

"JonathanRougier, J.C.Rougier@durham.ac.uk did the faster C implementation."

as.environment.Rd

"John Chambers "

as.function.Rd

14. 根据不同的值设置散点图点的样式

#dummy data

my_data <- read.table(text="X VALUE LABEL COLOR

1 78 T041N2 3

2 77 T018N3 2

3 97 T014N3 1

4 0 T149N4 1

5 62 T043N1 3

6 66 T018N3 3

7 56 T145N4 3

8 63 T019N4 1

9 82 T039N0 1

10 75 T018N3 1

11 76 T018N3 1

12 63 T043N1 2

13 0 T149N4 2

14 73 T019N4 2

15 77 T019N4 3

16 100 T149N4 3

17 92 T043N1 3", header=TRUE)

mycols<-c("red","green","yellow")

#using base plot

plot(my_data$VALUE, pch=19,bty="n",col=mycols[my_data$COLOR],main="Using base R")

lines(my_data$VALUE, type="b")

text(my_data$VALUE, y = NULL,

labels = my_data$LABEL,

adj = NULL, pos = 3,

offset = 0.5, vfont = NULL,cex = 0.5, col = NULL, font = NULL)

15. 判断一个字符串是不是合法的formula

formula.test <- function(x){

ifelse( class(x)=="formula", "This is a formula, you cango ahead!",

stop("This is not a formula, we must stop here."))

}

formula.test(y ~ x1*x2) # this is OK

formula.test("a") # stops execution and throws an error

formula.test(1) # stops execution and throws an error

或者

foo <- y ~ x

inherits(foo, "formula")

## [1] TRUE

foo <- 1

if (!inherits(foo, "formula"))stop("foo isn't a formula")

## Error: foo isn't a formula