I am using the lapp functin of {terra} in R and I want to update rast_a with values from rast_b or rast_c (and some other math) depending on the value in each cell of rast_a.
sample data
rast_a <- rast(ncol = 2, nrow = 2)
values(rast_a) <- 1:4
rast_b <- rast(ncol = 2, nrow = 2)
values(rast_b) <- c(2,2,2,2)
rast_c <- rast(ncol = 2, nrow = 2)
values(rast_c) <- c(3,3,3,3)
Problem
This is my (wrong) attempt.
my_update_formula <- function(a, b, c) {
a[a == 1] <- b[a == 1] + 10 + 20 - 30
a[a == 2] <- c[a == 2] + 10 + 50 - 50
return(a)
}
result <- lapp(c(rast_a, rast_b, rast_c),
fun = my_update_formula)
values(result)
lyr1
[1,] 3
[2,] 3
[3,] 3
[4,] 4
The actual result should be 2,3,3,4. But because of the operations inside the formula, the first value gets updated twice. First it is changed from 1 to 2 (correctly) but then it fulfills the condition of the second line of code also, and is changed again (I don't want that to happen).
How can I solve this please?
You can change your formula to
f1 <- function(a, b, c) {
d <- a
d[a == 1] <- b[a == 1]
d[a == 2] <- c[a == 2] + 10
d
}
#or
f2 <- function(a, b, c) {
i <- a == 1
j <- a == 2
a[i] <- b[i]
a[j] <- c[j] + 10
return(a)
}
lapp(c(rast_a, rast_b, rast_c), fun = f1) |> values()
# lyr1
#[1,] 2
#[2,] 13
#[3,] 3
#[4,] 4
lapp(c(rast_a, rast_b, rast_c), fun = f2) |> values()
# lyr1
#[1,] 2
#[2,] 13
#[3,] 3
#[4,] 4
You can get the same result with
x <- ifel(rast_a==1, rast_b,
ifel(rast_a == 2, rast_c + 10, rast_a))
Related
Just some smaller changes which do not need to be considered.
This for loop may be helpful.
1. Run all of your codes
s <- 60000
t <- 20
mu <- function(x, t) {
A <- .00022
B <- 2.7*10^(-6)
c <- 1.124
mutemp <- A + B*c^(x + t)
out <- ifelse(t <= 2, 0.9^(2 - t)*mutemp, mutemp)
out}
f <- function(x) (s - x - 0.05*(0.04*x + 1810.726 - mu(40, t)*(s - x)))
2. Run the for loop below for iteration
2.1 Predefine the length of the outcome. In your case is 400 (t/0.05 = 400).
output <- vector(mode = "numeric", length = t/0.05)
2.2 Run through the for loop from 1 to 400. Save each uniroot result to step 2.1, and then reassign both s and t accordingly.
for (i in 1:400) {
output[i] <- uniroot(f, lower=0.1, upper=100000000)$root
s <- output[i]
t <- 20 - i * 0.05
}
3. Inspect the result
output
Hope this is helpful.
You could use vapply on a defined t sequence.
s <- 6e4
tseq <- seq.int(19.95, 0, -.05)
x <- vapply(tseq, \(t) {
s <<- uniroot(\(x) (s - x - 0.05*(0.04*x + 1810.726 - mu(40, t)*(s - x))), lower=0.1, upper=100000000)$root
}, numeric(1L))
Note, that <<- changes s in the global environment, and at the end gets the last value.
s
# [1] 2072.275
res <- cbind(t=tseq, x)
head(res)
# t x
# [1,] 19.95 59789.92
# [2,] 19.90 59580.25
# [3,] 19.85 59371.01
# [4,] 19.80 59162.18
# [5,] 19.75 58953.77
# [6,] 19.70 58745.77
I need to identify pairs of variables that are dominated: if both values of the pair are lower than the other pairs in the data.
I already tried the functions min or pmin but I am not sure if they are the most appropriate.
a = matrix(c(50,70), ncol = 2)
b = matrix(c(45,85), ncol = 2)
df = rbind(a,b)
Dominance <- function(a){
for (i in 1:nrow(a)) {
for (j in 1:nrow(a)) {
i1 <- rowSums(a[i,] < a[j,]) == ncol(a)
a[i1,, drop = FALSE]
}
}
return(a)
}
l = Dominance(df)
> l
X1 X2
1 45 65
2 50 70
I expect the pair (45,65) to be removed.
An option is to use do a comparison (<) between equal sized objects, then get the rowSums, if the sum is equal to the number of columns of the dataset, it implies all the elements in that row is less than the second data corresponding row
f1 <- function(mat1, mat2) {
i1 <- !rowSums(mat1 < mat2) == ncol(mat1)
i2 <- !rowSums(mat2 < mat1) == ncol(mat2)
rbind(mat1, mat2)[c(i1, i2),, drop = FALSE]
}
b <- matrix(c(45,65), ncol = 2)
b1 <- matrix(c(45,85), ncol = 2)
f1(a, b)
# [,1] [,2]
#[1,] 50 70
f1(a, b1)
# [,1] [,2]
#[1,] 50 70
#[2,] 45 85
I want to collapse rows in a matrix so that no value of a particular column ever falls below 20. And I want to apply a custom function to the rows to collapse/sum them...
Here is an example matrix:
d <- matrix(data = c(0,105,1,21,2,11,4,5,5,15,7,21,9,1),
ncol = 2,
byrow = TRUE
)
colnames(d) <- c('val','freq')
Looking like this:
d
val freq
[1,] 0 105
[2,] 1 21
[3,] 2 11
[4,] 4 5
[5,] 5 15
[6,] 7 21
[7,] 9 1
The column where the cells must be 20 or above is "freq". So row 1 and 2 are fine, but I need to collapse row 3:5. And I want to replace row 3:5 with the single row from this function:
library(reshape)
replacement <- function(x){
mat <- d[x, ]
mat.res <- untable(mat[ ,c(1, 2)],
num = mat[ ,2]
)
res <- c(mean(mat.res[ ,1]), length(mat.res[ ,1]))
return(res)
}
The function call:
replacement(3:5)
[1] 3.774194 31.000000
Going through the matrix; row 6 is fine, but since row 7 would be left with freq=1 this row needs to be collapsed with row 6. The function call again:
replacement(6:7)
[1] 7.090909 22.000000
The resulting matrix should be:
val freq
[1,] 0 105
[2,] 1 21
[3,] 3.774194 31.000000
[4,] 7.090909 22.000000
The final row numbering is not important.
I have a feeling that the window functions of dplyr might hold the solution, but I need help understanding exactly how. It does not have to be dplyr. I take whatever works ;-)
For future reference, this is not very elegant, but it works...
rows <- dim(d)[1]
tmp <- NULL
inc <- 1
tmpSum <- 0
for(i in 1:rows){
if(d[i, 2] > 19){
tmp <- rbind(tmp, c(d[i, ], inc))
inc <- inc + 1
tmpSum <- 0
} else {
tmp <- rbind(tmp, c(d[i, ], inc))
tmpSum <- d[i,2] + tmpSum
if(tmpSum > 19){
inc <- inc + 1
}
}
}
if(sum(tmp[tmp[ ,3] == max(tmp[ ,3]), 2]) < 19){
tmp[tmp[ ,3] == max(tmp[ ,3]), 3] <- tmp[tmp[ ,3] == max(tmp[ ,3]), 3]-1
}
res <- NULL
for(i in 1:max(tmp[ ,3])){
val <- mean(rep(tmp[tmp[ ,3] == i, 1], tmp[tmp[ ,3] == i, 2]))
freq <- length(rep(tmp[tmp[ ,3] == i, 1], tmp[tmp[ ,3] == i, 2]))
res <- rbind(res, c(val, freq))
}
res
I have a question about how to express x1x2 in objective function.
Here is an example in the Internet.
##
## min x1^2 +2x2^2 + 4x3^2 - x1 - x2 + 5x3
## x1 + x3 <= 1
## x1 >= 5
## x2 <= 0
##
P = 2*diag (c (1, 2, 4));
d = c (-1, -1, 5);
A = matrix (0, nrow=3, ncol=3);
A[1,] = c(-1, 0, -1);
A[2,] = c( 1, 0, 0);
A[3,] = c( 0, -1, 0);
b = c(-1, 5, 0);
From the example, the objective finction is x1^2 +2x2^2 + 4x3^2 - x1 - x2 + 5x3
In R, it is P = 2*diag (c (1, 2, 4)); d = c (-1, -1, 5);
However, if i have an objective function like x1x2 or x1^2
How to key the commands in R ?
Thanks a lot in advance.
solve.QP function minimizes the following expression:
min 1/2 * (t(x) %*% D %*% x) - t(d) %*% x
where x is the vector of n variables (e.g. x1, x2 ...), D a symmetric matrix of n x n coefficients and d a vector of n coefficients.
In order to understand how those matrix products translate to an objective function expression, I've created the following simple function to expand the quadprog objective given the inputs :
# Given matrix D and vector d that will be passed to solve.QP,
# it returns the objective function expression as string
expandQPObj <- function(D, d, var.name = 'x') {
# helper function that expands a matrix product. NB it does not compute the result,
# it just returns the expressions of each element of the resulting matrix
expandMatrixProd <- function(m1, m2) {
m1 <- as.matrix(m1)
m2 <- as.matrix(m2)
if (ncol(m1) != nrow(m2)) { stop("incompatible dimensions") }
n <- nrow(m1)
m <- ncol(m2)
res <- matrix('', nrow = n, ncol = m)
for (i in 1:n) {
for (j in 1:m) {
a <- m1[i, ]
b <- m2[, j]
a <- ifelse(grepl('[+*]', a), paste0('(', a, ')'), a)
b <- ifelse(grepl('[+*]', b), paste0('(', b, ')'), b)
res[i, j] <- gsub('+-','-',paste(a, b, sep = '*', collapse = '+'),fixed = TRUE)
}
}
return(res)
}
D <- as.matrix(D)
d <- as.vector(d)
n <- length(d)
if (!all(dim(D) == n) || n == 0) {
stop('Dimensions problem: D should be an nxn matrix and d a vector of length n (n>0)')
}
xvec <- paste(var.name, 1:n, sep = '')
quadComp <- as.vector(Reduce(list(t(xvec), D, xvec),f=expandMatrixProd))
linearComp <- as.vector(strMatrixMult(t(d), xvec))
return(paste0('1/2*(', quadComp, ') - (', linearComp, ')'))
}
By calling it with literal coefficients we can easily understand how to set these coefficients to get our desired result :
Dliteral <- matrix(paste0('D',1:9),nrow=3,byrow = T)
# [,1] [,2] [,3]
#[1,] "D1" "D2" "D3"
#[2,] "D4" "D5" "D6"
#[3,] "D7" "D8" "D9"
dliteral <- paste0('d',1:3)
#[1] "d1" "d2" "d3"
expandQPObj(Dliteral,dliteral)
#"1/2*((x1*D1+x2*D4+x3*D7)*x1+(x1*D2+x2*D5+x3*D8)*x2+(x1*D3+x2*D6+x3*D9)*x3) - d1*x1+d2*x2+d3*x3"
So, in order to get :
min x1*x2
we need to set D2=1 and D4=1 (not just D2=2 since matrix D must be symmetric!) and all the others coefficients = 0, hence :
D = rbind(c(0,1,0),c(1,0,0),c(0,0,0))
# [,1] [,2] [,3]
#[1,] 0 1 0
#[2,] 1 0 0
#[3,] 0 0 0
d <- rep(0,3)
#[1] 0 0 0
expandQPObj(D,d)
[1] "1/2*((x1*0+x2*1+x3*0)*x1+(x1*1+x2*0+x3*0)*x2+(x1*0+x2*0+x3*0)*x3) - 0*x1+0*x2+0*x3"
Similarly, to obtain :
min x1^2 (== min x1*x1)
we need to set D1=2 and all the others coefficients = 0 :
D = rbind(c(2,0,0),c(0,0,0),c(0,0,0))
# [,1] [,2] [,3]
#[1,] 2 0 0
#[2,] 0 0 0
#[3,] 0 0 0
d <- rep(0,3)
#[1] 0 0 0
expandQPObj(D,d)
# "1/2*((x1*2+x2*0+x3*0)*x1+(x1*0+x2*0+x3*0)*x2+(x1*0+x2*0+x3*0)*x3) - 0*x1+0*x2+0*x3"
Let's say I have a matrix that looks like this, and I convert it into a dist class object (without diagonal), and then into a vector for later purposes.
m = matrix(c(0,1,2,3, 1,0,3,4, 2,3,0,5, 3,4,5,0), nrow=4)
#m:
[,1] [,2] [,3] [,4]
[1,] 0 1 2 3
[2,] 1 0 3 4
[3,] 2 3 0 5
[4,] 3 4 5 0
md = as.dist(m, diag=F)
# md:
1 2 3
2 1
3 2 3
4 3 4 5
mdv = as.vector(md)
# 1 2 3 3 4 5
I can access the original matrix as usual with [], and I could easily access the one-dimensional index (of, for example row 3, col 2) using m[ 3+((2-1)*4) ]. The dist object (and the vector) is one-dimensional, but composes only of the lower triangle of the original matrix (and also lacks one element from each original col/row, since the diagonal was removed).
How can I later access the equivalent element in the vector mdv? So e.g. how could I access the equivalent of m[3,2] (value 3) in the object mdv? (Not by the value, since there can be duplicate values, but by the index) Related Q&A resolve similar problems with as.matrix on the dist object, but that doesn't do it for me (since I need to deal with the vector).
Having the lower.tri(, diag = FALSE) distances-vector ("mdv") you could (1) find the respective dimensions of the distances-matrix ("m") and (2) convert the i + (j - 1)*nrow indices accordingly by subtracting the equivalent missing "upper.tri".
ff = function(x, i, j)
{
#assumes that 'x' is a valid distances vector that results in correct 'n'
n = (1 + sqrt(1 + 8 * length(x))) / 2
#make sure i >= j
ii = pmax(i, j); jj = pmin(i, j)
#insert 0s to handle 'i == j'
x = c(unlist(lapply(split(x, rep(seq_len(n - 1), (n - 1):1)),
function(X) c(0, X)), FALSE, FALSE), 0)
#subtract the missing `upper.tri` elements
x[(ii + (jj - 1L) * n) - cumsum(0:(n - 1))[jj]]
}
E.g.:
n = 3
m = matrix(0, n, n); m[lower.tri(m)] = runif(choose(n, 2)); m = m + t(m); x = c(as.dist(m))
m
# [,1] [,2] [,3]
#[1,] 0.0000000 0.3796833 0.5199015
#[2,] 0.3796833 0.0000000 0.4770344
#[3,] 0.5199015 0.4770344 0.0000000
m[cbind(c(2, 2, 3, 1), c(3, 2, 1, 2))]
#[1] 0.4770344 0.0000000 0.5199015 0.3796833
ff(x, c(2, 2, 3, 1), c(3, 2, 1, 2))
#[1] 0.4770344 0.0000000 0.5199015 0.3796833
n = 23
m = matrix(0, n, n); m[lower.tri(m)] = runif(choose(n, 2)); m = m + t(m); x = c(as.dist(m))
i = sample(seq_len(n), 25, TRUE); j = sample(seq_len(n), 25, TRUE)
all.equal(m[cbind(i, j)], ff(x, i, j))
#[1] TRUE
etc...
How about this function:
fun <- function(r, c){
stopifnot(r != c)
if(r > c) (r-2)*(r-1)/2 + c
else (c-2)*(c-1)/2 + r
}
mdv[fun(1, 2)] # 1
mdv[fun(2, 3)] # 3
mdv[fun(3, 4)] # 5
mdv[fun(2, 1)] # 1
mdv[fun(3, 2)] # 3
mdv[fun(1, 1)] # stop
Cases with r == c should be handled before applying fun. For convenience, You can write another function for handling this case.