3
\$\begingroup\$

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.

Spherical Joint Distribution

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.