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\$

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.