Composite traffic model

This page is a method. The page identifier is Op_en5136
Moderator:Smxb (see all)
This page is a stub. You may improve it into a full page, and then a rating bar will appear here.
Upload data

This page is about a composite traffic model that is an updated version of File:Composite traffic.ANA. The new version is coded with R.

Definition

R model

• Trip aggregator
  • Optimization rules:

1. No second transfer -> prioritize "secondary" passengers
2. Fill as many 8-person-vehicles as possible
3. Fill as many 4-person-vehicles as possible
4. Special rule: for trips with no possible transfer-point -> direct trip
5. Transfer the rest (will always be 4-person-vehicles)
6. Re-check vehicle configurations, when exact numbers of primary and secondary passengers as well as transferees are known

+ Show code- Hide code # Trip aggregator, sampled passenger data as input n.intervals.per.h <- 5 trips.next <- data.frame() trips.left <- data.frame() trips.out <- data.frame() trips.secondary <- data.frame() times <- seq(1, 25, 1 / n.intervals.per.h) times[length(times)] <- 1 library(OpasnetBaseUtils) roads <- op_baseGetData("opasnet_base", "Op_en2634", apply.utf8 = FALSE) colnames(roads)[6] <- "Through" trips.locs <- op_baseGetLocs("opasnet_base", "Op_en2625", apply.utf8 = FALSE) trips <- op_baseGetData("opasnet_base", "Op_en2625") for (i in 1:(length(times) - 1)) { if(i == 1) { trips.sample.1 <- trips[trips$Time == times[1],] #trips.sample.1 <- op_baseGetData("opasnet_base", "Op_en2625", include = trips.locs$loc_id[trips.locs$ind == "Time" & # trips.locs$loc == as.character(times[1])]) trips.sample.1$Secondary <- 0 } else { trips.sample.1 <- trips.sample.2 trips.sample.1 <- merge(trips.sample.1, trips.secondary, all.x = TRUE) trips.sample.1$Secondary[is.na(trips.sample.1$Secondary)] <- 0 } trips.sample.2 <- trips[trips$Time == times[i + 1],] #trips.sample.2 <- op_baseGetData("opasnet_base", "Op_en2625", include = trips.locs$loc_id[trips.locs$ind == "Time" & # trips.locs$loc == as.character(times[i + 1])]) # Optimizer main code optimal.d.trips <- 0 sub.optimal.d.trips <- 0 optimal.d.trips <- (trips.sample.1$Result + trips.sample.1$Secondary) %/% 4 * 4 sub.optimal.d.trips <- ifelse(trips.sample.1$Secondary - optimal.d.trips > 0, trips.sample.1$Result + trips.sample.1$Secondary - optimal.d.trips, 0) busiest <- tapply(trips.sample.2$Result, trips.sample.2$From, sum) busiest <- sort(busiest, decreasing = TRUE) condition <- trips.sample.1$Result + trips.sample.1$Secondary - optimal.d.trips - sub.optimal.d.trips > 0 trips.next <- merge(trips.sample.1[condition, c("From","To")], roads[,c("From","To","Through")], all.x = TRUE) trips.next$Through <- match(trips.next$Through, names(busiest)) checkpoints <- tapply(trips.next$Through, trips.next[,c("From", "To")], min) trips.sample.1 <- merge(trips.sample.1, as.data.frame(as.table(checkpoints)), all.x = TRUE) colnames(trips.sample.1)[colnames(trips.sample.1) == "Freq"] <- "Checkpoint" trips.sample.1$Checkpoint <- names(busiest)[trips.sample.1$Checkpoint] # Take into account those that don't have a checkpoint condition2 <- is.na(trips.sample.1$Checkpoint) condition3 <- trips.sample.1$Result + trips.sample.1$Secondary - optimal.d.trips - sub.optimal.d.trips > 0 no.transfer <- ifelse(condition2 & condition3, (trips.sample.1$Result + trips.sample.1$Secondary - optimal.d.trips - sub.optimal.d.trips)[condition2 & condition3], 0) trips.sample.1$Optim.d.trips <- optimal.d.trips trips.sample.1$Sub.optim.d.trips <- sub.optimal.d.trips trips.sample.1$No.transfer <- no.transfer # Transfers trips.left.trans <- data.frame(trips.sample.1[!condition2 & condition3, c("From", "Checkpoint", "To", "Time")], Transferred = (trips.sample.1$Result + trips.sample.1$Secondary - optimal.d.trips - sub.optimal.d.trips)[!condition2 & condition3]) colnames(trips.left.trans)[1] <- "From" colnames(trips.left.trans)[3] <- "Destination" colnames(trips.left.trans)[2] <- "To" trips.sample.1 <- merge(trips.sample.1, as.data.frame(as.table(tapply(trips.left.trans$Transferred, trips.left.trans[,c("From","To")], sum))), all.x = TRUE) colnames(trips.sample.1)[colnames(trips.sample.1) %in% "Freq"] <- "Transferred" trips.sample.1$Transferred[is.na(trips.sample.1$Transferred)] <- 0 # Now divide passengers to cars n.full.8.cars <- (trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer + trips.sample.1$Transferred) %/% 8 n.full.4.cars <- (trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer + trips.sample.1$Transferred - n.full.8.cars * 8) %/% 4 n.4.cars.3.pas <- (trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer + trips.sample.1$Transferred - n.full.8.cars * 8 - n.full.4.cars * 4) %/% 3 n.4.cars.2.pas <- (trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer + trips.sample.1$Transferred - n.full.8.cars * 8 - n.full.4.cars * 4 - n.4.cars.3.pas * 3) %/% 2 n.4.cars.1.pas <- trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer + trips.sample.1$Transferred - n.full.8.cars * 8 - n.full.4.cars * 4 - n.4.cars.3.pas * 3 - n.4.cars.2.pas * 2 d8 <- ifelse(trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer < 8 * n.full.8.cars, trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer, 8 * n.full.8.cars) d4 <- ifelse(trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer - d8 < 4 * n.full.4.cars, trips.sample.1$Optim.d.trip + trips.sample.1$Sub.optim.d.trip + trips.sample.1$No.transfer - d8, 4 * n.full.4.cars) c8 <- 8 * n.full.8.cars - d8 c4 <- 4 * n.full.4.cars - d4 c3 <- n.4.cars.3.pas * (trips.sample.1$Transferred - c8 - c4) # Note: there will be only 1 partially filled car d3 <- 3 * n.4.cars.3.pas - c3 c2 <- n.4.cars.2.pas * (trips.sample.1$Transferred - c8 - c4) d2 <- 2 * n.4.cars.2.pas - c2 c1 <- n.4.cars.1.pas * (trips.sample.1$Transferred - c8 - c4) d1 <- n.4.cars.1.pas - c1 # Add transferred passengers to the next time slot as secondary passengers # delay <- distance / speed delay <- 0.2 colnames(trips.left.trans)[5] <- "Secondary" colnames(trips.left.trans)[1] <- "Origin" colnames(trips.left.trans)[2] <- "From" colnames(trips.left.trans)[3] <- "To" trips.left.trans$Time <- as.character(as.numeric(as.character(trips.left.trans$Time)) + delay) trips.left.trans <- as.data.frame(as.table(tapply(trips.left.trans$Secondary, trips.left.trans[, c("From","To","Time")], sum))) colnames(trips.left.trans)[4] <- "Secondary" trips.left.trans <- trips.left.trans[!is.na(trips.left.trans$Secondary),] trips.secondary <- rbind(trips.secondary, trips.left.trans) trips.out <- rbind(trips.out, data.frame(trips.sample.1[, c("From", "To", "Time")], d8, d4, d3, d2, d1, c8, c4, c3, c2, c1)) } # Summary d8 <- tapply(trips.out$d8, trips.out$Time, sum) d4 <- tapply(trips.out$d4, trips.out$Time, sum) d3 <- tapply(trips.out$d3, trips.out$Time, sum) d2 <- tapply(trips.out$d2, trips.out$Time, sum) d1 <- tapply(trips.out$d1, trips.out$Time, sum) c8 <- tapply(trips.out$c8, trips.out$Time, sum) c4 <- tapply(trips.out$c4, trips.out$Time, sum) c3 <- tapply(trips.out$c3, trips.out$Time, sum) c2 <- tapply(trips.out$c2, trips.out$Time, sum) c1 <- tapply(trips.out$c1, trips.out$Time, sum) test <- data.frame(Time = names(d8), Type = rep(colnames(trips.out)[4:13], each = length(d8)), Result = c(d8, d4, d3, d2, d1, c8, c4, c3, c2, c1)) test$Time <- as.numeric(as.character(test$Time)) library(ggplot2) ggplot(test, aes(x = Time, y = Result, fill = Type)) + geom_area()

TODO: {{#todo:Ruvetaan keräämään tälle sivulle matskua mallin uudesta versiosta.|Smxb|}}