It is well known that 0 dependence implies 0 correlation, while 0 correlation does not imply 0 dependence. I have a paper here illustrating nonlinear correlation coefficients from relationship subsets of the joint distribution. I have another paper here demonstrating that dependence is the average absolute value of the subset correlation coefficients.
The following partial moment functions are needed for the correlation coefficient:
CLPM = function(n, x, y, target.x = mean(x), target.y = mean(y)){
output <- vector("numeric", length(x))
for (i in 1:length(x)){
if (x[i]<target.x & y[i]<target.y )
output[i]<- (((target.x-x[i])^n)*((target.y -y[i])^n))
}
clpm = (sum(output)/length(x))
return(clpm)
}
CUPM = function(n, x, y, target.x = mean(x), target.y = mean(y)){
output <- vector("numeric", length(x))
for (i in 1:length(x)){
if (x[i]>target.x & y[i]>target.y)
output[i]<- (((x[i]-target.x)^n)*((y[i]-target.y)^n))
}
cupm = (sum(output)/length(x))
return(cupm)
}
DLPM = function(n, x, y, target.x = mean(x), target.y = mean(y)){
output <- vector("numeric", length(x))
for (i in 1:length(x)){
if (x[i]>target.x & y[i]<target.y)
output[i]<- (((x[i]-target.x)^n)*((target.y-y[i])^n))
}
dlpm = (sum(output)/length(x))
return(dlpm)
}
DUPM = function(n, x, y, target.x = mean(x), target.y = mean(y)){
output <- vector("numeric", length(x))
for (i in 1:length(x)){
if (x[i]<target.x & y[i]>target.y)
output[i]<- (((target.x-x[i])^n)*((y[i]-target.y)^n))
}
dupm = (sum(output)/length(x))
return(dupm)
}
And the subsetting function:
partition_map = function(x, y,order= ceiling(log10(length(x))), degree=1){
temp_df = data.frame(x=x, y=y)
temp_df[,'temp_part'] = 'p'
temp_df[,'master_part'] = 'p'
if(order==1){return("Please Increase the Order Specification")}
if(order >1){
for(i in 1:(order-1)){
for(item in unique(temp_df$master_part)){
tmp_xbar = mean(temp_df[temp_df$master_part == item,'x'])
tmp_ybar = mean(temp_df[temp_df$master_part == item, 'y'])
temp_df[temp_df$x >= tmp_xbar & temp_df$y >= tmp_ybar & temp_df$master_part == item,'temp_part'] = paste(temp_df[temp_df$x >= tmp_xbar & temp_df$y >= tmp_ybar & temp_df$master_part == item,'master_part'], 0, sep = '')
temp_df[temp_df$x <= tmp_xbar & temp_df$y >= tmp_ybar & temp_df$master_part == item,'temp_part'] = paste(temp_df[temp_df$x <= tmp_xbar & temp_df$y >= tmp_ybar & temp_df$master_part == item,'master_part'], 1, sep = '')
temp_df[temp_df$x >= tmp_xbar & temp_df$y <= tmp_ybar & temp_df$master_part == item,'temp_part'] = paste(temp_df[temp_df$x >= tmp_xbar & temp_df$y <= tmp_ybar & temp_df$master_part == item,'master_part'], 2, sep = '')
temp_df[temp_df$x <= tmp_xbar & temp_df$y <= tmp_ybar & temp_df$master_part == item,'temp_part'] = paste(temp_df[temp_df$x <= tmp_xbar & temp_df$y <= tmp_ybar & temp_df$master_part == item,'master_part'], 3, sep = '')
}
temp_df[,'master_part'] = temp_df[, 'temp_part']
}
}
return(temp_df[, c('x', 'y', 'master_part')])
}
Yielding the correlation coefficient:
VN_rho = function(x, y,order= ceiling(log10(length(x))), degree=1){
if(order==1){return("Please Increase the Order Specification")}
partitioned_df = partition_map(x, y,order,degree)
clpm = numeric(0)
cupm = numeric(0)
dlpm = numeric(0)
dupm = numeric(0)
for(item in unique(partitioned_df$master_part)){
sub_x = partitioned_df[partitioned_df$master_part == item, 'x']
sub_y = partitioned_df[partitioned_df$master_part == item, 'y']
clpm = c(clpm, CLPM(degree, sub_x, sub_y))
cupm = c(cupm, CUPM(degree, sub_x, sub_y))
dlpm = c(dlpm, DLPM(degree, sub_x, sub_y))
dupm = c(dupm, DUPM(degree, sub_x, sub_y))
}
nonlin_cor = (sum(clpm) +sum(cupm) -sum(dlpm) -sum(dupm))/(sum(clpm)+sum(cupm)+sum(dlpm)+sum(dupm))
return(nonlin_cor)
}
And finally the dependence measure:
VN_dep = function(x, y,order= ceiling(log10(length(x))), degree=1){
if(order==1){return("Please Increase the Order Specification")}
partitioned_df = partition_map(x, y,order,degree)
clpm = numeric(0)
cupm = numeric(0)
dlpm = numeric(0)
dupm = numeric(0)
rhos = numeric(0)
for(item in unique(partitioned_df$master_part)){
sub_x = partitioned_df[partitioned_df$master_part == item, 'x']
sub_y = partitioned_df[partitioned_df$master_part == item, 'y']
clpm = c(clpm, CLPM(degree, sub_x, sub_y))
cupm = c(cupm, CUPM(degree, sub_x, sub_y))
dlpm = c(dlpm, DLPM(degree, sub_x, sub_y))
dupm = c(dupm, DUPM(degree, sub_x, sub_y))
}
for(i in 1:order){
rhos[i] = abs((clpm[i]+cupm[i]-dlpm[i]-dupm[i]) / (clpm[i]+cupm[i]+dlpm[i]+dupm[i]))
}
plot(x,y)
m<- rbind(VN_rho(x, y,order,degree),sum(na.omit(rhos))/length(na.omit(rhos)))
rownames(m) = c("Correlation","Dependence")
print(m)
return(sum(na.omit(rhos))/length(na.omit(rhos)))
}
A quick confirmation test yields:
set.seed(123)
x=rnorm(1000)
y=x^2
Degree 0 case:
VN_dep(x,y,degree=0)
[,1]
Correlation 0.007131858
Dependence 0.890496479
Degree 1 case (default degree, distances matter):
VN_dep(x,y)
[,1]
Correlation 0.1380487
Dependence 0.9986242
It also works on the spherical distribution, illustrated below.
Generated by:
set.seed(123)
df <- data.frame(x=runif(5000, -1, 1), y=runif(5000, -1, 1))
df <- subset(df, (x^2 + y^2 <= 1 & x^2 + y^2 >= 0.95))
VN_dep(df$x,df$y)
[,1]
Correlation 0.05515558
Dependence 0.99773177
I would like to know if there would be any computational benefit from combining all of the routines into a single function or is it best to keep them separate. Also, if any of the steps could use a more efficient syntax.
