A "MapList" function - performance

Question

In Mathematica there are a number of functions that return not only the final result or a single match, but all results. Such functions are named *List. Exhibit:
FoldList
NestList
ReplaceList
ComposeList
Something that I am missing is a MapList function.
For example, I want:
MapList[f, {1, 2, 3, 4}]
{{f[1], 2, 3, 4}, {1, f[2], 3, 4}, {1, 2, f[3], 4}, {1, 2, 3, f[4]}}
I want a list element for each application of the function:
MapList[
f,
{h[1, 2], {4, Sin[x]}},
{2}
] // Column
{h[f[1], 2], {4, Sin[x]}}
{h[1, f[2]], {4, Sin[x]}}
{h[1, 2], {f[4], Sin[x]}}
{h[1, 2], {4, f[Sin[x]]}}
One may implement this as:
MapList[f_, expr_, level_: 1] :=
MapAt[f, expr, #] & /#
Position[expr, _, level, Heads -> False]
However, it is quite inefficient. Consider this simple case, and compare these timings:
a = Range#1000;
#^2 & /# a // timeAvg
MapList[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
0.00005088
0.01436
0.0003744
This illustrates that on average MapList is about 38X slower than the combined total of mapping the function to every element in the list and creating a 1000x1000 array.
Therefore, how may MapList be most efficiently implemented?

Answer 1

I suspect that MapList is nearing the performance limit for any transformation that performs structural modification. The existing target benchmarks are not really fair comparisons. The Map example is creating a simple vector of integers. The ConstantArray example is creating a simple vector of shared references to the same list. MapList shows poorly against these examples because it is creating a vector where each element is a freshly generated, unshared, data structure.
I have added two more benchmarks below. In both cases each element of the result is a packed array. The Array case generates new elements by performing Listable addition on a. The Module case generates new elements by replacing a single value in a copy of a. These results are as follows:
In[8]:= a = Range#1000;
#^2 & /# a // timeAvg
MapList[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
Array[a+# &, 1000] // timeAvg
Module[{c}, Table[c = a; c[[i]] = c[[i]]^2; c, {i, 1000}]] // timeAvg
Out[9]= 0.0005504
Out[10]= 0.0966
Out[11]= 0.003624
Out[12]= 0.0156
Out[13]= 0.02308
Note how the new benchmarks perform much more like MapList and less like the Map or ConstantArray examples. This seems to show that there is not much scope for dramatically improving the performance of MapList without some deep kernel magic. We can shave a bit of time from MapList thus:
MapListWR4[f_, expr_, level_: {1}] :=
Module[{positions, replacements}
, positions = Position[expr, _, level, Heads -> False]
; replacements = # -> f[Extract[expr, #]] & /# positions
; ReplacePart[expr, #] & /# replacements
]
Which yields these timings:
In[15]:= a = Range#1000;
#^2 & /# a // timeAvg
MapListWR4[#^2 &, a] // timeAvg
ConstantArray[#^2 & /# a, 1000] // timeAvg
Array[a+# &, 1000] // timeAvg
Module[{c}, Table[c = a; c[[i]] = c[[i]]^2; c, {i, 1000}]] // timeAvg
Out[16]= 0.0005488
Out[17]= 0.04056
Out[18]= 0.003
Out[19]= 0.015
Out[20]= 0.02372
This comes within factor 2 of the Module case and I expect that further micro-optimizations can close the gap yet more. But it is with eager anticipation that I join you awaiting an answer that shows a further tenfold improvement.

Answer 2

(Updated my function)
I think I can offer another 2x boost on top of WReach's attempt.
Remove[MapListTelefunken];
MapListTelefunken[f_, dims_] :=
With[{a = Range[dims], fun = f[[1]]},
With[{replace = ({#, #} -> fun) & /# a},
ReplacePart[ConstantArray[a, {dims}], replace]
]
]
Here are the timings on my machine (Sony Z laptop; i7, 8GB ram, 256 SSD in Raid 0):
a = Range#1000;
#^2 & /# a; // timeAvg
MapList[#^2 &, a]; // timeAvg
MapListWR4[#^2 &, a]; // timeAvg
MapListTelefunken[#^2 &, 1000]; // timeAvg
0.0000296 (* just Mapping the function over a Range[1000] for baseline *)
0.0297 (* the original MapList proposed by Mr.Wizard *)
0.00936 (* MapListWR4 from WReach *)
0.00468 (* my attempt *)

Answer 3

I think you'd still need to create the 1000x1000 array, and I don't think there's any cleverer way than a constant array. More to the point, your examples are better served with the following definition, although I admit that it lacks the finesse of levels.
MapList[f_, list_] := (Table[MapAt[f, #, i], {i, Length##}] &)#list;
The culprit in your own definition is the Position[] call, which creates a complex auxiliary structure.
Provide a more complex use case, that will better cover your intentions.