Composite traffic model: Difference between revisions

Latest revision as of 07:14, 12 January 2018

This page is a knowledge crystal of subtype method. The page identifier is Op_en5136
Moderator:Smxb (see all)
This page is a stub. You may improve it into a full page.
Upload data {{#opasnet_base_link:Op_en5136}}

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.

Question

How to estimate potential to aggregate individual trips into public transportation or composite vehicles (airport-taxi-like vehicles for several passengers)?

Answer

Rationale

Variables

+ Show code - Hide code


library(OpasnetUtils)

roads <- opbase.data("Op_en2634") # , series_id = 2575, apply.utf8 = FALSE)
colnames(roads)[3] <- "Through"

distance <- opbase.data("Op_en5322") # , include = 14299, exclude = c(53097, 53098))

trips <- opbase.data(
	"Op_en2625", 
	include = list(Time = c("7", "7.2", "7.4", "7.6", "7.8", "8", "8.2", "8.4", "8.6", "8.8", "9"))
) # , include = 53096)

objects.store(roads, distance, trips)

cat("Successfully stored roads, distance, and trips.\n")

Initiation code

Actual model

Trip aggregator
- Optimization rules:

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

+ Show code - Hide code


library(OpasnetUtils)
library(ggplot2)
library(reshape2)

objects.latest("Op_en5136", code_name = "initiate")

# 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(7, 9, 1 / n.intervals.per.h)
times[length(times)] <- 1

speed <- 40 # kmh^-1

tdelay <- distance[distance$Mode == "Car" & distance$Time == "1", c("From", "To", "Result")]
tdelay$Result <- ceiling((tdelay$Result / speed) * n.intervals.per.h) / n.intervals.per.h
colnames(tdelay)[colnames(tdelay) %in% "Result"] <- "Delay"

for (i in 1:(length(times) - 2)) {
	if(i == 1) {
		trips.sample.1 <- trips[trips$Time == 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],]
	
	# 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"
#	print(i)
#	if(i >9) print(head(trips.left.trans))
	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
	
	trips.left.trans <- merge(trips.left.trans, tdelay)
	
	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)) + trips.left.trans$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))


ggplot(test, aes(x = Time, y = Result, fill = Type)) + geom_area()

# Vehicle kilometers

d8 <- tapply(trips.out$d8, trips.out[,c("From","To")], sum)
d4 <- tapply(trips.out$d4, trips.out[,c("From","To")], sum)
d3 <- tapply(trips.out$d3, trips.out[,c("From","To")], sum)
d2 <- tapply(trips.out$d2, trips.out[,c("From","To")], sum)
d1 <- tapply(trips.out$d1, trips.out[,c("From","To")], sum)
c8 <- tapply(trips.out$c8, trips.out[,c("From","To")], sum)
c4 <- tapply(trips.out$c4, trips.out[,c("From","To")], sum)
c3 <- tapply(trips.out$c3, trips.out[,c("From","To")], sum)
c2 <- tapply(trips.out$c2, trips.out[,c("From","To")], sum)
c1 <- tapply(trips.out$c1, trips.out[,c("From","To")], sum)

n.full.8.cars <- as.data.frame(as.table((d8 + c8) / 8))
n.full.4.cars <- as.data.frame(as.table((d4 + c4) / 4))
n.4.cars.3.pas <- as.data.frame(as.table((d3 + c3) / 3))
n.4.cars.2.pas <- as.data.frame(as.table((d2 + c2) / 2))
n.4.cars.1.pas <- as.data.frame(as.table(d1 + c1))

colnames(n.full.8.cars)[3] <- "n.full.8.cars"
colnames(n.full.4.cars)[3] <- "n.full.4.cars"
colnames(n.4.cars.3.pas)[3] <- "n.4.cars.3.pas"
colnames(n.4.cars.2.pas)[3] <- "n.4.cars.2.pas"
colnames(n.4.cars.1.pas)[3] <- "n.4.cars.1.pas"

test2 <- merge(n.full.8.cars, n.full.4.cars)
test2 <- merge(test2, n.4.cars.3.pas)
test2 <- merge(test2, n.4.cars.2.pas)
test2 <- merge(test2, n.4.cars.1.pas)

test2 <- melt(test2, id.vars = c("From","To"), variable_name = "Type")
test2 <- merge(test2, distance[,c("From", "To", "Result")])
colnames(test2)[5] <- "Distance"

