Question

我一直在尝试在R中编写一个实现Newton方法的程序。我一直很成功，但有两个小障碍一直困扰着我。这是我的代码：

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)
}

如果我尝试使用f提示用户输入，我无法让R识别函数f.和readline()。我收到错误“牛顿错误（）：找不到函数”f。“”但是，如果我注释掉读取线（如上所述），事先定义f和f.，那么一切正常细
我一直试图让R计算函数的导数。问题是R可以使用符号导数的类对象是expression()，但我想取function()的导数并让它给我一个function()。简而言之，我在expression()和function()之间进行类型转换时遇到问题。

从function()到expression()，我有一个丑陋但有效的解决方案。给定函数f，D(body(f)[[2]],"x")将给出f的导数。但是，此输出为expression()，我无法将其转回function()。我是否需要使用eval()或其他内容？我尝试过子集，但无济于事。例如：

g <- expression(sin(x))
g[[1]]
sin(x)
f <- function(x){g[[1]]}
f(0)
sin(x)

当我想要的是f（0）= 0，因为sin（0）= 0。

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)
}

Answer 1

出现第一个问题是因为readline读入了一个文本字符串，而你需要的是一个表达式。您可以使用parse()将文本字符串转换为表达式：
```
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)
```
要在表达式（whew！）中传入函数调用中的参数值，可以在包含提供值的环境中eval()它。很好，R将允许您在envir=的{{1}}参数提供的列表中提供这些值：
```
eval()
```

Answer 2

顺便说一句，最近写了一个基于牛顿方法在复平面上的根收敛计算分形模式的玩具，我建议你抛出一些代码，如下所示（其中主函数的参数列表包括“func”和“ varname“）。

func<- gsub(varname, 'zvar', func)
    funcderiv<- try( D(parse(text=func), 'zvar') )
    if(class(funcderiv) == 'try-error') stop("Can't calculate derivative")

如果你更谨慎，你可以包含一个参数“funcderiv”，并将我的代码包装在

中

if(missing(funcderiv)){blah blah}

啊，为什么不呢：这是我所有使用和享受的完整功能： - ）

# 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))
}

Answer 3

乔希回答了你的问题

对于第2部分，您可以使用

g <- expression( sin(x) )

g[[1]]
# sin(x)

f <- function(x){ eval( g[[1]] ) }

f(0)
# [1] 0
f(pi/6)
# [1] 0.5

R类型转换表达式（）函数（）

3 个答案: