Нахождение ближайших подходящих точек

Question

Что я хотел бы сделать, так это чтобы красные точки нашли ближайшую эквивалентную синюю точку на другой стороне аблайна (т. Е. 1,5 найдите 5,1).

Данные:

https://1drv.ms/f/s!Asb7WztvacfOuesIq4evh0jjvejZ4Q

Редактировать: чтобы открыть данные, сделайте readRDS("path/to/data")

Итак, я попытался найти разницу между координатами x и y, ранжировать их, а затем найти минимальное значение, спускаясь по рангу как для x, так и для y. Результаты и довольно плохие. То, с чем я борюсь, - это найти способ найти ближайшее совпадение кортежей.

Моя попытка:

find_nearest <- function(query, subject){

  weight_df <- data.frame(ID=query$ID)
  #find difference of first, then second, rank and find match in both going from top to bottom
  tmp_df <- query

  for(i in 1:nrow(subject)){
    first_order <- order(abs(query$mean_score_n-subject$mean_score_n[i]))
    second_order <- order(abs(query$mean_score_p-subject$mean_score_p[i]))

    tmp_df$order_1[first_order] <- seq(1, nrow(tmp_df))
    tmp_df$order_2[second_order] <- seq(1, nrow(tmp_df))

    weight_df[,i+1] <- tmp_df$order_1 + tmp_df$order_2

  }
  rownames(weight_df) <- weight_df$ID
  weight_df$ID <- NULL

  print(dim(weight_df))

  nearest_match <- list()
  count <- 1
  subject_ids <- NA
  query_ids <- NA
  while(ncol(weight_df) > 0 & count <= ncol(weight_df)){
    pos <- which(weight_df == min(weight_df, na.rm = TRUE), arr.ind = TRUE)
    if(length(unique(rownames(pos))) > 1){
      for(i in nrow(pos)){
        #if subject/query already used then mask and find another
        if(subject$ID[pos[i,2]] %in% subject_ids){
          weight_df[pos[i,1],pos[i,2]] <- NA
        }else if(query$ID[pos[i,1]] %in% query_ids){
          weight_df[pos[i,1],pos[i,2]] <- NA 
        }else{
          subject_ids <- c(subject_ids, subject$ID[pos[i,2]])
          query_ids <- c(query_ids, query$ID[pos[i,1]])
          nearest_match[[count]] <- data.frame(query=query[pos[i,1],]$ID, subject=subject[pos[i,2],]$ID)
          #mask
          weight_df[pos[i,1],pos[i,2]] <- NA

          count <- count + 1
        }
      }
    }else if(nrow(pos) > 1){
      #if subject/query already used then mask and find another
      if(subject$ID[pos[1,2]] %in% subject_ids){
        weight_df[pos[1,1],pos[1,2]] <- NA
      }else if(query$ID[pos[1,1]] %in% query_ids){
        weight_df[pos[1,1],pos[1,2]] <- NA 
      }else{
        subject_ids <- c(subject_ids, subject$ID[pos[1,1]])
        query_ids <- c(query_ids, query$ID[pos[1,1]])
        nearest_match[[count]] <- data.frame(query=query[pos[1,1],]$ID, subject=subject[pos[1,2],]$ID)
        #mask
        weight_df[pos[1,1],pos[1,2]] <- NA

        count <- count + 1
      }
    }else{
      #if subject/query already used then mask and find another
      if(subject$ID[pos[2]] %in% subject_ids){
        weight_df[pos[1],pos[2]] <- NA
      }else if(query$ID[pos[1]] %in% query_ids){
        weight_df[pos[1],pos[2]] <- NA 
      }else{
        subject_ids <- c(subject_ids, subject$ID[pos[2]])
        query_ids <- c(query_ids, query$ID[pos[1]])
        nearest_match[[count]] <- data.frame(query=query[pos[1],]$ID, subject=subject[pos[2],]$ID)
        #mask
        weight_df[pos[1],pos[2]] <- NA

        count <- count + 1
      }
    }
  }

  out <- plyr::ldply(nearest_match, rbind)

  out <- merge(out, data.frame(subject=subject$ID, 
                                 mean_score_p_n=subject$mean_score_p, 
                                 mean_score_n_n= subject$mean_score_n), by="subject", all.x=TRUE)

  out <- merge(out, data.frame(query=query$ID, 
                                 mean_score_p_p=query$mean_score_p, 
                                 mean_score_n_p= query$mean_score_n), by="query", all.x=TRUE)


  return(out)

}

Редактировать: это то, что решение выглядит для вас?

ggplot() +
  geom_point(data=B[out,], aes(x=mean_score_p, y= mean_score_n, color="red")) +
  geom_point(data=A, aes(x=mean_score_p, y=mean_score_n, color="blue")) +
  geom_abline(intercept = 0, slope = 1)

Answer 1

Пусть

query <- readRDS("query.dms")
subject <- readRDS("subject.dms")
kA <- nrow(subject)
kB <- nrow(query)
A <- as.matrix(subject[, 2:3])
B <- as.matrix(query[, 2:3])

, где мы хотим найти ближайшую "обратную" точку (строку) в B к каждой точке в A.

Решение, допускающее неуникальные результаты

Затем, если вы используете евклидово расстояние,

D <- as.matrix(dist(rbind(A, B[, 2:1])))[(1 + kA):(kA + kB), 1:kA]
unname(apply(D, 2, which.min))
#  [1] 268 183 350 284  21 360 132 287 100 298  58  56 170  70  47 305 353
# [18]  43 266 198  58 215 198 389 412 321 255 181  79 340 292 268 198  54
# [35] 390  38 376  47  19  94 244  18 168 201 160 194 114 247 287 273 182
# [52]  87  94  87 192  63 160 244 101 298  62

- соответствующие номера строк вB.Хитрость заключалась в том, чтобы переключать координаты точек в B, используя B[, 2:1].

Решение с уникальными результатами

out <- vector("numeric", length = kA)
colnames(D) <- 1:ncol(D)
rownames(D) <- 1:nrow(D)
while(any(out == 0))
  for(i in 1:nrow(D)) {
    aux <- apply(D, 2, which.min)
    if(i %in% aux) {
      win <- which(aux == i)[which.min(D[i, aux == i])]
      out[as.numeric(names(win))] <- as.numeric(rownames(D)[i])
      D <- D[-i, -win, drop = FALSE]
    }
  }
out
#  [1] 268 183 350 284  21 360 132 213 100 298  22  56 170  70 128 305 353
# [18]  43 266 198  58 215 294 389 412 321 255 181  79 340 292  20 347  54
# [35] 390  38 376  47  19  94  73  18 168 201 160 194 114 247 287 273 182
# [52]  87 365 158 192  63 211 244 101  68  62

, тогда как

all(table(res) == 1)
# [1] TRUE

подтверждает уникальность.Решение не самое эффективное, но для вашего набора данных это займет всего пару секунд.Это занимает некоторое время, потому что он продолжает проходить все доступные точки в B, проверяя, является ли он ближайшим к любой из точек в A.Если это так, соответствующая точка в B назначается ближайшей точке в A.Тогда и точка в A, и точка в B удаляются из матрицы расстояний.Цикл продолжается до тех пор, пока каждая точка в A не найдет совпадения в B.