Help Calculating My "Deviation"

Question

I created a "distribution deviation" where for $\left\{a_1,...,a_k\right\}$ we take all take the mean of all combinations of $\frac{\min\left\{a_{i},a_{j}\right\}}{\max\left\{a_{i},a_j\right\}}$ ($i,j\in\left\{1,...,k\right\}$) without repetitions, subtract by one and take the absolute value.

$$\left|1-\frac{1}{\sum\limits_{i=1}^{k-1}i}\sum_{j=2}^{k}\sum_{i=1}^{j-1}\frac{\min\left\{a_{i},a_{j}\right\}}{\max\left\{a_{i},a_{j}\right\}}\right|$$

For infinite $k$ we simply take

$$\left|1-\frac{2}{k(k-1)}\sum_{j=1}^{k}\sum_{i=1}^{j-1}\frac{\min\left\{a_{i},a_{j}\right\}}{\max\left\{a_{i},a_{j}\right\}}\right|$$

This works well for values of $a_i$ that are extremely small.

I want to apply this deviation to the differences of elements in the folner sequence of $\left\{\frac{\ln(m)}{\ln(n)}:m\in\mathbb{N}_{>0},n\in\mathbb{N}_{>1}\right\}\cap[0,1]$. The folner sequence is

$$g(d)=\left\{\frac{\ln(m)}{\ln(n)}:m\in\mathbb{N}_{>0},n\in\mathbb{N}_{>1},n\le d\right\}\cap[0,1]$$

For every $d\in\mathbb{R}$, if we list $g(d)$ (note $g(d)$ is finite) as $\left\{a_1,...,a_{k}\right\}$ ($k$ is the number of elements in the list depending on $d\in\mathbb{R}$) we take $|a_{i+1}-a_i|$ where $i,j\in\left\{1,...,k\right\}$. My distribution deviation as $d,k\to\infty$.

$$\lim_{k\to\infty}\left|1-\frac{2}{k(k-1)}\sum_{j=2}^{k}\sum_{i=1}^{j-1}\frac{\min\left\{a_{j+1}-a_{j},a_{i+1}-a_{i}\right\}}{\max\left\{a_{j+1}-a_{j},a_{i+1}-a_{i}\right\}}\right|$$

Here is my attempt to do this

F[d_] := Abs[
   Differences[
    DeleteDuplicates[
     Sort[Flatten[
       Table[Log[m]/Log[n], {n, 2, d}, {m, 1, Floor[n]}]]]]]];
G[d_] := Table[
  N[Min[F[d][[i]], F[d][[j]]]/Max[F[d][[i]], F[d][[j]]], 10], {j, 2, 
   Length[F[100]]}, {i, 1, j - 1}]

Unfortunately it takes too long to load. Is there a way to shorten the time? Does my code match my math equations?

Answer 1

You can speed up the calculations for your initial equation several orders of magnitude (with ever larger increases in speed for larger values of k) by using Sort and Accumulate:

(* Generate a random sample of positive numbers *)
k = 100;
SeedRandom[12345];
x = RandomVariate[ChiSquareDistribution[20], k];

(* Original equation *)
t1 = AbsoluteTiming[Abs[1 - (2/(k (k - 1))) Sum[Min[x[[i]], x[[j]]]/Max[x[[i]], x[[j]]],
  {j, 2, k}, {i, 1, j - 1}]]]
(* {0.0120628, 0.262134} *)

(* Updated equation *)
t2 = AbsoluteTiming[y1 = Sort[x]; y2 = Accumulate[y1]; 
  Abs[1 - (2/(k (k - 1))) Sum[y2[[j - 1]]/y1[[j]], {j, 2, k}]]]
(* {0.0001317, 0.262134} *)

(* Ratio of timings *)
t1[[1]]/t2[[1]]
(* 91.593 *)

For k = 1000 the ratio of timings is around 1,100.

Addition:

Here is a general formula for your index. (I have left off any removal of duplicates as I'm a bit skeptical about the usefulness even without the fact that duplicates cause problems.)

deviation[a_] := Module[{a1, a2},
  a1 = Sort[a, Less];
  a2 = Accumulate[a1];
  Abs[1 - (2/(Length[a] (Length[a] - 1))) Sum[a2[[j - 1]]/a1[[j]], {j, 2, Length[a]}]]]

Using a list of numbers from above the deviation index is found with

deviation[x]
(* 0.278869 *)

And the same index on the differences is found with

deviation[Differences[x]]
(* 1.62546 *)

Using your function F I get the following:

x = F[5]

deviation[x] // N
(* 0.470385 *)
deviation[Differences[x]] // N
(* 0.821658 *)