Source code of nlm function in stats package - r

I need to find the source code of the nlm function.
When I use
edit(nlm)
below code appears
function (f, p, ..., hessian = FALSE, typsize = rep(1, length(p)),
fscale = 1, print.level = 0, ndigit = 12, gradtol = 1e-06,
stepmax = max(1000 * sqrt(sum((p/typsize)^2)), 1000), steptol = 1e-06,
iterlim = 100, check.analyticals = TRUE)
{
print.level <- as.integer(print.level)
if (print.level < 0 || print.level > 2)
stop("'print.level' must be in {0,1,2}")
msg <- (1 + c(8, 0, 16))[1 + print.level]
if (!check.analyticals)
msg <- msg + (2 + 4)
.External2(C_nlm, function(x) f(x, ...), p, hessian, typsize,
fscale, msg, ndigit, gradtol, stepmax, steptol, iterlim)
}
now when I want to see what is insode C_nlm
I tried
stats:::C_nlm
and I get
$name
[1] "nlm"
$address
<pointer: 0x0000000004a83920>
attr(,"class")
[1] "RegisteredNativeSymbol"
$dll
DLL name: stats
Filename: C:/Program Files/R/R-3.1.2/library/stats/libs/x64/stats.dll
Dynamic lookup: FALSE
$numParameters
[1] 11
attr(,"class")
[1] "ExternalRoutine" "NativeSymbolInfo"
After some web search I found out that I need to use grep after this.
But I am not getting how to use it.
I tried these references
How to locate code called by .External2()?
How can I view the source code for a function?
Can anyone please tell me how to proceed further?

