1
$\begingroup$

I have an initial list which is partitioned as follows.

data = {1, 2, 3, 4, 5, 6, 7, 8} part = {{1, 2}, {1, 2, 3}, {2, 3, 4}, {3, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}}

The partition puts element i of data in a sublist {i-1,i,i+1}, e.g. the fourth element in data (4) appears in the third, fourth and fifth elements in part in positions 3,2,1 respectively. I want to cursor across part and if a test suceeds I want to replace

1) the ith element in data 2) the elements in part that correspond to it

This code does what I want, with one error that does not affect me.

list := {1, 2, 3, 4, 5, 6, 7, 8} part := {{1, 2}, {1, 2, 3}, {2, 3, 4}, {3, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}} func[{a_, b_, c_}] := (a + b + c)/3 func[{a_, b_}] := (a + b)/2 func[{b_, c_}] := (b + c)/2 Do[{Print[part[[i]]]; test = RandomVariate[NormalDistribution[func[part[[i]]], 1]]; If[list[[i]] > test, {list = ReplacePart[list, i -> test]; part = ReplacePart[part, {{i - 1, 3} -> test, {i, 2} -> test, {i + 1, 1}-> test}]}, Nothing]; }, {i, 1, 8}] part list

To make things as clear as possible, I print the input to test and in the end I call the output. I use SetDelayed to store the updated lists in each step. The Do loop does not break for i=1, i=8, which is very useful.

{1,2}

{-0.149498,2,3}

{2,3,4}

{3,4,5}

{3.64625,5,6}

{3.69681,6,7}

{6,7,8}

{7,8}

(part output, as intended)

{{1, -0.149498}, {-0.149498, 2, 3}, {2, 3, 3.64625}, {3, 3.64625, 3.69681}, {3.64625, 3.69681, 6}, {3.69681, 6, 7}, {6, 7, 7.7758}, {7, 7.7758}}

(list output, as intended)

{-0.149498, 2, 3, 3.64625, 3.69681, 6, 7, 7.7758}

The error is in the first element of part, which should be {-0.149498,2}. Since I won't be needing this I can live with the issue. The last element is updated correctly, on the other hand.

I keep the question about efficiency open. Transpose does not cover me because part must be updated in parallel with list (one step at a time), and Table constructs a new list every time which is time consuming (I use ReplacePart to avoid that). Because ReplacePart is slow, possible candidates are MapAt/ Apply, or even NestList.

Again, thank you all for your patience and good will. Hopefully this explains what I am aiming for, which is a dynamic sequence.

Improve this question
$\endgroup$
1
  • $\begingroup$ Large overhaul in OP. $\endgroup$ Commented Nov 28, 2018 at 18:33

2 Answers 2

Reset to default
1
$\begingroup$

is this what you are looking for?
Here is the result after applying the operation to all elements 

ClearAll[data, list, k, l] list = {1, 2, 3, 4, 5, 6, 7, 8}; l = Length@list; data[x_] := Partition[x, 3, 1, {-2, 2}, {}] Table[test = RandomReal[{1, 8}]; If[list[[i]] > test, list = ReplacePart[list, i -> test]]; data@list, {i, l}] list

{{{1, 2}, {1, 2, 3}, {2, 3, 4}, {3, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}},
{{1, 2}, {1, 2, 3}, {2, 3, 4}, {3, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}},
{{1, 2}, {1, 2, 3}, {2, 3, 4}, {3, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}},
{{1, 2}, {1, 2, 3}, {2, 3, 3.51974}, {3, 3.51974, 5}, {3.51974, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}},
{{1, 2}, {1, 2, 3}, {2, 3, 3.51974}, {3, 3.51974, 5}, {3.51974, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}},
{{1, 2}, {1, 2, 3}, {2, 3, 3.51974}, {3, 3.51974, 5}, {3.51974, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}},
{{1, 2}, {1, 2, 3}, {2, 3, 3.51974}, {3, 3.51974, 5}, {3.51974, 5, 6}, {5, 6, 6.08169}, {6, 6.08169, 8}, {6.08169, 8}},
{{1, 2}, {1, 2, 3}, {2, 3, 3.51974}, {3, 3.51974, 5}, {3.51974, 5, 6}, {5, 6, 6.08169}, {6, 6.08169, 5.86203}, {6.08169, 5.86203}}}

{1, 2, 3, 3.51974, 5, 6, 6.08169, 5.86203}

Improve this answer
$\endgroup$
2
  • $\begingroup$ Thank you very much, this does indeed wht I described but with one difference: Because part is actually input for the actual test (e.g. test =Mean[part[[i]]]), I need to Table a list at every iteration so that the i+1 element in part will have been updated before the cursoring reaches it. I updated the OP. $\endgroup$ Commented Nov 28, 2018 at 9:04
  • $\begingroup$ @Titus updated. Is that the output you want? $\endgroup$ Commented Nov 28, 2018 at 11:28
1
$\begingroup$

Update: to do conditional replacements iteratively:

