R：模拟线段条件

Question

对于感知任务，我希望模拟多个项目，每个项目都由一条带有两个“断点”的单线组成，其中线突然改变方向。所以本质上，这条线由三个相连的线段（AB、BC 和 CD）组成，连接四个坐标（Axy、Bxy、Cxy、Dyx），每个坐标都有不同的斜率。

该行必须符合以下三个条件：

1) 线的总长度（L），即三个线段（AB、BC、CD）的长度之和，应该因项目而异，但始终在 l1 和 l2 的范围内.

2) 线条应适合并占据 X*Y 大小的矩形。也就是说，至少一个 x 坐标（Ax、Bx、Cx 或 Dx）应该等于 0，至少一个 x 坐标（Ax、Bx、Cx 或 Dx）应该等于 X，至少一个 y 坐标（ Ay、By、Cy 或 Dy) 应为 0，至少一个 y 坐标（Ay、By、Cy 或 Dy）应等于 Y； x 坐标不得低于 0 或高于 X，y 坐标不得低于 0 或高于 Y。

3) 线段不能交叉。也就是说，线段 AB 和 CD 不能相交（因为线 BC 的一端连接到其他两条线段，所以不能相交）。

我希望在 R 中执行此操作。到目前为止，我只管理了一个代码，其中创建了一个随机行，然后代码检查它是否满足所有三个条件。如果没有，它会重新开始。此方法耗时太长！

有谁知道如何让这段代码更高效？下面提供了当前的 R 代码。

    #START WHILE LOOP
    STOP = FALSE
    CONDITION_COUNTER <- c(0,0,0)
    while(STOP==FALSE){ #start condition checking loop

    #SETTINGS:
    l1 = 8 #minimum length L
    l2 = 12 #maximum length L
    L = runif(1,l1,l2) #length L
    X = 5 #width square for length L
    Y = 7 #heigth square for length L

    #CREATE LINE SEGMENT:
    Ax <- runif(1,0,X) #x-coordinate point A
    Ay <- runif(1,0,Y) #y-coordinate point A
    Bx <- runif(1,0,X) #x-coordinate point B
    By <- runif(1,0,Y) #y-coordinate point B
    Cx <- runif(1,0,X) #x-coordinate point C
    Cy <- runif(1,0,Y) #y-coordinate point C
    Dx <- runif(1,0,X) #x-coordinate point D
    Dy <- runif(1,0,Y) #y-coordinate point D

    #CHECK CONDITION 01 (line has to equal length L)
    AB = sqrt((Ax-Bx)^2 + (Ay-By)^2) #length line segment AB
    BC = sqrt((Bx-Cx)^2 + (By-Cy)^2) #length line segment BC
    CD = sqrt((Cx-Dx)^2 + (Cy-Dy)^2) #length line segment CD

    CONDITION_COUNTER[1] <- L == AB + BC + CD #Condition 1 satisfied (1) or not (0)?

    #CHECK CONDITION 02 (line has to fill the square)
    c1 = sum(c(Ax, Bx, Cx, Dx) == 0) > 0 #does one point have x-coordinate 0?
    c2 = sum(c(Ax, Bx, Cx, Dx) == X) > 0 #does one point have x-coordinate X?
    c3 = sum(c(Ay, By, Cy, Dy) == 0) > 0 #does one point have y-coordinate 0?
    c4 = sum(c(Ay, By, Cy, Dy) == Y) > 0 #does one point have y-coordinate Y?

    CONDITION_COUNTER[2] <- sum(c(c1,c2,c3,c4)) == 4 #Condition 2 satisfied (1) or not (0)?

    #CHECK CONDITION 03 (line segments may not cross)
    a <- max(c(Ax,Bx)); b <- min(c(Ax,Bx)); x <- a-b; x
    a <- c(Ay,By)[which.max(c(Ax,Bx))]; b <- c(Ay,By)[which.min(c(Ax,Bx))]; y <- a-b; y
    slopeAB <- y/x
    InterceptAB <- Ay - slopeAB * Ax

    c <- max(c(Cx,Dx)); d <- min(c(Cx,Dx)); x <- c-d; x
    c <- c(Cy,Dy)[which.max(c(Cx,Dx))]; d <- c(Cy,Dy)[which.min(c(Cx,Dx))]; y <- c-d; y
    slopeCD <- y/x
    InterceptCD <- Cy - slopeCD * Cx

    intersection <- (InterceptAB - InterceptCD)/(slopeCD - slopeAB) #what is the hypothetical x-coordinate of intersection?
    c1 <- min(c(Ax,Bx)) <= intersection  & intersection <= max(c(Ax,Bx)) #does AB contain that x-coordinate? (TRUE=yes, FALSE=no)
    c1 <- (c1 -1)*-1

    CONDITION_COUNTER[3] <- c1

    CHECK <- (sum(CONDITION_COUNTER) == 3) #check if all conditions are met
    if(CHECK == TRUE){STOP <- TRUE} #if all conditions are met, stop loop

    } #END WHILE LOOP

    #Plot:
    plot(-1:10, -1:10, xaxt='n',yaxt='n',bty='n',pch='',ylab='',xlab='', col="white")
    segments(Ax,Ay,Bx,By, lwd=2) #segment AB
    segments(Bx,By,Cx,Cy, lwd=2) #segment BC
    segments(Cx,Cy,Dx,Dy, lwd=2) #segment CD

    #Add square that it has to fill
    segments(0,0,X,0, col="red")
    segments(0,0,0,Y, col="red")
    segments(X,0,X,Y, col="red")
    segments(0,Y,X,Y, col="red")

Answer 1

由于您的约束迫使图片看起来像您的图像（或者可能是旋转副本），您可以将问题视为选择 4 个数字（每条边上的一个位置）而不是 8 个。交叉点是不可能的，所以无需检查。选择前三个点，然后暂停检查是否是 可以将其扩展到第四个（鉴于长度限制）。作为安全阀，限制尝试找到可行解决方案的次数：

dis <- function(x0,y0,x1,y1){
  sqrt(sum((c(x1,y1)-c(x0,y0))^2))
}

broken.line <- function(X,Y,l1,l2,attempts = 1000){
  Ax <- 0
  By <- 0
  Cx <- X
  Dy <- Y
  for(i in 1:attempts){
      Ay <- runif(1,0,Y)
      Bx <- runif(1,0,X)
      Cy <- runif(1,0,Y)
      L <- dis(Ax,Ay,Bx,By) + dis(Bx,By,Cx,Cy)
      d.min <- Y - Cy #min dist to top edge
      if(l1 <  L + d.min && L + d.min < l2){
        #it is feasible to complete this
        #configuration -- calulate how much
        #of top edge is a valid choice
        #d.max is farthest that last point
        #can be from the upper right corner:
        d.max <- sqrt((l2 - L)^2 - d.min^2)
        Dx <- runif(1,max(0,X-d.max),X)
        points <- c(Ax,Bx,Cx,Dx,Ay,By,Cy,Dy)
        return(matrix(points,ncol = 2))
      }
  }
  NULL #can't find a feasible solution
}

相当快。使用您的参数，它每秒可以生成数万个解决方案。快速测试：

> m <- broken.line(5,7,8,12)
> m
         [,1]     [,2]
[1,] 0.000000 1.613904
[2,] 1.008444 0.000000
[3,] 5.000000 3.627471
[4,] 3.145380 7.000000
> plot(m,type = 'l')

图表：