Difference between revisions of "Composite traffic model"

# 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)

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)

for (i in 1:(length(times) - 2)) {
	if(i == 1) {
		trips.sample.1 <- op_baseGetData("opasnet_base", "Op_en2625", include = trips.locs$loc_id[trips.locs$ind == "Time" & 
			trips.locs$loc == 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 <- op_baseGetData("opasnet_base", "Op_en2625", include = trips.locs$loc_id[trips.locs$ind == "Time" & 
		trips.locs$loc == 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))
}