ClearAll[tstF, replaceAndPartition] replaceAndPartition = Module[{d = #, p = partition@#, tf = #2}, Table[d[[i]] = Min[d[[i]], tf[p[[i]]]]; p = partition[d]; {d, p}, {i, 1, Length@d}]] &;

Examples:

SeedRandom[1] tstF = RandomVariate[NormalDistribution[Mean[#], 1]] &; Grid[replaceAndPartition[data, tstF] /. x_Real :> Round[x, .01], Dividers -> All] // TeXForm

$\tiny\begin{array}{|c|c|} \hline \{1,2,3,4,5,6,7,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,5\},\{4,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,2,3,4,5,6,7,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,5\},\{4,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,2,3,4,5,6,7,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,5\},\{4,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,2,3,4,5,6,7,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,5\},\{4,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,2,3,4,4.58,6,7,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,4.58\},\{4,4.58,6\},\{4.58,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,2,3,4,4.58,5.85,7,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,4.58\},\{4,4.58,5.85\},\{4.58,5.85,7\},\{5.85,7,8\},\{7,8\}\} \\ \hline \{1,2,3,4,4.58,5.85,6.97,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,4.58\},\{4,4.58,5.85\},\{4.58,5.85,6.97\},\{5.85,6.97,8\},\{6.97,8\}\} \\ \hline \{1,2,3,4,4.58,5.85,6.97,7.58\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,4.58\},\{4,4.58,5.85\},\{4.58,5.85,6.97\},\{5.85,6.97,7.58\},\{6.97,7.58\}\} \\ \hline \end{array}$

SeedRandom[1] tf= Mean[#] + RandomReal[{-.5, .5}] &; Grid[replaceAndPartition[data, tf] /. x_Real :> Round[x, .1], Dividers -> All] // TeXForm

$\tiny\begin{array}{|c|c|} \hline \{1,2,3,4,5,6,7,8\} & \{\{1,2\},\{1,2,3\},\{2,3,4\},\{3,4,5\},\{4,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,1.6,3,4,5,6,7,8\} & \{\{1,1.6\},\{1,1.6,3\},\{1.6,3,4\},\{3,4,5\},\{4,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,1.6,3,4,5,6,7,8\} & \{\{1,1.6\},\{1,1.6,3\},\{1.6,3,4\},\{3,4,5\},\{4,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,1.6,3,3.7,5,6,7,8\} & \{\{1,1.6\},\{1,1.6,3\},\{1.6,3,3.7\},\{3,3.7,5\},\{3.7,5,6\},\{5,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,1.6,3,3.7,4.6,6,7,8\} & \{\{1,1.6\},\{1,1.6,3\},\{1.6,3,3.7\},\{3,3.7,4.6\},\{3.7,4.6,6\},\{4.6,6,7\},\{6,7,8\},\{7,8\}\} \\ \hline \{1,1.6,3,3.7,4.6,5.4,7,8\} & \{\{1,1.6\},\{1,1.6,3\},\{1.6,3,3.7\},\{3,3.7,4.6\},\{3.7,4.6,5.4\},\{4.6,5.4,7\},\{5.4,7,8\},\{7,8\}\} \\ \hline \{1,1.6,3,3.7,4.6,5.4,6.9,8\} & \{\{1,1.6\},\{1,1.6,3\},\{1.6,3,3.7\},\{3,3.7,4.6\},\{3.7,4.6,5.4\},\{4.6,5.4,6.9\},\{5.4,6.9,8\},\{6.9,8\}\} \\ \hline \{1,1.6,3,3.7,4.6,5.4,6.9,7.2\} & \{\{1,1.6\},\{1,1.6,3\},\{1.6,3,3.7\},\{3,3.7,4.6\},\{3.7,4.6,5.4\},\{4.6,5.4,6.9\},\{5.4,6.9,7.2\},\{6.9,7.2\}\} \\ \hline \end{array}$

Original answer:

ClearAll[partition] partition = Partition[#, 3, 1, {-2, 2}, {}] &; data = {1, 2, 3, 4, 5, 6, 7, 8}; part = partition[data]

{{1, 2}, {1, 2, 3}, {2, 3, 4}, {3, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}}

SeedRandom[1] tests = RandomVariate[NormalDistribution[Mean[#], 1]] & /@ part

{1.98568, 2.26188, 4.5443, 4.1307, 4.58325, 5.98513, 7.02065, 7.59776}

data2 = Min /@ Transpose[{data, tests}]

{1, 2, 3, 4, 4.58325, 5.98513, 7, 7.59776}

part2 = partition @ data2

{{1, 2}, {1, 2, 3}, {2, 3, 4}, {3, 4, 4.58325}, {4, 4.58325, 5.98513}, {4.58325, 5.98513, 7}, {5.98513, 7, 7.59776}, {7, 7.59776}}

Note: Whenever part i of data is replaced with, say, xx, appropriate parts of part are also replaced with xx.

i = 3; modifieddata = ReplacePart[data, i -> xx]

{1, 2, xx, 4, 5, 6, 7, 8}

modifiedpart = ReplacePart[part, {{i - 1, 3} -> xx, {i, 2} -> xx, {i + 1, 1} -> xx}]

{{1, 2}, {1, 2, xx}, {2, xx, 4}, {xx, 4, 5}, {4, 5, 6}, {5, 6, 7}, {6, 7, 8}, {7, 8}}

Instead of using ReplacePart on part you can partition modifieddata using the function partition and get the same result:

partition @ modifieddata == modifiedpart

True

Improve this answer
$\endgroup$
2
  • $\begingroup$ That is a very neat solution but it does not quite do what I need. I used part=ReplacePart[etc] in my code because part is input for the test, so elem. i+1 needs to be updated before the test uses it. As I said, it is a cursoring, not something done in parallel. I updated my OP with 'test=Mean[part[[i]]]` to make this clearer. Still, thank you very much! $\endgroup$ Commented Nov 28, 2018 at 9:12
  • $\begingroup$ @Titus, updated with your new example. $\endgroup$ Commented Nov 28, 2018 at 9:41

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.