r数据期末考试

第一题

library(tidyverse)

## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──

## ✔ ggplot2 3.3.6     ✔ purrr   0.3.4
## ✔ tibble  3.1.7     ✔ dplyr   1.0.9
## ✔ tidyr   1.2.0     ✔ stringr 1.4.0
## ✔ readr   2.1.2     ✔ forcats 0.5.1

## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()

library(ggplot2)
best_in_class <- mpg %>%
 group_by(class) %>%
 filter(row_number(desc(hwy)) == 1)
ggplot( mpg,aes(displ, hwy)) +
  geom_point(aes(color = class)) +
 geom_point(size = 3, shape = 1, data =best_in_class ) +
 ggrepel::geom_label_repel(
 aes(label = model),
 data = best_in_class
 )

第二题

library(tidyverse)
library(ggplot2)
library(hexbin)
smaller<-diamonds%>%
  filter(carat<3)
ggplot(data = smaller, mapping = aes(x = carat, y = price)) +
 geom_boxplot(mapping = aes(group = cut_width(carat, 0.1)))

ggplot(data = smaller, mapping = aes(x = carat, y = price)) +
 geom_boxplot(mapping = aes(group = cut_number(carat, 20)))

第三题

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

第四题

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 <- length(initVals)


OPTIM <- data.frame(matrix(NA, ncol = np + 1, nrow = maxIter * (2 * np + 2)))
o <- 1

SIMPLEX <- data.frame(matrix(NA, ncol = np + 1, nrow = np + 1))
names(SIMPLEX) <- names(OPTIM) <- c(names(initVals), "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")
}


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