If I have following variables
x <- data.frame(ret = c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) )
k <- 4
and I want to get y such that
y[i,1] = x[i,1]*(1/k) + x[i+1,1]*(2/k) + x[i+2,1]*(3/k) + x[i+3,1]*(k/k)
.
.
.
till i = nrow(x) - k + 1
how can I achieve this?
It is basically sum of last k values but it is multiplied by n/k where n is the index of last k elements.
for the given x as input the output will have following values
y
7.5 <- y[1,1] = (x[1,1] * 0.25 + x[2,1] *0.5 + x[3,1] *0.75 + 1 * x[4,1])
10
12.5
15
17.5
20
22.5
25
27.5
30
32.5
35
Use rollapply with the indicated function:
library(zoo)
wsum <- function(x, k) sum(seq(k) * x) / k
transform(x, ret = rollapply(ret, k, wsum, k = k, align = "left", fill = NA))
Update
An alternative that allows us to omit the k = k argument is:
wsum <- function(x, k = length(x)) sum(seq(k) * x) / k
transform(x, ret = rollapply(ret, k, wsum, align = "left", fill = NA))
Related
I am trying to replicate the following visual with the following Matlab code:
% Pumpkin
[X,Y,Z]=sphere(200);
R=1-(1-mod(0:.1:20,2)).^2/12;
x=R.*X; y=R.*Y; z=Z.*R;
c=hypot(hypot(x,y),z)+randn(201)*.03;
surf(x,y,(.8+(0-(1:-.01:-1)'.^4)*.3).*z,c, 'FaceColor', 'interp', 'EdgeColor', 'none')
% Stem
s = [ 1.5 1 repelem(.7, 6) ] .* [ repmat([.1 .06],1,10) .1 ]';
[t, p] = meshgrid(0:pi/15:pi/2,0:pi/20:pi);
Xs = -(.4-cos(p).*s).*cos(t)+.4;
Zs = (.5-cos(p).*s).*sin(t) + .55;
Ys = -sin(p).*s;
surface(Xs,Ys,Zs,[],'FaceColor', '#008000','EdgeColor','none');
% Style
colormap([1 .4 .1; 1 1 .7])
axis equal
box on
material([.6 1 .3])
lighting g
camlight
I am working on the bottom but have not gotten very far (see here for reference). The code that I have is:
library(pracma)
library(rgl)
sphere <- function(n) {
dd <- expand.grid(theta = seq(0, 2*pi, length.out = n+1),
phi = seq(-pi, pi, length.out = n+1))
with(dd,
list(x = matrix(cos(phi) * cos(theta), n+1),
y = matrix(cos(phi) * sin(theta), n+1),
z = matrix(sin(phi), n+1))
)
}
# Pumpkin
sph<-sphere(200)
X<-sph[[1]]
Y<-sph[[2]]
Z<-sph[[3]]
R<- 1-(1-seq(from=0, to=20,by=0.1))^2/12
x<-R * X
y<-R * Y
z<-Z * R
c<-hypot(hypot(x,y),z)+rnorm(201)*0.3
persp3d(x,y,(0.8+(0-seq(from=1, to=-1, by=-0.01)^4)*0.3)*z,col=c)
and it gives me the following.
What is it that's going wrong in my present code? What would be a suggested fix?
As #billBokeey mentioned, there's a missing mod modulo operator function for periodic scaling factors.
In addition, the scaling on the z-axis 0.8 + (0-seq(from=1, to=-1, by=-0.01)^4) * 0.3 doesn't go well with the output from your sphere function. We maybe use Z[1,] to replace seq(from=1, to=-1, by=-0.01). phi = seq(-pi, pi, length.out = n+1)) shoud be seq(-pi/2, pi/2, length.out = n+1)) instead.
Finally, the color c needs to be convert to RGB code for persp3d.
Here's the result look like from the code below.
library(rgl)
sphere <- function(n) {
dd <- expand.grid(theta = seq(0, 2*pi, length.out = n+1),
phi = seq(-pi/2, pi/2, length.out = n+1))
with(dd,
list(x = matrix(cos(phi) * cos(theta), n+1),
y = matrix(cos(phi) * sin(theta), n+1),
z = matrix(sin(phi), n+1))
)
}
# Unit ball
sph <- sphere(200)
X <- sph[[1]]
Y <- sph[[2]]
Z <- sph[[3]]
# scaling
R <- 1 - (1 - seq(from=0, to=20, by=0.1) %% 2) ^ 2 / 12 # Modulo Operator %%
R2 <- 0.8 + (0 - seq(from=1, to=-1, by=-0.01)^4)*0.2 # didn't match with the order of z from sphere function
#R2 <- 0.8 - Z[1,]^4 * 0.2
x <- R * X # scale rows for wavy side
y <- R * Y # scale rows for wavy side
z <- t(R2 * t(Z)) # scale columns by transpose for flat oval shape
# color according to distance to [0,0,0]
hypot_3d <- function(x, y, z) {
return(sqrt(x^2 + y^2 + z^2))
}
c_ <- hypot_3d(x,y,z) + rnorm(201) * 0.03
color_palette <- terrain.colors(20) # color look-up table
col <- color_palette[ as.numeric(cut(c_, breaks = 20)) ] # assign color to 20 levels of c_
persp3d(x, y, z, color = col, aspect=FALSE)
Hey I have following code in R
S0 = 40
r = log(1 + 0.07)
sigma = 0.3
K = 45
n_steps_per_year = 4
dt = 1 / n_steps_per_year
T = 3
n_steps = n_steps_per_year * T
R = n_paths
Q = 70
P = 72
n_paths = P * Q
d = exp(-r * dt)
N = matrix(rnorm(n_paths * n_steps, mean = 0, sd = 1), n_paths, n_steps)
paths_S = matrix(nrow = n_paths, ncol = n_steps + 1, S0)
for(i in 1:n_paths){
for(j in 1:n_steps){
paths_S[i, j + 1] = paths_S[i, j] * exp((r - 0.5 * sigma ^ 2) * dt + sigma * sqrt(dt) * N[i, j])
}
}
I = apply(K - paths_S, c(1,2), max, 0)
V = matrix(nrow = n_paths, ncol = n_steps + 1)
V[, n_steps + 1] = I[, n_steps + 1]
dV = d * V[, n_steps + 1]
model = lm(dV ~ poly(paths_S[, n_steps], 10))
pred = predict(model, data.frame(x = paths_S[, n_steps]))
plot(paths_S[, n_steps], d * V[, n_steps + 1])
lines(paths_S[, n_steps], pred)
but when I run the last two lines then I get very strange plot (multiple lines instead of one line). What is going on?
You did not provide n_paths, lets assume:
n_paths = 7
set.seed(111)
Then running your code, before you plot, you need to order your x values before plotting:
o = order(paths_S[,12])
plot(paths_S[o, n_steps], d * V[o, n_steps + 1],cex=0.2,pch=20)
lines(paths_S[o, n_steps], pred[o],col="blue")
I have an interval from for example from 1 to 671. I would like to divide it into 5 random non-overlapping bins of length 50 but also spaced with min 51.
interval <- 1:671 (example, it does not need to be 671)
Result (this is an example as the bins should be random but within interval, equal length and spaced as defined):
bin1 <- 3:52
bin2 <- 103:152
bin3 <- 209:258
bin4 <- 425:474
bin5 <- 610:659
I would preferentially like the output to be a dataframe(bin, startOfbin, endOfbin), but other types like list would be also ok.
I am currently writing a function in R that would use this sampling for large number of intervals and I cannot come up with sensible solution. Thank you in advance.
If I understand your problem correctly you want 5 parts of your interval with length 50 and minimal distance of 51.
So your randomness is in how much bigger each distance is than 51.
This means you calculate how much space there really is to distribute.
intervalLength <- 671
nBins <- 5
binWidth <- 50
binMinDistance <- 51
spaceToDistribute <- intervalLength - (nBins * binWidth + (nBins - 1) * binMinDistance)
calculate a random splitting of this value
distances <- diff(floor(c(0, sort(runif(nBins))) * spaceToDistribute))
and construct your desired data.frame
startOfBin <- cumsum(distances) + (0:(nBins-1)) * 101
result <- data.frame(bin = 1:nBins, startOfBin = startOfBin, endOfBin = startOfBin + 49)
I don't know if this has the desired kind of randomness:
interval <- 1:671
set.seed(42)
repeat { #rejection sampling
int <- list(interval)
s <- integer(5) * NA
for (i in 1:5) {
#sample an interval from the list
sel <- sample(length(int), 1)
isel <- int[[sel]]
#sample start value
s[[i]] <- sample(head(isel,-49), 1)
#remove sampled values from interval
sp <-
split(isel, findInterval(isel, c(0, s[[i]], s[[i]] + 50, Inf)))
if (s[[i]] > isel[1] &&
s[[i]] < length(isel) - 49)
sp <- sp[-2]
else
if (s[[i]] == isel[1])
sp <- sp[-1]
else
if (s[[i]] == length(isel) - 49)
sp <- head(sp,-1)
sp <- sp[lengths(sp) >= 50]
int <- c(sp, int[-sel])
#break out of for loop
#if not enough intervals of sufficient length left
if (length(int) < 1) break
}
if (!anyNA(s)) break
}
s
#[1] 321 74 245 170 441
library(ggplot2)
ggplot(data.frame(s = s, e = s + 49), aes(x = s, xend = e, y = 0, yend = 0)) +
geom_segment(size = 3) +
theme_minimal() +
theme(axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
panel.grid.major.y = element_blank()) +
xlab("") + ylab("")
Something like this could work:
set.seed(111)
n_bins <- 5
bl <- 50
spacing <- 51
start <- 1
end <- 671
end_int <- end - n_bins*bl - (n_bins-1)*spacing
first_bin_start <- sample(start:end_int, 1)
first_bin_end <- first_bin_start + bl
avail_spacing <- end - first_bin_end - (n_bins-1)*bl - (n_bins-1)*spacing
sp <- c()
for (i in 1:(n_bins-1)){
end <- sample(1:avail_spacing, 1)
sp <- c(sp, end)
avail_spacing <- avail_spacing - end
}
bin_start <- c(first_bin_start, first_bin_start + cumsum(spacing + bl + sp))
bin_end <- bin_start + bl
df <- data.frame(bin = 1:n_bins,
bin_start = bin_start,
bin_end = bin_end)
df
I want to write an R function that takes a mathematical function in x and returns a new function in x as an output. For example:
The input should be passed in as a mathematical function (or relation) in x:
g <- x^2 + 9*x + log(x)
And the resulting output should be:
function(x) (exp(g))
i.e. I want to return the symbolic exponential expression of the original function in x i.e. exp(x^2 + 9*x + log(x)) in this illustrative example
So ideally it would return the function object:
function(x) (exp(x^2 + 9*x + log(x)))
I tried as follows:
test <- function(g){
h <- function(x){exp(g)}
return(h)
}
m <- test(x^2 + 9*x + log(x))
m(10)
So m(10) should return:
exp(10^2 + 9*10 + log(10))
which is exp(192.3026) in this case.
Could anyone show how to do this please?
You could use package functional:
library(functional)
fun <- Compose(function(x) x^2 + 9*x + log(x), exp)
fun(1)
#[1] 22026.47
Here is one approach:
test <- function(e) {
ee <- substitute(e)
eee <- substitute(exp(X), list(X=ee))
f <- function(x) {}
body(f) <- eee
environment(f) <- parent.frame()
f
}
## Check that it works
m <- test(x^2 + 9*x + log(x))
m
# function (x)
# exp(x^2 + 9 * x + log(x))
m(1)
# [1] 22026.47
m(1) == exp(10)
# [1] TRUE
edit - for functionality in question
f <- function(...) {
l <- eval(substitute(alist(x = x, ...)))
l[[2]] <- substitute(exp(X), list(X = l[[2]]))
as.function(`names<-`(l, l[sapply(l, is.symbol)]))
}
g <- f(x^2 + 2*x + 5)
# function (x = x)
# exp(x^2 + 2 * x + 5)
g(1)
# [1] 2980.958
Here is another way for a general case:
f <- function(...) {
l <- eval(substitute(alist(...)))
as.function(`names<-`(l, l[sapply(l, is.symbol)]))
}
g <- f(x, x^2 + 9*x + log(x))
# function (x = x)
# x^2 + 9 * x + log(x)
g(10)
# [1] 192.3026
This version will also work for any number of variables, just define them followed by the function:
g <- f(x, y, z, x + 2 * y + z ** 3)
# function (x = x, y = y, z = z)
# x + 2 * y + z^3
g(1, 2, 0)
# [1] 5
There may be a better way to add ... to functions, but here is how you can do that
f <- function(..., use_dots = FALSE) {
l <- eval(substitute(alist(...)))
if (use_dots)
l <- c(head(l, -1), list('...' = as.symbol('...')), tail(l, 1))
as.function(`names<-`(l, l[sapply(l, is.symbol)]))
}
So now you don't have to name all the variables/arguments
g <- f(x, y, plot(x, y, ...), use_dots = TRUE)
g(1:5, 1:5, main = 'main title', pch = 16, col = 3, cex = 3, xpd = NA)
When using recursion in R, it would be useful to have recursive environments as well. For example, in the the below example, it would be useful for the below code to print 1 to 9. That is, the x in the environment of each recursion would be one more than the x in the parent environment. Is there an easy way to modify the code such that this is the case?
x = 1
y = function() {
print(x)
x = x + 1
if (x <= 10) y()
}
Edit: a more complicated situation would just involve more variables:
w = 1
x = 2
y = 3
z = 4
y = function() {
print(x)
w = w + 1
x = w + x
y = x + y
z = y + z
if (w <= 10) y()
}
Now instead of four variables, say there's 50 variables. This couldn't be solved very easily through argument passing.
Edit 2:
In edit 1, what I'm hoping for would be something like this:
global: w = 1, x = 2, y = 3, z = 4
recursion 1: w = 2, x = 4, y = 7, z = 11
recursion 2: w = 3, x = 7, y = 14, z = 25
etc. Excuse math errors.
You could use a for loop and build up vectors of the variable states at each iteration. If it runs for long this might become inefficient however.
w <- 1
x <- 2
y <- 3
z <- 4
while(w[1] <= 10){
w <- c(w[1] + 1, w)
x <- c(w[1] + x[1], x)
y <- c(x[1] + y[1], y)
z <- c(y[1] + z[1], z)
}
cbind(w, x, y, z)
If you really want to use recursive environments (although I'd prefer a looping solution) you can get around the problem by passing all four variables along in a vector.
y <- function(v=c(w=1, x=2, y=3, z=4)) {
print(v["x"])
v["w"] <- 1 + v["w"]
v["x"] <- v["w"] + v["x"]
v["y"] <- v["x"] + v["y"]
v["z"] <- v["y"] + v["z"]
if (v["w"] <= 10){
y(v)
} else {
v
}
}
y()