July 3rd, 2014

Исходные коды инструмента широкоформатного скрининга для знакомств

Дисклеймер: это самодельный инструмент использования BASH, открытого API и анализа данных в R.

Подробная постановка задачи была описана здесь, потому не буду расписывать её. Принцип скрининга заключается в наборе сырых данных из базовых сведений пользователей сети Vk, принадлежащих каким-либо группам, последовательной фильтрации пользователей по ряду параметров и получению дополнительной информации уже для отсеянных пользователей.
Блок набора данных: bash скрипт, выполняющий собственно скачивание сырых данных с серверов Vk, для работы нужен список названий целевых групп и токен (как получить токен и вообще как пользоваться API Vk я не буду расписывать), скрипт работает в связке с блоком анализа, исходный код приведён ниже


#!/bin/bash

targets=$1
outPrefix='vkDB-'
token=$2 ###

for group in $targets
do
 echo ' Group: ' $group
 wget 'https://api.vk.com/method/groups.getById.xml?group_id='$group'&fields=members_count' -O ~/$group.txt -o /dev/null
 string=`grep -P -o 'members_count>\d+' ~/$group.txt`
 string=${string/members_count>/}
 echo ' members: ' $string
 rm ~/$group.txt
 step=`echo $string' / 1000 ' | bc`
 echo $step
 for count in `seq 0 $step`
 do
  wget 'https://api.vk.com/method/groups.getMembers.xml?group_id='$group'&offset='$count'000&fields=sex,bdate,city,country,education,last_seen,relation,photo_max_orig&access_token='$token -O $outPrefix$count-$group'.txt'
 done
done




Блок анализа данных: R-скрипт с парсингом XML, последовательной фильтрацией, дополнительными запросами и выводом итоговых данных, через него ведётся управление блоком набора данных. Исходный код с примером использования приведён ниже


# набор целевых групп - возьмём тех, кто слушает Dream Theater и смотрит "Doctor Who"
# Нет, это не значит что это мои интересы, это взято только для примера
target <- c('dreamtheater', 'bbcdoctorwho')
targets <- paste0(target, collapse = ' ')
token <- 'не_покажу_свой_токен'
 
# Запуск!
system(paste0('bash vkAutoSearch.bash \'', targets, '\' ', token))
 
# выбор режима - "все группы вместе" или "любая группа"
mode <- 'AND' # может быть 'AND' или 'OR'
 
# парсинг сырых XML-данных
usersdata <- list()
for (group in target) {
  usersdata[[group]] <- data.frame()
  print(paste('parsing group:', group))
  for (filename in list.files(pattern = paste0('*-', group, '.txt'))) {
    xmldata <- xmlParse(filename)
    print(paste("  parsing", filename))
    tmp <- xmlToDataFrame(nodes = xmlChildren(xmlRoot(xmldata)[['users']]))
    usersdata[[group]] <- merge(usersdata[[group]], tmp, all=T)
  }
}
# сколько из какой группы получилось? - dreamtheater 12220, bbcdoctorwho 152115
sapply(usersdata, nrow)
 
# слияние данных по группам и классификация
vkdata <- data.frame()
for (group in names(usersdata)) {
  category <- as.vector(rep(group, nrow(usersdata[[group]])))
  if (nrow(vkdata) == 0) {
    vkdata <- cbind(usersdata[[group]], category)
  } else {
    vkdata <- rbind(vkdata, cbind(usersdata[[group]], category))
  }
}
 
Как выглядят данные? А вот так:
          uid first_name   last_name sex      bdate    city country                                        photo_max_orig   last_seen university_name
52   10136310     Kirill    Podlesny   2       18.9       2       1 http://cs410425.vk.me/v410425310/7cee/dDNssSWFLR0.jpg 14042973657            <NA>
171  10382020        Yar       Gusev   2 18.11.1992     154       1 http://cs617131.vk.me/v617131020/ec80/Ay-CsrF72c0.jpg 14043273917           ЮГУ\n
311 107027838    Bozhena Vintskovska   1       <NA> 1951986      65 http://cs410220.vk.me/v410220838/8dbe/VXu7axMWZUE.jpg 14043270837            <NA>
                                                            faculty_name graduation relation relation_partner deactivated
52                                                                  <NA>       <NA>     <NA>             <NA>        <NA>
171 Институт (НОЦ) управления и информационных технологий (бывш. ИПМИиУ)          0        1             <NA>        <NA>
311                                                                 <NA>       <NA>     <NA>             <NA>        <NA>

# применение выбранного режима отбора по принадлежности к группам
if (mode == 'AND') {
  targetUID <- names(table(vkdata$uid)[table(vkdata$uid) == length(levels(vkdata$category))])
  if (length(targetUID) == 0) {
    print('ALARM! empty groups intersection!')
  } else {
    # удаление дубликатов UID
    vkdata <- vkdata[!duplicated(vkdata$uid),]
    # выбрать именно повторяющиеся UID
    vkdata <-  vkdata[vkdata$uid %in% targetUID,]
    # удалить бесполезную при таком методе колонку "category"
    vkdata <-  vkdata[,!colnames(vkdata) == 'category']
  }
}
# сколько осталось? - 205
nrow(vkdata)
 
# удалить бесполезные колонки: type, university, faculty, education_form, education_status
vkdata <- vkdata[,!(colnames(vkdata) %in% c('type', 'university', 'faculty', 'education_form', 'education_status'))]
 
