# Extending a list

I have a range of n integers (always starting at 1) which are 1 apart, f.e. Range[10], Range[17] or Range[100].

I want to extend the range by [1, 2, 3 ... n] elements by duplicating n existing elements at random positions. With n = 2 for example Range[10] could become

{1, 2, 3, 3, 5, 6, 7, 7, 9, 10, 11, 12}

There are 3 requirements:

(1) The first and the last element should not be duplicated.

(2) After a duplication there should be a jump of 2 (like from 3 to 5 in the above example list).

(3) There should be at least 1 non-repeated element between 2 duplications (5 and 6 in the list).

I finally found an ugly solution with Fors and Whiles but somehow got lost trying to find a functional one.

• I'm not clear on what you are asking. You state "I want to extend the range by [1, 2, 3 ... n] elements", but [1, 2, 3 ... n] has no meaning to me as a Mathematica expression nor as a mathematical one. You mention duplicating elements, but your example doesn't show duplication as I understand it; it shows ... k, k + 1, ... being replaced by ... k, k, ... and then n + 1 tacked onto the end of a list that previously had n elements. So I'm confused about what your goal really is. Perhaps you should add your ugly but working code. The code at least would give a precise specification. Nov 28, 2015 at 18:18

## 3 Answers

f[m_, n_] := Module[{rg, ok, rs},
rg = Range[m + n];
ok = rg[[2 ;; -2]];
While[True,
rs = Sort@RandomSample[ok, n];
If[FreeQ[Differences@rs, 1 | 2], Break[]]];
Fold[ReplacePart[#1, #2 + 1 -> #2] &, rg, rs]]

f[10, 2]


{1, 2, 2, 4, 5, 6, 7, 8, 9, 10, 10, 12}

• Beautiful combination of Fold and ReplacePart. Sometimes I get two duplicate pairs next to each other like 4,4,5,5. Not a big deal, but I asked for a separation (point 3 of the question).
– eldo
Nov 28, 2015 at 22:37
• @eldo - Ok, fixed that with FreeQ[ ... , 1 | 2] Nov 28, 2015 at 23:00
• The While loop and RandomSample may be problematic for large inputs because it would be unlikely that Differences@rs do not have any $1$s or $2$s. For example, f[81,40] would take a long time to calculate. Nov 29, 2015 at 6:11

This would work:

ExtendedList[range_, duplicates_] :=
MapAt[# - 1 &, Range[range],
List /@ Accumulate[Most[RandomChoice[
Flatten[Permutations /@
IntegerPartitions[range - 2 duplicates, {duplicates + 1}],
1]
]] + 2]
]


The above code is not efficient for large lists. The code below would be more efficient:

ExtendedList[range_, duplicates_] :=
MapAt[# - 1 &, Range[range],
List /@ Accumulate[Most[RandomSample[RandomChoice[
IntegerPartitions[range - 2 duplicates, {duplicates + 1}]
]]] + 2]
]


Edit: The above codes generate a list of length range: the length does not change. You would need to type ExtendedList[12,2] instead of [10,2] in order to get the result in the question.

Edit 2: Fixed the code.

ExtendedList[range_, duplicates_] :=
MapAt[# - 1 &, Range[range + duplicates],
List /@ Accumulate[Most[RandomSample[RandomChoice[
IntegerPartitions[range - duplicates, {duplicates + 1}]
]]] + 2]
]

ExtendedList[10,2]
(*{1, 2, 3, 3, 5, 6, 7, 8, 8, 10, 11, 12}*)

• Now it works, thanks a lot, +1
– eldo
Nov 28, 2015 at 21:54
• These codes have one flaw: they subtract 1 from certain elements instead of duplicating elements. So, you would need to input the final length of the list (initial length + number of duplicates) and the number of duplicates in order to get the desired result. Nov 28, 2015 at 22:02
• Yes, I noticed, but that's not a big problem
– eldo
Nov 28, 2015 at 22:05
• Fixed the code! Nov 29, 2015 at 5:30

Using SequenceReplace:

Clear[f, m, n];
f[m_, n_] := SequenceReplace[Range[m + n]
, {k : Repeated[_, {n}], c_, Repeated[_, {n - 1}]} :>
Splice@{k, Splice@ConstantArray[c, n]}
, If[Mod[m + n, 2 n] == 0
, Quotient[m + n, 2 n] - 1
, Quotient[m + n, 2 n]]
]


Explanation:

The SequenceReplace command starts with an extended list with m + n entries. It replaces the entry c_ (following n repeated entries) by a ConstantArray of n such cs. Further, it removes the following n-1 entries. If the list divides evenly by 2n, then it doesn't make the last replacement (using the third argument of SequenceReplace which is the number of replacements) in order to keep the last entry in place (as required) using the If command that uses the Mod and the Quotient commands.

Examples:

f[10, 2]


{1, 2, 3, 3, 5, 6, 7, 7, 9, 10, 11, 12}

f[13, #] & /@ Range[5]


Visualization

fvis[m_, n_] :=
SequenceReplace[
Range[m + n], {k : Repeated[_, {n}], c_, Repeated[_, {n - 1}]} :>
Splice@{k
, Splice@(Style[#, Red, Bold] & /@ ConstantArray[c, n])}
, If[Mod[m + n, 2 n] == 0
, Quotient[m + n, 2 n] - 1
, Quotient[m + n, 2 n]]
]

fvis[13, #] & /@ Range[5]