Untitled
帅昀洋
2022-06-23
R Markdown
This is an R Markdown document. Markdown is a simple formatting syntax for authoring HTML, PDF, and MS Word documents. For more details on using R Markdown see http://rmarkdown.rstudio.com.
When you click the Knit button a document will be generated that includes both content as well as the output of any embedded R code chunks within the document. You can embed an R code chunk like this:
summary(cars)## speed dist
## Min. : 4.0 Min. : 2.00
## 1st Qu.:12.0 1st Qu.: 26.00
## Median :15.0 Median : 36.00
## Mean :15.4 Mean : 42.98
## 3rd Qu.:19.0 3rd Qu.: 56.00
## Max. :25.0 Max. :120.00Including Plots
You can also embed plots, for example:
Note that the echo = FALSE parameter was added to the
code chunk to prevent printing of the R code that generated the plot. #
3
之前的code报错,evaluate函数有误，缺少大括号，已修改。
# install.packages("lattice")
library(lattice)
# install.packages("zoo")
library(zoo)
evaluate <- function(PARAM, minVal = NA, maxVal = NA, y = 2014,
transform = FALSE, verbose = FALSE,
negative = FALSE, transformOnly = FALSE,
returnData = FALSE, accountParams = NULL){
# Step 1
# Convert and declare parameters if they exist on unbounded (-inf,inf) domain
if( transform | transformOnly ){
PARAM <- minVal +
(maxVal - minVal) * unlist(lapply( PARAM, function(v) (1 + exp(-v))^(-1) ))
if( transformOnly ){
}
}
return(PARAM)
}
## 修改
# Declare bounds and step size for optimization
lowerBound <- c(n1 = 5, nFact = 3, nSharpe = 22, shThresh = 0.05)
upperBound <- c(n1 = 80, nFact = 3, nSharpe = 22, shThresh = 0.95)
stepSize <- c(n1 = 5, nFact = 1, nSharpe = 1, shThresh = 0.05)
pnames <- names(stepSize)
np <- length(pnames)
# Declare list of all test points
POINTS <- list()
for( p in pnames ){
POINTS[[p]] <- seq(lowerBound[[p]], upperBound[[p]], stepSize[[p]])
}
OPTIM <- data.frame(matrix(NA, nrow = prod(unlist(lapply(POINTS, length))),
ncol = np + 1))
names(OPTIM)[1:np] <- names(POINTS)
names(OPTIM)[np+1] <- "obj"
# Store all possible combinations of parameters
for( i in 1:np ){
each <- prod(unlist(lapply(POINTS, length))[-(1:i)])
times <- prod(unlist(lapply(POINTS, length))[-(i:length(pnames))])
OPTIM[,i] <- rep(POINTS[[pnames[i]]], each = each, times = times)
}
# Test each row of OPTIM
timeLapse <- proc.time()[3]
for( i in 1:nrow(OPTIM) ){
OPTIM[i,np+1] <- evaluate(OPTIM[i,1:np], transform = FALSE, y = 2014)
cat(paste0("## ", floor( 100 * i / nrow(OPTIM)), "% complete\n"))
cat(paste0("## ",
round( ((proc.time()[3] - timeLapse) *
((nrow(OPTIM) - i)/ i))/60, 2),
" minutes remaining\n\n"))
}
library(lattice)
wireframe(obj ~ n1*shThresh, data = OPTIM,
xlab = "n1", ylab = "shThresh",
main = "Long-Only MACD Exhaustive Optimization",
drape = TRUE,
colorkey = TRUE,
screen = list(z = 15, x = -60)
)
levelplot(obj ~ n1*shThresh, data = OPTIM,
xlab = "n1", ylab = "shThresh",
main = "Long-Only MACD Exhaustive Optimization"
)4
之前的报错是找不到initVALS,修改为上题的POINTS，并修改np =4
#install.packages("lattice")
library(lattice)
K <- maxIter <- 200
# Vector theta_0
initDelta <- 6
deltaThresh <- 0.05
PARAM <- PARAMNaught <-
c(n1 = 0, nFact = 0, nSharpe = 0, shThresh = 0) - initDelta/2
# bounds
minVal <- c(n1 = 1, nFact = 1, nSharpe = 1, shThresh = 0.01)
maxVal <- c(n1 = 250, nFact = 10, nSharpe = 250, shThresh = .99)
# Optimization parameters
alpha <- 1
gamma <- 2
rho <- .5
sigma <- .5
randomInit <- FALSE
np <- 4 ## 修改
OPTIM <- data.frame(matrix(NA, ncol = np + 1, nrow = maxIter * (2 * np + 2)))
SIMPLEX <- data.frame(matrix(NA, ncol = np + 1, nrow = np + 1))
names(SIMPLEX) <- names(OPTIM) <- c(names(POINTS), "obj") #修改
# Print function for reporting progress in loop
printUpdate <- function(){
cat("Iteration: ", k, "of", K, "\n")
cat("\t\t", paste0(strtrim(names(OPTIM), 6), "\t"), "\n")
cat("Global Best:\t",
paste0(round(unlist(OPTIM[which.min(OPTIM$obj),]),3), "\t"), "\n")
cat("Simplex Best:\t",
paste0(round(unlist(SIMPLEX[which.min(SIMPLEX$obj),]),3), "\t"), "\n")
cat("Simplex Size:\t",
paste0(max(round(simplexSize,3)), "\t"), "\n\n\n")
}
o <- 1
# Initialize SIMPLEX
for( i in 1:(np+1) ) {
SIMPLEX[i,1:np] <- PARAMNaught + initDelta * as.numeric(1:np == (i-1))
SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np], minVal, maxVal, negative = TRUE,
y = y)
OPTIM[o,] <- SIMPLEX[i,]
o <- o + 1
}
# Optimization loop
for( k in 1:K ){
SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),]
centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
cat("Computing Reflection...\n")
reflection <- centroid + alpha * (centroid - SIMPLEX[np+1,-(np+1)])
reflectResult <- evaluate(reflection, minVal, maxVal, negative = TRUE, y = y)
OPTIM[o,] <- c(reflection, obj = reflectResult)
o <- o + 1
if( reflectResult > SIMPLEX[1,np+1] &
reflectResult < SIMPLEX[np, np+1] ){
SIMPLEX[np+1,] <- c(reflection, obj = reflectResult)
} else if( reflectResult < SIMPLEX[1,np+1] ) {
cat("Computing Expansion...\n")
expansion <- centroid + gamma * (reflection - centroid)
expansionResult <- evaluate(expansion,
minVal, maxVal, negative = TRUE, y = y)
OPTIM[o,] <- c(expansion, obj = expansionResult)
o <- o + 1
if( expansionResult < reflectResult ){
SIMPLEX[np+1,] <- c(expansion, obj = expansionResult)
} else {
SIMPLEX[np+1,] <- c(reflection, obj = reflectResult)
}
} else if( reflectResult > SIMPLEX[np, np+1] ) {
cat("Computing Contraction...\n")
contract <- centroid + rho * (SIMPLEX[np+1,-(np+1)] - centroid)
contractResult <- evaluate(contract, minVal, maxVal, negative = TRUE, y = y)
OPTIM[o,] <- c(contract, obj = contractResult)
o <- o + 1
if( contractResult < SIMPLEX[np+1, np+1] ){
SIMPLEX[np+1,] <- c(contract, obj = contractResult)
} else {
cat("Computing Shrink...\n")
for( i in 2:(np+1) ){
SIMPLEX[i,1:np] <- SIMPLEX[1,-(np+1)] +
sigma * (SIMPLEX[i,1:np] - SIMPLEX[1,-(np+1)])
SIMPLEX[i,np+1] <- c(obj = evaluate(SIMPLEX[i,1:np],
minVal, maxVal,
negative = TRUE, y = y))
}
OPTIM[o:(o+np-1),] <- SIMPLEX[2:(np+1),]
o <- o + np
}
}
centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1,
function(v) abs(v - centroid))))
if( max(simplexSize) < deltaThresh ){
cat("Size Threshold Breached: Restarting with Random Initiate\n\n")
for( i in 1:(np+1) ) {
SIMPLEX[i,1:np] <- (PARAMNaught * 0) +
runif(n = np, min = -initDelta, max = initDelta)
SIMPLEX[i,np+1] <- evaluate(SIMPLEX[i,1:np],
minVal, maxVal, negative = TRUE, y = y)
OPTIM[o,] <- SIMPLEX[i,]
o <- o + 1
SIMPLEX <- SIMPLEX[order(SIMPLEX[,np+1]),]
centroid <- colMeans(SIMPLEX[-(np+1),-(np+1)])
simplexSize <- rowMeans(t(apply(SIMPLEX[,1:np], 1, function(v) abs(v - centroid))))
}
}
printUpdate()
}
# Return the best optimization in untransformed parameters
evaluate(OPTIM[which.min(OPTIM$obj),1:np], minVal, maxVal, transformOnly = TRUE)