# первичная фильтрация
selected <- vkdata[vkdata$sex == 1,] # оставить только женский пол
selected <- selected[,!colnames(selected) == 'sex'] # убрать ненужную уже колонку про пол
selected <- selected[is.na(selected$deactivated),] # выбрать не забаненных и не заблокированных
selected <- selected[,!colnames(selected) == 'deactivated'] # удалить колонку 'deactivated'
 
# выбрать "single", "actively searching" и "it's complicated"* по статусу отношений
# 1 – single
# 2 – in a relationship
# 3 – engaged
# 4 – married
# 5 – it's complicated
# 6 – actively searching
# 7 – in love
# удалить тип 2, 3, 4, 7
selected <- selected[!selected$relation %in% c(2,3,4,7),]
selected <- selected[is.na(selected$relation_partner),] # удалить тех, у кого есть тот, с кем сложно
selected <- selected[,!colnames(selected) == 'relation_partner'] # удалить колонку 'relation_partner'
# удаление неактивных пользователей
removeLast <- function(x) { substr(x, 1, nchar(x)-1) } # создать функциб для отрезания номера платформы от даты last_seen
selected$last_seen <- removeLast(selected$last_seen) # удалить номер платформы от last_seen
selected$last_seen <- as.numeric(selected$last_seen) # преобразовать last_seen UNIX-time в число
selected <- selected[difftime(Sys.time(), as.POSIXct(selected$last_seen, origin='1970-01-01'), units='d') < 10,] # удалить неактивных в течении 10 дней
# отсечение по возрасту
selected$bdate <- as.character(as.Date(selected[,'bdate'], format='%d.%m.%Y')) # преобразование содержимого поля в даты
subselected <- selected[!is.na(selected$bdate),] # разбить по определённой величине bdate
selected <- selected[is.na(selected$bdate),] # ...и неопределённой
subselected <- subselected[difftime(Sys.Date(), as.Date(subselected[,'bdate'], format='%Y-%m-%d'), units='d')/365 > 20,] # удалить моложе чем 20 лет если возраст не NA
subselected <- subselected[difftime(Sys.Date(), as.Date(subselected[,'bdate'], format='%Y-%m-%d'), units='d')/365 < 25,] # удалить старше чем 25 лет если возраст не NA
selected <- rbind(subselected, selected) # склеить обратно в целый датафрейм
# итого - 43
nrow(selected)
 
# получение стран из базы данных Vk
countries <- levels(as.factor(selected$country))
download.file(paste0('https://api.vk.com/method/database.getCountriesById.xml?country_ids=', paste(countries, collapse=',')), destfile='db/countries.txt', method='wget')
xmldata <- xmlParse('db/countries.txt')
countidb <- xmlToDataFrame(nodes = xmlChildren(xmlRoot(xmldata)))
# замещение индексных номеров стран на нормальные названия
for (country in levels(countidb$cid) ) {
  selected[selected$country == country, 'country'] <- rep(x=as.character(countidb[countidb$cid == country, 'name']), times=length(selected[selected$country == country, 'country']))
}
 
# получение городов из базы данных Vk
citydb <- data.frame()
cities <- levels(as.factor(selected$city))
for (k in 1:ceiling(length(cities)/500)) {
  tmp <- cities[(1 + (k-1) * 500):(k * 500)]
  download.file(paste0('https://api.vk.com/method/database.getCitiesById.xml?city_ids=', paste(tmp, collapse=',')), destfile=paste0('db/cities-', k, '-.txt'), method='wget')
  xmldata <- xmlParse(paste0('db/cities-', k, '-.txt'))
  tmp <- xmlToDataFrame(nodes = xmlChildren(xmlRoot(xmldata)))
  if (nrow(citydb) == 0) {
    citydb <- tmp
  } else {
    citydb <- rbind(citydb, tmp)
  }
}
# замена идентификаторов городов на нормальные названия
for (city in levels(citydb$cid) ) {
  selected[selected$city == city, 'city'] <- rep(x=as.character(citydb[citydb$cid == city, 'name']), times=length(selected[selected$city == city, 'city']))
}
 
# удалить символ "\n" из имён университетов и факультетов
selected$university_name <- gsub(pattern='\n', replacement='', selected$university_name, perl=T)
selected$faculty_name <- gsub(pattern='\n', replacement='', selected$faculty_name, perl=T)
 
### пакетная загрузка фотографий
# удалить тех, кто без фото
selected <- selected[!(selected$photo_max_orig == 'http://vk.com/images/camera_a.gif'),]
# последовательная загрузка фотографии типа 'photo_max_orig'
for (n in 1:nrow(selected)) {
    download.file(url=selected[n,'photo_max_orig'], destfile=paste0('~/INPUT/Photos/', selected[n,'uid'], '_', selected[n,'first_name'], '-', selected[n,'last_name'], '.jpg'), method='curl')
}
# вывод конечных результатов в табличный файл
write.table(file='HTS.tab', x=selected, sep='\t', row.names=F, col.names=T, quote=F)

Created by Pretty R at inside-R.org

Инструмент всё ещё в черновом состоянии, удобство не доработано и не все запланированные функции реализованы, но работоспособность полная. Важно то, что здесь почти нет отказа работать с разреженными данными - поскольку это реальные данные с кучей пропусков, неполноты и вранья, всегда присутствующими являются только два парамера: принадлежность пользователя к группе и последнее время активности, потому по остальным параметрам (кроме пола) фильтрация "либо нужное значение, либо NA". Также принцип отбора по интересам применим для поиска людей практически с любой целью, хотя степень автоматизации всё ещё невысока.