Kết nối hai điểm với đường cong (đường cong s-ish) trong R

Question

Giả sử tôi muốn tạo ra một loại cấu trúc cây như hình dưới đây:

plot(0, type="n",xlim=c(0, 5), ylim=c(-3, 8), axes=FALSE, xlab="", ylab="", main="") 
points(1, 2.5) 
points(3, 5) 
points(3, 0) 
lines(c(1, 3), c(2.5, 5)) 
lines(c(1, 3), c(2.5, 0)) 
text(1, 2.5, adj=1, label="Parent ") 
text(3, 5, adj=0, label=" Child 1") 
text(3, 0, adj=0, label=" Child 2") 

Tôi tự hỏi nếu có một cách trong R nơi chúng ta có thể tạo ra các đường cong giống với các mức độ khác nhau của đường cong hình chữ S giống như những đường bên dưới. Điều quan trọng là nó sẽ là tuyệt vời nếu nó sẽ có thể tạo ra các dòng như vậy mà không cần đến ggplot.

EDIT loại bỏ và làm thành một câu trả lời

Answer 1

Tiếp theo đề nghị @ thelatemail, tôi quyết định làm chỉnh sửa của tôi vào một câu trả lời. Giải pháp của tôi dựa trên câu trả lời của @ thelatemail.

Tôi đã viết một chức năng nhỏ để vẽ đường cong, mà làm cho việc sử dụng chức năng hậu cần:

#Create the function 
curveMaker <- function(x1, y1, x2, y2, ...){ 
    curve(plogis(x, scale = 0.08, loc = (x1 + x2) /2) * (y2-y1) + y1, 
        x1, x2, add = TRUE, ...) 
} 

Một ví dụ làm việc ở dưới. Trong ví dụ này, tôi muốn tạo một âm mưu phân loại với 3 cấp độ: parent ->2 children ->20 grandchildren. Một đứa trẻ có 12 đứa cháu, và đứa kia có 8 đứa con.

#Prepare data: 
parent <- c(1, 16) 
children <- cbind(2, c(8, 28)) 
grandchildren <- cbind(3, (1:20)*2-1) 
labels <- c("Parent ", paste("Child ", 1:2), paste(" Grandchild", 1:20)) 


#Make a blank plot canvas 
plot(0, type="n", ann = FALSE, xlim = c(0.5, 3.5), ylim = c(0.5, 39.5), axes = FALSE) 

#Plot curves 
#Parent and children 
invisible(mapply(curveMaker, 
        x1 = parent[ 1 ], 
        y1 = parent[ 2 ], 
        x2 = children[ , 1 ], 
        y2 = children[ , 2 ], 
        col = gray(0.6, alpha = 0.6), lwd = 1.5)) 

#Children and grandchildren 
invisible(mapply(curveMaker, 
        x1 = children[ 1, 1 ], 
        y1 = children[ 1, 2 ], 
        x2 = grandchildren[ 1:8 , 1 ], 
        y2 = grandchildren[ 1:8, 2 ], 
        col = gray(0.6, alpha = 0.6), lwd = 1.5)) 
invisible(mapply(curveMaker, 
        x1 = children[ 2, 1 ], 
        y1 = children[ 2, 2 ], 
        x2 = grandchildren[ 9:20 , 1 ], 
        y2 = grandchildren[ 9:20, 2 ], 
        col = gray(0.6, alpha = 0.6), lwd = 1.5)) 
#Plot text 
text(x = c(parent[1], children[,1], grandchildren[,1]), 
     y = c(parent[2], children[,2], grandchildren[,2]), 
     labels = labels, 
     pos = rep(c(2, 4), c(3, 20))) 

#Plot points 
points(x = c(parent[1], children[,1], grandchildren[,1]), 
     y = c(parent[2], children[,2], grandchildren[,2]), 
     pch = 21, bg = "white", col="#3182bd", lwd=2.5, cex=1) 

Answer 2

Âm thanh như một đường cong sigmoid, ví dụ .:

f <- function(x,s) s/(1 + exp(-x)) 
curve(f(x,s=1),xlim=c(-4,4)) 
curve(f(x,s=0.9),xlim=c(-4,4),add=TRUE) 
curve(f(x,s=0.8),xlim=c(-4,4),add=TRUE) 
curve(f(x,s=0.7),xlim=c(-4,4),add=TRUE) 

Kết quả:

Bạn có thể bắt đầu điều chỉnh điều này, ví dụ: đây là một chút thời gian mã:

plot(NA,type="n",ann=FALSE,axes=FALSE,xlim=c(-6,6),ylim=c(0,1)) 
curve(f(x,s=1),xlim=c(-4,4),add=TRUE) 
curve(f(x,s=0.8),xlim=c(-4,4),add=TRUE) 
curve(f(x,s=0.6),xlim=c(-4,4),add=TRUE) 
text(
    c(-4,rep(4,3)), 
    c(0,f(c(4),c(1,0.8,0.6))), 
    labels=c("Parent","Kid 1","Kid 2","Kid 3"), 
    pos=c(2,4,4,4) 
) 

Kết quả:

Answer 3

Tôi nghĩ rằng Paul Murrell có một tài liệu minh họa sơ đồ tương tự trong lưới. Dưới đây là một ví dụ cơ bản,

library(grid) 

labelGrob <- function(x,y,label, ...){ 
    t <- textGrob(x,y,label=label) 
    w <- convertWidth(1.5*grobWidth(t), "npc", valueOnly = TRUE) 
    h <- convertHeight(1.5*grobHeight(t), "npc", valueOnly = TRUE) 
    gTree(cl = "label", west = unit(x-0.5*w, "npc"), 
     east = unit(x+0.5*w, "npc"), 
     children=gList(t, roundrectGrob(x=x, y=y, gp=gpar(fill=NA), 
             width=w, height=h))) 

} 

xDetails.label <- function(x, theta){ 
    if(theta == 180) return(x$west[1]) else 
    if(theta == 0) return(x$east[1]) else 
    xDetails(x$children[[1]], theta) 
} 

yDetails.label <- function(x, theta){ 
    if(theta %in% c("west", "east")) return(x$y) else 
    yDetails(x$children[[1]], theta) 
} 

lab1 <- labelGrob(0.1, 0.5, "start") 
lab2 <- labelGrob(0.6, 0.75, "end") 
grid.newpage() 
grid.draw(lab1) 
grid.draw(lab2) 
grid.curve(grobX(lab1, "east"), grobY(lab1, "east"), 
      grobX(lab2, "west"), grobY(lab2, "west"), 
      inflect = TRUE, curvature=0.1)