I'm writing function used for forecasting sales on the base of trend and seasonality. I use dummy variables to represent seasonality and time variable for trend. Here is the code:
forecast<-function(data, time, fn) {
n <- length(data)
seasonal <- factor(cycle(data))
new_data <- seq(from=cycle(data)[n]+1, length=fn, by=1)
new_seasonal <- factor(new_data)
trend <- rep(0, n)
new_trend <- rep(0, n)
if (time > 0) {
trend <- vector()
new_trend <- vector()
ttrend <- seq(from=1, to=n, by=1)
tnew_trend <- seq(from=n+1, length=fn, by=1)
for(i in 1:time) {
trend <- cbind(trend, ttrend^i)
new_trend <- cbind(new_trend, tnew_trend^i)
}
model_trend <- lm(data ~ seasonal + trend)
} else {
model_trend <- lm(data ~ seasonal)
}
df <- data.frame(new_seasonal, new_trend)
p <- predict(model_trend, df)
}
forecast(data = dane.ts[,"SALES"], time=2, fn=5)
However I get warning:
Warning message:
'newdata' had 5 rows but variable(s) found have 104 rows
And it seems that sth is wrong with this function. I would appreciate any help.
Related
I want to calculate the rolling forecast origin using the for loops that I have created.
Firstly, I created a for loop in order to create a random walk forecast of the independent variables and store them as a list. Now, I want to estimate rolling regression and then I want to forecast them and store those models as a list. After that, my intention was to create another loop in order to extract t+1 from every created model and calculate RMSE for every vector.
I have a problem with finishing the second for the loop and creating the third one in order to calculate RMSE values.
If anyone has any time, I would appreciate your help. Thank you.
Here is the code:
library(readxl)
library(tidyverse)
library(lubridate)
library(fpp2)
library(naniar)
zalihe_input <- read_excel("C:/Users/User/OneDrive/Radna površina/zalihe_input.xlsx")
zalihe_input <- zalihe_input %>%
mutate(pcy_ii = 100 * (ii - lag(ii,4))/ lag(ii,4)* 100)
View(zalihe_input)
#FORECASTING HORIZONT
H <- 8
#LAST POINT OF ESTIMATION
LP <- 72
#FORECAST UNTIL
FU <- zalihe_input %>%
nrow() - 1
#OUT-OF-SAMPLE FORECAST (FORECAST UNTIL), WHICH IS HERE 2021Q4 - 2017Q4
OF <- FU - LP - H
#CREATING DATAFRAME FOR ACTUAL VALUES
actual_values <- data.frame()
#SETTING THE FORECASTING DATE
actual_values <- subset(zalihe_input, vrijeme > "2017Q4" & vrijeme < "2022Q1", select = vrijeme)
#CREATING FOR LOOP FOR ROOLING OF ACTUAL VALUES
for (i in 1:H){
first <- LP + i
last <- first + H
actual_values[0 : H + i, i + 1] = zalihe_input$ii[first:last]
}
#FUNCTION FOR CALCULATING RMSE
rmse <- function(actual, pred) {
sqrt(mean( (actual - pred) ^ 2))
}
#CORRELATION
cor(zalihe_input$ii, zalihe_input$inv)
#CREATING FOR LOOP FOR ESTIMATIONS AND FORECASTS OF LIN.REG./ARIMA MODELS
list_df <- list()
model_rw_inv <- list()
model_rw_ex <- list()
model_rw_imp <- list()
model.rw <- list()
model.est <- list()
model.fore <- list()
for (i in 1:OF){
list_df[[i]] <- zalihe_input %>%
slice_head(n = (LP + i)) %>%
select(vrijeme, ii, inv, ex, imp, pcy_ii)
model_rw_inv[[i]] <- rwf(list_df[[i]][["inv"]], h = H, drift = TRUE)
model_rw_ex[[i]] <- rwf(list_df[[i]][["ex"]], h = H, drift = TRUE)
model_rw_imp[[i]] <- rwf(list_df[[i]][["imp"]], h = H, drift = TRUE)
#FORECASTING MODELS
# forecast(model_rw_inv, newdata = list_df[[i]], h = H)$mean
# forecast(model_rw_ex, newdata = list_df[[i]], h = H)
# forecast(model_rw_imp, newdata = list_df[[i]], h = H)
}
#ESTIMATION OD MODELS
for (i in 1:OF){
list_df[[i]] <- zalihe_input %>%
slice_head(n = (LP + i - 1))
#USING RW VALUES TO ESTIMATE AND FORECAST OUT-OF-SAMPLE ONE STEP AHEAD
model.est[[i]] <- lm(ii ~ inv + ex + imp, data = list_df[[i]])
model_fore[[i]] <- forecast(model_est[[i]], newdata = list_df[[i]], h = H)
}
#FOR LOOP FOR CALCULATING RMSE WITH T+1 FROM EVERY MODEL FORECAST
for (i in 1:H){
horizont_fore[[i]] <- model_fore[[i]][72 + i]
for (j in 1:H){
}
}
all,
I'm trying to use JAGS model in R. The R package is "R2jags".
I'm confused with the error like beblow.
Compiling model graph
Resolving undeclared variables
Allocating nodes
Deleting model
Error in jags.model(model.file, data = data, inits = init.values, n.chains = n.chains, :
RUNTIME ERROR:
Non-conforming parameters in function inprod
The data processing part,
library(R2jags)
data <- read.table("H:/mlp2020/data109.csv",sep = ",",check.names = F,stringsAsFactors = F,header = T)
rownames(data) <- data[,1]
data <- data[,-1]
z <- as.vector(data$group)
z <- z+1
Y_input <- data[,c(1:1356)]
X_input <- data[,c(1358:1368)]
N <- 1702 #nrow(Y_input)
P <- 1356 #ncol(Y_input)
R <- 11 #ncol(X_input)
Y <- Y_input
X <- X_input
jags.data <- list("X","Y","z","N","P","R")
jags.params <- c("phi","delta")
jags.inits <- function(){
list("phi"=rbinom(1,1,0.1),"delta"=rbinom(1,1,0.1))
}
my model code is like,
model <- function(){
for (j in 1:P){
for (i in 1:N){
k[i,j] <- 1+phi[j]*z[i] #k=1 phi[j]=0，k=2 phi[j]=1 z[i]=1，k=3 phi[j]=1 z[i]=2
}
phi[j] ~ dbern(w)
}
for (j in 1:P){
for (i in 1:N){
Y[i,j] ~ dnorm(mu[i,j], tau[j])
mu[i,j] = e_1[j] + e_2[j]*equals(k[i,j],2) + inprod(X[i,],beta)
}
for (r in 1:R){
beta[r,j]<-delta[r,j]*beta_0[j]
#spike and slab pior for beta
delta[r,j] ~ dbern(t)
}
#spike and slab pior for beta
beta_0[j] ~ dnorm(0,tau_beta[j])
tau_beta[j] ~ dgamma(2, 15) # input
e_1[j]~dnorm(0,tau_1[j]) #tau_mu[j]=1
tau_1[j] ~ dgamma(2, 15) # input
e_2[j]~dnorm(0,tau_2[j]) #tau_mu[j]=1
tau_2[j] ~ dgamma(2, 15) # input
sigma[j] <- 1.0/sqrt(tau[j])
# input
tau[j] ~ dgamma(10, 1)
}
# t ~ dbeta(a_t,b_t) # input
# w ~ dbeta(a_w,b_w) # input
w ~ dbeta(1,0.1)
t ~ dbeta(0.4,1.6)
}
jagsfit <- jags(data=jags.data, inits=jags.inits, jags.params,
n.iter=10,
model.file=model)
Any help would be greatly appreciated!
inprod is the dot product. Its two arguments must be vectors of the same lengths, but the second argument in your code is a matrix.
I have not checked your model, but perhaps you want inprod(X[i,],beta[,j]).
I have a data set and want to essentially fit a linear model with a rolling time window, find the fitted values and calculate the errors in the estimate. I have functions which calculate the error and I have the start of the algorithm, but I keep getting null time series with the algorithm below. Can anybody spot a fix for it?
rollerOLS <- function(data, measure, predict, predictor){
error <- c()
m <- dim(data)[1]
for(i in 1:(floor(m/142)-10)){
data.new <- as.data.frame(data[c((1+(142*(i-1))):((i+9)*142)),])
data.pred <- as.data.frame(data[c((1+(142*(i+9))):((i+10)*142)-1),])
n <- dim(data.new)[1]
k <- dim(data.pred)[1]
x <- data.new[-1,predictor]
y <- data.new[-n, predict]
mod <- lm(y ~ x)
ts <- predict.lm(mod, newdata = data.frame(data.pred[, predictor]), interval="none")
actual <- data.pred[-k,predict]
error[i] <- measure(ts, actual)
}
return(mod)
}
Note that 142 is specific to my data set.
The problem was in the ts line and here is the fix.
rollerOLS <- function(data, measure, predict, predictor){
error <- c()
m <- dim(data)[1]
for(i in 1:(floor(m/142)-10)){
data.new <- as.data.frame(data[c((1+(142*(i-1))):((i+9)*142)),])
data.pred <- as.data.frame(data[c((1+(142*(i+9))):((i+10)*142)-1),])
n <- dim(data.new)[1]
k <- dim(data.pred)[1]
x <- data.new[-1,predictor]
y <- data.new[-n, predict]
mod <- lm(y ~ x)
ts <- mod$coefficients[1] + mod$coefficients[2]*data.pred[-1,predictor]
actual <- data.pred[-k,predict]
error[i] <- measure(ts, actual)
}
return(error)
}
I am trying to:
1) fit arma model on given data
2) obtain forecast for the next day
3) add forecast to the data
4) return to 1)
Code I have written:
library(forecast)
dates<- seq(as.Date(today), by="days", length=10)
sim<- rnorm(10)
tsdata<- as.ts(cbind(as.xts(dates),sim))
temp<- tsdata
for(i in 1:10){
Arma1[i]<- Arima(temp, order=c(2,0,2))
fcasts1[[i]]<- forecast(Arma1[i], h=1)
fore1[i]<-unlist(fcasts1[[i]]$mean[1])
temp<- as.ts(rbind(as.xts(temp),fore1[i]))
}
This gives me an error:
Error in x - fits : non-numeric argument to binary operator
In addition: Warning messages:
1: In Arma1[i] <- Arima(temp, order = c(2, 0, 2)) :
number of items to replace is not a multiple of replacement length
2: In mean.default(x, na.rm = TRUE) :
argument is not numeric or logical: returning NA
How can I fix this?
I am not exactly sure what you want to do and if the timeindex for the forecast-values is correct this way, but the loop in this code should at least work:
library(xts)
library(forecast)
dates <- seq(Sys.Date(), by="days", length=10)
sim <- rnorm(10)
tsdata <- xts(sim, order.by = dates)
temp.old <- tsdata
temp <- tsdata
Arma1 <- list(10)
fcasts1 <- list(10)
fore1 <- list(10)
temp <- list(10)
for(i in 1:10){
Arma1[[i]] <- Arima(temp.old, order=c(2,0,2))
fcasts1[[i]] <- forecast(Arma1[[i]], h=1)
fore1[i] <- unlist(fcasts1[[i]]$mean)
temp[i] <- as.xts(fore1[[i]], order.by = dates[i])
}
I have two raster stacks and I want to carry out a refression analysis. If each raster in each stack was a month in the year (6 data points would be three months in two years i.e. January, February and March for two different years), how do I calculate the slope using the indices such that the result generates 3 slope rasters (one for each month) please?
#First raster track
r <- raster(ncol=10, nrow=10)
r[]=1:ncell(r)
S <- stack(r,r,r,r,r,r)
#Second raster stack
r1 <- raster(ncol=10, nrow=10)
r1[]=1:ncell(r1)
N <- stack(r1,r1,r1,r1,r1,r1)
#combine both raster stacks
s <- stack(S,N)
#function to calculate slope
fun=function(x) { if (is.na(x[1])){ NA } else { lm(x[7:12] ~ x[1:6] )$coefficients [2]}}
#apply function
slope <- calc(s, fun)
Result should be 3 rasters.
A second question:
If I wanted to do a conditional regression using a third raster stack, what would the codes be?
Try fun with 1:12
fun(1:12)
# Error in model.frame.default(formula = x[6:12] ~ x[1:6], drop.unused.levels = TRUE) :
# variable lengths differ (found for 'x[1:6]')
it should be
fun=function(x) { if (is.na(x[1])){ NA } else { lm(x[7:12] ~ x[1:6] )$coefficients [2]}}
Working example
library(raster)
r <- raster(ncol=10, nrow=10)
set.seed(99)
s <- stack(sapply(1:12, function(i) setValues(r, runif(ncell(r)))))
fun <- function(x) { if (is.na(x[1])){ NA } else { lm(x[7:12] ~ x[1:6] )$coefficients [2]}}
slope <- calc(s, fun)
For the three slopes:
fun3 <- function(x) {
r <- rep(NA, 3)
if (!is.na(x[1])) {
r[1] <- lm(x[3:4] ~ x[1:2] )$coefficients[2]
r[2] <- lm(x[7:8] ~ x[5:6] )$coefficients[2]
r[3] <- lm(x[11:12] ~ x[9:10] )$coefficients[2]
}
r
}
slope3 <- calc(s, fun3)