Как оптимизировать мой код для запуска на Windows 2012 Server

Question

Мой код работает очень медленно на моем ноутбуке, и у меня есть доступ к Windows 2012 Server x64 с оперативной памятью 256 ГБ.

У меня настроен сервер под управлением R, и этот код работает, но 48 часов = 25%

Из того, что я узнал, это связано только с использованием одного ядра.

В настоящее время я изучаю цикл foreach, но медленно зацикливаюсь

library("sp")
library("rgeos")
library("geosphere")
library("gdistance")

# Data
dna <- data.frame(cbind(rnorm(400) * 2 + 13, rnorm(400) + 48))
dna$ID <- seq.int(nrow(dna))

match <- data.frame(cbind(rnorm(4000) * 2 + 13, rnorm(4000) + 48))
match$ID <- seq.int(nrow(match))

##Set row id 
RID2 <- 1

#create output table 
tablelength <- print (nrow(dna))

match1 = data.frame( UPRN=rep(0, tablelength), Long=rep(0,tablelength), Lats=rep(0,tablelength),   MatchID=rep(0,tablelength) , Longm=rep(0,tablelength), Latsm=rep(0,tablelength), distance=rep(0,tablelength))

#start loop
for(RID2 in dna[,3]) {

  #Set UPRN and Exchange Name
  Name <- paste(dna[RID2,3])

  set1 <- data.frame(dna[RID2,1:2])
  set2 <- data.frame(match[,1:2])

  set1sp <- SpatialPoints(set2)
  set2sp <- SpatialPoints(set1)

  set1$ID <- apply(gDistance(set1sp, set2sp, byid=TRUE), 1, which.min)
  ID <- paste(apply(gDistance(set1sp, set2sp, byid=TRUE), 1, which.min))

  #insert Row
  match1[RID2, ] = c(Name, set1[,1], set1[,2], paste(match[ID,3]), set2[ID,1], set2[ID,2],     distVincentyEllipsoid(c(set1[,1], set1[,2]), c(set2[ID,1], set2[ID,2]), a=6378137, b=6356752.3142, f=1/298.257223563))

  remove(set1,set2,set1sp,set2sp)
}

Вывод - это то, что я ищу, но в идеале с продолжительностью менее 1 дня (в настоящее время 8)

Answer 1

Вы уже можете получить хороший прирост скорости, просто оптимизировав код и удалив лишние части. Например, это более или менее в два раза быстрее на тестовых данных и легко распараллеливается.

library("sp")
library("rgeos")
library("geosphere")
library("gdistance")

# Data
dna <- data.frame(cbind(rnorm(400) * 2 + 13, rnorm(400) + 48))
dna$ID <- seq.int(nrow(dna))

match <- data.frame(cbind(rnorm(40000) * 2 + 13, rnorm(40000) + 48))
match$ID <- seq.int(nrow(match))

##Set row id 
RID2 <- 1

#create output table 
tablelength <- nrow(dna)
matchlist <- list()
set2 <- match[,1:2]
set1sp <- SpatialPoints(set2)
for(RID2 in dna[,3]) {
  set1 <- dna[RID2,1:2]
  set2sp <- SpatialPoints(set1)
  ID <- which.min(gDistance(set1sp, set2sp, byid=TRUE))
  #insert Row
  matchlist[[RID2]] = data.frame(UPRN = dna[RID2,3], 
                                 Long = set1[,1], 
                                 Lats = set1[,2], 
                                 matchid = match[ID,3], 
                                 Longm = set2[ID,1],
                                 Latsm = set2[ID,1], 
                                 distance = distVincentyEllipsoid(set1, set2[ID,],
                                                                  a=6378137, b=6356752.3142, f=1/298.257223563))
}
match1 <- data.table::rbindlist(matchlist)

Answer 2

спасибо всем за ваш вклад, я буду читать различные стили для дальнейшего изучения R *. 1001 *

Я использовал решение, опубликованное в ветке reddit, которую я также сделал в то же время.

require(foreach)
require(doParallel)

cl <- makeCluster(4)
registerDoParallel(cl)
temp <- foreach(I = 1:nrow(dna),.combine = "c", .packages = c("rgeos","sp"))     %dopar% {
    return(c(which.min(
        gDistance(
        SpatialPoints(data.frame(dna[I,1:2]))
        , SpatialPoints(data.frame(match[,1:2]))
        , byid=TRUE
        ))))
}

https://old.reddit.com/r/rstats/comments/aebamb/how_do_i_use_all_the_cores_on_a_server_to_match/

Еще раз спасибо за помощь: -D

Answer 3

Это работает для меня и сокращает время расчета (по вашим данным выборки) на моей машине вдвое.

set.seed(123)
# Data
dna <- data.frame(cbind(rnorm(400) * 2 + 13, rnorm(400) + 48))
dna$ID <- seq.int(nrow(dna))

match <- data.frame(cbind(rnorm(4000) * 2 + 13, rnorm(4000) + 48))
match$ID <- seq.int(nrow(match))

###
library( sf )
library( data.table )
dna.sf <- st_as_sf( x = dna, 
                    coords = c( "X1", "X2"), 
                    crs = "+proj=longlat +datum=WGS84" )

match.sf <- st_as_sf( x = match, 
                      coords = c( "X1", "X2"), 
                      crs = "+proj=longlat +datum=WGS84" )

#create data.tables
setDT(dna)
setDT(match)
#add suffixes to identify columns later (after join)
setnames(dna, names(dna), paste0(names(dna),".dna"))
setnames(match, names(match), paste0(names(match),".match"))

#create distance matrix
m <- round( st_distance( dna.sf, match.sf ), digits = 0 )
colnames( m ) <- match.sf$ID
rownames( m ) <- dna.sf$ID
#get colname of min to nearest (remember, colname = match-ID ;-) )
dna$nearest <- apply( m, 1, which.min )
#get the min distance
dna$dist <- apply( m, 1, min )
#now left-join to get the coordinates of match, use data.table for speed
library( data.table )
result <- match[dna, on = c("ID.match==nearest") ]

Результаты выглядят такими же, как и при использовании вашего «старого» метода, но время расчета примерно сокращается вдвое (7,5 -> 4 секунды)