I was wondering whether there exist any packages or other pre-built solutions for R that are capable of translating sets of linear equations into matrix form (e.g. for solution via the Gauss Seidel algorithm), similar to the equationsToMatrix(eqns,vars) function in Matlab?
An example from Matlab:
[A, b] = equationsToMatrix([x - y == 0, x + 2*y == 3, [x, y])
A =
[ 1, -1]
[ 1, 2]
b =
0
3
Suggestions for building blocks would be very helpful, too.
1) This is not exactly what you are asking for but maybe it will help anyways:
library(Ryacas)
x <- Sym("x")
y <- Sym("y")
Simplify(Solve(List(x - y == 0, x + 2*y == 3), List(x, y)))
giving:
expression(list(list(x - y == 0, y - 1 == 0)))
2) If we know these are linear equations exactly of the form shown in the question then try this. The two strapply calls perform matches of the regular expression against the components of args, capture the strings matched by the portions of the regular expressions within parentheses and call the function specified as the third argument with those captured strings as arguments. We combine the strapply outputs using rbind.fill and replace any NAs it generates with zero.
library(gsubfn) # strapply
library(plyr) # rbind.fill
eqn <- function(...) {
args <- c(...)
x2num <- function(x, y) { # determine coefficient value as a numeric
z <- gsub(" ", "", x)
setNames(if (z == "-") -1 else if (z == "") 1 else as.numeric(z), y)
}
lhs <- strapply(args, "(-? *\\d*)[ *]*([a-z])", x2num)
lhs <- do.call(rbind.fill, lapply(lhs, function(x) as.data.frame(t(x))))
lhs <- as.matrix(lhs)
lhs[] <- ifelse(is.na(lhs), 0, lhs)
list(lhs = lhs, rhs = strapply(args, "== *(\\d)", as.numeric, simplify = TRUE))
}
# test it out
eqn("x - y == 0", "2*y == 3")
giving:
$lhs
x y
[1,] 1 -1
[2,] 0 2
$rhs
[1] 0 3
Update: Generalized so that now not all variables need to be in each equation and also variables can be in different orders in different equations.
Can't tell from your example whether you just want simple linear equation solving or a more general system solver. If the latter, take a look at the BB and nleqslv packages.
You might also be interested in a "wrapper" tool written by some seriously twisted mind :-) , in the package ktsolve . This last tool lets you set up an arbitrary set of equations and back-solve for any desired set of variables.
Related
In Octave, I use the following to differentiate a function of 2-variables and then substitute 0 for x using subs(). Basically in doing moment-generating-function, Taylor series expansion, etc, we differentiate and then substitute some a for x. I am not able to find the equivalent substitution function in R. Can you please let me know how to do it? Thanks
pkg load symbolic; #octave symbolic package
syms lamb, x; #declare lamb, x symbols
mgf = lamb / (lamb - x); #moment generating function of exponential
mgf1 = diff(mgf, x, 1); #1st differivative
mgf1_0 = subs(mgf1, x, 0); #substitute 0 for E(X)
Using base R:
f <- quote( lambda / (lambda - x) )
Df <- D(f, "x")
do.call("substitute", list(Df, list(x = 0)))
## lambda/(lambda - 0)^2
or we can evaluate Df at specific x and lambda values:
eval(Df, list(x = 0, lambda = 3))
## [1] 0.3333333
Create function to represent result
We can use Df to define an R function der which evaluates the derivative at specific x and lambda values.
der <- function(x, lambda) {}
body(der) <- Df
der(0, 3)
## [1] 0.3333333
Currying
If we want to set x to 0 and create the resulting function of lambda
make_der0 <- function(x = 0) function(lambda) der(x, lambda)
der0 <- make_der0()
der0(3)
## [1] 0.3333333
This is known as currying or partialling and various packages have this as well:
library(functional)
der0a <- Curry(der, x = 0)
der0a(3)
## [1] 0.3333333
library(purrr)
der0b <- partial(der, x = 0)
der0b(3)
## [1] 0.3333333
This appears to be using the symbolic package, which in turn depends on the sympy Python library. R doesn't have built-in symbolic manipulation capabilities, but it does (TIL) have an rSymPy package that works similarly.
## https://kevinkotze.github.io/mm-tut1-symbolic/
library(rSymPy)
rSymPy doesn't have a built-in subs() function, so we'll define one:
subs <- function(expr,x,y) {
Sym(expr,".subs(",x,",",y,")")
}
Also useful to define this (not sure if there's a better way):
r_eval <- function(s,eval_list) {
eval(parse(text=sympy(unclass(s))), eval_list)
}
The rest of the code looks almost identical to the Octave code. Define variables:
## NOTE: 'lambda' is a reserved word in Python, so trying to use it as
## a variable gives rise to confusing errors ...
lam <- Var("lam")
x <- Var("x")
f <- lam/(lam-x)
Differentiate:
mgf1 <- deriv(f,x,1)
Substitute:
subs(mgf1,x,0)
There are other interfaces from R to symbolic math engines, e.g. Ryacas.
If you want to compute the second moment by calculating f''(0), that's not much harder:
v <- subs(deriv(f,x,2),x,0) ## "2/lam**2"
r_eval(v, list(lam=5)) ## 0.08
Maybe you can try package Deriv
library(Deriv)
f <- function(l,x) l/(l-x)
fprim <- Deriv(f,"x")(2,0)
such that
> fprim(2,0)
[1] 0.5
This is equation a <- x * t - 2 * x. I want to solve this equation for t.
So basically, set a = 0 and solve for t . I am new to the R packages for solving equations. I need the package that solves for complex roots. The original equations I am work with have real and imaginary roots. I am looking for an algebraic solution only, not numerical.
I tried:
a <- x * t - 2 * x
solve(a,t)
I run into an error:
Error in solve.default(a, t) : 'a' (1000 x 1) must be square
You can use Ryacas to get the solution as an expression of x:
library(Ryacas)
x <- Sym("x")
t <- Sym("t")
Solve(x*t-2*x == 0, t)
# Yacas vector:
# [1] t == 2 * x/x
As you can see, the solution is t=2 (assuming x is not zero).
Let's try a less trivial example:
Solve(x*t-2*x == 1, t)
# Yacas vector:
# [1] t == (2 * x + 1)/x
If you want to get a function which provides the solution as a function of x, you can do:
solution <- Solve(x*t-2*x == 1, t)
f <- function(x){}
body(f) <- yacas(paste0("t Where ", solution))$text
f
# function (x)
# (2 * x + 1)/x
You might be looking for optimize:
a=function(x,t) x*t-2*x
optimize(a,lower=-100,upper=100,t=10)
optimize(a,lower=-100,upper=100,x=2)
If you need more help, I need a reproductible example.
I am trying to create a function that computes the sum of digits of large numbers, of the order of 100^100. The approach described in this question does not work, as shown below. I tried to come up with a function that does the job, but have not been able to get very far.
The inputs would be of the form a^b, where 1 < a, b < 100 and a and b are integers. So, in that sense, I am open to making digitSumLarge a function that accepts two arguments.
digitSumLarge <- function(x) {
pow <- floor(log10(x)) + 1L
rem <- x
i <- 1L
num <- integer(length = pow)
# Individually isolate each digit starting from the largest and store it in num
while(rem > 0) {
num[i] <- rem%/%(10^(pow - i))
rem <- rem%%(10^(pow - i))
i <- i + 1L
}
return(num)
}
# Function in the highest voted answer of the linked question.
digitsum <- function(x) sum(floor(x / 10^(0:(nchar(x) - 1))) %% 10)
Consider the following tests:
x <- c(1,2,3,4,5,6,7,8,9,1,2,3,4,5,6,7,8,9)
as.numeric(paste(x, collapse = ''))
# [1] 1.234568e+17
sum(x)
# 90
digitSumLarge(as.numeric(paste(x, collapse = '')))
# 85
digitsum(as.numeric(paste(x, collapse = '')))
# 81, with warning message about loss of accuracy
Is there any way I can write such a function in R?
You need arbitrary precision numbers. a^b with R's numerics (double precision floats) can be only represented with limited precision and not exactly for sufficiently large input.
library(gmp)
a <- as.bigz(13)
b <- as.bigz(67)
sum(as.numeric(strsplit(as.character(a^b), split = "")[[1]]))
#[1] 328
have a question concerning the use of mapply.
Consider the following 2 cases:
Case 1 showing a simplified example of what I wish to do. I use mapply to transform my vector k element-wise with the functions stored in vector trans. This works (related to this question)
In Case 2 I wish to do something similar, however, I want extra function arguments (here, stored in a).But I might want n function arguments. What I get in this example is a 3x3 matrix with the expected results on the diagonal. I only want the computed output of the diagonal. How?
k <- seq(1:3)
# Case 1 -----------------------------------------------------------------------
trans <- c(function(x) x, function(x) 1/x, function(x) x^2)
# transform vektors elementwise with functions in a "transform" vektor
ktrans <- mapply(function(f, x) f(x), trans, k)
# 2 -----------------------------------------------------------------------
k <- seq(1:3)
a <- rep(2,3)
transa <- c(function(x,a) x*a, function(x,a) 1/x*a, function(x,a) x^2*a)
ktransa <- mapply(function(f, x,a) f(x,a), transa, MoreArgs= list(x = k, a= a))
> diag(ktransa)
[1] 2 1 18
Solution:
Instead of using a list to send the arguments to the function, I did it explicitly:
# 3 --- Example with n arguments -----------------------------------
k <- seq(1:3)
a <- rep(2,3)
transa <- c(function(x,a) x*a, function(x,a) 1/x*a, function(x,a) x^2*a)
ktransa <- mapply(function(f, x, a) f(x,a), transa,x = k , a = a)
I'm trying to recover the R matrix from the QR decomposition used in biglm. For this I am using a portion of the code in vcov.biglm and put it into a function like so:
qr.R.biglm <- function (object, ...) {
# Return the qr.R matrix from a biglm object
object$qr <- .Call("singcheckQR", object$qr)
p <- length(object$qr$D)
R <- diag(p)
R[row(R) > col(R)] <- object$qr$rbar
R <- t(R)
R <- sqrt(object$qr$D) * R
dimnames(R) <- list(object$names, object$names)
return(R)
}
More specifically, I'm trying to get the same result as using qr.R from the base package, which is used on QR decompositions of class "qr" such as those contained in the lm class (lm$qr). The code for the base function is as follows:
qr.R <- function (qr, complete = FALSE) {
if (!is.qr(qr))
stop("argument is not a QR decomposition")
R <- qr$qr
if (!complete)
R <- R[seq.int(min(dim(R))), , drop = FALSE]
R[row(R) > col(R)] <- 0
R
}
I manage to get the same result for a sample regression, except for the signs.
x <- as.data.frame(matrix(rnorm(100 * 10), 100, 10))
y <- seq.int(1, 100)
fit.lm <- lm("y ~ .", data = cbind(y, x))
R.lm <- qr.R(fit.lm$qr)
library(biglm)
fmla <- as.formula(paste("y ~ ", paste(colnames(x), collapse = "+")))
fit.biglm <- biglm(fmla, data = cbind(y, x))
R.biglm <- qr.R.biglm(fit.biglm)
Comparing both, it's clear that the absolute values match, but not the signs.
mean(abs(R.lm) - abs(R.biglm) < 1e-6)
[1] 1
mean(R.lm - R.biglm < 1e-6)
[1] 0.9338843
I can't quite figure out why this is. I would like to be able to get the same result for the R matrix as lm from biglm.
The difference between the two R matrices is that biglm apparently performs its rotations such that R's diagonal elements are all positive, while lm (or, really, the routines it calls) imposes no such constraint. (There should be no numerical advantage to one strategy or the other, so the difference is just one of convention, AFAIKT.)
You can make lm's results identical to biglm's by imposing that additional constraint yourself. I'd use a reflection matrix that multiplies columns by either 1 or -1, such that the diagonal elements all end up positive:
## Apply the necessary reflections
R.lm2 <- diag(sign(diag(R.lm))) %*% R.lm
## Show that they did the job
mean(R.lm2 - R.biglm < 1e-6)
# [1] 1