วิธีรับขอบเขตของวงรีจากข้อมูลที่กระจายแบบปกติ bivariate

ฉันมีข้อมูลที่ดูเหมือนว่า:

ฉันพยายามที่จะใช้การแจกแจงแบบปกติ (การประมาณความหนาแน่นของเคอร์เนลทำงานได้ดีขึ้น แต่ฉันไม่ต้องการความแม่นยำที่ยอดเยี่ยมเช่นนี้) และใช้งานได้ค่อนข้างดี พล็อตความหนาแน่นทำให้วงรี

ฉันต้องใช้ฟังก์ชันวงรีนั้นเพื่อตัดสินใจว่าจุดหนึ่งอยู่ในขอบเขตของวงรีหรือไม่ ทำอย่างไร

ยินดีต้อนรับรหัส R หรือ Mathematica

Corsario นำเสนอทางออกที่ดีในความคิดเห็น: ใช้ฟังก์ชันความหนาแน่นของเคอร์เนลเพื่อทดสอบการรวมภายในชุดระดับ

การตีความคำถามอีกข้อหนึ่งคือการขอให้ขั้นตอนการทดสอบสำหรับการรวมอยู่ในรูปวงรีที่สร้างขึ้นโดยการประมาณค่าปกติ bivariateกับข้อมูล ในการเริ่มต้นให้สร้างข้อมูลบางอย่างที่ดูเหมือนภาพประกอบในคำถาม:

library(mvtnorm) # References rmvnorm()
set.seed(17)
p <- rmvnorm(1000, c(250000, 20000), matrix(c(100000^2, 22000^2, 22000^2, 6000^2),2,2))

จุดไข่ปลาจะถูกกำหนดโดยช่วงเวลาที่หนึ่งและสองของข้อมูล:

center <- apply(p, 2, mean)
sigma <- cov(p)

สูตรต้องการการผกผันของเมทริกซ์ความแปรปรวนร่วม - ความแปรปรวนร่วม:

sigma.inv = solve(sigma, matrix(c(1,0,0,1),2,2))

ฟังก์ชัน "height" ของวงรีคือค่าลบของลอการิทึมของความหนาแน่นปกติ bivariate :

ellipse <- function(s,t) {u<-c(s,t)-center; u %*% sigma.inv %*% u / 2}

(ฉันไม่สนใจค่าคงที่เพิ่มเติมที่เท่ากับ )$\log(2\pi\sqrt{\det(\Sigma)})$

เพื่อทดสอบสิ่งนี้ลองวาดรูปทรงของมัน ที่ต้องสร้างตารางจุดในทิศทาง x และ y:

n <- 50
x <- (0:(n-1)) * (500000/(n-1))
y <- (0:(n-1)) * (50000/(n-1))

คำนวณฟังก์ชั่นความสูงที่กริดนี้และวางแผน

z <- mapply(ellipse, as.vector(rep(x,n)), as.vector(outer(rep(0,n), y, `+`)))
plot(p, pch=20, xlim=c(0,500000), ylim=c(0,50000), xlab="Packets", ylab="Flows")
contour(x,y,matrix(z,n,n), levels=(0:10), col = terrain.colors(11), add=TRUE)

เห็นได้ชัดว่ามันใช้งานได้ ดังนั้นการทดสอบเพื่อตรวจสอบว่าจุดอยู่ภายในเส้นรูปไข่ที่ระดับคือ$(s,t)$$c$

ellipse(s,t) <= c

Mathematicaทำงานในลักษณะเดียวกัน: คำนวณเมทริกซ์ความแปรปรวนร่วม - ความแปรปรวนร่วมของข้อมูลกลับด้านนั้นสร้างellipseฟังก์ชันและคุณพร้อมแล้ว

พล็อตตรงไปตรงมากับellipse()ฟังก์ชั่นของmixtoolsแพคเกจสำหรับ R:

library(mixtools)
library(mvtnorm) 
set.seed(17)
p <- rmvnorm(1000, c(250000, 20000), matrix(c(100000^2, 22000^2, 22000^2, 6000^2),2,2))
plot(p, pch=20, xlim=c(0,500000), ylim=c(0,50000), xlab="Packets", ylab="Flows")
ellipse(mu=colMeans(p), sigma=cov(p), alpha = .05, npoints = 250, col="red") 

วิธีแรก

คุณอาจลองวิธีนี้ใน Mathematica

มาสร้างข้อมูล bivariate กัน:

data = Table[RandomVariate[BinormalDistribution[{50, 50}, {5, 10}, .8]], {1000}];

จากนั้นเราต้องโหลดแพ็คเกจนี้:

Needs["MultivariateStatistics`"]

และตอนนี้:

ellPar=EllipsoidQuantile[data, {0.9}]

ให้เอาต์พุตที่กำหนดวงรีความเชื่อมั่น 90% ค่าที่คุณได้รับจากผลลัพธ์นี้อยู่ในรูปแบบต่อไปนี้:

{Ellipsoid[{x1, x2}, {r1, r2}, {{d1, d2}, {d3, d4}}]}

x1 และ x2 ระบุจุดที่วงรีอยู่กึ่งกลาง r1 และ r2 ระบุรัศมีครึ่งแกนและ d1, d2, d3 และ d4 ระบุทิศทางการจัดตำแหน่ง

คุณสามารถพล็อตเรื่องนี้:

