Изменить: реальный набор данных доступен здесь
С благодарностью
Ван, Руи, Фанглин Чен, Чжэньюй Чен, Тяньсин Ли, Габриэлла Харари, Стефани Тигнор, Ся Чжоу, Дрор Бен-Зеев и Эндрю Т. Кэмпбелл. StudentLife: оценка психического здоровья, успеваемости и поведенческих тенденций студентов колледжей, использующих смартфоны. В материалах конференции ACM по вездесущим вычислениям. 2014.
Объяснение
Я запускаю исследование моделирования, в котором я выполняю обнаружение остановки по данным о местоположении (координаты широты и долготы) на основе относительно простых критериев.
Место (A) является остановкой, если существует другое место (B) с отметкой времени не менее 180 секунд после A, и если все места между A и B включительно имеют расстояние от A меньше или равное 80 метрам.
Я попытался уменьшить данные, чтобы они все еще работали, но не требовали фактических координат.
data <- data.table(id = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10),
latlon = c(0, 50, 80, 90, 90, 100, 190, 110, 110, 110),
time = c(0, 60, 120, 180, 240, 300, 360, 420, 480, 520))
id 1 не является остановкой, потому что первое местоположение с разницей во времени › 180 (id 5) имеет расстояние в латлоне 90.
id 2 является остановкой, так как все локации между ней и первой локацией с разницей во времени › 180 (id 6) имеют расстояние меньше 80 (0, 30, 40, 40, 50).
id 6 не является остановкой, потому что, хотя id 10 составляет › 180 разницу во времени, id 7, которая находится между ними, имеет расстояние больше 80.
id 8 не является остановкой, потому что по прошествии как минимум 180 секунд после этого нет места.
В конечном счете, мне нужно иметь возможность жадно назначать идентификатор остановки, например, если я обнаружу, что id 2 имеет точки, которые удовлетворяют требованию расстояния до id 7, места с идентификаторами 2: 7 имеют идентификатор остановки 2.
Матрица и цикл for
Если я запускаю это:
nrows <- nrow(data)
latlon_dist <- outer(data$latlon, data$latlon, `-`)
latlon_dist[upper.tri(latlon_dist)] <- NA
time_window <- outer(data$time, data$time, `-`)
time_window[upper.tri(time_window)] <- NA
foo <- function(x){
mindist <- min(which(x[, 1] > 80), nrows)
if (mindist >= min(which(x[, 2] > 180), nrows + 1)) mindist else NA
}
bar <- array(c(latlon_dist, time_window),
dim = c(nrows, nrows, 2))
apply(bar, 2, foo)
Он возвращает мне пороговые значения > NA 7 7 NA NA NA NA NA NA NA, которые я могу использовать в цикле for, чтобы установить соответствующий идентификатор остановки.
threshholds <- apply(bar, 2, foo) - 1
previous_threshhold <- 0
for (i in seq_along(threshholds)) {
current_threshhold <- threshholds[i]
if (!is.na(current_threshhold) && current_threshhold > previous_threshhold) {
data[i:current_threshhold, stop_id := i]
previous_threshhold <- current_threshhold
}
}
На данный момент это единственный способ гарантировать точность. Все остальное, что я пробовал, я считал правильным, только чтобы обнаружить, что это не идентично этой ситуации. Но это, как вы можете себе представить, ужасно неэффективно, и в моем исследовании моделирования оно запускалось 116 000 раз.
Мое предположение состоит в том, что лучший способ справиться с этим — неэквивалентное соединение в data.table.
Другая реализация, которую я сейчас использую, работает лучше, когда количество строк в наборе данных делает массив слишком тяжелым для памяти. Я не буду переводить это для работы с данными, но оно здесь на случай, если оно даст кому-то идеи. Я застрял в цикле while, чтобы он мог пропускать некоторые итерации, когда он уже присвоил stop_id ряду точек. Если все точки 1:7 принадлежат stop_id 1, они сами не считаются остановками-кандидатами, мы просто снова переходим к тестированию в точке 8. Технически это возвращает другое решение, но остановки, которые достаточно близки, объединяются позже в этом процессе. , так что конечный результат вряд ли будет сильно отличаться.
Для цикла, без матрицы
stopFinder <- function(dt){
nrows <- nrow(dt)
if (nrows < 20000){
return(quickStopFinder(dt))
}
i <- 1
remove_indices <- 0
while (i < nrows) {
this_ends <- dt[!remove_indices,
Position(
geodist_vec(rep(longitude[1], .N),
rep(latitude[1], .N),
longitude,
latitude,
paired = TRUE),
f = function(x) x > 80,
nomatch = .N + 1) ] + i - 1
# A) Do some number of points occur within the distance?
# B) If so, is it at least three minutes out?
if (this_ends > (i + 1) && dt[c(i, (this_ends - 1)), timestamp[.N] > time_window[1]]) {
# Last index is the one before the distance is broken
last_index_of_stop <- this_ends - 1
# Next run, we will remove all prior considerations
remove_indices <- c(1:last_index_of_stop)
# Set the point itself
dt[i,
`:=`(candidate_stop = TRUE,
stop_id = id,
within_stop = TRUE)]
# Set the attached points
dt[(i + 1):last_index_of_stop,
`:=`(within_stop = TRUE,
stop_id = i)]
# Start iterating again on the point that broke the distance
i <- this_ends
} else {
# If no stop, move on and leave out this point
remove_indices <- c(1:i)
i <- i + 1
}
}
dt[]
}
quickStopFinder более или менее является реализацией, о которой я рассказал в начале, которая интенсивно использует память и работает медленно, но немного менее медленно, чем stopFinder.
Раньше у меня было что-то подобное в качестве основы, но это требовало множества последующих шагов и не всегда давало мне те результаты, которые я искал, но я добавлю это для потомков.
res <- dt[dt,
on = .(timestamp >= timestamp_dup,
timestamp <= time_window)]
res[, dist := geodist_vec(x1 = longitude,
y1 = latitude,
x2 = i.longitude,
y2 = i.latitude,
paired = TRUE,
measure = "haversine")]
res[, candidate_stop := all(dist <= 80), i.id]
Новое с реальными данными
Изменить с примером из реальных данных:
Это обрабатывает ситуацию с соединениями, но становится слишком большим слишком быстро. Это быстро, когда данных мало.
sm2 <- read.csv(file = "http://daniellemc.cool/sm.csv", row.names = NULL)
sm <- copy(sm2)
setDT(sm)
sm <- sm[, .(timestamp, longitude, latitude, id)]
sm[, timestamp := as.POSIXct(timestamp)]
sm[, id2 := id]
# This is problematic on my data because of how quickly it grows.
test <- sm[sm, on = .(id >= id)]
test[, i.id2 := NULL]
setnames(test, c("time.2", "longitude.2", "latitude.2", "id.1",
"id.2", "time.1", "longitude.1", "latitude.1"))
# Time and distance differences calculated between each pair
test[, distdiff := geodist_vec(longitude.1, latitude.1,
longitude.2, latitude.2,
paired = TRUE)]
test[, timediff := time.2 - time.1]
# Include the next distance to make sure there's at least one within distance and
# over 180 timediff.
test[, nextdistdiff := shift(distdiff, -1), id.1]
# Are all distances within 180 sec within 80, and is the next following also < 80
test[, dist_met := FALSE]
test[timediff < 180, dist_met := all(distdiff < 80 & nextdistdiff < 80), id.1]
test[, dist_met := any(dist_met), id.1]
# Test how many occur consecutively
# This keeps us from having > 80 dist but then coming back within 80
test[, consecutive := FALSE]
test[distdiff < 80, consecutive := c(TRUE, cummin(diff(id.2) == 1) == 1), id.1]
test[consecutive == TRUE & dist_met == TRUE, stop_id := min(id.1), id.2]
test[test[consecutive == TRUE & dist_met == TRUE], stop_id := i.stop_id, on = .(id.1 = id.2)]
test <- unique(test[, .(stop_id, id.1)])
# Join it back to the data.
sm[test, stop_id := stop_id, on = .(id = id.1)]
