This tool will help to compare video contents without having access to the files themselves.
In fact we will contact with a dataBase search engine called elasticserach helping us to locate all the relevant json streams describing
When you click the Knit HTML button a web page will be generated that includes both content as well as the output of any embedded R code chunks within the document. You can embed an R code chunk like this:
## Loading required package: RJSONIO
## Loading required package: RCurl
## Loading required package: bitops
## Loading required package: zoo
##
## Attaching package: 'zoo'
##
## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric
##
## Loading required package: pracma
## Loading required package: VideoComparison
You can also embed plots, for example:
#
extract_motion <- function(father, pos = 1, url = "http://localhost:9200/inteco2/inteco2/_search") {
str <- fromJSON("\n {\n \"facets\": {},\n \"from\": 0,\n \"query\": {\n \"bool\": {\n \"must\": [\n {\n \"term\": {\n \"FileName\": \"_video.json\"\n }\n },\n {\n \"text\": {\n \"ev_father\": \"to_be_replaced\"\n }\n }\n ],\n \"must_not\": [],\n \"should\": []\n }\n },\n \"size\": 50,\n \"sort\": []\n }\n ")
nm <- names(str$query$bool$must[[2]]$text)
str$query$bool$must[[2]]$text <- father
names(str$query$bool$must[[2]]$text) <- nm
res2 <- fromJSON(getURL(url, customrequest = "GET", httpheader = c(`Content-Type` = "application/json"),
postfields = toJSON(str)))
if (res2$hits$total == 1) {
kk <- res2$hits$hits[[1]]$`_source`$video_hash$frames
return(as.numeric(unlist(lapply(kk, function(x) {
return(x[1])
}))))
} else {
return(NULL)
}
}
# Extract frames where images were taken out
extract_imgpos <- function(father, url = "http://localhost:9200/inteco2/inteco2/_search") {
str <- fromJSON("\n {\n \"facets\": {},\n \"from\": 0,\n \"query\": {\n \"bool\": {\n \"must\": [\n {\n \"text\": {\n \"ev_father\": \"to_be_replaced\"\n }\n }\n ],\n \"must_not\": [\n {\n \"term\": {\n \"FileName\": \"_video.json\"\n }\n }\n ],\n \"should\": []\n }\n },\n \"size\": 50,\n \"sort\": []\n }\n ")
nm <- names(str$query$bool$must[[1]]$text)
str$query$bool$must[[1]]$text <- father
names(str$query$bool$must[[1]]$text) <- nm
res2 <- fromJSON(getURL(url, customrequest = "GET", httpheader = c(`Content-Type` = "application/json"),
postfields = toJSON(str)))
if (res2$hits$total > 0) {
out <- unlist(lapply(res2$hits$hits, function(x) {
return(x$`_source`$FileName)
}))
return(unique(sort(unlist(lapply(strsplit(out, "[-_]"), function(x) {
return(x[3])
})))))
} else {
return(NULL)
}
}
# Extract hashes from one specific frame where images were taken out
extract_imghash <- function(father, pos, url = "http://localhost:9200/inteco2/inteco2/_search") {
str <- fromJSON("\n {\n \"facets\": {},\n \"from\": 0,\n \"query\": {\n \"bool\": {\n \"must\": [\n {\n \"text\": {\n \"ev_father\": \"to_be_replaced\"\n } \n },\n {\n \"query_string\": {\n \"default_field\": \"FileName\",\n \"query\": \"to_be_replaced\"\n } \n } \n ],\n \"must_not\": [\n {\n \"term\": {\n \"FileName\": \"_video.json\"\n }\n }\n ],\n \"should\": []\n }\n },\n \"size\": 50,\n \"sort\": []\n }\n ")
nm <- names(str$query$bool$must[[1]]$text)
str$query$bool$must[[1]]$text <- father
names(str$query$bool$must[[1]]$text) <- nm
nm <- names(str$query$bool$must[[2]]$query_string[2])
str$query$bool$must[[2]]$query_string[2] <- paste("*", pos, "_out*", sep = "")
names(str$query$bool$must[[2]]$query_string[2]) <- nm
res2 <- fromJSON(getURL(url, customrequest = "GET", httpheader = c(`Content-Type` = "application/json"),
postfields = toJSON(str)))
if (res2$hits$total == 1) {
out <- res2$hits$hits[[1]]$`_source`$Hash
rt <- list(dct = as.character(out[1]), hstrada = as.numeric(unlist(strsplit(out[2],
","))), mw = as.numeric(unlist(strsplit(out[3], ","))), rd = as.numeric(unlist(strsplit(out[4],
","))))
return(rt)
} else {
return(NULL)
}
}
#
VideoSearch <- function(url = "http://localhost:9200/inteco2/inteco2/_search") {
str <- fromJSON("\n {\n \"facets\": {},\n \"from\": 0,\n \"query\": {\n \"bool\": {\n \"must\": [\n {\n \"term\": {\n \"FileName\": \"_video.json\"\n }\n }\n ],\n \"must_not\": [],\n \"should\": []\n }\n },\n \"size\": 500,\n \"sort\": []\n }\n ")
res2 <- fromJSON(getURL(url, customrequest = "GET", httpheader = c(`Content-Type` = "application/json"),
postfields = toJSON(str)))
vnam <- NULL
if (res2$hits$total > 0) {
vnam <- sort(unlist(lapply(res2$hits$hits, function(x) {
return(x$`_source`$ev_father)
})))
}
return(vnam)
}
#
aux1 <- function(x, j) {
return(x[j])
}
#
VideoVectorSearch <- function(x, l2) {
rs <- lapply(l2, VideoDistance, x)
ev <- matrix(0, nrow = 4, ncol = length(l2))
ul <- unlist(lapply(rs, aux1, 1))
ev[1, ] <- ul/max(ul)
ul <- unlist(lapply(rs, aux1, 2))
ev[2, ] <- ul/max(ul)
ul <- unlist(lapply(rs, aux1, 3))
ev[3, ] <- ul/max(ul)
ul <- unlist(lapply(rs, aux1, 4))
ev[4, ] <- 1 - ul/max(ul)
mev <- apply(ev, 2, sum)/4
j <- which(mev == min(mev))
return(list(idx = j, err = mev[j]))
}
#
VideoMatch <- function(lh1, lh2, sc) {
if (!is.list(lh1) | !is.list(lh2))
return(NULL)
if (length(lh1) > length(lh2)) {
l1 <- lh1
l2 <- lh2
pos <- 0
} else {
l1 <- lh2
l2 <- lh1
pos <- 1
}
rs <- lapply(l1, VideoVectorSearch, l2)
unord <- unlist(lapply(rs, function(x) {
return(x$idx)
}))
unerr <- unlist(lapply(rs, function(x) {
return(x$err)
}))
names(unerr) <- 1:length(unerr)
vl <- tapply(unerr, unord, function(x) {
return(names(which.min(x)))
})
unord <- sum(diff(as.numeric(vl)) < 0)
err <- mean(unerr[as.numeric(vl)])
fct <- sc
if (unord > 0)
fct <- fct * 0.5
return((1 - err) * fct)
}
#
intcurv <- function(x) {
gg <- function(l, y) {
return(sum(rollmean(y[1:l], 2)))
}
d1 <- diff(x, 1)
d3 <- c(d1[1], d1)
d31 <- diff(d3, 1)
crv <- c(d31, d31[length(d31)])
abcrv <- abs(crv)
cvint <- c(abcrv[1], apply(as.matrix(2:length(x)), 1, gg, abcrv) + abcrv[1])
return(list(crv = crv, crv_abs = abcrv, crv_int = cvint))
}
interpolate <- function(x, paso = 10, eps = 1e-04) {
gg <- function(x, eps) {
vx <- x
siz <- length(x)
for (i in 2:siz) {
if ((vx[i] - vx[i - 1]) < eps) {
vx[i] <- vx[i - 1] + eps
}
}
return(vx)
}
siz <- length(x)
res <- intcurv(x)
rsvint <- res[["crv_int"]]
rsv <- res[["crv"]]
vx <- gg(rsvint, eps)
vy <- 1:siz
xinterp <- linspace(vx[1], vx[siz], floor((vx[siz] - vx[1])/paso))
intk <- xinterp
ints <- approx(x = vx, y = vy, xout = xinterp, method = "linear")
crvk <- approx(x = vy, y = rsv, xout = ints$y, method = "linear")
return(list(k = crvk$y, s = ints$y, intk = intk))
}
# Match vurvature functions
part2part <- function(x, y, lmin = 100) {
# Correlation between x and y
calcor <- function(j, x, y) {
return(cor(x, y[j:(j + length(x) - 1)]))
}
# Look for correlation on specific positions of vector y described by idx
calvcor <- function(l, x, y, idx) {
xx <- x[1:l]
vc <- apply(as.matrix(idx), 1, calcor, xx, y)
mvc <- max(vc)
jvc <- which(vc == mvc)
return(list(cmax = mvc, cpos = jvc, lpos = l))
}
# Determine the correlation of x[p1:l]
calycor <- function(l, x, y, p1, p2) {
xx <- x[p1:l]
lg <- l - p1 + 1
return(calcor(p2, xx, y))
}
# Determine the moving correlation for x[1:l] over y
yvcor <- function(l, x, y) {
xx <- x[1:l]
vc <- apply(as.matrix(1:(length(y) - l + 1)), 1, calcor, xx, y)
jvc <- which(vc > 0.75)
return(jvc)
}
# Determine the correlation * length of segment maximum which represents the
# best matching relationship
incremental <- function(i, x, y, lngth, rr) {
p1 <- rr[[i]]$pos1
p2 <- rr[[i]]$pos2
siz <- length(x)
res <- apply(as.matrix((lngth + p1):siz), 1, calycor, x, y, p1, p2)
vv <- c(rr[[i]]$cmax, res) * ((lngth + p1 - 1):siz)
mrs <- max(vv)
jrs <- which(vv == mrs) - 1 + lngth + p1 - 1
return(list(cmax = mrs/jrs, pos1 = p1, pos2 = p2, lngth = jrs))
}
# Looks for the correlation for moving window of size lngth over x
looking <- function(i, x, y, idx, lngth) {
rs <- calvcor(lngth, x[i:(i + lngth - 1)], y, idx)
return(list(cmax = rs$cmax, pos2 = idx[rs$cpos], pos1 = i, lngth = lngth))
}
# Start the analysis by determining who is aguja and pajar
aguja <- x
pajar <- y
nominal <- TRUE
if (length(x) > length(y)) {
nominal <- FALSE
aguja <- y
pajar <- x
}
#
siz <- length(aguja)
lll <- floor(min(lmin, siz))
# buscamos candidatos
idx <- yvcor(lll, aguja, pajar)
# Look for candidate places on Y where higher correlation are retained.
rs <- apply(as.matrix(1:(siz - lll + 1)), 1, looking, aguja, pajar, idx,
lll)
vrs <- unlist(lapply(rs, function(x) {
return(x$cmax)
}))
ivc <- which(vrs > (summary(vrs)[5] + summary(vrs)[6])/2)
# starting from best matches with lmin. Explore coherence by extending x
# from lmin to siz and selecting the best one
res <- apply(as.matrix(ivc), 1, incremental, aguja, pajar, lll, rs)
vres <- unlist(lapply(res, function(x) {
return(x$cmax * x$lngth)
}))
mvres <- max(vres)
jvrs <- which(vres == mvres)
return(list(orderok = nominal, pos1 = res[[jvrs]]$pos1, pos2 = res[[jvrs]]$pos2,
cmax = res[[jvrs]]$cmax, lngth = res[[jvrs]]$lngth))
}
#
mm <- extract_motion("C0031D0")
imgs <- extract_imgpos("C0031D0")
hh <- extract_imghash("C0031D0", imgs[7])
# save(mm,imgs,hh,h2,file='tmp.RData') library(VideoComparison)
# lv<-VideoSearch() plot(ExtractMotion('C0041D0'),type='l')
# plot(ExtractMotion('C0036D0'),type='l') mm1<-ExtractMotion('C0041D0')
# mm2<-ExtractMotion('C0036D0') imm1<-interpolate(mm1,paso=10)
# imm2<-interpolate(mm2,paso=1)
# res2<-part2part(imm1$k,imm2$k,floor(0.75*min(length(imm1$k),length(imm2$k))))
# res2<-VideoComparison(mm2,mm1,10) img1<-ExtractImgPos('C0041D0')
# img2<-ExtractImgPos('C0036D0') idx2<-(as.numeric(img2)-res2$pos1 > 0 ) &
# (as.numeric(img2)-res2$pos1 < res2$lgth) idx1<-(as.numeric(img1)-res2$pos2
# > 0 ) & (as.numeric(img1)-res2$pos2 < res2$lgth) rimg1<-img1[idx1]
# rimg2<-img2[idx2] lh1<-apply(as.matrix(rimg1),1,ExtractImgHash,'C0041D0')
# lh2<-apply(as.matrix(rimg2),1,ExtractImgHash,'C0036D0')
# vm<-VideoMatch(lh2,lh1,res2$sc)
library(VideoComparison)
lv <- VideoSearch()
Compare2Videos("C0036D0", "C0041D0", 10, 1)
## $likelihood
## [1] 0.9159
##
## $msc
## [1] 0.9769
##
## $mp1
## [1] 1
##
## $mp2
## [1] 1238
##
## $lngth
## [1] 249