I would like to calculate the sum of list, which contains in every element the text mpfr1.
I have the following Code:
library(Rmpfr)
###### Central generalized Cofactorial #####
CgenC <- function(n,k,sigma){
i <- 0:k
B <- (-1)^i *choose(k,i)*pochMpfr((-i)*sigma, n)
CgenC <- sum(B)*1/(factorial(k))
return(CgenC)
}
#helpfunction
hfun <- function(d,n,k,sigma,gamma){
G <- choose(n,d)*CgenC(d,k,sigma)*pochMpfr(-(gamma), n-d)
return(G)
}
NCgenC <- function(n,k,sigma,gamma){
s <- k:n
E <- sapply(s,hfun,n=n,k=k,sigma=sigma,gamma=gamma)
NCgenC <- sum(E)
return(NCgenC)
}
Probably there is also a better way than using the helpfunction, but I am new to programming.
After that E Looks like:
[[1]]
'mpfr1' 58841424144769590802398501576045837205738093472425577422395207203116722951724046.536490917270720694092667549937401176716842829058677975377719677884520463728524151109618958095938032339354615748413119902638793141568563928308460798662023212923799608873996653084247997838235897625734493429191314427738979926169378387781579463813022200592226827918068083534511231048810054263460272712110560165030802860741581172618182744896043856500473312651443547811890843652043285582186302263502988917786388502716155013416710062301717698574066162109375
[[2]]
'mpfr1' 82871275202593779087122604776157996409481088998845801228666944089795992655102472.642373430793692374125929134125303485357643757531745742076715050078321471532137607446428722005372960997898005609266610074855955157895396722193218695989672456706464857213288691436880384233954098045336023019010212578667162712025383678754362300085837501918162183612037828788745867290227442574306429529728922577115900369140687795454923720717749187763638945864480587157831212835424687567575261647966653471636794832585905467382683540344896738333277759879099376438826851654084748588502407073974609375
...etc.
Thus, R cannot compute the sum, since it is a list and there is always the mpfr1.
I hope that I have been clear. Can somebody tell me how to calculate the sum?
Use Rmpfr::mpfr2array function to turn your list of mpfr number into an array of mpfr numbers then use the native R sum function.
library(Rmpfr)
vect = rep(0, 5)
for(i in 1:5){
vect[i] = mpfr(x=10^-(10*i), precBits=100)
}
# My vector has just turned to a list
vect
# Sum of list is an error
sum(vect)
# Turn it to a vector
converted_vect = Rmpfr::mpfr2array(vect, dim = length(vect))
converted_vect
# Now my sum and prod work fine and the precision is not lost
sum(converted_vect)
prod(converted_vect)
The function mpfr2array is not suposed to be called by the user, it is an internal tool for the package. However it's one way to solve the problem.
Related
Consider the function f which takes decision-tree node parameters {-1,+1} and maps it to an one-hot vector [0,0,0,1] for example.
I think this will end up being one of the bottlenecks of a program I'm working on, so I'd like to know if anyone finds a faster way to map the parameters to the vector.
f<-function(h){
# function takes as arguments:
# an m-bit vector of potential split decisions (h)
# function returns:
# an m+1-length one-hot indicator vector
theta_vec = c(rep(0,length(h)+1))
position = length(h)+1
for(bit in seq(1,length(h),2)){
if(h[bit]>0){
position=position
}
else{
position=position/2
}
}
theta_vec[position]=1
return(theta_vec)
}
Thank you for your help
I think I've got a solution that runs in a quarter of the time. Are you able to refactor so that you use (0,1) instead of (-1,1); and use it as lists of rows instead of a vector? I find its easier to interpret when thinking about the problem, although the function below could be re-written to use a vector as input.
findPos <- function(h){
# find number of rows from input
N <- length(h)
# go through and pick out the values in each tree that are valid based
# on previous route
out <- c(h[[1]], rep(0, N-1))
for(i in 2:N){
out[i] <- h[[i]][sum(out[i:(i-1)] * 2^(i-1)/(2^((i-1):1))) + 1]
}
# now find the final position in the bottom row and return as a vector
out_pos <- sum(out * 2^N/(2^(1:N))) + 1
full_vec <- rep(0, 2^N)
full_vec[out_pos] <- 1
return(full_vec)
}
# couple of e.gs
f(c(0,1,1))
findPos(list(0, c(1,1)))
f(c(1,1,1))
findPos(list(1, c(1,1)))
# works with larger trees
findPos(list(1, c(1,1), c(1,0,0,0)))
# check time using microbenchmark package
microbenchmark::microbenchmark(
"old" = {
f(c(0,1,1))
},
"new" = {
findPos(list(0, c(1,1)))
}
)
Best
Jonny
I'm trying to improve the speed of my code, which is trying to optimise a value using 3 variables which have large ranges. The most likely output uses values in the middle of the ranges, so it is wasting time starting from the lowest possible value of each variable. I want to start from the middle value and iterate out! The actual problem has thousands of lines with numbers from 150-650. C,H and O limits will be defined somewhat based on the starting number, but will always be more likely at a central value in the defined range. Is there a way to define the for loop to work outwards like I want? The only, quite shabby, way I can think of is to simply redefine the value within the loop from a vector (e.g. 1=20, 2=21, 3=19, etc). See current code below:
set_error<-2.5
ct<-c(325.00214,325.00952,325.02004,325.02762,325.03535,325.03831,325.04588, 325.05641,325.06402,325.06766,325.07167,325.07454,325.10396)
FormFun<-function(x){
for(C in 1:40){
for(H in 1:80){
for(O in 1:40){
test_mass=C*12+H*1.007825+O*15.9949146-1.0072765
error<-1000000*abs(test_mass-x)/x
if(error<set_error){
result<-paste("C",C,"H",H,"O",O,sep ="")
return(result)
break;break;break;break
}
}
}
}
}
old_t <- Sys.time()
ct2<-lapply(ct,FormFun)
new_t <- Sys.time() - old_t # calculate difference
print(new_t)
Use vectorization and create a closure:
FormFun1_fac <- function(gr) {
gr <<- gr
function(x, set_error){
test_mass <- with(gr, C*12+H*1.007825+O*15.9949146-1.0072765)
error <- 1000000 * abs(test_mass - x) / x
ind <- which(error < set_error)[1]
if (is.na(ind)) return(NULL)
paste0("C", gr[ind, "C"],"H", gr[ind, "H"],"O", gr[ind, "O"])
}
}
FormFun1 <- FormFun1_fac(expand.grid(C = 1:40, H = 1:80, O = 1:40))
ct21 <- lapply(ct, FormFun1, set_error = set_error)
all.equal(ct2, ct21)
#[1] TRUE
This saves a grid of all combinations of C, H, O in the function environment and calculates the error for all combinations (which is fast in vectorized code). The first combination that passes the test is returned.
I'm breaking my head on how to write multiple files from each row of the input matrix, after some calculations. The code that I'm using now looks like this:
akl <- function(dii) {
ddi <- as.matrix(dii)
m <- rowMeans(ddi)
M <- mean(m) # mean(ddi) == mean(m)
r <- sweep(ddi, 1, m)
b <- sweep(r, 2, m)
return(b + M)
}
require(plyr)
akl.list <- llply(1:nrow(aa), function(i) {
akl(dist(aa[i, ]))
})
The akl.list that I create is too large for large input matrix and I cannot store it in the RAM. My idea was to write on files each matrix that I obtain in the llply loop. Is there an easy way to do that?
thank you!!
gibbi
you can use do_ply since you want just the loop feature
d_ply(aa, 1,function(row){
a <- akl(dist(row))
write.table(a) ## you save in a file here
},.progress='text' ## to show progress (optional)
)
Thanks in advance, and sorry if this question has been answered previously - I have looked pretty extensively. I have a dataset containing a row of with concatenated information, specifically: name,color code,some function expression. For example, one value may be:
cost#FF0033#log(x)+6.
I have all of the code to extract the information, and I end up with a vector of expressions that I would like to convert to a list of actual functions.
For example:
func.list <- list()
test.func <- c("x","x+1","x+2","x+3","x+4")
where test.func is the vector of expressions. What I would like is:
func.list[[3]]
To be equivalent to
function(x){x+3}
I know that I can create a function using:
somefunc <- function(x){eval(parse(text="x+1"))}
to convert a character value into a function. The problem comes when I try and loop through to make multiple functions. For an example of something I tried that didn't work:
for(i in 1:length(test.func)){
temp <- test.func[i]
f <- assign(function(x){eval(expr=parse(text=temp))})
func.list[[i]] <- f
}
Based on another post (http://stats.stackexchange.com/questions/3836/how-to-create-a-vector-of-functions) I also tried this:
makefunc <- function(y){y;function(x){y}}
for(i in 1:length(test.func)){
func.list[[i]] <- assign(x=paste("f",i,sep=""),value=makefunc(eval(parse(text=test.func[i]))))
}
Which gives the following error: Error in eval(expr, envir, enclos) : object 'x' not found
The eventual goal is to take the list of functions and apply the jth function to the jth column of the data.frame, so that the user of the script can specify how to normalize each column within the concatenated information given by the column header.
Maybe initialize your list with a single generic function, and then update them using:
foo <- function(x){x+3}
> body(foo) <- quote(x+4)
> foo
function (x)
x + 4
More specifically, starting from a character, you'd probably do something like:
body(foo) <- parse(text = "x+5")
Just to add onto joran's answer, this is what finally worked:
test.data <- matrix(data=rep(1,25),5,5)
test.data <- data.frame(test.data)
test.func <- c("x","x+1","x+2","x+3","x+4")
func.list <- list()
for(i in 1:length(test.func)){
func.list[[i]] <- function(x){}
body(func.list[[i]]) <- parse(text=test.func[i])
}
processed <- mapply(do.call,func.list,lapply(test.data,list))
Thanks again, joran.
This is what I do:
f <- list(identity="x",plus1 = "x+1", square= "x^2")
funCreator <- function(snippet){
txt <- snippet
function(x){
exprs <- parse(text = txt)
eval(exprs)
}
}
listOfFunctions <- lapply(setNames(f,names(f)),function(x){funCreator(x)}) # I like to have some control of the names of the functions
listOfFunctions[[1]] # try to see what the actual function looks like?
library(pryr)
unenclose(listOfFunctions[[3]]) # good way to see the actual function http://adv-r.had.co.nz/Functional-programming.html
# Call your funcions
listOfFunctions[[2]](3) # 3+1 = 4
do.call(listOfFunctions[[3]],list(3)) # 3^2 = 9
attach(listOfFunctions) # you can also attach your list of functions and call them by name
square(3) # 3^2 = 9
identity(7) # 7 ## masked object identity, better detach it now!
detach(listOfFunctions)
I've been trying to write a program in R that implements Newton's method. I've been mostly successful, but there are two little snags that have been bothering me. Here's my code:
Newton<-function(f,f.,guess){
#f <- readline(prompt="Function? ")
#f. <- readline(prompt="Derivative? ")
#guess <- as.numeric(readline(prompt="Guess? "))
a <- rep(NA, length=1000)
a[1] <- guess
a[2] <- a[1] - f(a[1]) / f.(a[1])
for(i in 2:length(a)){
if(a[i] == a[i-1]){
break
}
else{
a[i+1] <- a[i] - f(a[i]) / f.(a[i])
}
}
a <- a[complete.cases(a)]
return(a)
}
I can't get R to recognize the functions f and f. if I try using readline() to prompt for user input. I get the error "Error in Newton() : could not find function "f."" However, if I comment out the readlines (as above), define f and f. beforehand, then everything works fine.
I've been trying to make R calculate the derivative of a function. The problem is that the class object with which R can take symbolic derivatives is expression(), but I want to take the derivative of a function() and have it give me a function(). In short, I'm having trouble with type conversion between expression() and function().
I have an ugly but effective solution for going from function() to expression(). Given a function f, D(body(f)[[2]],"x") will give the derivative of f. However, this output is an expression(), and I haven't been able to turn it back into a function(). Do I need to use eval() or something? I've tried subsetting, but to no avail. For instance:
g <- expression(sin(x))
g[[1]]
sin(x)
f <- function(x){g[[1]]}
f(0)
sin(x)
when what I want is f(0) = 0 since sin(0) = 0.
EDIT: Thanks all! Here's my new code:
Newton<-function(f,f.,guess){
g<-readline(prompt="Function? ")
g<-parse(text=g)
g.<-D(g,"x")
f<-function(x){eval(g[[1]])}
f.<-function(x){eval(g.)}
guess<-as.numeric(readline(prompt="Guess? "))
a<-rep(NA, length=1000)
a[1]<-guess
a[2]<-a[1]-f(a[1])/f.(a[1])
for(i in 2:length(a)){
if(a[i]==a[i-1]){break
}else{
a[i+1]<-a[i]-f(a[i])/f.(a[i])
}
}
a<-a[complete.cases(a)]
#a<-a[1:(length(a)-1)]
return(a)
}
This first problem arises because readline reads in a text string, whereas what you need is an expression. You can use parse() to convert the text string to an expression:
f <-readline(prompt="Function? ")
sin(x)
f
# [1] "sin(x)"
f <- parse(text = f)
f
# expression(sin(x))
g <- D(f, "x")
g
# cos(x)
To pass in values for the arguments in the function call in the expression (whew!), you can eval() it in an environment containing the supplied values. Nicely, R will allow you to supply those values in a list supplied to the envir= argument of eval():
> eval(f, envir=list(x=0))
# [1] 0
Josh has answered your question
For part 2 you could have used
g <- expression( sin(x) )
g[[1]]
# sin(x)
f <- function(x){ eval( g[[1]] ) }
f(0)
# [1] 0
f(pi/6)
# [1] 0.5
BTW, having recently written a toy which calculates fractal patterns based on root convergence of Newton's method in the complex plane, I can recommend you toss in some code like the following (where the main function's argument list includes "func" and "varname" ).
func<- gsub(varname, 'zvar', func)
funcderiv<- try( D(parse(text=func), 'zvar') )
if(class(funcderiv) == 'try-error') stop("Can't calculate derivative")
If you're more cautious, you could include a an argument "funcderiv" , and wrap my code in
if(missing(funcderiv)){blah blah}
Ahh, why not: here's my complete function for all to use and enjoy:-)
# build Newton-Raphson fractal
#define: f(z) the convergence per Newton's method is
# zn+1 = zn - f(zn)/f'(zn)
#record which root each starting z0 converges to,
# and to get even nicer coloring, record the number of iterations to get there.
# Inputs:
# func: character string, including the variable. E.g., 'x+ 2*x^2' or 'sin(x)'
# varname: character string indicating the variable name
# zreal: vector(preferably) of Re(z)
# zim: vector of Im(z)
# rootprec: convergence precision for the NewtonRaphson algorithm
# maxiter: safety switch, maximum iterations, after which throw an error
#
nrfrac<-function(func='z^5 - 1 ', varname = 'z', zreal= seq(-5,5,by=.1), zim, rootprec=1.0e-5, maxiter=1e4, drawplot=T, drawiterplot=F, ...) {
zreal<-as.vector(zreal)
if(missing(zim)) zim <- as.vector(zreal)
# precalculate F/F'
# check for differentiability (in R's capability)
# and make sure to get the correct variable name into the function
func<- gsub(varname, 'zvar', func)
funcderiv<- try( D(parse(text=func), 'zvar') )
if(class(funcderiv) == 'try-error') stop("Can't calculate derivative")
# Interesting "feature" of deparse : default is to limit each string to 60 or64
# chars. Need to avoid that here. Doubt I'd ever see a derivative w/ more
# than 500 chars, the max allowed by deparse. To do it right,
# need sum(nchar(funcderiv)) as width, and even then need to do some sort of
# paste(deparse(...),collapse='') to get a single string
nrfunc <- paste(text='(',func,')/(',deparse(funcderiv, width=500),')', collapse='')
# first arg to outer() will give rows
# Stupid Bug: I need to REVERSE zim to get proper axis orientation
zstart<- outer(rev(zim*1i), zreal, "+")
zindex <- 1:(length(zreal)*length(zim))
zvec <- data.frame(zdata=as.vector(zstart), zindex=zindex, itermap=rep(0,length(zindex)), badroot=rep(0,length(zindex)), rooterr=rep(0,length(zindex)) )
#initialize data.frame for zout.
zout=data.frame(zdata=rep(NA,length(zstart)), zindex=rep(NA,length(zindex)), itermap=rep(0,length(zindex)), badroot=rep(0,length(zindex)), rooterr=rep(0,length(zindex)))
# a value for rounding purposes later on; yes it works for rootprec >1
logprec <- -floor(log10(rootprec))
newtparam <- function(zvar) {}
body(newtparam)[2] <- parse(text=paste('newz<-', nrfunc, collapse=''))
body(newtparam)[3] <- parse(text=paste('return(invisible(newz))'))
iter <- 1
zold <- zvec # save zvec so I can return original values
zoutind <- 1 #initialize location to write solved values
while (iter <= maxiter & length(zold$zdata)>0 ) {
zold$rooterr <- newtparam(zold$zdata)
zold$zdata <- zold$zdata - zold$rooterr
rooterr <- abs(zold$rooterr)
zold$badroot[!is.finite(rooterr)] <- 1
zold$zdata[!is.finite(rooterr)] <- NA
# what if solvind = FFFFFFF? -- can't write 'nothing' to zout
solvind <- (zold$badroot >0 | rooterr<rootprec)
if( sum(solvind)>0 ) zout[zoutind:(zoutind-1+sum(solvind)),] <- zold[solvind,]
#update zout index to next 'empty' row
zoutind<-zoutind + sum(solvind)
# update the iter count for remaining elements:
zold$itermap <- iter
# and reduce the size of the matrix being fed back to loop
zold<-zold[!solvind,]
iter <- iter +1
# just wonder if a gc() call here would make any difference
# wow -- it sure does
gc()
} # end of while
# Now, there may be some nonconverged values, so:
# badroot[] is set to 2 to distinguish from Inf/NaN locations
if( zoutind < length(zindex) ) { # there are nonconverged values
# fill the remaining rows, i.e. zout.index:length(zindex)
zout[(zoutind:length(zindex)),] <- zold # all of it
zold$badroot[] <- 2 # yes this is safe for length(badroot)==0
zold$zdata[]<-NA #keeps nonconverged values from messing up results
}
# be sure to properly re-order everything...
zout<-zout[order(zout$zindex),]
zout$zdata <- complex(re=round(Re(zout$zdata),logprec), im=round(Im(zout$zdata),logprec) )
rootvec <- factor(as.vector(zout$zdata), labels=c(1:length(unique(na.omit(as.vector(zout$zdata))))))
#convert from character, too!
rootIDmap<-matrix(as.numeric(rootvec), nr=length(zim))
# to colorize very simply:
if(drawplot) {
colorvec<-rainbow(length(unique(as.vector(rootIDmap))))
imagemat<-rootIDmap
imagemat[,]<-colorvec[imagemat] #now has color strings
dev.new()
# all '...' arguments used to set up plot
plot(range((zreal)),range((zim)), t='n',xlab='real',ylab='imaginary',... )
rasterImage(imagemat, range(zreal)[1], range(zim)[1], range(zreal)[2], range(zim)[2], interp=F)
}
outs <- list(rootIDmap=rootIDmap, zvec=zvec, zout=zout, nrfunc=nrfunc)
return(invisible(outs))
}