Re: [問題] 表格轉換生成新標籤與區間對照

看板R_Language作者celestialgod (天)時間7年前 (2017/04/12 21:12)推噓6(6推 0噓 4→)

留言10則, 1人參與討論串2/3 (看更多)

※ 引述《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回來就好 -- R資料整理套件系列文： magrittr #1LhSWhpH (R_Language) https://goo.gl/72l1m9 data.table #1LhW7Tvj (R_Language) https://goo.gl/PZa6Ue dplyr(上.下) #1LhpJCfB,#1Lhw8b-s (R_Language) https://goo.gl/I5xX9b tidyr #1Liqls1R (R_Language) https://goo.gl/i7yzAz pipeR #1NXESRm5 (R_Language) https://goo.gl/zRUISx -- ※ 發信站: 批踢踢實業坊(ptt.cc), 來自: 36.233.82.44 ※ 文章網址: https://www.ptt.cc/bbs/R_Language/M.1492002777.A.1A7.html

推

YangPeiHung

04/13 10:10, , 1^F

04/13 10:10, 1^F

→

YangPeiHung

04/13 10:12, , 2^F

04/13 10:12, 2^F

→

YangPeiHung

04/13 10:13, , 3^F

04/13 10:13, 3^F