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