Если ошибка инструкции/не применяется, если оператор

Question

Я пытаюсь создать кусок кода, который аналогичен функциям, таким как rollapply, из zoo/xts, но применимым к моим потребностям. Я произвел код, используя некоторые очень простые данные образца, и все работает нормально. Но теперь, когда я пытаюсь запустить его на edhec, я получаю сообщение об ошибке. Я не понимаю, почему, но предположим, что это как-то связано с утверждением if. Кто-нибудь может диагностировать, почему я получаю ошибку?

#rm(list=ls()) #Clear environment 
cat("\014") #CTRL + L 

library(xts) 
library(lubridate) 

is.even <- function(x) x %% 2 == 0 

roundUp <- function(x,to=2) 
{ 
    to*(x%/%to + as.logical(x%%to)) 
} 

functionTest <- function(data, window, slide){ 

    nyears_t = nyears(data) 

    #IF statement for non-even numbers only 
    if(is.even(nyears_t == FALSE)) { 
    nyears_t <- roundUp(nyears_t) 
    data_extend <- data 

    start_extend <- .indexyear(data)[length(data)]+ 1900 + 1 
    end_extend <- start_extend + length(data) - 1 
    index(data_extend) <- update(index(data),year=start_extend:end_extend) 

    data <- rbind(data, data_extend) 

    warning("WARNING! The function has looped to the start of the timeseries. The final list(s) 
      will contain years that do not exist in the dataset. Please modify.") 
    } 

    nslides = nyears_t/slide 

    #Matrix 
    year_1 = (.indexyear(data)[1]+1900) 

    start <- seq(from = year_1, by = slide, length.out = nslides) 
    end <- start + window - 1 

    mat <- matrix(c(start, end), ncol = 2, dimnames = list(c(1:nslides), c("start", "end"))) 

    #For loop 
    subsetlist <- vector('list') 

    for(i in 1:nslides){ 
    subset <- data[paste0(mat[i,1], "/", mat[i,2])] 
    subsetlist[[i]] <- subset 
    } 
    print(subsetlist) 
} 

код

образца, который был использован, когда я делал функции выше:

a <- seq(from = as.POSIXct("2000", format = "%Y"), to = as.POSIXct("2008", format = "%Y"), by = "year") 
a <- as.xts(1:length(a), order.by = a) 
a 

functionTest(data = a, window = 3, slide = 2) 

Пример кода я тестирование, и получаю сообщение об ошибке:

> data(edhec, package = "PerformanceAnalytics") 
> edhec <- edhec[,1:3] 
> edhec <- edhec["/2007"] 
> head(edhec) 
      Convertible Arbitrage CTA Global Distressed Securities 
1997-01-31    0.0119  0.0393    0.0178 
1997-02-28    0..0298    0.0122 
1997-03-31    0.0078 -0.0021    -0.0012 
1997-04-30    0.0086 -0.0170    0.0030 
1997-05-31    0.0156 -0.0015    0.0233 
1997-06-30    0.0212  0.0085    0.0217 
> functionTest(data = edhec, window = 3, slide = 2) 
Show Traceback 

Rerun with Debug 
Error in start_extend:end_extend : NA/NaN argument 
> 

UPDATE:

Код теперь работает со следующими обновлениями к утверждению if (с благодарностью Джошуа Ульриху) (см. код ниже). Тем не менее, по-прежнему существует проблема с оператором if: она работает независимо от того, существует ли четкое или нечетное число лет в наборе данных. Хотя это не влияет на точность функции, это может стать проблематичным, поскольку рассматриваются большие наборы данных. Если у кого-то есть какие-то мысли по этому поводу, это будет очень признательно. Иначе это уже супер! Приветствия

if(is.even(nyears_t == FALSE)) { 
    nyears_t <- roundUp(nyears_t) 
    data_extend <- data 

    start_extend <- .indexyear(data)[nrow(data)] + 1900 + 1 
    end_extend <- start_extend + nyears(data) - 1 

    dates <- index(data) 
    tmp <- as.POSIXlt(dates) 
    tmp$year <- tmp$year + nyears(data) 
    dates2 <- as.POSIXct(tmp, tz = tz) 
    index(data_extend) <- dates2 

    data <- rbind(data, data_extend) 

    warning("WARNING! The function has looped to the start of the timeseries. The final list(s) 
      will contain years that do not exist in the dataset. Please modify.") 
    } 

Answer 1

Вызов length на матрице (который является то, что coredata из XTS/объектов зоопарка) дает общее количество элементов (то есть длина основного вектора). Вместо этого вы должны использовать nrow.

start_extend <- .indexyear(data)[nrow(data)] + 1900 + 1 
end_extend <- start_extend + nrow(data) - 1 

Если вы не уверены, будет ли data быть матрицу или вектор, то вам следует использовать NROW вместо nrow. Вызов nrow на возврат вектора NULL и NROW вернет length(x) если x - это вектор.

Answer 2

У меня есть полный ответ, который имеет желаемый эффект. Спасибо @ Joshua за помощь - я не думаю, что мог бы исправить код без него. Чтобы запустить его по большим данным, мне пришлось внести некоторые дополнительные изменения.

Ради интереса, это мой полный рабочий код (минус мои дополнительные пользовательские функции):

bootOffset <- function(data, window, slide, tz = "GMT"){ 

    nyears_t = nyears(data) 

    #IF statement for non-even numbers only 
    if(is.even(nyears_t) == FALSE) { 
    nyears_t <- roundUp(nyears_t) 
    data_extend <- data 

    start_extend <- .indexyear(data)[nrow(data)] + 1900 + 1 
    end_extend <- start_extend + nyears(data) - 1 

    dates <- index(data) 
     tmp <- as.POSIXlt(dates); tmp$year <- tmp$year + nyears(data) 
    dates2 <- as.POSIXct(tmp, tz = tz) 

    index(data_extend) <- dates2 
    data <- rbind(data, data_extend) 
    } 

    nslides = nyears_t/slide 

    year_1 = (.indexyear(data)[1] + 1900) 

    #Matrix 
    start <- seq(from = year_1, by = slide, length.out = nslides); end <- start + window - 1 
    mat <- matrix(c(start, end), ncol = 2, dimnames = list(c(1:nslides), c("start", "end"))) 

    #For loop 
    subsetlist <- vector('list') 

    for(i in 1:nslides){ 
    subset <- window(data, 
        start = as.POSIXct(paste0(mat[i,1], "-01-01")), 
        end = as.POSIXct(paste0(mat[i,2], "-12-31"))) 

    subsetlist[[i]] <- subset 
    } 
    print(subsetlist) 
} 

И для подтверждения того, что эти результаты, как требуется:

data(edhec, package = "PerformanceAnalytics") 
edhec <- edhec[,1:3] 
edhec08 <- edhec["/2008"] 
edhec07 <- edhec["/2007"] 

bootOffset(data = edhec08, #EVEN 
        window = 4, 
        slide = 3) 

bootOffset(data = edhec07, #ODD 
        window = 4, 
        slide = 3) 

#

> bootOffset.Check <- function(boot){ 
+ dates <- lapply(boot, year) 
+ dates <- lapply(dates, unique) 
+ dates <- lapply(dates, `length<-`, max(lengths(dates))) 
+ as.data.frame(dates, 
+ col.names = paste0("boot_", 1:length(boot))) 
+ 
+ } 
> 
> nyears(edhec08) 
[1] 12 
> bootOffset.Check(boot08) #EVEN number of years 
    boot_1 boot_2 boot_3 boot_4 
1 1997 2000 2003 2006 
2 1998 2001 2004 2007 
3 1999 2002 2005 2008 
4 2000 2003 2006  NA 
> 
> nyears(edhec07) 
[1] 11 
> bootOffset.Check(boot07) #ODD number of years 
    boot_1 boot_2 boot_3 boot_4 
1 1997 2000 2003 2006 
2 1998 2001 2004 2007 
3 1999 2002 2005 2008 
4 2000 2003 2006 2009 
>