Re: [問題] 一維陣列相臨值取平均的實作
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://www.ptt.cc/bbs/R_Language/M.1437700465.A.072.html
→
07/24 15:19, , 1F
07/24 15:19, 1F
不客氣
※ 編輯: celestialgod (123.205.27.107), 07/24/2015 15:58:21
討論串 (同標題文章)
R_Language 近期熱門文章
PTT數位生活區 即時熱門文章