I've got a function written in Rcpp:
library(Rcpp)
cppFunction("NumericVector MatVecMul_cpp (NumericVector y, double k) {
int n = y.size();
NumericVector z(n);
int i; double *p1, *p2, *end = &z[n];
double tmp = 1.0;
for (i = 0; i < n; i++) {
for (p1 = &z[i], p2 = &y[0]; p1 < end; p1++, p2++) *p1 += tmp * (*p2);
tmp *= k;
}
return z;
}")
Basically the goal of the function is to take a numeric vector and parameter k and to calculate output vector where an i-th element is a sum of i-1-th element multiplied by k and a i-th element of input vector y. However, now I need to make some tweak, i.e. I need to take additional parameter c which would tell that c row after non-zero value in y vector the output vector z should be 0. See desired output below with c = 4, k = 0.9.
structure(list(y = c(0.7, 0, 0, 0, 0, 0, 0, 4, 0, 0, 6, 0, 0,
0), z = c(0.7, 0.63, 0.567, 0.5103, 0.45927, 0, 0, 4, 3.6, 3.24,
8.916, 8.0244, 7.22196, 6.499764)), row.names = c(NA, -14L), class = "data.frame")
So once again, the 5-th value of z is 0, because the parameter c is equal to 4 so we doesn't multiply the previous value of z anymore. But the 11-th value of z is 8.916000 as we don't only multiply previous value by 0.9, but also add 6.0 from y column.
I have tried to create a new 0-1 column in data.frame named as c which would indicate if the 0.9 decrease is still considered or not and then tried to adjust above function, but the following didn't work (values of z doesn't reset where c = 0).
cppFunction("NumericVector adjust_cpp (NumericVector y, double k, NumericVector ctrl) {
int n = y.size();
NumericVector z(n);
int i; double *p1, *p2, *p3, *end = &z[n];
double tmp = 1.0;
for (i = 0; i < n; i++) {
for (p1 = &z[i], p2 = &y[0], p3 = &ctrl[0]; p1 < end; p1++, p2++, p3++) {
*p1 += tmp * (*p2);
*p1 *= *p3;
}
tmp *= k;
}
return z;
}"
)
How can I accomplish that?
structure(list(y = c(0.7, 0, 0, 0, 0, 0, 0, 4, 0, 0, 6, 0, 0,
0), z = c(0.7, 0.63, 0.567, 0.5103, 0.45927, 0, 0, 4, 3.6, 3.24,
8.916, 8.0244, 7.22196, 6.499764), ctrl = c(1, 1, 1, 1, 1, 0,
0, 1, 1, 1, 1, 1, 1, 1)), .Names = c("y", "z", "ctrl"), row.names = c(NA,
-14L), class = "data.frame")
With above data in R this would be:
fun <- function(y, k, ctrl) {
n <- length(y)
z <- numeric(n)
z[1] <- y[1]
for (i in 1:(n - 1)) {
z[i + 1] <- (y[i + 1] + z[i] * k) * ctrl[i + 1]
} return(z)
}
Translating such a simple R function into Rcpp can be done line by line with minimal changes:
#include <Rcpp.h>
using Rcpp::NumericVector;
// [[Rcpp::export]]
NumericVector funC(NumericVector y, double k, NumericVector ctrl) {
R_xlen_t n = y.length();
NumericVector z(n);
z(0) = y(0);
for (R_xlen_t i = 0; i < n - 1; ++i) {
z(i + 1) = (y(i + 1) + z(i) * k) * ctrl(i + 1);
}
return z;
}
/*** R
df <- structure(list(y = c(0.7, 0, 0, 0, 0, 0, 0, 4, 0, 0, 6, 0, 0,
0), z = c(0.7, 0.63, 0.567, 0.5103, 0.45927, 0, 0, 4, 3.6, 3.24,
8.916, 8.0244, 7.22196, 6.499764), ctrl = c(1, 1, 1, 1, 1, 0,
0, 1, 1, 1, 1, 1, 1, 1)), .Names = c("y", "z", "ctrl"), row.names = c(NA,
-14L), class = "data.frame")
fun <- function(y, k, ctrl) {
n <- length(y)
z <- numeric(n)
z[1] <- y[1]
for (i in 1:(n - 1)) {
z[i + 1] <- (y[i + 1] + z[i] * k) * ctrl[i + 1]
}
return(z)
}
z <- fun(df$y, 0.9, df$ctrl)
all.equal(df$z, z)
z <- funC(df$y, 0.9, df$ctrl)
all.equal(df$z, z)
*/
For the provided vectors with length 14, the R version is still faster on this machine. Duplicating y and ctrl ten times gives vectors, for which Rcpp is already faster.
Related
I am trying to make run this model. I am trying to maximize:x[4]
w.r.t Mv = c(0,0,0,0)
lb < v < ub
But I have 2 problems, first matrix multiplication.
library(ompr)
lb <- c(-200, 0, -200, -200)
ub <- c(1000, 1000, 1000, 1000)
M <- matrix(rbind(
c(-1, 0, -1, 0), # A
c(-1, 0, 0, -2), # B
c(1, -2, 0, 0), # C
c(1, 0, 0, 2), # D
c(0, 2, -1, 0), # E
c(0, 0, 1, -1) # F
), nrow = 6)
n <- 4
rhs <- rep(0, n)
model <- MIPModel() %>%
add_variable(x[i], i = 1:n, type = "continuous") %>%
set_objective(x[4]) %>%
add_constraint(M[i, ] %*% x == rhs[i], i = 1:n)
I got the following error.
Error in M[i, ] %*% x : requires numeric/complex matrix/vector
arguments
Second, I am trying to set the bounds in a vectorized way, but I don't know how to do that. I tried the following:
set_bounds(x[i], ub = ub[i], lb = lb[i], i = 1:n)
This gives:
object 'i' not found
Any help would be very useful!
Works like this, but the solution is (0, 0, 0, 0):
library(ompr)
library(ompr.roi)
library(ROI.plugin.glpk)
library(magrittr)
lb <- c(-200, 0, -200, -200)
ub <- c(1000, 1000, 1000, 1000)
M <- matrix(rbind(
c(-1, 0, -1, 0), # A
c(-1, 0, 0, -2), # B
c(1, -2, 0, 0), # C
c(1, 0, 0, 2), # D
c(0, 2, -1, 0), # E
c(0, 0, 1, -1) # F
), nrow = 6)
n <- 4
rhs <- rep(0, n)
model <- MIPModel() %>%
add_variable(x[i], i = 1:n, type = "continuous") %>%
set_objective(x[4], "max") %>%
add_constraint(sum_over(M[i, j] * x[j], j = 1:4) == rhs[i], i = 1:n) %>%
add_constraint(x[i] <= ub[i], i = 1:n) %>%
add_constraint(x[i] >= lb[i], i = 1:n) %>%
solve_model(with_ROI(solver = "glpk"))
get_solution(model, x[i])
I have a list that looks something like this (a must-reduced version of a list with 301 sub-elements):
myList <- list()
myList$Speaker1 <- list("ID" = c(1, 2, 3, 4, 5),
"S1C1.Sonorant" = c(0, 0, 0, 0.5, 0, -1),
"S1C1.Consonantal" = c(0, 0, 0, 0, 0, 1),
"S1C1.Voice" = c(0, 0, 1, 1, 1, -1),
"S1C1.Nasal" = c(0, 0, 1, 0, 1, -1))
myList$Speaker2 <- list("ID" = c(1, 2, 3, 4, 5),
"S1C1.Sonorant" = c(0, 0, 0, 0.5, 0, -1),
"S1C1.Consonantal" = c(0, 0, 0, 0, 0, 1),
"S1C1.Voice" = c(0, 0, 1, 1, 1, -1),
"S1C1.Nasal" = c(0, 0, 1, 0, 1, -1))
myList$Speaker3 <- list("ID" = c(1, 2, 3, 4, 5),
"S1C1.Sonorant" = c(0, 0, 0, 0.5, 0, -1),
"S1C1.Consonantal" = c(0, 0, 0, 0, 0, 1),
"S1C1.Voice" = c(0, 0, 1, 1, 1, -1),
"S1C1.Nasal" = c(0, 0, 1, 0, 1, -1))
For each speaker, I want to run some functions through all the sub-elements that include the string S1C1.. So far, I have the following, which calls each column containing S1C1 individually:
my_matrix <- lapply(myList, FUN = function(element) {
ones <- rep(1, nrow(element)) # count repeated rows
sonorant_vec.S1C1 <- element$S1C1.Sonorant
sonorant_mat.S1C1 <- (sonorant_vec.S1C1 %*% t(ones) - ones %*% t(sonorant_vec.S1C1))^2
consonantal_vec.S1C1 <- element$S1C1.Consonantal
consonantal_mat.S1C1 <- (consonantal_vec.S1C1 %*% t(ones) - ones %*% t(consonantal_vec.S1C1))^2
voice_vec.S1C1 <- element$S1C1.Voice
voice_mat.S1C1 <- (voice_vec.S1C1 %*% t(ones) - ones %*% t(voice_vec.S1C1))^2
nasal_vec.S1C1 <- element$S1C1.Nasal
nasal_mat.S1C1 <- (nasal_vec.S1C1 %*% t(ones) - ones %*% t(nasal_vec.S1C1))^2
mat.S1C1 <- sonorant_mat.S1C1 +
consonantal_mat.S1C1 +
voice_mat.S1C1 +
nasal_mat.S1C1
rownames(mat.S1C1) <- element$S1C1.S1C1
colnames(mat.S1C1) <- element$S1C1.S1C1
all_mat <- sqrt(mat.S1C1[,])
return(all_mat)
})
Is there a way I can iterate through all the sub-elements that start with the string S1C1.? The current code works but is very long!
set.seed(1)
### i would like to do this
dmvnorm(c(.5,.5), mean= c(2,15), matrix(c(3, 0, 0, 9), 2))
dmvnorm(c(.6,.6), mean= c(5,18), matrix(c(6, 0, 0, 15), 2))
##### BUT using mapply instead... how can that be done?
u1 = c(2,15)
sigma1 = matrix(c(3, 0, 0, 9), 2)
u2 = c( 5, 18)
sigma2 = matrix(c(6, 0, 0, 15), 2)
parameters = list(mu = list(u1, u2), sigma = list(sigma1, sigma2))
mapply( c(c(.5,.5),c(.6,.6)), dmvnorm,
mean = c(parameters$mu[[1]], parameters$mu[[2]] ) ,
sigma= c(parameters$sigma[[1]],parameters$sigma[[2]]
) )
Put every parameters to the same argument in a list:
library(mvtnorm)
u <- list(u1 = c(2,15), u2 = c( 5, 18))
sigma <- list(sigma1 = matrix(c(3, 0, 0, 9), 2),
sigma2 = matrix(c(6, 0, 0, 15), 2))
x <- list(c(0.5, 0.5), c(0.6, 0.6))
result <- mapply(dmvnorm, x, u, sigma)
# [1] 1.780234e-07 1.384004e-07
This is equivalent to:
result <- numeric(length(x))
for (i in 1:length(x))
result[i] <- dmvnorm(x[[i]], u[[i]], sigma[[i]])
Im trying to get the command rows_equal to work but not managing to do so.
The matrix in question is:
P <- matrix(c(0, 0, 0, 0.5, 0, 0.5, 0.1, 0.1, 0, 0.4, 0, 0.4, 0, 0.2, 0.2, 0.3, 0, 0.3, 0, 0, 0.3, 0.5, 0, 0.2, 0, 0, 0, 0.4, 0.6, 0, 0, 0, 0, 0, 0.4, 0.6), nrow = 6, ncol = 6, byrow = TRUE)
What I'm trying to figure out is how large "n" has to be in P^n that will make all the rows in the matrix equal.
mpow <- function(P, n) {if (n == 0) {return(diag(nrow(P)))} else if
(n == 1) {return(P)} else {
return(P %*% mpow(P, n - 1))} }
rows_equal <- function(P, d = 4) {P_new <- trunc(P * 10^d)
for (k in 2:nrow(P_new)) {if
(!all(P_new[1, ] == P_new[k, ])) {
return(FALSE)} }
return(TRUE) }
This is what I enter into Rstudio, however, I don't see what I'm doing wrong. Isn't the command rows_equal suppose to give us False or True?
Thank you for reading my question/
Confused student with a large headache.
Aside from formatting, I made two changes to your code:
you forgot to use your mpow function and used trunc(P * 10^d) instead.
I replaced == with all.equal, which allows for some numerical imprecision.
Using all.equal to compare numerical values is typically preferable to == in these situations.
rows_equal <- function(P, d = 4) {
P_new <- mpow(P, d)
for (k in 2:nrow(P_new)) {
if ((all.equal(P_new[1, ], P_new[k, ])) != TRUE) {
return(FALSE)
}}
return(TRUE)
}
This outputs
> rows_equal(P, 10)
[1] FALSE
> rows_equal(P, 50)
[1] TRUE
I've the following data.table
structure(list(xi = c(1, 1, 1, 2, 2, 2, 3, 3, 3), yi = c(1, 2,
3, 1, 2, 3, 1, 2, 3), flag = c(0, 0, 0, 0, 0, 0, 0, 0, 0)), .Names = c("xi",
"yi", "flag"), row.names = c(NA, -9L), class = c("data.table",
"data.frame"), .internal.selfref = <pointer: 0x11a1a78>)
I also have a 3x3 matrix as below.
structure(c(1, 1, 0.4, 1, 0, 0, 1, 0, 0.2), .Dim = c(3L, 3L))
I want to assign a third column to the data.table flag such that if the element in the matrix represented by the xi row and yi column is less than 1, then flag = 1 else 0. I wrote a function for this,
func <- function (x, y, m) {
if (m[x, y] < 1) {
return(1)
}
else {
return(0)
}
}
However, if I try
y[,flag := func(xi,yi,m)]
my flag values are always 0. Could someone point out what I'm doing wrong here?
Thanks in advance.
You don't need a custom function...
dt[ , flag := as.integer( m[cbind(xi,yi)] < 1 ) ]
You do need to be careful to index the matrix in the correct way (using cbind(...) rather than [,] form of indexing).