Sequential Subsets of a list - wolfram-mathematica

Given a list say
{"a", "b", "c", "d"}
Is there any easier way to generate list of sequential subsets like this (order of the result is not important)
{
{"a"},
{"a b"},
{"a b c"},
{"a b c d"},
{"b"},
{"b c"},
{"b c d"},
{"c"},
{"c d"},
{"d"}
}


I think I like this best of all:
set = {"a", "b", "c", "d"};
ReplaceList[set, {___, x__, ___} :> {x}]
With the string joining:
ReplaceList[set, {___, x__, ___} :> "" <> Riffle[{x}, " "]]
In a similar vein, specific to strings:
StringCases["abcd", __, Overlaps -> All]
Since Nasser says I am cheating, here is a more manual approach that also has greater efficiency on large sets:
ClearAll[f, f2]
f[i_][x_] := NestList[i, x, Length#x - 1]
f2[set_] := Join ## ( f[Most] /# f[Rest][set] )
f2[{"a", "b", "c", "d"}]


Flatten[Partition[{a, b, c, d}, #, 1] & /# {1, 2, 3, 4}, 1]
gives
{{a}, {b}, {c}, {d}, {a, b}, {b, c}, {c, d}, {a, b, c}, {b, c, d}, {a,
b, c, d}}


How about this:
origset = {"a", "b", "c", "d"};
bdidxset = Subsets[Range[4], {1, 2}]
origset[[#[[1]] ;; #[[-1]]]] & /# bdidxset
which gives
{{"a"}, {"b"}, {"c"}, {"d"}, {"a", "b"}, {"a", "b", "c"}, {"a", "b",
"c", "d"}, {"b", "c"}, {"b", "c", "d"}, {"c", "d"}}


I like TomD's method better, but this is what came to my mind, sans string processing:
set = {"a", "b", "c", "d"};
n = Length#set;
Join ## Table[set~Take~{s, f}, {s, n}, {f, s, n}] // Column


Here is one possible solution
a={"a","b","c","d"};
StringJoin#Riffle[#, " "] & /#
DeleteDuplicates[
LongestCommonSubsequence[a, #] & /#
DeleteCases[Subsets#a, {}]] // Column
Result
a
b
c
d
a b
b c
c d
a b c
b c d
a b c d


one way:
makeList[lst_] := Map[ Union[lst[[1 ;; #]]] &, Range#Length[lst]]
r = Map[makeList[lst[[# ;; -1]]] &, Range#Length[lst]];
Flatten[r, 1]
gives
{{"a"},
{"a", "b"},
{"a", "b", "c"},
{"a", "b", "c", "d"},
{"b"},
{"b", "c"},
{"b", "c", "d"},
{"c"},
{"c", "d"},
{"d"}}


You can do it like this:
a = {"a", "b", "c", "d"};
b = List[StringJoin[Riffle[#, " "]]] & /#
Flatten[Table[c = Drop[a, n];
Table[Take[c, i], {i, Length[c]}],
{n, 0, Length[a]}], 1]
the output will look like this:
{{"a"}, {"a b"}, {"a b c"}, {"a b c d"}, {"b"}, {"b c"}, {"b c d"}, {"c"}, {"c d"}, {"d"}}

Related

Hash with array of characters as key

I need to have a Hash in which keys are represented by arrays with chars.
But when i have arrays like these:
a = %w(a b c), b = %w(d e f), c = %w(g h i)
and i create a new Hash and try to give it values, my results are strange, i expect something similar to this:
H = { ["a", "b", "c"] => 1, ["d", "e", "f"] => 2 }
but i get something like this:
{"[\"a\", \"b\", \"c\"]"=>1}
The way i create this hash is simple:
H = {}
H["#{array_name}"]
Is this normal behaviour? If so how can i make these keys normal arrays of chars?

a,b,c are local variables. They are not array names. They are holding the references of 3 different Array instances. So do as below :
a = %w(a b c)
b = %w(d e f)
c = %w(g h i)
H = {}
H[a] = 1
H[b] = 2
H[c] = 3
H # => {["a", "b", "c"]=>1, ["d", "e", "f"]=>2, ["g", "h", "i"]=>3}
One Rubyish way :
a = %w(a b c), %w(d e f), %w(g h i)
Hash[a.zip([1,2,3])]
# => {["a", "b", "c"]=>1, ["d", "e", "f"]=>2, ["g", "h", "i"]=>3}

Using data returned form Tally command in Mathematica

I have a small piece of code to generate sequences, which is ok.
List = Reap[
For[i = 1, i <= 10000, i++,
Sow[RandomSample[Join[Table["a", {2}], Table["b", {2}]], 2]]];][[2, 1]];
Tally[List]
Giving the following output,
{{{"b", "b"}, 166302}, {{"b", "a"}, 333668}, {{"a", "b"}, 332964}, {{"a", "a"}, 167066}}
My problem is I have yet to find a way to extract the frequencies from the output ....?
Thanks in advance for any help

Note: Generally do not start user-created Symbol names with a capital letter as these may conflict with internal functions.
It is not clear to me how you wish to transform the output. One interpretation is that you just want:
{166302, 333668, 332964, 167066}
In your code you use [[2, 1]] so I presume you know how to use Part, of which this is a short form. The documentation for Part includes:
If any of the listi are All or ;;, all parts at that level are kept.
You could therefore use:
Tally[list][[All, 2]]
You could also use:
Last /# Tally[list]
As george comments you can use Sort, which due to the structure of the Tally data will sort first by the item because it appears first in each list, and each list has the same length.
tally =
{{{"b","b"},166302},{{"b","a"},333668},{{"a","b"},332964},{{"a","a"},167066}};
Sort[tally][[All, 2]]
{167066, 332964, 333668, 166302}
You could also convert your data into a list of Rule objects and then pull values from a predetermined list:
rules = Rule ### tally
{{"b", "b"} -> 166302, {"b", "a"} -> 333668, {"a", "b"} -> 332964, {"a", "a"} -> 167066}
These could be in any order you choose:
{{"a", "a"}, {"a", "b"}, {"b", "a"}, {"b", "b"}} /. rules
{167066, 332964, 333668, 166302}
Merely to illustrate another technique if you have a specific list of items you wish to count you may find value in this Sow and Reap construct. For example, with a random list of "a", "b", "c", "d":
SeedRandom[1];
dat = RandomChoice[{"a", "b", "c", "d"}, 50];
Counting the "a" and "c" elements:
Reap[Sow[1, dat], {"a", "c"}, Tr[#2] &][[2, All, 1]]
{19, 5}
This is not as fast as Tally but it is faster than doing a Count for each element, and sometimes the syntax is useful.

Mathematicas Map and Join functions used together

I've been fiddling with some Mathematica code to join 2 lists but doing some operations on the one list before adding it to the other. So for example I have
list={{1, "A"}, {1, "B"}, {1, "C"}, {2, "D"}, {2, "E"}, {2, "F"}};
p = {};
q = {};
ones = Select[list, #[[1]] == 1 &];
p = Join[{#[[2]], "t"}, p] & /# Reverse[ones];
Table[
q = Join[{{ones[[m, 2]], "t"}}, q];
, {m, Length[ones]}];
twos = Select[list, #[[1]] == 2 &];
p = Join[{{#[[2]], "t"}}, p] & /# Reverse[twos];
Table[
q = Join[{{twos[[m, 2]], "t"}}, q];
, {m, Length[twos]}];
This yields the following values of p and q respectively:
p={{{F, t}, {C, t}, {B, t}, {A, t}}, {{E, t}, {C, t}, {B, t}, {A, t}}, {{D, t}, {C, t}, {B, t}, {A, t}}}
and
q={{F, t}, {E, t}, {D, t}, {C, t}, {B, t}, {A, t}}
From what I can gather, the second time Join is used with the /#or Map function, each list item in p which at the moment is {{C, t}, {B, t}, {A, t}} is applied to the Join function and is added to a list of results. Is there a way to use Map and rather apply the join to the new value of p each time, so as to obtain a result exactly the same as the value of q but achieved with one line of code.
I tried the same line of code using PrependTo instead of Join and it works fine, I assume this is because PrependTo updates the value of p each time the function is called. For example PrependTo[p, {#[[2]], "t"}] & /# twos;
The reason I was trying to do it this was was to determine whether it will be more time efficient to use Join rather then PrependTo. But ran into this problem before I could get an answer.
Another thing I do not quite understand, is why I need to apply Reverse[] to the lists when using Map to achieve the same result as running through the list using a loop. Could someone possibly explain why this is the case?! I would have assumed Map would run through a list forwards. But this behaviour seems to me as though is traversing the list backwards.
Thanks in advance for the help.

Map does traverse the list as you would expect, in a left right direction. I suspect later elements of your code are introducing reversals.
For instance:
Sqrt /# Select[Range#10, OddQ]
gives {1, Sqrt[3], Sqrt[5], Sqrt[7], 3}
If you want to apply some function to the ones from your list and another function to the twos the structure in a functional language might look something like this:
ans=Join[f1 /# Select[myList, #[[1]] == 1 &], f2 /# Select[myList, #[[1]] == 2 &]]
Further from your clarification:
Method 1 to produce q:
Reverse /# Reverse#list /. {2 -> "t", 1 -> "t"}
Method 2:
Reverse#Join[{Last##, "t"} & /# Select[list, #[[1]] == 1 &], {Last##, "t"} & /# Select[list, First## == 2 &]]

Reordering an array in the same order as another array was reordered

I have two arrays a, b of the same length:
a = [a_1, a_2, ..., a_n]
b = [b_1, b_2, ..., b_n]
When I sort a using sort_by!, the elements of a will be arranged in different order:
a.sort_by!{|a_i| some_condition(a_i)}
How can I reorder b in the same order/rearrangement as the reordering of a? For example, if a after sort_by! is
[a_3, a_6, a_1, ..., a_i_n]
then I want
[b_3, b_6, b_1, ..., b_i_n]
Edit
I need to do it in place (i.e., retain the object_id of a, b). The two answers given so far is useful in that, given the sorted arrays:
a_sorted
b_sorted
I can do
a.replace(a_sorted)
b.replace(b_sorted)
but if possible, I want to do it directly. If not, I will accept one of the answers already given.

One approach would be to zip the two arrays together and sort them at the same time. Something like this, perhaps?
a = [1, 2, 3, 4, 5]
b = %w(a b c d e)
a,b = a.zip(b).sort_by { rand }.transpose
p a #=> [3, 5, 2, 4, 1]
p b #=> ["c", "e", "b", "d", "a"]

How about:
ary_a = [ 3, 1, 2] # => [3, 1, 2]
ary_b = [ 'a', 'b', 'c'] # => ["a", "b", "c"]
ary_a.zip(ary_b).sort{ |a,b| a.first <=> b.first }.map{ |a,b| b } # => ["b", "c", "a"]
or
ary_a.zip(ary_b).sort_by(&:first).map{ |a,b| b } # => ["b", "c", "a"]

If the entries are unique, the following may work. I haven't tested it. This is partially copied from https://stackoverflow.com/a/4283318/38765
temporary_copy = a.sort_by{|a_i| some_condition(a_i)}
new_indexes = a.map {|a_i| temporary_copy.index(a_i)}
a.each_with_index.sort_by! do |element, i|
new_indexes[i]
end
b.each_with_index.sort_by! do |element, i|
new_indexes[i]
end

How would you do a PivotTable function in Mathematica?

PivotTables in Excel (or, cross tabulations) are quite useful. Has anyone already thought about how to implement a similar function in Mathematica?

I am not familiar with the use of pivot tables, but taking the example on the page linked above, I propose this:
Needs["Calendar`"]
key = # -> #2[[1]] & ~MapIndexed~
{"Region", "Gender", "Style", "Ship Date", "Units", "Price", "Cost"};
choices = {
{"North", "South", "East", "West"},
{"Boy", "Girl"},
{"Tee", "Golf", "Fancy"},
IntegerString[#, 10, 2] <> "/2011" & /# Range#12,
Range#15,
Range[8.00, 15.00, 0.01],
Range[6.00, 14.00, 0.01]
};
data = RandomChoice[#, 150] & /# choices // Transpose;
This creates data that looks like:
{"East", "Girl", "Golf", "03/2011", 6, 12.29`, 6.18`},
{"West", "Boy", "Fancy", "08/2011", 6, 13.01`, 12.39`},
{"North", "Girl", "Golf", "05/2011", 1, 14.87`, 12.89`},
{"East", "Girl", "Golf", "09/2011", 3, 13.99`, 6.25`},
{"North", "Girl", "Golf", "09/2011", 13, 12.66`, 8.57`},
{"East", "Boy", "Fancy", "10/2011", 2, 14.46`, 6.85`},
{"South", "Boy", "Golf", "11/2011", 13, 12.45`, 11.23`}
...
Then:
h1 = Union#data[[All, "Region" /. key]];
h2 = Union#data[[All, "Ship Date" /. key]];
Reap[
Sow[#[[{"Units", "Ship Date"} /. key]], #[["Region" /. key]]] & ~Scan~ data,
h1,
Reap[Sow ### #2, h2, Total # #2 &][[2]] &
][[2]];
TableForm[Join ## %, TableHeadings -> {h1, h2}]
This is a rough example, but it gives an idea of how this may be done. If you have more specific requirements I will attempt to address them.
Here is an update in the manner of Sjoerd's answer.
The Manipulate block is largely copied, but I believe my pivotTableData is more efficient, and I sought to localize symbols correctly, since this is now presented as usable code rather than a rough example.
I start with the same sample data, but I embed the field headings, since I feel this is more representative of normal use.
data = ImportString[#, "TSV"][[1]] & /# Flatten[Import["http://lib.stat.cmu.edu/datasets/CPS_85_Wages"][[28 ;; -7]]];
data = Transpose[{
data[[All, 1]],
data[[All, 2]] /. {1 -> "South", 0 -> "Elsewhere"},
data[[All, 3]] /. {1 -> "Female", 0 -> "Male"},
data[[All, 4]],
data[[All, 5]] /. {1 -> "Union Member", 0 -> "No member"},
data[[All, 6]],
data[[All, 7]],
data[[All, 8]] /. {1 -> "Other", 2 -> "Hispanic", 3 -> "White"},
data[[All, 9]] /. {1 -> "Management", 2 -> "Sales", 3 -> "Clerical", 4 -> "Service", 5 -> "Professional", 6 -> "Other"},
data[[All, 10]] /. {0 -> "Other", 1 -> "Manufacturing", 2 -> "Construction"},
data[[All, 11]] /. {1 -> "Married", 0 -> "Unmarried"}
}];
PrependTo[data,
{"Education", "South", "Sex", "Experience", "Union", "Wage", "Age", "Race", "Occupation", "Sector", "Marriatal status"}
];
My pivotTableData is self contained.
pivotTableData[data_, field1_, field2_, dependent_, op_] :=
Module[{key, sow, h1, h2, ff},
(key## = #2[[1]]) & ~MapIndexed~ data[[1]];
sow = #[[key /# {dependent, field2}]] ~Sow~ #[[key#field1]] &;
{h1, h2} = Union#data[[2 ;;, key##]] & /# {field1, field2};
ff = # /. {{} -> Missing#"NotAvailable", _ :> op ## #} &;
{
{h1, h2},
Join ## Reap[sow ~Scan~ Rest#data, h1, ff /# Reap[Sow ### #2, h2][[2]] &][[2]]
}
]
pivotTable relies only on pivotTableData:
pivotTable[data_?MatrixQ] :=
DynamicModule[{raw, t, header = data[[1]], opList =
{Mean -> "Mean of \[Rule]",
Total -> "Sum of \[Rule]",
Length -> "Count of \[Rule]",
StandardDeviation -> "SD of \[Rule]",
Min -> "Min of \[Rule]",
Max -> "Max of \[Rule]"}},
Manipulate[
raw = pivotTableData[data, f1, f2, f3, op];
t = ConstantArray["", Length /# raw[[1]] + 2];
t[[1, 1]] = Control[{op, opList}];
t[[1, 3]] = Control[{f2, header}];
t[[2, 1]] = Control[{f1, header}];
t[[1, 2]] = Control[{f3, header}];
{{t[[3 ;; -1, 1]], t[[2, 3 ;; -1]]}, t[[3 ;; -1, 3 ;; -1]]} = raw;
TableView[N#t, Dividers -> All],
Initialization :> {op = Mean, f1 = data[[1,1]], f2 = data[[1,2]], f3 = data[[1,3]]}
]
]
Use is simply:
pivotTable[data]

A quick-and-dirty pivot table visualization:
I'll start with a more interesting real-life data set:
data = ImportString[#, "TSV"][[1]] & /#
Flatten[Import["http://lib.stat.cmu.edu/datasets/CPS_85_Wages"][[28 ;; -7]]
];
A bit of post-processing:
data =
{
data[[All, 1]],
data[[All, 2]] /. {1 -> "South", 0 -> "Elsewhere"},
data[[All, 3]] /. {1 -> "Female", 0 -> "Male"},
data[[All, 4]],
data[[All, 5]] /. {1 -> "Union Member", 0 -> "No member"},
data[[All, 6]],
data[[All, 7]],
data[[All, 8]] /. {1 -> "Other", 2 -> "Hispanic", 3 -> "White"},
data[[All, 9]] /. {1 -> "Management", 2 -> "Sales", 3 -> "Clerical",
4 -> "Service", 5 -> "Professional", 6 -> "Other"},
data[[All, 10]] /. {0 -> "Other", 1 -> "Manufacturing", 2 -> "Construction"},
data[[All, 11]] /. {1 -> "Married", 0 -> "Unmarried"}
}\[Transpose];
header = {"Education", "South", "Sex", "Experience", "Union", "Wage",
"Age", "Race", "Occupation", "Sector", "Marriatal status"};
MapIndexed[(headerNumber[#1] = #2[[1]]) &, header];
levelNames = Union /# Transpose[data];
levelLength = Length /# levelNames;
Now for the real stuff. It also uses the function SelectEquivalents defined in What is in your Mathematica tool bag?
pivotTableData[levelName1_, levelName2_, dependent_, op_] :=
Table[
SelectEquivalents[data,
FinalFunction -> (If[Length[#] == 0, Missing["NotAvailable"], op[# // Flatten]] &),
TagPattern ->
_?(#[[headerNumber[levelName1]]] == levelMember1 &&
#[[headerNumber[levelName2]]] == levelMember2 &),
TransformElement -> (#[[headerNumber[dependent]]] &)
],
{levelMember1, levelNames[[headerNumber[levelName1]]]},
{levelMember2, levelNames[[headerNumber[levelName2]]]}
]
DynamicModule[
{opList =
{Mean ->"Mean of \[Rule]", Total ->"Sum of \[Rule]", Length ->"Count of \[Rule]",
StandardDeviation -> "SD of \[Rule]", Min -> "Min of \[Rule]",
Max -> "Max of \[Rule]"
}, t},
Manipulate[
t=Table["",{levelLength[[headerNumber[h1]]]+2},{levelLength[[headerNumber[h2]]]+2}];
t[[3 ;; -1, 1]] = levelNames[[headerNumber[h1]]];
t[[2, 3 ;; -1]] = levelNames[[headerNumber[h2]]];
t[[1, 1]] = Control[{op, opList}];
t[[1, 3]] = Control[{h2, header}];
t[[2, 1]] = Control[{h1, header}];
t[[1, 2]] = Control[{h3, header}];
t[[3 ;; -1, 3 ;; -1]] = pivotTableData[h1, h2, h3, op] // N;
TableView[t, Dividers -> All],
Initialization :> {op = Mean, h1 = "Sector", h2 = "Union", h3 = "Wage"}
]
]
There's still a bit of work to do. The DynamicModule should be turned into a fully standalone function, with the header stuff more streamlined, but this should be sufficient for a first impression.

#Mr.Wizard's answer is indeed robust and long-lasting as it grounds on ReapSow method suitable for some map reduce jobs in Mathematica. Due to the fact that MMA itself develops, consider a new option as well.
GroupBy (introduced in Mathematica v.10.0) provides a generalization of the map reduce operation.
So, the above data job may be implemented as follows (partly an overkill for readability):
headings = Union # data[[All, #]] & /# {1, 4}
{{"East", "North", "South", "West"}, {"01/2011", "02/2011", "03/2011",
"04/2011", "05/2011", "06/2011", "07/2011", "08/2011", "09/2011",
"10/2011", "11/2011", "12/2011"}}
We may use Outer to set up a rectangular template for TableForm:
template = Outer[List, Apply[Sequence][headings]];
Main job with GroupBy and Total as third argument:
pattern = Append[Normal #
GroupBy[data, (#[[{1, 4}]] &) -> (#[[-1]] &), Total],
_ -> Null];
Finally, inject pattern into template (and apply TableForm headings for beauty):
TableForm[Replace[template, pattern, {2}], TableHeadings -> headings]
This outputs some:
Note: we have made a total of last column in data. (Many other aggregations are, of course, possible.)

Use http://www.wolfram.com/products/applications/excel_link/ , this way you have the best of both worlds. This product creates a flawless link between Excel and mma, 2-ways.

Here's what I've come up with. It uses the function SelectEquivalents defined in What is in your Mathematica tool bag?. Function1 and Function2 are meant to have different grouping possibilities of criteria1 and criteria2. FilterFunction is here in order to define an arbitrary filter formula on the data based on the header names.
Using the data example of Mr. Wizard here are some usages of this function.
criteria={"Region", "Gender", "Style", "Ship Date", "Units", "Price", "Cost"};
criteria1 = "Region";
criteria2 = "Ship Date";
consideredData = "Units";
PivotTable[data,criteria,criteria1,criteria2,consideredData]
A neat example
function2 = If[ToExpression#StringTake[#, 2] <= 6, "First Semester", "Second Semester"] &;
PivotTable[data,criteria,criteria1,criteria2,consideredData,FilterFunction->("Gender"=="Girl"&&"Units"*"Price"<=100&),Function2->function2]
Here's the definition of the function
keysToIndex[keys_] :=
Module[{keyIndex},
(keyIndex[#1] = #2[[1]])&~MapIndexed~keys;
keyIndex
];
InverseFlatten[l_,dimensions_]:= Fold[Partition[#, #2] &, l, Most[Reverse[dimensions]]];
Options[PivotTable]={Function1->Identity,Function2->Identity,FilterFunction->(True &),AggregationFunction->Total,FormatOutput->True};
PivotTable[data_,criteria_,criteria1_,criteria2_,consideredData_,OptionsPattern[]]:=
Module[{criteriaIndex, criteria1Index, criteria2Index, consideredDataIndex, criteria1Function, criteria2Function, filterFunctionTranslated, filteredResult, keys1, keys1Index, keys2, keys2Index, resultTable, function1, function2, filterFunction, aggregationFunction, formatOutput,p,sharp},
function1 = OptionValue#Function1;
function2 = OptionValue#Function2;
filterFunction = OptionValue#FilterFunction;
aggregationFunction = OptionValue#AggregationFunction;
formatOutput=OptionValue#FormatOutput;
criteriaIndex=keysToIndex[criteria];
criteria1Index=criteriaIndex#criteria1;
criteria2Index=criteriaIndex#criteria2;
consideredDataIndex=criteriaIndex#consideredData;
criteria1Function=Composition[function1,#[[criteria1Index]]&];
criteria2Function=Composition[function2,#[[criteria2Index]]&];
filterFunctionTranslated = filterFunction/.(# -> p[sharp, criteriaIndex##]& /# criteria /. sharp -> #)/.p->Part;
filteredResult=
SelectEquivalents[
data
,
TagElement->({criteria1Function##,criteria2Function##,filterFunctionTranslated##}&)
,
TransformElement->(#[[consideredDataIndex]]&)
,
TagPattern->_?(#[[3]]&)
,
TransformResults->(Append[Most##1,aggregationFunction##2]&)
];
If[formatOutput,
keys1=filteredResult[[All,1]]//Union//Sort;
keys2=filteredResult[[All,2]]//Union//Sort;
resultTable=
SelectEquivalents[
filteredResult
,
TagElement->(#[[{1,2}]]&)
,
TransformElement->(#[[3]]&)
,
TagPattern->Flatten[Outer[List, keys1, keys2], 1]
,
FinalFunction-> (InverseFlatten[Flatten[#/.{}->Missing[]],{Length#keys1,Length#keys2}]&)
];
TableForm[resultTable,TableHeadings->{keys1,keys2}]
,
filteredResult
]
];

I little latter in the game. Here is another self contained solution with object like form.
Using random data created by #Mr.Wizard:
key = # -> #2[[1]] & ~MapIndexed~
{"Region", "Gender", "Style", "Ship Date", "Units", "Price", "Cost"};
choices = {
{"North", "South", "East", "West"},
{"Boy", "Girl"},
{"Tee", "Golf", "Fancy"},
IntegerString[#, 10, 2] <> "/2011" & /# Range#12,
Range#15,
Range[8.00, 15.00, 0.01],
Range[6.00, 14.00, 0.01]
};
data = RandomChoice[#, 5000] & /# choices // Transpose;
Using an MapIndexed and SparseArray as key functions, here is the code:
Options[createPivotTable]={"RowColValueHeads"-> {1,2,3},"Function"-> Total};
createPivotTable[data_,opts:OptionsPattern[{createPivotTable}]]:=Module[{r,c,v,aggDataIndex,rowRule,colRule,pivot},
{r,c,v}=OptionValue["RowColValueHeads"];
pivot["Row"]= Union#data[[All,r]];
pivot["Col"]= Union#data[[All,c]];
rowRule= Dispatch[#->#2[[1]]&~MapIndexed~pivot["Row"]];
colRule= Dispatch[#->#2[[1]]&~MapIndexed~pivot["Col"]];
aggDataIndex={#[[1,r]]/.rowRule,#[[1,c]]/.colRule}->OptionValue["Function"]##[[All,v]]&/#GatherBy[data,#[[{r,c}]]&];
pivot["Data"]=Normal#SparseArray#aggDataIndex;
pivot["Properties"]={"Data","Row","Col"};
pivot["Table"]=TableForm[pivot["Data"], TableHeadings -> {pivot["Row"], pivot["Col"]}];
Format[pivot]:="PivotObject";
pivot
]
That you can use as:
pivot=createPivotTable[data,"RowColValueHeads"-> ({"Ship Date","Region","Units"}/.key)];
pivot["Table"]
pivot["Data"]
pivot["Row"]
pivot["Col"]
To get:
I believe that the speed is faster than #Ms.Wizard, but I have to make a better test, and don't have time now.

Resources