test2$vehicle.kilometers <- test2$value * test2$Distance

# Costs

oprint(head(test2))

test3 <- as.data.frame(as.table(tapply(test2$vehicle.kilometers, test2$Type, sum)))
colnames(test3) <- c("Type", "vehicle.kilometers")

fuel.cons.emis.CO2 <- data.frame(Type = c("n.full.8.cars", "n.full.4.cars", "n.4.cars.3.pas", "n.4.cars.2.pas", "n.4.cars.1.pas"), 
	Consumption = c(8.7, 5.7, 5.7, 5.7, 5.7) / 100, Emis.factor.CO2 = c(232, 153, 153, 153, 153))

emis.factor.PM <- 0.1 # gkm^-1

fuel.price <- 1.374 # 4.8. average cost of a liter of diesel fuel in Finland

maint.price <- 0.0582 # €km^-1

driver.salary <- 2313 / 160 * 1.35 # €h^-1

test3 <- merge(test3, fuel.cons.emis.CO2)

test3$Fuel.cost <- test3$vehicle.kilometers * test3$Consumption * fuel.price

test3$Maint.cost <- test3$vehicle.kilometers * maint.price

test3$Emis.CO2 <- test3$vehicle.kilometers * test3$Emis.factor.CO2

test3$Emis.PM <- test3$vehicle.kilometers * emis.factor.PM

test3$Driver.cost <- test3$vehicle.kilometers / speed * driver.salary

PM.lethality <- c(-7.223e-004, 5.640e-006, 4.228e-005, 5.987e-005, 8.013e-005, 1.150e-004, 2.037e-004, 2.939e-004, 3.598e-004, 4.132e-004,
	4.640e-004, 5.139e-004, 5.662e-004, 6.233e-004, 6.854e-004, 7.577e-004, 8.441e-004, 9.519e-004, 1.093e-003, 1.314e-003, 2.805e-003)

PM.lethality <- median(PM.lethality) # deaths / kg

value.of.life <- (2e6 + 0.98e6) / 2 # runif(n, 0.98e6, 2e6) # € / death

emis.price.PM <- PM.lethality * value.of.life # 201.879 # €kg^-1

emis.price.CO2 <- 10e-3 # runif(n, 5e-3, 40e-3) # €kg^-1, the price of CO2 allowances fluctuates quite a bit, in 8.8.2011 they 
	# were going for 10.74 € per ton of CO2 equivalent

test3$CO2.cost <- test3$Emis.CO2 * emis.price.CO2

test3$PM.cost <- test3$Emis.PM * emis.price.PM

oprint(test3)

----#: . Takes below 10 minutes to run. Neat! --Teemu R 14:08, 2 August 2011 (EEST) (type: truth; paradigms: science: comment)

----#: . Though much slower on the serverside R... --Teemu R 14:26, 2 August 2011 (EEST) (type: truth; paradigms: science: comment)

⇤--#: . Current problems: 1) The whole trip data does not load from the database, but 2 hours works. 2) The last time point with trips.left.trans has 0 rows, so the code temporarily calculates up to the second last time point. --Jouni (talk) 20:42, 18 March 2015 (UTC) (type: truth; paradigms: science: attack)

Plans for further development:

Make an input form for bus transport subsidies (user can decide)
Based on subsidies less or more bus routes will be running.

----#: . Got any ideas on how the active bus routes should be derived from the amount of subsidies? --Teemu R 10:12, 18 August 2011 (EEST) (type: truth; paradigms: science: comment)

If bus is not available, trips will be made by private cars.
Calculate the impacts on costs due to a) fine particles and health, b) CO2 and climate, c) fuel costs, d) driver salary costs based on kilometres driven. Parking, rush delay, and capital costs due to vehicle maintenance are ignored. (All these ignorances are biased towards cars looking good.)
Play with the model in the course. The model runs should be quick because there is no optimising.

⇤--#: . Though there will be more data (private + public trips vs. only private) downloaded. Which might also cause memory problems, since the data is fairly large (4M rows). --Teemu R 10:12, 18 August 2011 (EEST) (type: truth; paradigms: science: attack)

Practical implementation: Teemu does as much of the model as he can; Sami finalises the work.

----#: . By the way, what should be the name for a new page considering the model described in these comments? Since we're no longer talking about composite traffic... Something like "Helsinki metropolitan area traffic model"? --Teemu R 14:50, 18 August 2011 (EEST) (type: truth; paradigms: science: comment)