# Constructing transition probability matrix

I have the following list:

x={"A", "A", "A", "E", "D", "D", "D", "C", "B", "E", "E", "E", "D", \
"B", "A", "D", "B", "E", "C", "A", "D", "A", "A", "A", "A", "C", "C", \
"C", "D", "D", "E"}


I want to make the Markov transition probability matrix of first order. To do so I have started by writing:

Partition[x, 2, 1] // Sort // Counts


This will give:

<|{"A", "A"} -> 5, {"A", "C"} -> 1, {"A", "D"} -> 2, {"A", "E"} ->
1, {"B", "A"} -> 1, {"B", "E"} -> 2, {"C", "A"} -> 1, {"C", "B"} ->
1, {"C", "C"} -> 2, {"C", "D"} -> 1, {"D", "A"} -> 1, {"D", "B"} ->
2, {"D", "C"} -> 1, {"D", "D"} -> 3, {"D", "E"} -> 1, {"E", "C"} ->
1, {"E", "D"} -> 2, {"E", "E"} -> 2|>


above shows the frequencies of state transition A to A, A to B, A to C, A to D and A to E and so on for other letters, I wonder how can I show this result as a matrix?

You can use SparseArray with additive assembly as follows:

x = RandomChoice[Alphabet["English", "IndexCharacters"], 1000000];
data = Flatten[ToCharacterCode[x]] - (ToCharacterCode["A"][[1]] - 1); // AbsoluteTiming // First
A = With[{
spopt = SystemOptions["SparseArrayOptions"]},
InternalWithLocalSettings[
SetSystemOptions["SparseArrayOptions" -> {"TreatRepeatedEntries" -> Total}],

(*assemble matrix*)
SparseArray[
Partition[data, 2, 1] -> 1,
Max[data] {1, 1}
]

,
(*reset "SparseArrayOptions" to previous value*)
SetSystemOptions[spopt]]
]; // AbsoluteTiming // First


0.739454

0.114682

# Remarks

• As the timings suggest, it is worthwhile to avoid strings in the first place.

• Formerly, I used LetterNumber, but ToCharacterCode is much, much faster.

• It is "TreatRepeatedEntries" -> Total which enables summing of entries. Count is not needed anymore. DeveloperToPackedArray might speed up things a bit if x is very long. The other hokus-pokus is for making things bulletproof against aborts (i.e., options are reset even if computations are interrupted). See also (37566) and (136017).

• That "TreatRepeatedEntries" -> Total is a nice trick! Commented Aug 7, 2018 at 13:41
• Thank you, @ChrisK. You know, I could not live without the "TreatRepeatedEntries" option. Commented Aug 7, 2018 at 13:46
• @HenrikSchumacher Thank you for this, I turned this into matrix form using //MatrixForm and I got the answer I was after, I wonder if it is possible to use the same for different size of partition and offsets? Such as SparseArray[ Partition[DeveloperToPackedArray[LetterNumber[x]], 3, 1] -> 1] in that case I get wrong matrix positions Commented Aug 7, 2018 at 14:56
• You may try this, instead: A = With[{ data = DeveloperToPackedArray[LetterNumber[x]], spopt = SystemOptions["SparseArrayOptions"] }, InternalWithLocalSettings[ SetSystemOptions[ "SparseArrayOptions" -> {"TreatRepeatedEntries" -> Total}], SparseArray[Partition[data, 3, 1] -> 1, Max[data] {1, 1, 1}], SetSystemOptions[spopt]]]. It prescribes the tensor dimensions explicitly. Commented Aug 7, 2018 at 14:59

You can use the package CrossTabulate.m. (More detailed references are given in this MSE answer.)

Import["https://raw.githubusercontent.com/antononcube/MathematicaForPrediction/master/CrossTabulate.m"]

cmat = CrossTabulate[Partition[x, 2, 1]];

MatrixForm[cmat]


cmat["SparseMatrix"] = cmat["SparseMatrix"]/Total[cmat["SparseMatrix"], {2}];
MatrixForm[cmat]


ArrayRules[cmat["SparseMatrix"]]

(* {{1, 1} -> 5/9, {1, 5} -> 1/9, {1, 4} -> 2/9, {1, 3} -> 1/
9, {2, 5} -> 2/3, {2, 1} -> 1/3, {3, 2} -> 1/5, {3, 1} -> 1/
5, {3, 3} -> 2/5, {3, 4} -> 1/5, {4, 4} -> 3/8, {4, 3} -> 1/
8, {4, 2} -> 1/4, {4, 1} -> 1/8, {4, 5} -> 1/8, {5, 4} -> 2/
5, {5, 5} -> 2/5, {5, 3} -> 1/5, {_, _} -> 0} *)

• I like to create a transition matrix using a weighted, directed graph with the domain of weights, [0, 1.5]. My states will be 7 equal length subsets of the domain and the transition matrix will have the number of binary links in each subset. I could have asked a new question but then I realized that instead of letters I wanted to use subsets. I have two directed graphs (time t and t+1) to start with the exercise. But you may just create two randreal graphs to answer. Can you help me? Commented Aug 25, 2020 at 22:49
• @TugrulTemel Yes, please post a new MSE question. (The possible answers are too long to be just comments...) Commented Aug 26, 2020 at 12:23
• I have posted a new question yesterday after sending you my request. I realized that the answers are too long for comments. Commented Aug 26, 2020 at 12:27

You can also use EstimatedProcess and MarkovProcessProperties as follows:

states = DeleteDuplicates[x];
ordering = Ordering[states];
data = ArrayComponents @ x ;
estproc = EstimatedProcess[data, DiscreteMarkovProcess[Length@states]];
tm = MarkovProcessProperties[estproc, "TransitionMatrix"][[ordering, ordering]]

`
$\begin{array}{cccccc} & \text{A} & \text{B} & \text{C} & \text{D} & \text{E} \\ \text{A} & \frac{5}{9} & 0 & \frac{1}{9} & \frac{2}{9} & \frac{1}{9} \\ \text{B} & \frac{1}{3} & 0 & 0 & 0 & \frac{2}{3} \\ \text{C} & \frac{1}{5} & \frac{1}{5} & \frac{2}{5} & \frac{1}{5} & 0 \\ \text{D} & \frac{1}{8} & \frac{1}{4} & \frac{1}{8} & \frac{3}{8} & \frac{1}{8} \\ \text{E} & 0 & 0 & \frac{1}{5} & \frac{2}{5} & \frac{2}{5} \\ \end{array}$