Commit 959fd378 authored by Oliver Dechant's avatar Oliver Dechant
Browse files

Revert "Merge branch 'master' of gitlab.com:nashjc/histoRicalg"

This reverts commit 91782543
parent 91782543
y <- 0
for (i in 1:10000) {
x <- sin(cos(exp(log(i))))
y <- y + x
if (i == 1000 * int(i/1000)) cat(i," ")
}
cat("y = ", y,"\n")
?int
?trunc
y <- 0
for (i in 1:10000) {
x <- sin(cos(exp(log(i))))
y <- y + x
if (i == 1000 * floor(i/1000)) cat(i," ")
}
cat("y = ", y,"\n")
---
output:
pdf_document: default
title: "Running the Collected Algorithms of the ACM"
author:
- John C. Nash, Telfer School of Management, University of Ottawa\\
- Oliver Dechant, Dalhousie University\\
- possible others, other places
date: Sept 23, 2017
bibliography: ../historicalg.bib
---
# Abstract
The Collected Algorithms of the ACM -- CALGO --(?? probably need a ref) are one of the most
extensive collections of primarily numerical program codes, and they capture
the evolution of computation in the latter half of the 20th century. The codes
are in programming languages or dialects that are now often obsolete. However,
the ideas and thinking behind these codes can still be of interest, so actually
running the codes is worthwhile as well as an interesting challenge. We look
at running the first ??100 codes in the CALGO set. Some other early code
collections are also considered.
# The CALGO codes
?? here a brief overview of the codes
# Why do we want to run them
- intellectual challenge
- check that the codes actually do what they claim
- discover coding quirks or errors
- learn how to document older codes
# Running the first ??100 CALGO codes
Issues:
- predates IEEE 754, so arithmetic not standardized and can give varied results on different machines
- dialects of languages, particularly Algol
- anything other than Fortran and Algol
## Fortran
## Algol
## Other programming languages
# Other collections
- Wilkinson and Reinsch
- Applied Statistics
- codes in Computer J
- Computer Physics Communications
# References
......@@ -122,7 +122,7 @@ The need to store the matrix $B$ when the number of parameters is large motivate
look into methods that avoided the need to do so. Storing information for the BFGS updates of the
Hessian inverse as a set of vectors leads to the Limited Memory BFGS approach. See
https://en.wikipedia.org/wiki/Limited-memory_BFGS. Most of the major work is linked in some
way to the work of @Byrd1995. Note, however, a 2011 update as @Morales2011.
way to the work of @Byrd1995. Note, however, a 2011 update as @Morales201
From a different starting point, various nonlinear conjugate gradient methods aim to provide good
search directions by modifying the gradient (which gives the steepest descent direction) to avoid
......@@ -284,8 +284,7 @@ require(funconstrain)
rosen <- rosen()
rosenf <- rosen$fn
roseng <- rosen$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
......@@ -304,8 +303,7 @@ require(funconstrain)
exrosen <- ex_rosen()
exrosenf <- exrosen$fn
exroseng <- exrosen$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
......@@ -328,8 +326,7 @@ require(funconstrain)
helval <- helical()
hvf <- helval$fn
hvg <- helval$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
n <- 3
......@@ -352,8 +349,8 @@ require(funconstrain)
pbs <- powell_bs()
pbsf <- pbs$fn
pbsg <- pbs$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
# meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B")
require(optimx)
cat("Powell Badly Scaled function (n=2)\n")
......@@ -387,8 +384,7 @@ require(funconstrain)
fr <- freud_roth()
frf <- fr$fn
frg <- fr$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
cat("Freudenstein and Roth: n=",2,"\n")
x0 <- fr$x0
......@@ -404,8 +400,7 @@ require(funconstrain)
br <- brown_bs() ## Gotta love that name!
brf <- br$fn
brg <- br$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
cat("Brown Badly Scaled: n=",2,"\n")
......@@ -422,8 +417,7 @@ require(funconstrain)
bl <- beale()
blf <- bl$fn
blg <- bl$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
......@@ -480,8 +474,7 @@ require(funconstrain)
ba <- bard()
baf <- ba$fn
bag <- ba$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
......@@ -499,8 +492,7 @@ require(funconstrain)
ga <- gauss()
gaf <- ga$fn
gag <- ga$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
......@@ -520,8 +512,7 @@ require(funconstrain)
me <- meyer()
mef <- me$fn
meg <- me$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- me$x0
cat("Meyer: n=",length(x0),"\n")
......@@ -537,8 +528,7 @@ require(funconstrain)
gu <- gulf(m = 99)
guf <- gu$fn
gug <- gu$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- gu$x0
cat("Gulf: n=",length(x0),"\n")
......@@ -554,8 +544,7 @@ require(funconstrain)
b3 <- box_3d(m = 20)
b3f <- b3$fn
b3g <- b3$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- b3$x0
cat("Box 3D: n=",length(x0),"\n")
......@@ -574,8 +563,7 @@ require(funconstrain)
ps <- powell_s()
psf <- ps$fn
psg <- ps$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- ps$x0
cat("Powell Singular: n=",length(x0),"\n")
......@@ -592,8 +580,7 @@ require(funconstrain)
wo <- wood()
wof <- wo$fn
wog <- wo$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- wo$x0
cat("Wood 4 parameter: n=",length(x0),"\n")
......@@ -610,8 +597,7 @@ require(funconstrain)
ko <- kow_osb()
kof <- ko$fn
kog <- ko$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- ko$x0
cat("Kowalik and Osborne: n=",length(x0),"\n")
......@@ -629,8 +615,7 @@ require(funconstrain)
bd <- brown_den()
bdf <- bd$fn
bdg <- bd$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- bd$x0
cat("Brown and Dennis: n=",length(x0),"\n")
......@@ -649,8 +634,7 @@ require(funconstrain)
o1 <- osborne_1()
o1f <- o1$fn
o1g <- o1$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- o1$x0
cat("Osborne 1: n=",length(x0),"\n")
......@@ -668,8 +652,7 @@ require(funconstrain)
be6 <- biggs_exp6(m = 13)
be6f <- be6$fn
be6g <- be6$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- be6$x0
cat("Biggs EXP6: n=",length(x0),"\n")
......@@ -687,8 +670,7 @@ require(funconstrain)
o2 <- osborne_2()
o2f <- o2$fn
o2g <- o2$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- o2$x0
cat("Osborne 2: n=",length(x0),"\n")
......@@ -713,8 +695,7 @@ waf <- wa$fn
wag <- wa$gr
# meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
# lbfgsb3c fails with n=8
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- wa$x0(n)
......@@ -733,8 +714,7 @@ require(funconstrain)
xpo <- ex_powell()
xpof <- xpo$fn
xpog <- xpo$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
x0 <- xpo$x0(12)
cat("Extended Powell: n=",length(x0),"\n")
......@@ -753,8 +733,7 @@ require(funconstrain)
pen1 <- penalty_1()
pen1f <- pen1$fn
pen1g <- pen1$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
## n<-6
for (n in seq(2,12, by=2)) {
......@@ -798,8 +777,7 @@ require(funconstrain)
vd <- var_dim()
vdf <- vd$fn
vdg <- vd$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- vd$x0(n)
......@@ -824,8 +802,7 @@ require(funconstrain)
tr <- trigon()
trf <- tr$fn
trg <- tr$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,10, by=2)) {
......@@ -886,8 +863,8 @@ trig.g <- function(x) { # unvectorized
g<- as.vector(2.0 * ( t(J) %*% res ))
return(g)
}
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
......@@ -906,8 +883,7 @@ require(funconstrain)
ba <- brown_al()
baf <- ba$fn
bag <- ba$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- ba$x0(n)
......@@ -926,8 +902,7 @@ require(funconstrain)
dbv <- disc_bv()
dbvf <- dbv$fn
dbvg <- dbv$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- dbv$x0(n)
......@@ -947,8 +922,7 @@ require(funconstrain)
die <- disc_ie()
dief <- die$fn
dieg <- die$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- die$x0(n)
......@@ -967,8 +941,7 @@ require(funconstrain)
bt <- broyden_tri()
btf <- bt$fn
btg <- bt$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
......@@ -990,8 +963,7 @@ require(funconstrain)
bb <- broyden_band()
bbf <- bb$fn
bbg <- bb$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
......@@ -1011,8 +983,7 @@ require(funconstrain)
lfr <- linfun_fr()
lfrf <- lfr$fn
lfrg <- lfr$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- lfr$x0(n)
......@@ -1031,8 +1002,7 @@ require(funconstrain)
lfr1 <- linfun_r1()
lfr1f <- lfr1$fn
lfr1g <- lfr1$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- lfr1$x0(n)
......@@ -1051,8 +1021,7 @@ require(funconstrain)
lfr1z <- linfun_r1z()
lfr1zf <- lfr1z$fn
lfr1zg <- lfr1z$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- lfr1z$x0(n)
......@@ -1071,8 +1040,7 @@ require(funconstrain)
cyq <- chebyquad()
cyqf <- cyq$fn
cyqg <- cyq$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- cyq$x0(n)
......@@ -1089,8 +1057,7 @@ require(optimx)
```{r, Nesterov}
require(adagio)
## Nesterov unbounded from 1:n/3
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- (1:n) # an artificial start??
......@@ -1125,8 +1092,7 @@ cstick.g<-function(x,alpha=1){
g<-as.double(g1+g2)
return(g)
}
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "Rcgdesc",
"L-BFGS-B", "lbfgs","lbfgsb3c")
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- (1:n)/3 # an artificial start??
......@@ -1138,5 +1104,24 @@ for (n in seq(2,12, by=2)) {
```
## Chebyquad function
```{r, cyq}
require(funconstrain)
cyq <- chebyquad()
cyqf <- cyq$fn
cyqg <- cyq$gr
meths <- c("BFGS", "Rvmmin", "Rvmminq", "ucminf", "Rcgmin", "Rcgmin2", "L-BFGS-B", "lbfgs","lbfgsb3c")
require(optimx)
for (n in seq(2,12, by=2)) {
x0 <- cyq$x0(n)
cat("Chebyquad: n=",length(x0),"\n")
print(x0)
cyqfg <- opm(x0, cyqf, cyqg, method=meths)
print(summary(cyqfg, par.select=1:2, order=value))
}
```
## References
print("1 = ", f1)
f1 <- function(a) { (a+1)**(1/3) }
print("1 = ", f1)
print("1 = ")
print(f1)
fsin <- function(x){
sin(x) - 0.5
}
require(rootoned)
TraceSetup <- function(itn=0, trace=FALSE){
# JN: Define globals here
groot<-list(itn=itn, trace=trace)
envroot<<-list2env(groot) # Note globals in FnTrace
# end globals
}
FnTrace <- function(x, fn=NULL, label=NA, ...) {
# Substitute function to call when rootfinding
# Evaluate fn(x, ...)
val <- fn(x, ...)
envroot$itn <- envroot$itn + 1 # probably more efficient ways
if (trace) {
cat("f(",x,")=",val," after ",itn," ",label,"\n")
}
val
}
TraceSetup(trace=TRUE)
tst <- root1d(FnTrace(x,fn=fsin), c(0,1.5))
TraceSetup(trace=TRUE)
x<-pi/4
tst <- root1d(FnTrace(x,fn=fsin), c(0,1.5))
TraceSetup(trace=TRUE)
x<-pi/4
tst <- root1d(FnTrace(x,fn=fsin), c(0,1.5))
trace <- TRUE
tst <- root1d(FnTrace(x,fn=fsin), c(0,1.5))
mymeth <- c( "uniroot", "root1d", "zeroin", "newton", "bisect", "secant", "regulaFalsi", "muller", "brent", "ridders")
f1 <- function(x){ # [0, 1.2], 0.399 422 2917
x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18
}
cat("Function f1 = x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18 -- root at 0.399 422 2917\n")
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
print(t1)
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/multrfind.R', echo=TRUE)
mymeth <- c( "uniroot", "root1d", "zeroin", "newton", "bisect", "secant", "regulaFalsi", "muller", "brent", "ridders")
f1 <- function(x){ # [0, 1.2], 0.399 422 2917
x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18
}
cat("Function f1 = x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18 -- root at 0.399 422 2917\n")
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/rwx.R', echo=TRUE)
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
traceback()
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/multrfind.R', echo=TRUE)
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/multrfind.R', echo=TRUE)
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/multrfind.R', echo=TRUE)
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/multrfind.R', echo=TRUE)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/rootwrap.R', echo=TRUE)
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/multrfind.R', echo=TRUE)
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/rwx.R', echo=TRUE)
source('~/current/historicalg/histoRicalg/provenance-of-rootfinding/src/multrfind.R', echo=TRUE)
mymeth <- c( "uniroot", "root1d", "zeroin", "newton", "bisect", "secant", "regulaFalsi", "muller", "brent", "ridders")
f1 <- function(x){ # [0, 1.2], 0.399 422 2917
x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18
}
cat("Function f1 = x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18 -- root at 0.399 422 2917\n")
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
require(rootoned)
mymeth <- c( "uniroot", "root1d", "zeroin", "newton", "bisect", "secant", "regulaFalsi", "muller", "brent", "ridders")
f1 <- function(x){ # [0, 1.2], 0.399 422 2917
x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18
}
cat("Function f1 = x^2 * (x^2/3 + sqrt(2)*sin(x)) - sqrt(3)/18 -- root at 0.399 422 2917\n")
t1 <- multrfind(f1, ri=c(0, 1.2), ftrace=FALSE, meths=mymeth)
print(t1)
SomeTests <- function(){
# put in a function to avoid run when source'ing
fsin <- function(x){ sin(x) - 0.5 }
gsin <- function(x){ cos(x)}
allmeths <- c( "uniroot", "root1d", "zeroin", "newt1d", "newton", "bisect", "secant", "regulaFalsi", "muller", "brent")
tryall <- multrfind(fn=fsin, gr=gsin, ri=c(0, 1.5), ftrace=TRUE, meths=allmeths)
tryall
tryn <- multrfind(fn=fsin, gr=gsin, ri=c(0, 1.5), ftrace=TRUE, meths=c("newt1d", "newton"))
tryn
mymeth <- c( "uniroot", "root1d", "zeroin", "newton", "bisect", "muller", "brent")
rivl <- c(0, 1.5)
fsin <- function(x, fpar=0.5){ sin(x) - fpar }
gsin <- function(x) { cos(x) }
mytest <- multrfind(fsin, ri=rivl, meths=mymeth)
mytest <- mytest[order(abs(mytest$froot)),]
mytest
}
\ No newline at end of file
\Sconcordance{concordance:roots-vig.tex:roots-vig.Rnw:%
1 92 1 1 2 1 0 1 7 6 0 2 1 5 0 2 1 19 0 5 1 6 0 1 2 3 1 1 2 1 0 2 1 19 %
0 4 1 6 0 1 2 2 1 1 2 1 0 2 1 19 0 4 1 6 0 1 2 2 1 1 2 1 0 2 1 19 0 4 1 %
6 0 1 2 28 1 1 2 1 0 2 1 19 0 4 1 5 0 1 2 5 0 2 1 19 0 2 1 6 0 1 2 16 1 %
1 2 1 0 1 3 2 0 2 1 18 0 4 1 5 0 4 1 9 0 1 3 10 1 1 2 1 0 1 3 2 0 2 1 %
18 0 4 1 5 0 4 1 9 0 1 3 12 1 1 2 6 0 1 4 3 0 1 2 5 0 3 1 18 0 1 1 5 0 %
2 1 19 0 1 2 35 1 1 2 6 0 1 4 3 0 8 1 10 0 1 2 21 1 1 2 1 0 1 9 8 0 2 1 %
5 0 1 1 5 0 3 1 5 0 1 1 5 0 2 1 19 0 1 2 11 1 1 2 1 0 1 3 2 0 2 1 5 0 1 %
1 5 0 3 1 5 0 1 1 5 0 2 1 9 0 1 1 5 0 4 1 5 0 2 1 19 0 1 2 46 1 1 19 18 %
0 1 3 2 0 1 9 37 0 1 2 17 1 1 2 6 0 10 1 5 0 1 2 6 0 3 1 27 0 2 1 5 0 1 %
2 8 0 1 2 132 1}
### R code from vignette source 'roots-vig.Rnw'
### Encoding: UTF-8
###################################################
### code chunk number 1: chunk1
###################################################
rm(list=ls())
railss<-function(xx){ # SPMA rail problem to provide sumsquares of residuals
r<-xx[1]
p<-xx[2] # get the two parameters
e1<-r*sin(p)-2640
e2<-r*p-2640.5
ss<-e1*e1+e2*e2
}
x<-c(10000, 0.5) # start
cat("Function at start = ",railss(x),"\n")
ans<-optim(x, railss)
print(ans)
rr<-ans$par[1]
pp<-ans$par[2]
GG<-4 + 8.5/12
AA<- rr*(1-cos(pp))
cat("rail distance = ",AA,