Optimizing a function definition

Question

I am using the following function to calculate A358497 as defined by OEIS:

A358497[k_] := 
  FromDigits[
   Table[Mod[
     CountDistinct[Take[#, FirstPosition[#, #[[i]]][[1]]]] &[
      IntegerDigits[k]], 10], {i, 1, IntegerLength[k]}]];

This function is supposed to return the canonical form for any integer that enumerates digits in order of their first occurrence from left to right. For example, 385823 would be converted to 123241. For 11- or 12-digit numbers, it takes way longer to calculate this function than to run Prime[] or PrimeQ[] for a number of the same length, although the function is much simpler. I am running it in a huge loop for all prime numbers, and it seems to be slowing things down considerably. Can you suggest any way to optimize or re-write this function so that it works faster?

Answer 1

This can be done mostly procedurally, and sped using Compile.

a358497[k_] := FromDigits@a358497C[k]
a358497C = Compile[{{k, _Integer}}, Module[
    {firstpos = ConstantArray[0, 10], digits = IntegerDigits[k], 
     indx = 0},
    Table[
     If[firstpos[[digits[[j]] + 1]] == 0,
      firstpos[[digits[[j]] + 1]] = ++indx];
     firstpos[[digits[[j]] + 1]]
     , {j, Length[digits]}]]];

I'll modify slightly the speed test used by others.

tests = Prime@Range[10^7, 10^8, 10^4];

AbsoluteTiming[r1 = A358497 /@ tests;]
AbsoluteTiming[r2 = a358497 /@ tests;]
r1 == r2

(* Out[140]= {0.714911, Null}

Out[141]= {0.015036, Null}

Out[142]= True *)

So a factor in the 40-50 range.

Answer 2

Update

Edit: Per @SjoerdSmit here, ReplaceAll is overkill in this case, and we should instead use Lookup. We can also write this in a more readable way than my previous answer:

 Module[{digs = IntegerDigits@k, orderedDigs, rules}, 
  orderedDigs = Keys@PositionIndex@digs;
  rules = MapIndexed[#1 -> Mod[#2[[1]], 10] &, orderedDigs];
  Lookup[rules, digs] // FromDigits
  ]

And now we golf it a little to make it slightly faster by not defining any new local variables

A358497$Sjoerd[
  k_] := (Lookup[ 
      MapIndexed[#1 -> Mod[#2[[1]], 10] &, Keys@PositionIndex@#], #] //
      FromDigits) &@IntegerDigits@k

And compare our 2 new functions to the original:

tests = Prime@Range[10^8, 10^9, 10^7];

A358497$Orig /@ tests; // RepeatedTiming // ScientificForm
A358497$New /@ tests; // RepeatedTiming // ScientificForm
A358497$Sjoerd /@ tests; // RepeatedTiming // ScientificForm

(*{8.14147*10^(-3),Null}*)

(*{1.85377*10^(-3),Null}*)

(*{1.16995*10^(-3),Null}*)

So using Sjoerd's Lookup method gives a 6-7x time improvement over the original.

---

Original Post

We use PositionIndex to get the index values where each distinct digit occurs (these are already sorted in the order they first occur). We then use MapIndexed to create a list that looks like index -> order at which first digit occurs, and use Mod[#,10] to replace the 10th order digit with 0th order digit. and construct a SparseArray from this:

A358497$New[k_] := With[{pI = Values@PositionIndex@IntegerDigits@k},
  MapIndexed[#1 -> Mod[#2[[1]], 10] &, pI, {2}] // Flatten // 
    SparseArray // FromDigits
  ]

We can compare performance with the original function:

A358497$New[k_] := With[{pI = Values@PositionIndex@IntegerDigits@k},
  MapIndexed[#1 -> Mod[#2[[1]], 10] &, pI, {2}] // Flatten // 
    SparseArray // FromDigits
  ]

A358497$Orig[k_] := 
  FromDigits[
   Table[Mod[
     CountDistinct[Take[#, FirstPosition[#, #[[i]]][[1]]]] &[
      IntegerDigits[k]], 10], {i, 1, IntegerLength[k]}]];


tests = Prime@Range[10^8, 10^9, 10^7];
A358497$Orig /@ tests; // RepeatedTiming // ScientificForm
A358497$New /@ tests; // RepeatedTiming // ScientificForm

{8.0767*10^(-3),Null}

{1.8007*10^(-3),Null}

giving a 4-5x improvement in time. And we verify the two functions produce the same output:

(A358497$Orig /@ tests) == (A358497$New /@ tests)

(*True*)

Answer 3

I think you code has a bug. In your example, digit 2 appears first at position 5 and not 4.

Further, here is some corrected code:

code[k_] := Block[{dig = IntegerDigits[k]},
  Map[(FirstPosition[dig, #][[1]]) &, dig]
    // FromDigits
  ]
code[385823]

123251

This is 3 to 4 times faster than the original code:

num=26493726344;
Do[code[num], 10^4] // Timing
Do[A358497[num], 10^4] // Timing

{0.5625, Null}
{2.0625, Null}