作者celestialgod (攸藍)
看板R_Language
標題Re: [問題] 一維陣列相臨值取平均的實作
時間Fri Jul 24 09:14:22 2015
nxply <- function(x, n, FUN, na.rm = FALSE, ...){
if (!is.vector(x))
stop("The input must be a vector.")
if (na.rm)
x = na.omit(x)
if (length(n) == 1)
n <- rep(n, 2)
if (all(n == 0))
return(sapply(x, function(y) FUN(y, ...)))
if (sum(n)+1 > length(x))
stop("The number of proximity number is more than the length of vector.")
ns <- sum(n)
out <- vector('numeric', length(x))
if (n[2] > 0)
for (i in 1:n[2])
out[i] <- FUN(head(x,n[1]+i), ...)
if (n[1] > 0)
for (i in 1:n[1])
out[length(x)-i+1] <- FUN(tail(x,n[2]+i), ...)
for (i in 1:(length(x)-ns))
out[n[2]+i] <- FUN(x[i:(ns+i)], ...)
return(out)
}
nxply(1:5, 0, mean)
nxply(1:5, 1, mean)
nxply(1:5, 1, sum)
nxply(1:5, 2, sum)
nxply(1:5, 2, quantile, p = 0.05)
nxply(1:5, 2, quantile, p = 0.05)
nxply(1:5, 2, min)
nxply(1:5, 2, max)
nxply(1:5, 3, sum)
nxply(1:5, c(0,1), sum)
nxply(1:5, c(1,0), sum)
locVec <- sample(c(TRUE, FALSE), 5, TRUE)
nxply(locVec, c(1,0), any)
nxply(locVec, 1, any)
nxply(LETTERS[1:5], c(0,1), paste0, collapse = "")
nxply(LETTERS[1:5], 1, paste0, collapse = "")
後來發現zoo:::rollapply有一樣的功能
※ 引述《andrew43 (討厭有好心推文後刪文者)》之銘言：
: [問題類型]: 程式諮詢
: [軟體熟悉度]: 使用者
: [問題敘述]: 想寫一個 function 自動求出相鄰元素之平均（或其它統計量）
: 我想做出一個 funciton，可以做相鄰值的統計量或套用特定的 function。
: 目前想到的參數有
: 1. x: 來源 numeric vector
: 2. n: 取幾個相鄰元素
: 3. FUN: 想套用的統計量或 function
: 我的第一個困難是，在頭和在尾的元素在取相鄰元素會有例外。
: 例如 1:3 的第一個元素是 1，但它沒有上一個元素，
: 所以就只能往之後的元素納入。
: 如果是用 for loop，裡頭做例外處理，
: 我還辦得到，但不知道有沒有更好的寫法。
: 我的第二個困難是，我想寫成類似 R 中 *apply 系列的 FUN 的風格，
: 但我不甚了解怎麼撰寫這類風格的 function。
: 我猜是建出一個 list 再用 lapply 來延伸，不知道好不好？
: 舉一個例好了
: x <- 1:5
: newFun(x, n, FUN) <- function{...}
: newFun(x, 0, sum) #回傳 1, 2, 3, 4, 5
: newFun(x, 1, sum) #回傳 3, 6, 9, 12, 9
: # =1+2 =1+2+3 =2+3+4 =3+4+5 =4+5
: newFun(x, 2, sum) #回傳 6, 10, 15, 14, 12
: newFun(x, 0, function(a){a+1}) #回傳 2,3,4,5,6
: 如果有什麼想法，歡迎請提供線索給我即可，不用全刻出來沒關係。
--
※ 發信站: 批踢踢實業坊(ptt.cc), 來自: 123.205.27.107
※ 文章網址: https://webptt.com/m.aspx?n=bbs/R_Language/M.1437700465.A.072.html
1F：→ andrew43: 太細心了～連輸入驗證都幫我寫了！ 07/24 15:19
不客氣
※ 編輯: celestialgod (123.205.27.107), 07/24/2015 15:58:21