Show[{ListPlot[data, PlotRange -> {{0, 100}, {0, 100}}, AspectRatio -> 1],  Graphics[EllipsoidQuantile[data, 0.9]]}]

รูปแบบพารามิเตอร์ทั่วไปของวงรีคือ:

ell[t_, xc_, yc_, a_, b_, angle_] := {xc + a Cos[t] Cos[angle] - b Sin[t] Sin[angle],
    yc + a Cos[t] Sin[angle] + b Sin[t] Cos[angle]}

และคุณสามารถพล็อตได้ด้วยวิธีนี้:

ParametricPlot[
    ell[t, ellPar[[1, 1, 1]], ellPar[[1, 1, 2]], ellPar[[1, 2, 1]], ellPar[[1, 2, 2]],
    ArcTan[ellPar[[1, 3, 1, 2]]/ellPar[[1, 3, 1, 1]]]], {t, 0, 2 \[Pi]},
    PlotRange -> {{0, 100}, {0, 100}}]

คุณสามารถทำการตรวจสอบโดยใช้ข้อมูลทางเรขาคณิตที่บริสุทธิ์: หากระยะห่างแบบยุคลิดระหว่างศูนย์กลางของวงรี (ellPar [[1,1]]) และจุดข้อมูลของคุณมีขนาดใหญ่กว่าระยะห่างระหว่างกึ่งกลางของวงรีและขอบของ วงรี (ชัดเจนในทิศทางเดียวกับที่จุดของคุณอยู่) จากนั้นจุดข้อมูลนั้นอยู่นอกวงรี

แนวทางที่สอง

วิธีนี้ขึ้นอยู่กับการกระจายเคอร์เนลที่ราบรื่น

นี่คือข้อมูลบางส่วนที่แจกจ่ายในลักษณะเดียวกันกับข้อมูลของคุณ:

data1 = RandomVariate[BinormalDistribution[{.3, .7}, {.2, .3}, .8], 500];
data2 = RandomVariate[BinormalDistribution[{.6, .3}, {.4, .15}, .8], 500];
data = Partition[Flatten[Join[{data1, data2}]], 2];

เราได้รับการกระจายเคอร์เนลที่ราบรื่นในค่าข้อมูลเหล่านี้:

skd = SmoothKernelDistribution[data];

เราได้รับผลลัพธ์ที่เป็นตัวเลขสำหรับแต่ละจุดข้อมูล:

eval = Table[{data[[i]], PDF[skd, data[[i]]]}, {i, Length[data]}];

เรากำหนดเกณฑ์และเราเลือกข้อมูลทั้งหมดที่สูงกว่าเกณฑ์นี้:

threshold = 1.2;
dataIn = Select[eval, #1[[2]] > threshold &][[All, 1]];

ที่นี่เราได้รับข้อมูลที่อยู่นอกภูมิภาค:

dataOut = Complement[data, dataIn];

และตอนนี้เราสามารถพล็อตข้อมูลทั้งหมด:

Show[ContourPlot[Evaluate@PDF[skd, {x, y}], {x, 0, 1}, {y, 0, 1}, PlotRange -> {{0, 1}, {0, 1}}, PlotPoints -> 50],
ListPlot[dataIn, PlotStyle -> Darker[Green]],
ListPlot[dataOut, PlotStyle -> Red]]

จุดสีเขียวนั้นอยู่เหนือขีด จำกัด และจุดสีแดงนั้นต่ำกว่าขีด จำกัด

ellipseฟังก์ชั่นในellipseแพคเกจสำหรับ R จะสร้างจุดเหล่านี้ (ที่จริงรูปหลายเหลี่ยมที่ใกล้เคียงกับวงรี) คุณสามารถใช้วงรีนั้น

สิ่งที่จริงอาจง่ายกว่าคือการคำนวณความสูงของความหนาแน่นที่จุดของคุณและดูว่ามันจะสูงกว่า (ภายในวงรี) หรือต่ำกว่า (นอกวงรี) กว่าค่ารูปร่างที่วงรี ellipseinternals ฟังก์ชั่นใช้คุ้มค่าในการสร้างวงรีคุณสามารถเริ่มต้นมีความสูงสำหรับการค้นหาที่จะใช้งาน$\chi^2$

ฉันพบคำตอบได้ที่: /programming/2397097/how-can-a-data-ellipse-be-superimposed-on-a-ggplot2-scatterplot

#bootstrap
set.seed(101)
n <- 1000
x <- rnorm(n, mean=2)
y <- 1.5 + 0.4*x + rnorm(n)
df <- data.frame(x=x, y=y, group="A")
x <- rnorm(n, mean=2)
y <- 1.5*x + 0.4 + rnorm(n)
df <- rbind(df, data.frame(x=x, y=y, group="B"))

#calculating ellipses
library(ellipse)
df_ell <- data.frame()
for(g in levels(df$group)){
df_ell <- rbind(df_ell, cbind(as.data.frame(with(df[df$group==g,], ellipse(cor(x, y), 
                                         scale=c(sd(x),sd(y)), 
                                         centre=c(mean(x),mean(y))))),group=g))
}
#drawing
library(ggplot2)
p <- ggplot(data=df, aes(x=x, y=y,colour=group)) + geom_point(size=1.5, alpha=.6) +
  geom_path(data=df_ell, aes(x=x, y=y,colour=group), size=1, linetype=2)