Wrapping a data selection in Mathematica

Question

I was wondering what would be the most efficient way to add brackets to given elements in my data set in order to change it's form from {{a,b},{c,d}} to {{{a},b},{{c},d}}.

I took a look through a few questions within the exchange database but couldn't find an answer which would output data in that form. I found an example for strings here, however,the output is a string which I can't manipulate as data (if that makes any sense).

My example data is as follows:

List = {{0.343051, 48.3831}, {0.331855, 81.4873}, {0.323979, 101.01}, {0.317126, 108.65}, {0.310429, 106.103}, {0.303265, 95.0686}, {0.294876, 77.2432}, {0.283812, 54.3249}, {0.265673, 28.0113}, {0., 0.00176955}, {-0.265673, 28.0113}, {-0.283812, 54.3249}, {-0.294876, 77.2433}, {-0.303265, 95.0686}, {-0.310429, 106.103}, {-0.317126, 108.65}, {-0.323979, 101.01}, {-0.331855, 81.4882}, {-0.343051, 48.3836}}

(I'm not looking for it to be done for a specific dataset of just this size, but rather for the more general case initially suggested)

My current method looks a bit like this:

Transpose@{Partition[List[[All,1]],1],List[[All,2]]}

where I separate the list into two and use partition to wrap all the first elements of list in a set of brackets and then transpose.

As the list size increases the timing becomes a bit too nonsensical. Could someone suggest a faster method please or possibly direct me to the answer?

Thanks in advance

Answer 1

Direct solution

This should be pretty fast:

wrapList[lst_List]:=
    Module[{copy=lst},
        copy[[All,1]]=Transpose[{copy[[All,1]]}];
        copy
    ];

for example:

wrapList[{{a, b}, {c, d}}]

(* {{{a}, b}, {{c}, d}} *)

This does a million pair list in 0.4 sec on my machine:

tst = RandomInteger[100, {1000000, 2}];
wrapList[tst] // Length // Timing

(* {0.342305, 1000000} *)

A major speed-up for packed arrays by using the transposed list

Note, however, that whatever implementation you pick, it will always unpack. However, if you can use the transposed form of your list, you will benefit a lot for packed arrays. Here are the functions for this case:

ClearAll[wrapFlat, wrapTransposed];
wrapFlat[lst_] := Transpose[{lst}];
wrapTransposed[lst_List] := {wrapFlat[First@lst], Last@lst};

Here is a small example:

small = Transpose[{{a, b}, {c, d}}]
wrapTransposed[small]

(* {{a, c}, {b, d}} *)

(* {{{a}, {c}}, {b, d}} *)

And here is the large one, using the same tst defined before:

trans = Transpose[tst];
wrapTransposed[trans]; // AbsoluteTiming

(* {0.009302, Null} *)

You get a 40x speed-up w.r.t. the previous code, because now no unpacking takes place. This can be verified:

Developer`PackedArrayQ /@ wrapTransposed[trans]

(* {True, True} *)

The 40 here is a very characteristic coefficient for a speed-up one gets from utilizing packed arrays vs. unpacked general lists.

It is another question how to use this transposed list conveniently for your purposes, but in many cases there are ways.

Answer 2

One method...

Apply[{{#1},#2}&, {{a,b},{c,d}}, {1}]

Apply applies a function which in this case takes two arguments and return a list of the first argument as a list and the second un-altered. The trailing {1} is a levelspec to make Apply work at the right level. All in the docs (See Apply and Map, they are your friends).

Answer 3

Another way, which also involves a levelspec, is to use a pattern replacement rule:

lis = {{a, b}, {c, d}};
Replace[lis, {x_, y_} :> {{x}, y}, {1}]
(* {{{a}, b}, {{c}, d}} *)

The original question asked about efficiency. Here's a comparison:

pairs = RandomReal[{-1, 1}, {100000, 2}];
Replace[pairs, {x_, y_} :> {{x}, y}, {1}] // Timing // First
(* 0.061176 *)

Apply[{{#1}, #2} &, pairs, {1}] // Timing // First
(* 0.068718 *)  

Here's a further comparison of the two methods:

compare[len_] := 
   Module[{xy = RandomReal[{0, 1}, {len, 2}]}, 
   {First @ Timing @ Replace[xy, {x_, y_} :> {{x}, y}, {1}],
    First @ Timing @ Apply[{{#1}, #2} &, xy, {1}]}
  ]

timings = Table[compare[10^k], {k, 1, 7}];

ListPlot[{First /@ timings, Last /@ timings}, 
   PlotStyle -> {Directive[Red, PointSize@Large], 
                 Directive[Blue, PointSize@Large]}, 
   PlotRange -> All]