※ 引述《YangPeiHung (杨培宏)》之铭言：
: [问题类型]:
: 程式咨询(我想用R 做某件事情，但是我不知道要怎么用R 写出来)
: [软件熟悉度]:
: 入门(写过其他程式，只是对语法不熟悉)
: [问题叙述]:
: 目前有4个学生与不同科目的试题共10份，由电脑随机控制他们可以作答的时间间隔，
: 想要观察的是他们在同时作答的时候的考试表现，资料格式如下
: Examtable
: StudentID examID start(sec) end(sec) average(score/sec)
: 001 1 A D 0.05
: 001 1 G K 0.63
: ...以此类推
: 因为要转换成一个自创的标签为：(examID)-(start)-(end)
: 要观察他们的同时作答秒数区间，就要把每个人在同一份试卷的作答秒数区间取交集
: 例如：红色为有作答的秒数
: start|ABCD|EF|GHIJK|LMNO|PQRS|TUVW|XYZ12345|end 学生1
: start|ABCDE|FGH|IJKLMN|OPQ|RSTUVWXYZ|12|345|end 学生2
: start|ABCD|EFGH|IJK|LMNOPQ|RS|TUVW|XYZ|12|345|end 取交集
: 新的标签就是1-A-D 1-I-K 1-R-S 1-X-Z 1-3-5 ，以此类推，
: 并且做出一个新的table
: rownames就是新标签，colnames是studentID 中间要填入的就是average(score/sec)
: （这里假设在作答秒数内分数分配为uniform，
: 并且每份试卷的最开始与最后结束考试时间等长）
: StudentID_1 StudentID_2 ......
: 1-(A)-(D) 0.05 score/sec ......
: 1-(I)-(K) 0.63 score/sec ......
: ....以此类推
: [程式范例]:
: 取intersect的程式码运行上没有问题
: 但是不知道如何回测并且生成新标签与填入平均分数
: for (i in 1:10){
: ExamTemp<- Examtable[,c(1:4)]
: ExamTemp1<-subset(ExamTemp, ExamTemp$examID =="i")[,-2]
: intersect<-function(start, end, id, overlap=length(unique(id))) {
: dd<-rbind(data.frame(pos=start, event=1), data.frame(pos=end, event=-1))
: dd<-aggregate(event~pos, dd, sum)
: dd<-dd[order(dd$pos),]
: dd$open <- cumsum(dd$event)
: r<-rle(dd$open>=overlap)
: ex<-cumsum(r$lengths-1 + rep(1, length(r$lengths)))
: sx<-ex-r$lengths+1
: cbind(dd$pos[sx[r$values]],dd$pos[ex[r$values]+1])
: }
: with(ExamTemp1, intersect(Start,End,StudentID,length(unique(StudentID)))) ->df
: 如何利用df这个intersect的矩阵回测原本的资料并且填入新标签与平均
: }
: [环境叙述]:
: R-3.3.2
这问题，我觉得解起来好难XD
而且我看不懂你的intersect的思维Orz，只好自己干一个XD
好读版：https://pastebin.com/8R1iXjcz
library(foreach)
library(iterators)
library(data.table)
library(pipeR)
# data generation
set.seed(10)
k <- 1
outList <- foreach(v = iter(matrix(sample(3:29, 6000, TRUE), 1000),
by = "row")) %:% when(k <= 4) %do%
{
if (all(diff(sort(v)) > 2)) {
k <- k + 1
return(data.table(studentID = k, matrix(c(1, sort(v), 31), 4, 2, TRUE,
list(NULL, c("Start", "End")))))
} else return(NULL)
}
outDT <- rbindlist(outList) %>>%
`[`(j = `:=`(studentID = match(studentID, sort(unique(studentID))),
avgScore = abs(rnorm(nrow(.)))))
# studentID Start End avgScore
# 1: 1 1 3 0.4605151
# 2: 1 6 10 0.2350253
# 3: 1 19 22 0.6432573
# 4: 1 25 31 0.9131981
# 5: 2 1 4 0.9882860
# 6: 2 7 11 0.1127413
# 7: 2 16 20 1.4900499
# 8: 2 26 31 0.4432356
# 9: 3 1 5 1.3623441
# 10: 3 10 14 1.0452357
# 11: 3 21 25 0.2339315
# 12: 3 28 31 2.5524180
# 13: 4 1 4 1.7687187
# 14: 4 7 10 0.6595706
# 15: 4 19 23 0.3707332
# 16: 4 26 31 0.5928033
# find overlap
iter <- isplit(outDT, outDT$studentID)
resDT <- copy(iter$nextElem()$value) %>>% `[`(j = `:=`(studentID = NULL))
setkey(resDT, Start, End)
while (TRUE) {
v <- tryCatch(iter$nextElem(), error = function(e) e)
if (any(class(v) == "error"))
break
resDT <- foverlaps(v$value, resDT, type = "any", nomatch = 0) %>>%
`[`(j = `:=`(Start = pmax(Start, i.Start), End = pmin(End, i.End))) %>>%
`[`(j = .(Start, End))
setkey(resDT, Start, End)
}
# Start End
# 1: 1 3
# 2: 10 10
# 3: 28 31
# 得到最后的答案
finalResDT <- foreach(it = isplit(outDT, outDT$studentID), .final =
rbindlist) %do%
{
foverlaps(it$value, resDT, type = "any", nomatch = 0) %>>%
`[`(j = avgScore := (i.End-End+1)/(Start-i.Start+1) * avgScore) %>>%
`[`(j = .(Start, End, studentID, avgScore))
} %>>% dcast(Start + End ~ studentID, val.var = "avgScore") %>>%
setnames(as.character(1:(ncol(.)-2)), paste0("studentID-", 1:(ncol(.)-2)))
# Start End studentID-1 studentID-2 studentID-3 studentID-4
# 1: 1 3 0.46051506 1.97657201 4.087032 3.5374375
# 2: 10 10 0.04700506 0.05637067 5.226179 0.1648927
# 3: 28 31 0.22829953 0.14774520 2.552418 0.1976011
有十个考试就把后面两段code包成函数，一次丢一个考试的outDT进来计算
最后合并再记得多加一个examID回来就好