You can browse the R source code at this GitHub repo: r-source.
Search it for the term "SEXP nlm" since stats:::C_nlm points to a function with the name "nlm" and all functions returning data to R use a datatype called SEXP (S expression).
You'll get two hits in the files statsR.h and optimize.c. The c-file is what you are looking for, so go down to the line starting with SEXP nlm and you got it.
SEXP nlm(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP value, names, v, R_gradientSymbol, R_hessianSymbol;
double *x, *typsiz, fscale, gradtl, stepmx,
steptol, *xpls, *gpls, fpls, *a, *wrk, dlt;
int code, i, j, k, itnlim, method, iexp, omsg, msg,
n, ndigit, iagflg, iahflg, want_hessian, itncnt;
/* .Internal(
* nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
* msg, ndigit, gradtol, stepmax, steptol, iterlim)
*/
function_info *state;

Related

R use stats::optimize in Rcpp, simple example fails to compile

I want to use the R stats::optimize function in Rcpp because I haven't been able to find an Rcpp equivalent. The code below is my attempt at a simple example based on the Example in the optimize help, but fails.
Here's the R function and results
f <- function (x) (x - .33)^2
xmin <- optimize(f, c(0, 1), tol = 0.0001)
xmin
This returns
$minimum
[1] 0.333
$objective
[1] 0
Here's the Rcpp code that fails when sourcing it.
#include <Rcpp.h>
const double tolerance = 1e-0;
// [[Rcpp::export]]
Rcpp::NumericVector f(Rcpp::NumericVector x) {
return pow(x-0.33, 2);
}
Rcpp::List fTg_opt(const double optmin, const double optmax) {
Rcpp::Environment base("package:stats");
Rcpp::Function optimize_r = base["optimize"];
Rcpp::NumericVector interval = {optmin,optmax};
return optimize_r(f, interval, tolerance);
}
The Rstudio console has the following error messages.
> Rcpp::sourceCpp("R/cpp/testopt.cpp")
In file included from testopt.cpp:1:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp.h:27:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/RcppCommon.h:157:
In file included from /Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/traits/traits.h:45:
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/traits/is_convertible.h:35:10: error: function cannot return function type 'Rcpp::Vector<14> (Rcpp::Vector<14>)'
static T MakeT() ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap.h:770:75: note: in instantiation of template class 'Rcpp::traits::is_convertible<Rcpp::Vector<14> (Rcpp::Vector<14>), SEXPREC *>' requested here
return wrap_dispatch_unknown(object, typename ::Rcpp::traits::is_convertible<T,SEXP>::type());
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap.h:787:20: note: in instantiation of function template specialization 'Rcpp::internal::wrap_dispatch_eigen<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return wrap_dispatch_eigen(object, typename traits::is_eigen_base<T>::type());
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap.h:807:20: note: in instantiation of function template specialization 'Rcpp::internal::wrap_dispatch_unknown_importable<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return wrap_dispatch_unknown_importable(object, typename ::Rcpp::traits::is_importer<T>::type());
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/internal/wrap_end.h:30:25: note: in instantiation of function template specialization 'Rcpp::internal::wrap_dispatch<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return internal::wrap_dispatch( object, typename ::Rcpp::traits::wrap_type_traits<T>::wrap_category() ) ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/grow.h:44:26: note: in instantiation of function template specialization 'Rcpp::wrap<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return grow( wrap(head), tail ) ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/grow.h:65:26: note: in instantiation of function template specialization 'Rcpp::internal::grow__dispatch<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return internal::grow__dispatch(typename traits::is_named<T>::type(), head, y);
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/generated/grow__pairlist.h:45:9: note: in instantiation of function template specialization 'Rcpp::grow<Rcpp::Vector<14> (Rcpp::Vector<14>)>' requested here
return grow( t1, grow( t2, grow( t3, R_NilValue ) ) ) ;
^
/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include/Rcpp/generated/Function__operator.h:45:20: note: in instantiation of function template specialization 'Rcpp::pairlist<Rcpp::Vector<14> (Rcpp::Vector<14>), Rcpp::Vector<14>, double>' requested here
return invoke(pairlist(t1, t2, t3), R_GlobalEnv);
^
testopt.cpp:13:20: note: in instantiation of function template specialization 'Rcpp::Function_Impl<PreserveStorage>::operator()<Rcpp::Vector<14> (Rcpp::Vector<14>), Rcpp::Vector<14>, double>' requested here
return optimize_r(f, interval, tolerance);
^
1 error generated.
make: *** [testopt.o] Error 1
clang++ -mmacosx-version-min=10.13 -std=gnu++14 -I"/Library/Frameworks/R.framework/Resources/include" -DNDEBUG -I"/Library/Frameworks/R.framework/Versions/4.1/Resources/library/Rcpp/include" -I"/Users/gcn/Documents/workspace/ISIMIPData/R/cpp" -I/usr/local/include -fPIC -Wall -g -O2 -c testopt.cpp -o testopt.o
Error in Rcpp::sourceCpp("R/cpp/testopt.cpp") :
Error 1 occurred building shared library.
One of your problems here is that you assume that becomes a function you submit to compilation under Rcpp::sourceCpp() is callable under its exported name.
It is not. Try Rcpp::sourceCpp(..., verbose=TRUE), i.e. add that arguments, to see what is really called. Those you could pass around (using SEXP argunments and results, but they are unwieldy).
To prove, here is a 'working but useless' version of your code. If we pass f() from R too, everything is callable.
Morale: The interface still is SEXP .Call("name", SEXP a, SEXP b, ...) even if Rcpp hides that. No Free Lunch (TM). But as my comment hinted, there are optimization packages you can use with Rcpp.
Code
#include <Rcpp.h>
// [[Rcpp::export]]
Rcpp::List fTg_opt(Rcpp::Function f, const double optmin, const double optmax) {
Rcpp::Environment base("package:stats");
Rcpp::Function optimize_r = base["optimize"];
Rcpp::NumericVector interval = {optmin,optmax};
Rcpp::List res = optimize_r(f, interval);
return res;
}
/*** R
f <- function (x) (x - .33)^2
xmin <- optimize(f, c(0, 1), tol = 0.0001)
xmin
fTg_opt(f, 0, 1)
*/
Output
> Rcpp::sourceCpp("~/git/stackoverflow/68674076/question.cpp")
> f <- function (x) (x - .33)^2
> xmin <- optimize(f, c(0, 1), tol = 0.0001)
> xmin
$minimum
[1] 0.33
$objective
[1] 0
> fTg_opt(f, 0, 1)
$minimum
[1] 0.33
$objective
[1] 0

Unable to understand dimension mismatch error in Julia

I’m a beginner with Julia and ML. I’m attempting to re-use code from the Flux Model Zoo, specifically this, to classify images from this dataset. Below is my version of the code - I modified the data load and the params in the build_model to account for the difference in image size and the number of character types to be classified. The original had 28x28 and 10 digits, the arabic character set had 32x32 images and 28 characters.
function getimages(filename)
filepath = pwd() * "/images/" * filename
mtrx = Matrix(DataFrame(CSV.File(filepath)))
r, _ = size(mtrx)
v = Vector{Matrix{Int64}}()
for i = 1:r
push!(v, reshape(m[i, :], 32, 32))
end
v
end
function getlabels(filename)
filepath = pwd() * "/images/" * filename
vec(Matrix(DataFrame(CSV.File(filepath))))
end
function load_data(args)
train_data_file = "csvTrainImages.csv"
test_data_file = "csvTestImages.csv"
train_label_file = "csvTrainLabel.csv"
test_label_file = "csvTestLabel.csv"
train_data = getimages(train_data_file)
test_data = getimages(test_data_file)
train_labels = getlabels(train_label_file)
test_labels = getlabels(test_label_file)
xtrain = Flux.flatten(train_data)
xtest = Flux.flatten(test_data)
ytrain, ytest = onehotbatch(train_labels, 1:28), onehotbatch(test_labels, 1:28)
train_loader = DataLoader((xtrain, ytrain), batchsize=args.batchsize, shuffle=true)
test_loader = DataLoader((xtest, ytest), batchsize=args.batchsize)
return train_loader, test_loader
end
function build_model(; imgsize=(32,32,1), nclasses=28)
return Chain(
Dense(prod(imgsize), 32, relu),
Dense(32, nclasses))
end
function loss_and_accuracy(data_loader, model, device)
acc = 0
ls = 0.0f0
num = 0
for (x, y) in data_loader
x, y = device(x), device(y)
ŷ = model(x)
ls += logitcrossentropy(model(x), y, agg=sum)
acc += sum(onecold(cpu(model(x))) .== onecold(cpu(y)))
num += size(x, 2)
end
return ls / num, acc / num
end
#kwdef mutable struct Args
η::Float64 = 3e-4 # learning rate
batchsize::Int = 256 # batch size
epochs::Int = 10 # number of epochs
use_cuda::Bool = true # use gpu (if cuda available)
end
function train(; kws...)
args = Args(; kws...) # collect options in a struct for convenience
if CUDA.functional() && args.use_cuda
#info "Training on CUDA GPU"
CUDA.allowscalar(false)
device = gpu
else
#info "Training on CPU"
device = cpu
end
# Create test and train dataloaders
train_loader, test_loader = load_data(args)
# Construct model
model = build_model() |> device
ps = Flux.params(model) # model's trainable parameters
## Optimizer
opt = ADAM(args.η)
## Training
for epoch in 1:args.epochs
for (x, y) in train_loader
x, y = device(x), device(y) # transfer data to device
gs = gradient(() -> logitcrossentropy(model(x), y), ps) # compute gradient
Flux.Optimise.update!(opt, ps, gs) # update parameters
end
# Report on train and test
train_loss, train_acc = loss_and_accuracy(train_loader, model, device)
test_loss, test_acc = loss_and_accuracy(test_loader, model, device)
println("Epoch=$epoch")
println(" train_loss = $train_loss, train_accuracy = $train_acc")
println(" test_loss = $test_loss, test_accuracy = $test_acc")
end
end
I get the following error when I train the model. Specifically, during the gradient computation. Could you help me understand which two matrices the error refers to and point me towards a solution? My guess is that it has to do with the build_model params, but I’m not quite sure what needs to change and how.
DimensionMismatch("matrix A has dimensions (32,1024), matrix B has dimensions (1,256)")
macro expansion#interface2.jl:0[inlined]
_pullback(::Zygote.Context, ::typeof(throw), ::DimensionMismatch)#interface2.jl:9
_pullback#matmul.jl:814[inlined]
_pullback(::Zygote.Context, ::typeof(LinearAlgebra._generic_matmatmul!), ::Matrix{Matrix{Float32}}, ::Char, ::Char, ::Matrix{Float32}, ::Matrix{Matrix{Int64}}, ::LinearAlgebra.MulAddMul{true, true, Bool, Bool})#interface2.jl:0
_pullback#matmul.jl:802[inlined]
_pullback(::Zygote.Context, ::typeof(LinearAlgebra.generic_matmatmul!), ::Matrix{Matrix{Float32}}, ::Char, ::Char, ::Matrix{Float32}, ::Matrix{Matrix{Int64}}, ::LinearAlgebra.MulAddMul{true, true, Bool, Bool})#interface2.jl:0
_pullback#matmul.jl:302[inlined]
_pullback#matmul.jl:275[inlined]
_pullback(::Zygote.Context, ::typeof(LinearAlgebra.mul!), ::Matrix{Matrix{Float32}}, ::Matrix{Float32}, ::Matrix{Matrix{Int64}})#interface2.jl:0
_pullback#matmul.jl:153[inlined]
_pullback(::Zygote.Context, ::typeof(*), ::Matrix{Float32}, ::Matrix{Matrix{Int64}})#interface2.jl:0
_pullback#basic.jl:147[inlined] ....
Solved by fixing the get images method as below.
function getimages(filename)
filepath = pwd() * "/images/" * filename
mtrx = Matrix(DataFrame(CSV.File(filepath)))
return mtrx'
end

Evaluating an integral in R multiple times

I am trying to integrate the next function with respect x
integrand <- function(x) {
f1 <- pnorm((1/sqrt(u/x))*( sqrt((t*u*v)/x) - sqrt(x/(t*u*v)) ))}
where,
v=10
u=5
However, I need to integrate considering different values of t, so tried defining a sequence of values as:
t=seq(0,100,0.1)
And used the sapply function as:
data=sapply(t, function(x) integrate(integrand, lower = 0 , upper = 10000)$value )
I got these errors:
Error in integrate(integrand, lower = 0, upper = 10000) :
evaluation of function gave a result of wrong length
In addition: Warning messages:
1: In (t * u * v)/x : longer object length is not a multiple of shorter object length
2: In x/(t * u * v) : longer object length is not a multiple of shorter object length
3: In (1/sqrt(u/x)) * (sqrt((t * u * v)/x) - sqrt(x/(t * u * v))) :
longer object length is not a multiple of shorter object length
I haven't had any luck.
I would greatly appreciate any help.
Regards!
You can still use sapply like so:
sapply(t, function(t) {
integrate(function(x) {
pnorm((1/sqrt(u/x))*( sqrt((t*u*v)/x) - sqrt(x/(t*u*v)) ))
}, lower = 0, upper = 1000)$value
})
Output
[1] 0.000000 5.416577 10.251273 15.146418 20.084907 25.049283 ...
A previous post have a similar problem with an specific solution here
the code would result as:
t=seq(0,100,0.1)
fu<- list()
int<- numeric()
for(i in 1:length(t))
{
fu[[i]] = function(x){
f1 <- pnorm((1/sqrt(u/x))*( sqrt((t[i]*u*v)/x) - sqrt(x/(t[i]*u*v)) ));
}
int[i] = integrate(h[[i]], lower=0, upper=1000)$value
}
int

How to get R's variable name in C (substitute in C)?

How can I get from C an object name used as a function argument? I
have sample code in C that gives me access to the name of the function
being called:
#include <Rinternals.h>
SEXP xname(SEXP x)
{
const char *fun_name = CHAR(PRINTNAME(CAR(x)));
x = CDR(x);
const char *arg_name = isNull(TAG(x)) ? "" : CHAR(PRINTNAME(TAG(x)));
Rprintf("fn_name: %s, arg_name: %s\n", fun_name, arg_name);
return R_NilValue;
}
and from R:
> xname <- function(...) invisible(.External("xname", ...))
> x1 = 123
> xname(x1)
fn_name: xname, var_name:
However, I am trying to find a way to access the object name. In the
documentation I found a solution for named args only:
> xname(arg = x1)
fn_name: xname, var_name: arg
And I'd like to find the C equivalent for substitute():
> substitute(x1)
x1
I tried substitute() from Rinternals.h, but it always returned a list with what above. Does anyone know how to do it? Maybe findVarInFrame()?
Best regards

R code: "Error in parse unexpected end of input" when using non-linear solver

I am using the non-linear solver (nls) in R, but cannot run my model due to a parser error that I have no idea how to debug. Could someone please offer some advice on how to fix this?
Code:
Bass.nls <- nls( Zt[which(!is.na(Zt))] ~ M * ( ((P+Q)^2 / P) * exp(-(P+Q) * days) ) / (1+(Q/P)*exp(-(P+Q)*days))^2, start = list(M=Z[tInt], P=0.03, Q=0.38), lower = list(Y[tInt], 0,0), upper = list(2e10, 1,1), algorithm = "port", trace = TRUE)
Error:
Error in parse(text = x, keep.source = FALSE) :
:2:0: unexpected end of input
1: ~
The error
Unexpected end of input
occurs because of a missing paranthesis. You might have forgotten to finish the call to the function with a closing paranthesis - ")".
Look at the section 6.4 of this link for a better explanation.
You should write the script as described in Johannes' answer as it gets easy for you to debug the mistake then.
My advice would be to write a script that contains the call in a more readable form, like
Bass.f <- function(days, M, P, Q) {
M * (((P + Q)^2 / P) * exp(-(P + Q) * days)) /
(1 + (Q / P) * exp(-(P + Q) * days))^2
}
Then you can call the function to see if it is written correctly, like
Bass.f(1, 100, 0.03, 0.38)
and then try with the call
Bass.nls <- nls( Zt[which(!is.na(Zt))] ~ Bass.f(days, M, P, Q),
start = list(M = Z[tInt], P = 0.03, Q = 0.38),
lower = list(Y[tInt], 0, 0),
upper = list(2e10, 1, 1),
algorithm = "port", trace = TRUE)
Does this still give the same error? If yes, it would be useful to see the data you are using, i.e. the output of
dput(Zt)
Z[tInt]
days

Resources