在R中繪制通用曲面和輪廓

Question

我有以下數據

var.asym <- function(alpha1, alpha2, xi, beta, n){
  term11 <- alpha1*(1-alpha1)^(2*xi-1)
  term12 <- alpha1*(1-alpha1)^(xi-1)*(1-alpha2)^xi
  term22 <- alpha2*(1-alpha2)^(2*xi-1)
  Sigma <- matrix(c(term11, term12, term12, term22), nrow=2, byrow=TRUE)
  Sigma*beta^2/n
}

mop.jacob.inv <- function(alpha1, alpha2, xi, beta){
  term11 <- -qgpd(alpha1, xi, 0, beta)/xi - beta*(1-alpha1)^xi*log(1-alpha1)/xi
  term12 <- qgpd(alpha1, xi, 0, beta)/beta
  term21 <- -qgpd(alpha2, xi, 0, beta)/xi - beta*(1-alpha2)^xi*log(1-alpha2)/xi
  term22 <- qgpd(alpha2, xi, 0, beta)/beta
  jacob <- matrix(c(term11, term12, term21, term22), nrow=2, byrow=TRUE)
  jacob.inv <- solve(jacob)
  jacob.inv
}

var.asym2 <- function(alpha1, alpha2) var.asym(alpha1, alpha2, 0.2, 1, 1000)
mop.jacob.inv2 <- function(alpha1, alpha2) mop.jacob.inv(alpha1, alpha2, 0.2, 1)
object <- function(alpha1, alpha2){
  term1 <- mop.jacob.inv2(alpha1, alpha2)%*%var.asym2(alpha1, alpha2)%*%t(mop.jacob.inv2(alpha1, alpha2))
  sum(diag(term1))
}

x <- seq(0.01, 0.98, by=0.01)
y <- seq(x[1]+0.01, 0.99, by=0.01)
xy <- cbind(rep(x[1], length(x)), y)

for(i in 2:length(x)){
  y <- seq(x[i]+0.01, 0.99, by=0.01)
  xy <- rbind(xy, cbind(rep(x[i], length(x)-i+1), y))
}

object.xy <- rep(0, 4851)

for(i in 1:4851){
  object.xy[i] <- object(xy[i, 1], xy[i, 2])
}

現在我想繪制(xy[, 1], xy[, 2], object.xy) 。 有沒有辦法在R做到這一點？ 我嘗試了persp和contour函數，但似乎不適用於這種情況，因為它們都需要增加序列x和y。 我猜一個更籠統的問題是當給定三連串（x，y，z）序列時如何繪制等高線圖。

Answer 1

library(dplyr)
library(tidyr)
library(magrittr)

long_data = 
  data.frame(
    x = xy[,1] %>% round(2),
    y = xy[,2] %>% round(2),
    z = object.xy)

wide_data = 
  long_data %>%
  spread(x, z)

y = wide_data$y
wide_data %<>% select(-y)
x = names(wide_data) %>% as.numeric
z = wide_data %>% as.matrix
persp(x, y, z)
contour(x, y, z)

鄧諾（Dunno）為什么本輪有所幫助，但確實有幫助。 重塑對於根據x，y，z數據構建矩陣是必要的。 請注意，由於數據中存在巨大的窄峰，因此輪廓線合並為黑點。