library(quantmod)
library(xts)
getSymbols("SY1.DE", from = "2019-4-10", to = "2019-4-19", auto.assign = TRUE)
getSymbols("PEP", from = "2019-4-9", to = "2019-4-19", auto.assign = TRUE)
calcreturn <- function(data, amount = 24) {
start <- as.numeric(data[,4][1])
end <- as.numeric(data[,4][nrow(data)])
difference <- end - start
winning <- difference * amount
return(winning)
}
allstocks <- list(SY1.DE, PEP)
amount <- list(24, 23)
lapply(allstocks, calcreturn)
Hello everbody!
This is my code to calculate my returns for my stocks. However, the amount of stocks i bought differ, so lapply does only work when the amount argument does not change. Is there a day to deal with changing arguments?
Thank you!
You can modify your lapply to run over an index pairing one by one stock with amount:
lapply(1:length(allstocks), function(x) calcreturn(allstocks[[x]], amount[[x]]))
Related
I'm having a weird error which I can not understand. Let me explain the variables and their meaning:
ts <- a xts object
range.matrix <- matrix with two columns and n rows (only knows at execution time)
so, range.matrix contains ranges of dates. first column is the start of the range and second column is the end of it. The goal is to slice the ts time series by the ranges in range.matrix a get a list with all slices.
It fails with some ranges but not in others, and fails with 1 row matrices... The error message is:
Error in array(ans, c(len.a%/%d2, d.ans), if (!is.null(names(dn.ans))
length of 'dimnames' 1 not equal to array extent
Check yourself with this toy example (range.matrix contains numbers which are cast as.Date)
library(xts)
ts <- xts(cbind('a'= c(1,2,3,4,5,6,7,8),'b' =c(1,2,3,4,5,6,7,8),'c'= c(1,2,3,4,5,6,7,8))
,order.by = as.Date(as.Date('2017-01-01'):(as.Date('2017-01-01')+7)) )
range.matrix <- matrix(c(16314,17286), ncol = 2,byrow = TRUE) # Fails. Range: "2014-09-01/2017-04-30"
range.matrix <- matrix(c(16314,17236,16314,17286), ncol = 2,byrow = TRUE) # Fails. Range: "2014-09-01/2017-03-11" and "2014-09-01/2017-04-30"
range.matrix <- matrix(c(16314,17236,17237,17286), ncol = 2,byrow = TRUE) # does not fail. "2014-09-01/2017-03-11" and "2017-03-12/2017-04-30"
apply(range.matrix,
1,
function(r) {
ts[paste0(as.Date(r[1]), '/', as.Date(r[2]))]
})
Any clue? It has to do with dimnames but can not find the solution
Try this instead, and you won't have issues:
lapply(split(range.matrix, row(range.matrix)), function(x) {
ts[paste0(as.Date(r[1]), '/', as.Date(r[2]))]})
Personally I would not use apply on xts objects in the way you want to do it (i'd do the above; lapply is much more natural).
apply is used on arrays, and an xts object is not just a matrix (array), but also supports a time index and other attributes that give xts its power. You could use something like coredata on the xts object to just return the underlying matrix to the apply call, and then you won't get errors, but the results don't make much sense.
apply(range.matrix,
1,
function(r) {
res <- ts[paste0(as.Date(r[1]), '/', as.Date(r[2]))]
coredata(res)
})
My objective is to create a number of time-series subsets from a list of variables. I wrote this with a for-loop. However, I'm looking for more elegant ideas on how to do with an existir R function, that doesn't require a loop.
All ideas and intros to new functions in R are much appreciated.
A reproducible example of the code:
russell_sim <- arima.sim(model=list(ar=c(.9,-.2)),n=449)
russell_sim <- ts(russell_sim, start = c(1980,1), end = c(2017,5) ,frequency = 12)
pmi_sim <- arima.sim(model=list(ar=c(.9,-.2)),n=449)
pmi_sim <- ts(russell_sim, start = c(1980,1), end = c(2017,5) ,frequency = 12)
big_list<- list(russell = russell_sim, pmi= pmi_sim)
for (i in 1: length(big_list)) {
assign(paste(names(x = big_list)[i], "_before08", sep = ""), window(big_list[[i]], start=c(1981,1), end=c(2007, 12)) )
}
Thank you.
You can make use of the handy list2env function but you will need to edit the list first to get your desired output:
# New List to edit
big_list_before08 <- big_list
# change your observations
big_list_before08 <- lapply(big_list_before08, function(x) window(x, start = c(1981,1),
end = c(2007,12)))
# change the individual list element names
names(big_list_before08) <- paste0(names(big_list),"_before08")
# save to the global environment
list2env(big_list_before08, envir = .GlobalEnv)
Let me know if you have any questions!
I need to fill backwards the historical prices knowing the returns (in real situation they are simulated).
So far I have this code:
library(quantmod)
getSymbols("AAPL")
df = AAPL["2014-01-01/2015-01-01", "AAPL.Close"]
df_ret = diff(log(df),1)
# imagine the half of the past prices are missing
df["2014-01-01/2014-07-01"] = NA
df_tot = cbind(df, df_ret)
fillBackwards = function(data, range_to_fill){
index_array = index(data[range_to_fill,])
data_out = data
for (i in (length(index_array)-1):1){
inx = index_array[i]
inx_0 = index_array[i+1]
data_out[inx,1] = exp(-(data_out[inx_0,2]))*(data_out[inx_0,1])
}
return (data_out)
}
df_filled = fillBackwards(df_tot,"2014-01-01/2014-07-02")
sum(AAPL["2014-01-01/2015-01-01", "AAPL.Close"] - df_filled[,1]) # zero up to computation error, i.e. identical
This works perfect, but a bit slow. Could you please suggest something using build-in rollapply()
# i want something like this
df_filled = rollapply(df_tot["2014-07-02/2014-01-01",], by=-1, function(x) {....})
You don't need rollapply, or a loop. You can use cumprod on the returns. Here's a version of fillBackwards that uses cumprod:
fillBackwards <- function(data, range_to_fill) {
data_range <- data[range_to_fill,]
returns <- rev(coredata(data_range[-1L, 2L]))
last_price <- drop(coredata(last(data_range[, 1L])))
new_prices <- rev(last_price * cumprod(exp(-returns)))
data[range_to_fill, 1L] <- c(last_price, new_prices)
return(data)
}
I came across this function a while back that was created for fixing PCA values. The problem with the function was that it wasn't compatible xts time series objects.
amend <- function(result) {
result.m <- as.matrix(result)
n <- dim(result.m)[1]
delta <- apply(abs(result.m[-1,] - result.m[-n,]), 1, sum)
delta.1 <- apply(abs(result.m[-1,] + result.m[-n,]), 1, sum)
signs <- c(1, cumprod(rep(-1, n-1) ^ (delta.1 <= delta)))
zoo(result * signs)
}
Full sample can be found https://stats.stackexchange.com/questions/34396/im-getting-jumpy-loadings-in-rollapply-pca-in-r-can-i-fix-it
The problem is that applying the function on a xts object with multiple columns and rows wont solve the problem. Is there a elegant way of applying the algorithm for a matrix of xts objects?
My current solution given a single column with multiple row is to loop through row by row...which is slow and tedious. Imagine having to do it column by column also.
Thanks,
Here is some code to get one started:
rm(list=ls())
require(RCurl)
sit = getURLContent('https://github.com/systematicinvestor/SIT/raw/master/sit.gz', binary=TRUE, followlocation = TRUE, ssl.verifypeer = FALSE)
con = gzcon(rawConnection(sit, 'rb'))
source(con)
close(con)
load.packages('quantmod')
data <- new.env()
tickers<-spl("VTI,IEF,VNQ,TLT")
getSymbols(tickers, src = 'yahoo', from = '1980-01-01', env = data, auto.assign = T)
for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)
bt.prep(data, align='remove.na', dates='1990::2013')
prices<-data$prices[,-10] #don't include cash
retmat<-na.omit(prices/mlag(prices) - 1)
rollapply(retmat, 500, function(x) summary(princomp(x))$loadings[, 1], by.column = FALSE, align = "right") -> princomproll
require(lattice)
xyplot(amend(pruncomproll))
plotting "princomproll" will get you jumpy loadings...
It isn't very obvious how the amend function relates to the script below it (since it isn't called there), or what you are trying to achieve. There are a couple of small changes that can be made. I haven't profiled the difference, but it's a little more readable if nothing else.
You remove the first and last rows of the result twice.
rowSums might be slightly more efficient for getting the row sums than apply.
rep.int is a little bit fster than rep.
amend <- function(result) {
result <- as.matrix(result)
n <- nrow(result)
without_first_row <- result[-1,]
without_last_row <- result[-n,]
delta_minus <- rowSums(abs(without_first_row - without_last_row))
delta_plus <- rowSums(abs(without_first_row + without_last_row))
signs <- c(1, cumprod(rep.int(-1, n-1) ^ (delta_plus <= delta_minus)))
zoo(result * signs)
}
I have a really odd issue... I am using the to.weekly and to.period function to convert a daily xts object to weekly data. In most instances, I get the week-ending date as a Friday (day.of.week function will return 5) (e.g. "2010-01-08", "2011-02-11"), but there are a few cases where I get something other than Friday (Saturday/Sunday/Thursday/etc.)
I have tried to.weekly and to.period(x, period = 'weeks') and both return the same problem.
Why is this happening? Is there a work-around for this??
Thanks!!
[EDIT: EXAMPLE BELOW]
test.dates <- as.Date(c("2010-04-27","2010-04-28","2010-04-29","2010-04-30","2010-05-03","2010-05-04","2010-05-05","2010-05-06","2010-05-07","2010-05-10","2010-05-11","2010-05-12","2010-05-13","2010-05-14","2010-05-17","2010-05-18","2010-05-19","2010-05-20","2010-05-21","2010-05-22","2010-05-24","2010-05-25","2010-05-26","2010-05-27","2010-05-28","2010-06-01","2010-06-02","2010-06-03","2010-06-04"))
test.data <- rnorm(length(test.dates),mean=1,sd=2)
test.xts <- xts(x=test.data,order.by=test.dates)
#Function that takes in a vector of zoo/xts objects (e.g. "2010-01-08") and returns the day of the week for each
dayofweek <- function(x) {
placeholder <- vector("list",length=length(x))
names(placeholder) <- x
for(i in 1:length(x)) {placeholder[[i]] <- month.day.year(x[i])}
placeholder2 <- rep(NA,times=length(x))
for(i in 1:length(x)) {placeholder2[i] <- day.of.week(placeholder[[i]][[1]],placeholder[[i]][[2]],placeholder[[i]][[3]])}
return(placeholder2)}
This returns the date(s) that are not Friday: time(to.weekly(test.xts))[dayofweek(time(to.weekly(test.xts))) != 5]
You have 2 problems with your example:
Your dayofweek function is a bit cumbersome, and probably incorrect in its results.
Your example dates is missing some dates, such as 05-23-2010.
Here is a cleaned-up version of your code:
library(xts)
test.dates <- as.Date(c("2010-04-27","2010-04-28","2010-04-29","2010-04-30","2010-05-03","2010-05-04","2010-05-05","2010-05-06","2010-05-07","2010-05-10","2010-05-11","2010-05-12","2010-05-13","2010-05-14","2010-05-17","2010-05-18","2010-05-19","2010-05-20","2010-05-21","2010-05-22","2010-05-24","2010-05-25","2010-05-26","2010-05-27","2010-05-28","2010-06-01","2010-06-02","2010-06-03","2010-06-04"))
test.data <- rnorm(length(test.dates),mean=1,sd=2)
test.xts <- xts(x=test.data,order.by=test.dates)
test.weekly <- to.weekly(test.xts)
library(lubridate)
test.weekly[wday(test.weekly, label = TRUE, abbr = TRUE) != "Fri"]
The only result of this function is
test.xts.Open test.xts.High test.xts.Low test.xts.Close
2010-05-22 -1.705749 1.273982 -2.084203 -1.502611
The problem of course, is that this week ends on 05-23-2010, but that date is not present in the time series. Therefore, to.weekly uses the next closest date as the end point, which is 05-22-2010. This is the source of your problem.
Here is a better example, which reveals no issue with the to.weekly function.
library(lubridate); library(xts)
test.dates <- seq(as.Date("1900-01-01"),as.Date("2011-10-01"),by='days')
test.dates <- test.dates[wday(test.dates)!=1 & wday(test.dates)!=7] #Remove weekends
test.data <- rnorm(length(test.dates),mean=1,sd=2)
test.xts <- xts(x=test.data,order.by=test.dates)
test.weekly <- to.weekly(test.xts)
test.weekly[wday(test.weekly, label = TRUE, abbr = TRUE) != "Fri"]