Basic: Tools for Understanding Highway Performance

Documented in brktrials2

#' \code{brktrials2} produces \code{t-x} trajectories for lead and following vehicles at a bottleneck
#'
#' @return \code{brktrials2} returns  \code{t-x} trajectories of \code{nveh} vehicles at a bottleneck.
#' @param tend end time for a simulation run, a number
#' @param umn start speed (mph) for vehicle in lane 1, a number
#' @param usd speed volatility for \code{umn}, a number
#' @param xstart a vector of  \code{nveh} start locations, (feet), a vector
#' @param xfunnel upstream location where the lane drop starts (feet), a number
#' @param leff effective vehicle length(feet), a number
#' @param lane a vector of \code{nveh} numbers, a vector
#' @param delt size in seconds, a number
#' @param type 0 no plots, 1 prediction plot, 2 all plots, a number
#' @usage brktrials2(tend, umn, usd, xstart, xfunnel, leff, lane, delt, type)
#' @examples
#' brktrials2(30, 41, 11, xstart, -500, 14, lane, 0.5, 1)
#' @export
brktrials2 <- function(tend, umn, usd, xstart, xfunnel, leff, lane, delt, type) {
  if(type != 0) {
    if(type == 2) {
      # layout(matrix(c(1,1,2,3,4,4,5,5), 4,2, byrow = TRUE))
      layout(matrix(c(1,1,2,3), 2,2, byrow = TRUE))
    } else {
      par(mfrow = c(1,1), pty = "m")
    }
  }
  tend.save  <- tend
  lane.      <- lane
  tseq       <- seq(0,tend,delt)
  tlen       <- length(tseq)
  nveh       <- length(lane)
  tstart     <- 0
  # 1. store bmfree2 output in a data frame "df = nveh * tux matrices".
  # df. = tux: tlen by  6 matrix. colnames(tux) = t, u, x, y, lane, vehicle
  for(veh in 1:nveh) {
    df.     <- bmfree2(umn, usd, tstart, tend, xstart[veh], delt)
    vehicle <- rep(veh, tlen)
    y       <- rep(NA, tlen)
    lane    <- rep(lane.[veh], tlen)
    df.     <- cbind(df., y, lane, vehicle)
    if(veh == 1) df <- df. else df <- cbind(df, df.)
  }

  # 2. Calculate y = f(x, lane, xfunnel)
  for(veh in 1:nveh) {
    df.   <- vehdf(veh, nveh, df)
    x.    <- vehdf(veh, nveh, df)[,3]
    y.    <- vehdf(veh, nveh, df)[,4]
    lane  <- vehdf(veh, nveh, df)[,5]
    for(t in 1:tlen) {
      if(as.numeric(df.[t,3]) <= xfunnel & as.numeric(df.[t,5]) == 1) df.[t,4] = -6
      if(as.numeric(df.[t,3]) <= xfunnel & as.numeric(df.[t,5]) == 2) df.[t,4] = 6
      if(as.numeric(df.[t,3]) > 0) df.[t,4] = 0
      if(as.numeric(df.[t,3]) > xfunnel & as.numeric(df.[t,3]) <= 0 &
         as.numeric(df.[t,5]) == 1)
        df.[t,4] = -6/xfunnel * as.numeric(df.[t,3])
      if(as.numeric(df.[t,3]) > xfunnel & as.numeric(df.[t,3]) <= 0 &
        as.numeric(df.[t,5]) == 2)
        df.[t,4] = 6/xfunnel * as.numeric(df.[t,3])
    }
    ufix <- df.[,2]
    xfix <- df.[,3]
    yfix <- df.[,4]
    df   <- vehfix(veh, nveh, ufix, xfix, yfix, df)
  }
  # 3. plot "driver desire lines."
  if(type == 2) {
    plotoptimize(df, xfunnel, type)
  }
  # df0 = with driver constraints
  df0 <- df
  # dfcross = data frame t0 = times when lead vehicles cross line x = 0.
  # Use brkcross0(veh, dfij)
  dfcross <- {}
  for(veh in 1:nveh) {
    dfij    <- vehdf(veh, nveh, df)
    result  <- brkcross0(veh, dfij)
    h <- u  <- x <- hobs <- time <- NA
    result2 <- data.frame(time = time, hsafe = h, u = u, x = x, hobs = hobs)
    result  <- c(result, result2)
    dfcross <- rbind(dfcross, result)
  }
  colnames(dfcross) <- c("vehicle","tl","ul","xl","tf","uf","xf","hsafef","hobs")
  rownames(dfcross) <- paste("", sep = "",1:nveh)
  # 4. plot Lane 1 and 2 "desire line" trajectories
  if(type == 2) type. <- 2 else type. <- 0
  pick <- 1
  df   <- plotupstream(pick, lane., nveh, df, xfunnel, leff, type = type.)
  pick <- 2
  df   <- plotupstream(pick, lane., nveh, df, xfunnel, leff, type = type.)
  # 5. Model forecast plot
  df   <- plotoptimize(df, xfunnel, type)
  for(veh in 1:nveh) {
    dfij    <- vehdf(veh, nveh, df)
    dfij0   <- dfij[dfij[,3] < 0,]
    index   <- dim(dfij0)[1]
    dfij0   <- as.numeric(dfij0[index,])
    dfx0.   <- data.frame(t = dfij0[1], u = dfij0[2], x = dfij0[3], vehicle = veh)
    if(veh > 1) dfx0 <- rbind(dfx0, dfx0.) else dfx0 = dfx0.
  }
  o         <- order(dfx0[,1])
  dfx0      <- dfx0[o,]
  vehorder  <- dfx0[,4]
  dfcross   <- dfcross[o,]
  xlimit    <- vehdf(1, nveh, df)[,3]
  for(i in 2:nveh) {
    xlimit  <- c(xlimit, vehdf(i, nveh, df)[,3])
  }
  ylim <- c(min(xlimit), max(xlimit))
  for(i in 1:nveh) {
    if(type != 0) {
      if(i == 1) {
        veh     <- vehorder[i]
        dfij    <- vehdf(veh, nveh, df)
        if(type != 0) {}
        if(dfij[1,5] == "1") {
          plot(dfij[,1], dfij[,3], xlab = "t", ylab = "x", typ = "l",
               xlim = c(0,tend.save), ylim = ylim)
        } else {
          plot(dfij[,1], dfij[,3], xlab = "t", ylab = "x", typ = "l",
               xlim = c(0,tend.save), ylim = ylim, col = "blue")
        }
        abline(h = c(0, xfunnel), col = gray(0.8))
        abline(v = 0, col = gray(0.8))
        text(dfij[tlen,1], dfij[tlen,3], labels = as.character(veh), pos = 4, cex = 1)
      } else {
        veh     <- vehorder[i]
        dfij    <- vehdf(veh, nveh, df)
        if(dfij[1,5] == "1") lines(dfij[,1], dfij[,3], lty = 4)
        else  lines(dfij[,1], dfij[,3], lty = 4, col = "blue")
      }
    }
  }
#      browser()
  # Filter the upstream data to assure drivers conform to safe driving hsafe rules.
  for(i in 2:nveh) {
    # follower
    veh     <- vehorder[i]
    dfij    <- vehdf(veh, nveh, df)
    tf0     <- as.numeric(dfcross[i-1,2])
    uf0     <- as.numeric(dfij[dfij[,1] == tf0, 2])
    xf0     <- dfij[dfij[,1] == tf0, 3]
    hsafef  <- hsafe(uf0, leff)
    hobs    <- as.numeric(dfcross[i-1,4]) - xf0
    dfcross[i,5]  <- tf0
    dfcross[i,6]  <- uf0
    dfcross[i,7]  <- xf0
    dfcross[i,8]  <- hsafef
    dfcross[i,9]  <- hobs
    # Check
    if(as.numeric(dfcross[i,8]) <= as.numeric(dfcross[i,9])) {
    # no safety violation for xab.
      dfij      <- vehdf(veh, nveh, df)
      dfij0     <- dfij[dfij[,1] <= dfcross[i,5],]
      if(type != 0) {
        if(dfij0[1,5] == "1") {
          lines(dfij0[,1], dfij0[,3])
        } else {
          lines(dfij0[,1], dfij0[,3], col = "blue")
        }
      }
      tindex    <- as.numeric(dfcross[i,5])
      tux       <- dfij[dfij[,1] >= tindex,]
      # check downstream for hsafe violations
      tuxlead   <- vehdf(veh = vehorder[i-1], nveh, df)
      tuxlead   <- tuxlead[tuxlead[,1] >= tindex,]
      # no passing allowed check
      if(is.null(dim(tux))) nope <- c(tuxlead[c(1,2,3)], tux[c(2,3)])
      else {
        nope    <- cbind(tuxlead[,c(1,2,3)], tux[,c(2,3)])
        colnames(nope) <- c("t", "u.lead","x.lead","u.follow","x.follow")
      }
      tuxfix     <- nopass(veh, nope, leff)
      # Fix tailgating
      if(is.data.frame(tuxfix) & type != 0) {
        if(dfij0[1,5] == "1" ) {
          lines(tux[,1], tuxfix[,2], lwd = 1)
        } else {
          lines(tux[,1], tuxfix[,2], lwd = 1, col = "blue")
        }
        nsteps <- dim(tuxfix)[1]
        text(tux[nsteps,1], tuxfix[nsteps,2],
             labels = as.character(veh), pos = 4, cex = 1)
      } else {
        text(tend, tux[3],
             labels = as.character(veh), pos = 4, cex = 1)
      }
#      browser()
    } else {
      # Safe headway violation
      dfij            <- vehdf(veh, nveh, df)
      dfijab          <- dfij[dfij[,3] >= xfunnel & dfij[,3] <= 0,]
      index           <- dim(dfijab)[1]
      if(index > 0) {
        dfcross[i,5]    <- tindex <- as.numeric(dfijab[index,1])
        dfcross[i,6]    <- as.numeric(dfijab[1,2])
        dfcross[i,7]    <- as.numeric(dfijab[1,2])
        dfcross[i,8]    <- hsafe(as.numeric(dfijab[1,2]), leff)
        dfijlead        <- vehdf(veh-1, nveh, df)
        hobs            <- as.numeric(dfijlead[dfijlead[,1] == tindex,3])
        dfcross[i,9]    <- hobs
        dfijfun         <- dfij[dfij[,3] <= xfunnel,]
#        browser()
        if(type != 0) lines(dfijfun[,1], dfijfun[,3], lwd = 1)
        index           <- dim(dfijfun)[1]
        tstartab        <- dfijfun[index,1]
        ustartab        <- dfijfun[index,2]
        xstartab        <- dfijfun[index,3]
        tendab          <- as.numeric(dfcross[i,5])
        uendab          <- as.numeric(dfcross[i,6])
        xendab          <- as.numeric(dfcross[i,7])
        ab              <- xabparam(tstart = tstartab, tend = tendab,
                              ustart = ustartab, uend = uendab,
                              xstart = xstartab, xend = xendab)
        a               <- ab[1]
        b               <- ab[2]
        x0              <- xstartab
        u0              <- ustartab
        t0              <- tstartab
        tseq            <- seq(tstartab, tendab, delt)
        xmab <- uab  <- yab  <- {}
        for(j in 1:length(tseq)) {
          xmab <- c(xmab, xab(x0,u0,a,b,t = tseq[j],t0))
          uab  <- c(uab, uab(u0,a,b,t = tseq[j],t0))
          yab  <- c(yab, df[df[,1] == tseq[j], 4])
        }
        xabpoints <- rbind(data.frame(t = tstartab, u = ustartab, x = xstartab),
                           data.frame(t = tendab, u = uendab, x = xendab)
        )
        if(type != 0) lines(tseq, xmab, lwd = 1)
        tstart  <- tendab
        xstart  <- xmab[length(xmab)]
        umn     <- 3600/5280*uab[length(uab)]
        if(tstart < tend) {
          tux     <- bmfree2(umn, usd, tstart, tend, xstart, delt)
          if(type != 0) lines(tux[,1],tux[,3])
          tuxlead <- vehdf(veh = vehorder[i - 1], nveh, df)
          tuxlead <- tuxlead[tuxlead[,1] >= tstart,]
          # no passing allowed check
          nope           <- cbind(tuxlead[,c(1,2,3)], tux[,c(2,3)])
          colnames(nope) <- c("t", "u.lead","x.lead","u.follow","x.follow")
          tuxfix     <- nopass(veh, nope, leff)
          # Fix tailgating
          if(type != 0) {
            lines(tux[,1], tuxfix[,2], lwd = 1)
            nsteps <- dim(tuxfix)[1]
            text(tux[nsteps,1], tuxfix[nsteps,2],
                 labels = as.character(veh), pos = 4, cex = 1)
          }
        }
      } else {
        if(type != 0) {
          if(dfij[1,5] == "1") {
            lines(dfij[,1], dfij[,3])
            text(dfij[tlen,1], dfij[tlen,3], labels = veh, pos = 4)
          } else {
            lines(dfij[,1], dfij[,3], col = "blue")
            text(dfij[tlen,1], dfij[tlen,3], labels = veh, pos = 4)
          }
        }
      }
    }
  }
  if(type != 0) {
    title(main = "Model Predictions")
    legend("topleft", legend = c(
      "Leading vehicle",
      "Following vehicles",
      "Lane 1", "Lane 2"
    ),
    lty = c(1,4,1,1),
    col = c("black","black","black","blue"),
    bty = "n")
  }
  return(list(dfcross, df, df0))
}