The following function performs basic formatting of a text and encodes it in a factor of phonemes:
phonemes <- str_split("a ą b c ć d e ę f g h i j k l ł m n ń o ó p r s ś t u ú v w x y z ź ż", pattern=" ")[[1]]
phonemes <- c(phonemes, c("rz", "ch", "ci", "zi", "dż", "dz", "dź", "sz", "cz", "si", " "))
factorize.text <- function(str, phnms=phonemes){
# Converts a string to a factor of phonemes
str <- str_replace_all(str, '[^\\s\\w]*', '') # replace all non-word non-whitespace characters with an empty character
str <- str_replace_all(str, '[0-9]*', '') # replace all numbers with an empty character
str <- str_replace_all(str, '[\\s]+', ' ') # replace a sequence of at least one whitespace character with a single space
str <- str_to_lower(str)
L <- str_length(str) # need to use str_length instead of length because from R's perspective str is a vector of length one
fctr <- factor(character(L), levels=phnms) # allocate memory
str_i = 1 # position in the original string
fctr_i = 1 # position in the factor
print.thr <- round(L/10) # used to print percentage of string processed
while(str_i < L){
if(str_i %% print.thr == 0){
print(paste0(10*str_i/print.thr, "% processed"))
}
s <- str_sub(str, str_i, str_i+1) # take a pair of letters
if(s %in% phnms){
# if the pair is in the phoneme list, add it to the factor
fctr[fctr_i] <- s
fctr_i <- fctr_i + 1
str_i <- str_i + 2
} else {
# otherwise, add the first letter only
fctr[fctr_i] <- str_sub(s, 1, 1)
fctr[fctr_i+1] <- str_sub(s, 2, 2)
fctr_i <- fctr_i + 1
str_i <- str_i + 1
}
}
fctr <- fctr[1:fctr_i] # the final factor will be shorter because we've merged some of the letters
return(fctr)
}Load the original text:
alice <- read_file("Datasets/Ortografia/Alicja.txt")Factorize the original text (it may take a while - loops in R are very slow):
alice <- factorize.text(alice)## [1] "10% processed"
## [1] "20% processed"
## [1] "30% processed"
## [1] "40% processed"
## [1] "50% processed"
## [1] "60% processed"
## [1] "70% processed"
## [1] "80% processed"
## [1] "90% processed"
## [1] "100% processed"The text with errors is already factorized and written in a convenient format. Read it and split over newline character. This procedure will add a blank character at the end, because the file ends with a newline character. Remove the last element and convert the character vector to a factor. You need to specify the factor levels explicitly to make it consistent with the original text.
mutalice <- read_file("Datasets/Ortografia/Mutalicja.txt")
mutalice <- str_split(mutalice, "\n")[[1]]
mutalice <- mutalice[-length(mutalice)]
mutalice <- factor(mutalice, levels=levels(alice))Inspect the number of errors.
print(paste("The text contains", round(100*mean(alice != mutalice), 2), "percent of ortographical errors"))## [1] "The text contains 0.75 percent of ortographical errors"Compute the average occurences of each letter in the original text.
letter.frequency <- tapply(alice, alice, length)
letter.frequency <- letter.frequency/sum(letter.frequency)
round(letter.frequency, 2)## a ą b c ć d e ę f g h i j k l
## 0.09 0.01 0.01 0.01 0.01 0.02 0.07 0.02 0.00 0.01 0.00 0.06 0.02 0.03 0.02
## ł m n ń o ó p r s ś t u ú v w
## 0.03 0.03 0.04 0.00 0.06 0.01 0.03 0.02 0.02 0.01 0.03 0.02 0.00 0.00 0.04
## x y z ź ż rz ch ci zi dż dz dź sz cz si
## 0.00 0.03 0.02 0.00 0.01 0.01 0.01 0.01 0.00 0.00 0.01 0.00 0.01 0.01 0.01
##
## 0.17We will use the texts for supervised training of the Hidden Markov Model. The transition matrix needs to be trained from the original text. Use both texts to train the observation matrix.
We will train the matrix using a ML estimate of transition probabilities. Despite an advanced mathematical derivation, it’s the most natural way you could imagine: just count the numbers of transitions and normalize the rows to sum to 1. Note that if you use apply to normalize the rows, you need to transpose the resulting matrix - apply stacks the vectors column by column. A transposition is implemented in the function t(). The same needs to be done with the observation matrix. We’ll also do a trick - we’ll add one observation to each field of the observation matrix. Even though this adds errors, it actually makes the algorithm work better. Try to comment the trick, see what happens when we correct the text and think why.
M <- matrix(0, nrow=length(phonemes), ncol=length(phonemes), dimnames=list(phonemes, phonemes))
Y <- matrix(0, nrow=length(phonemes), ncol=length(phonemes), dimnames=list(phonemes, phonemes))
for(i in seq(1, length(alice), by=2)){
M[alice[i], alice[i+1]] = M[alice[i], alice[i+1]] + 1
Y[alice[i], mutalice[i]] = Y[alice[i], mutalice[i]] + 1
Y[alice[i+1], mutalice[i+1]] = Y[alice[i+1], mutalice[i+1]] + 1
}
M <- t(apply(M, 1, function(x) x/sum(x)))
Y <- Y + 1 # the trick
Y <- t(apply(Y, 1, function(x) x/sum(x)))We can now check the probabilities of some errors:
round(Y['ć', ], 3)## a ą b c ć d e ę f g h i
## 0.002 0.002 0.002 0.002 0.854 0.002 0.002 0.002 0.002 0.002 0.002 0.002
## j k l ł m n ń o ó p r s
## 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002
## ś t u ú v w x y z ź ż rz
## 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002
## ch ci zi dż dz dź sz cz si
## 0.002 0.067 0.002 0.002 0.002 0.002 0.002 0.002 0.002 0.002We will use the trained matrices to correct the errors in the text. What we want to do is find the most probable vector of states, i.e. the correct letters, given the vector of observations. Since we have trained the matrices, we can use the Viterbi algorithm. We’ll use the algorithm implemented in the library HMM. We will assume that the probability distribution of the first letter is given by the occurences in the original text.
library(HMM)
alice.hmm <- initHMM(States=levels(mutalice), # set of states of Markov process
Symbols=levels(mutalice), # set of possible observations, in our case it's the set of levels
startProbs=letter.frequency,
transProbs=M,
emissionProbs=Y)We have initialized our Hidden Markov Model. Now, run the Viterbi algorithm. Correcting the whole text would take a lot of time; We’ll just correct a fragment.
L = 4000
coralice <- viterbi(alice.hmm, mutalice[1:L]) # Corrected mutalice Let’s look at a fragment the corrected text.
print(paste("Mutated text:\n", str_c(mutalice[1:100], collapse='')))## [1] "Mutated text:\n lewis carroll alicja w krainie czaruw nota baśniowa opowieść o przygodah alicji w krainie czarów powsta"print(paste("Corrected text:\n", str_c(coralice[1:100], collapse='')))## [1] "Corrected text:\n lewis carroll alicja w krainie czarów nota baśniowa opowieść o przygodach alicji w krainie czarów powsta"print(c("Mutated text:\n", str_c(mutalice[3673:4000], collapse='')))## [1] "Mutated text:\n"
## [2] "studnia była widać tak głęboka czy morze alicja spadała tak wolno że miała dości czasu aby rozejrzeć się dokoła i zastanowić nad tym co się dalej stanie przede wszystkim starała się dojżeć dno studni ale jak to zrobić w ciemnościach zaówarzyła jedynie że ściany nory zapełnione były szafami i pułkami na książki tu i ówdzie wisiały mapy i obrazki "print(c("Corrected text:\n", str_c(coralice[3673:4000], collapse='')))## [1] "Corrected text:\n"
## [2] "studnia była widać tak głęboka czy morze alicja spadała tak wolno że miała dości czasu aby rozejrzeć się dokoła i zastanowić nad tym co się dalej stanie przede wszystkim starała się dojrzeć dno studni ale jak to zrobić w ciemnościach zauwarzyła jedynie że ściany nory zapełnione były szafami i półkami na książki tu i uwdzie wisiały mapy i obrazki "Our approach has corrected quite many errors. Note that it didn’t correct the word “morze” to “może” - but the former is a fully correct word, and our method does not look at the context. Our approach has also introduced an error, by changing “ówdzie” to “uwdzie”. That’s reasonable, because “ó” is very rare at the beginning of a word.
Notice also that our approach doesn’t handle foreign words very well (which is also reasonable, because it was trained on a Polish text):
print("Mutated text:")## [1] "Mutated text:"str_c(mutalice[193:248], collapse='')## [1] "wykładowca matematyki w oxfordzie i autor poważnych książek"print("Corrected text:")## [1] "Corrected text:"str_c(coralice[193:248], collapse='')## [1] "wykładowca matematyki w o fordzie i autor poważnych książek"print("Mutated text:")## [1] "Mutated text:"str_c(mutalice[263:324], collapse='')## [1] "opowiedział ją małej alicji pleasaunce liddel i jej dwu siostrom"print("Corrected text:")## [1] "Corrected text:"str_c(coralice[263:324], collapse='')## [1] "opowiedział ją małej alicji pleńsaunce liddel i jej dwu siostrom"print(paste("Before correction:", sum(alice[1:L] != mutalice[1:L]), "errors"))## [1] "Before correction: 33 errors"print(paste("After correction:", sum(alice[1:L] != coralice[1:L]), "errors (including foreign words)"))## [1] "After correction: 22 errors (including foreign words)"Our next task is separating stems from inflectional suffixes. For example, in the word “kraina”, the stem is the “krain” and the inflectional suffix is “a”. We want to make an algorithm which will automatically detect suffixes. But, we have a problem: we have no training set! That is why we need to use unsupervised learning - our HMM needs to figure the transition matrix and emmission probabilites all by itselt.
The Baum-Welch algorithm, covered during the lecture, performs an unsupervised learning of a Hidden Markov Model. We’ll use it to train our model. First, we need to state the initial transition matrix and emmission probabilities. We’ll use some basic knowledge about stems and suffixes. First, if a letter belongs to a stem, then the next letter will rather still belong to a stem than to a suffix. Second, there are no whitespaces in the stem, but a suffix always contains one, so there is a pretty high probability of emmitting a whitespace at the stem. Also, the text will always start from a stem.
In general, it’s not a good idea to start from any matrices. In particular, avoid starting your algorithm on uniform probabilities, because usually that’s a local minimum.
stem.M <- matrix(c(0.9, 0.1, 0.4, 0.6), byrow=T, ncol=2, dimnames=list(c("Stem", "Suffix"), c("Stem", "Suffix"))) # used as a starting point for BW algorithm
stem.M## Stem Suffix
## Stem 0.9 0.1
## Suffix 0.4 0.6stem.Start <- c(1, 0)
stem.Y <- matrix(1, nrow=2, ncol=length(phonemes), dimnames=list(c("Stem", "Suffix"), phonemes))
stem.Y[1, " "] <- 0 # no whitespace at stem
stem.Y[2, " "] <- 3 # slightly higher probability of emmission of whitespace at the suffix
stem.Y[1, ] <- stem.Y[1,]/sum(stem.Y[1, ])
stem.Y[2, ] <- stem.Y[2, ]/sum(stem.Y[2, ])We’re all set with our starting point. Now, create the HMM.
stem.hmm <- initHMM(States=c("Stem", "Suffix"),
Symbols=phonemes,
startProbs = stem.Start,
transProbs=stem.M,
emissionProbs=stem.Y)We have initialized our model with our basic knowledge on stems and suffixes. Now, to train it, use baumWelsch function from the HMM library. The first word in our text is “Lewis”, which is not a Polish word, and may disturb our results. That’s why we won’t use it for training our algorithm. Be warned: BW algorithm may take a considerable amount of time! That’s why we’ll take a very short fragment of the text.
fragmentalice <- alice[10025:11000]
stem.trained <- baumWelch(stem.hmm, fragmentalice)$hmmThe Baum Welch algorithm has now trained our model. Take a look at the inferred transition probabilities:
stem.trained$transProbs## to
## from Stem Suffix
## Stem 0.6126354 0.3873646
## Suffix 0.2642734 0.7357266To get the most probable vector of states, we need to use the Viterbi algorithm.
stemalice <- viterbi(stem.trained, fragmentalice)We can now visualize our results. We’ll highlight the stems by capital letters.
capitalice <- ifelse(stemalice=="Suffix", as.character(fragmentalice), str_to_upper(as.character(fragmentalice)))
str_c(capitalice, collapse="")## [1] "UZNAŁA że jej wzrost już się NIE ZMIENIA postANoWIŁA pójść NAtychmIAst do ogrodu NIEstety KIEdy bIEDNA ALICJA ZNALAZŁA się przy drzWIAch uprzytomNIŁA sobIE że ZApomNIAŁA NA stoLE KLUCZyKA wróciŁA WIęC ALE oKAZAŁo się że jest zbyt mAŁA by dosięgNąć KLUCZA WIDZIAŁA go wyrAŹNIE poprzez szKŁo chciAŁA NAWEt wspIąć się po NogAch stoLIKA ALE byŁy zbyt śLIsKIE KIEdy przEKoNAŁA się bIEDACtwo o bezsKUtECZNości swoIch prób usiADŁA NA podŁoDZE I ZACZęŁA rzEWNIE pŁAKAć dość tego poWIEDZIAŁA sobIE po chWILI surowym toNEm pŁACZ NIC ci NIE pomoże roZKAZUJę ci przestAć NAtychmIAst ALICJA UDZIELAŁA sobIE często tAKIch dobrych rAd choć rzADKo się do NIch stosoWAŁA I CZAsAMI KArciŁA się tAK ostro że KończyŁo się to pŁACZEm rAZ NAWEt usiŁoWAŁA przeciągNąć się ZA uszy Aby UKARAć się ZA oszUKIWANIE w CZAsie pArtII KroKIEtA Którą rozgryWAŁA przeciWKo sobIE ALICJA bARDZo LUbIŁA UDAWAć dWIE osoby NARAZ ALE po Cóż pomyśLAŁA UDAWAć dWIE osoby NARAZ KIEdy LEDWIE wystARCZy mNIE NA JEDNą godNą szACUNKU osobę NAGLE ZAUWAżyŁA pod stoLIKIEm mAŁE szKLANE pude"Our approach has failed spectacularly. There are at least two reasons for this: First, we’ve used a very short fragment of the text. Second, there are words which do not have suffixes. Another possible reason is that there are some other features of words which have a higher influence on the letter distribution. The BW algorithm infers some states which influence the letter distribution - but they may not be the stem and suffix! That’s why we can never fully trust our results, and always need to check if they agree with our predictions.
Let’s inspect reason 2: words with no suffixes. We’ll add another state to our model, called “Other”. Initialize the matrix:
stem2.M <- matrix(c(0.9, 0.1, 0.0, 0.2, 0.6, 0.2, 0.4, 0.0, 0.6), byrow=T, ncol=3, dimnames=list(c("Stem", "Suffix", "Other"), c("Stem", "Suffix", "Other"))) # used as a starting point for BW algorithm
stem2.M## Stem Suffix Other
## Stem 0.9 0.1 0.0
## Suffix 0.2 0.6 0.2
## Other 0.4 0.0 0.6Initialize starting point and emmission probabilities:
stem2.Start <- c(1, 0, 0)
stem2.Y <- matrix(1, nrow=3, ncol=length(phonemes), dimnames=list(c("Stem", "Suffix", "Other"), phonemes))
stem2.Y[1, " "] <- 0 # no whitespace at stem
stem2.Y[2, " "] <- 3 # slightly higher probability of emmission of whitespace at the suffix
stem2.Y[1, ] <- stem2.Y[1,]/sum(stem2.Y[1, ])
stem2.Y[2, ] <- stem2.Y[2, ]/sum(stem2.Y[2, ])
stem2.Y[3, ] <- stem2.Y[3, ]/sum(stem2.Y[3, ])Initialize the model:
stem2.hmm <- initHMM(States=c("Stem", "Suffix", "Other"),
Symbols=phonemes,
startProbs = stem2.Start,
transProbs=stem2.M,
emissionProbs=stem2.Y)Train the model.
stem2.trained <- baumWelch(stem2.hmm, fragmentalice)$hmmPredict the states:
stemalice2 <- viterbi(stem2.trained, fragmentalice)Now, highlight the “Suffix” state. But, be careful: Just because we’ve named it “suffix”, doesn’t mean that it actually corresponds to suffixes. The names of states don’t matter for BW algorithm. Since the algorithm doesn’t know what “Suffix” or “Other” mean, it might as well swap those classes. That’s why we need to inspect all the classes.
capitalice2 <- ifelse(stemalice2=="Suffix", str_to_upper(as.character(fragmentalice)), as.character(fragmentalice))
str_c(capitalice2, collapse="")## [1] "uznałA żE jEJ wzrost juŻ siĘ niE zmiEniA postAnowiłA pójśĆ nAtychmiAst do ogrodu niEstEty kiEdy biEdnA alicjA znalAzłA siĘ przY drzwiAch uprzYtomniłA sobiE żE zApomniałA nA stolE kluCZykA wróciłA wiĘC alE okAzaŁo siĘ żE jEst zbYt małA bY dosiĘgnĄĆ kluczA widziałA go wYraźniE poprzEz szkŁo chciałA nawEt wspiĄĆ siĘ po nogaCH stolikA alE bYŁy zbYt ślIskiE kiEdy przEkonałA siĘ biEdaCtwo o bEzskutECZnośCI swoiCH prób usiAdłA nA podŁodzE i zaczĘŁA rzEwniE płAkaĆ dośĆ tEgo powiEdziałA sobiE po chwilI surowYm tonEm płaCZ niC ci niE pomożE rozkAzujĘ ci przEstaĆ nAtychmiAst alicjA udziElałA sobiE czĘsto tAkiCH dobrYch rAd choĆ rzAdko siĘ do niCH stosowałA i CZAsami karciłA siĘ tAk ostro żE kończYŁo siĘ to płaczEm rAz nawEt usiŁowałA przECIĄgnĄĆ siĘ zA uszy abY ukAraĆ siĘ zA oszukiwAniE w czasiE partiI krokiEta którĄ rozgrYwałA przEciwko sobiE alicjA bArdzo lubiłA udawaĆ dwiE osobY nAraz alE po cóŻ pomyślałA udawaĆ dwiE osobY nAraz kiEdy lEdwiE wYstArczY mniE nA jEdnĄ godnĄ szaCunku osobĘ nAglE zAuwaŻyłA pod stolikiEm małE szklanE pudE"Now, it’s much better! In many words the “Suffix” class actually corresponds to the suffixes. But, the words with no suffixes, like “że” or “się”, are not that well predicted:
capitalice2 <- ifelse(stemalice2=="Other", str_to_upper(as.character(fragmentalice)), as.character(fragmentalice))
str_c(capitalice2, collapse="")## [1] "uznała że jej WZROST już się nie ZMieNia POStaNOWiła Pójść naTYCHMiaST DO OGRODU nieSteTY KieDY bieDna alicja ZnalaZła się Przy DrzwiaCH UPrzyTOMniła SObie że zaPOMniała na STOle KluczYka WRóciła Więc ale OkaZałO się że jeST ZbyT Mała by DOsięGnąć Klucza Widziała GO wyRaźnie POPrzeZ SZkłO CHCIała naweT WSPiąć się PO NOGach STOlika ale byłY ZbyT śliSKie KieDY PrzeKOnała się bieDacTWO O beZSKUteczNOści SWOich PRób UsiaDła na POdłOdze i Zaczęła rzeWnie PłaKać DOść teGO POWieDZiała SObie PO CHWili SUROwyM TOneM Płacz nic CI nie POMOże ROZkaZUję CI PrzeSTać naTYCHMiaST alicja UDZieLała SObie częSTO taKich DObryCH raD CHoć rzaDKO się DO nich STOSOWała i czaSAMi KARCIła się taK OSTRO że KOńczyłO się TO PłaczeM raZ naweT UsiłOWała PrzeciąGnąć się za USZY aby UkaRać się za OSZUKiwaNie W czasie PARTii KROKieTA KTórą ROZGryWała PrzeCIWKO SObie alicja baRDZO lubiła UDawać DWie OSOby naRAZ ale PO cóż POMYślała UDawać DWie OSOby naRAZ KieDY leDWie wyStaRczy Mnie na jeDną GODną SZacUNKU OSObę naGle zaUWażYła POD STOlikieM Małe SZKlane PUde"The “Stem” class is also rather poorly predicted, but it agrees in some words. Using a larger training set (e.g. 200 000 letters) could potentially improve the results, but we would wait for hours for the algorithm to finish.
capitalice2 <- ifelse(stemalice2=="Stem", str_to_upper(as.character(fragmentalice)), as.character(fragmentalice))
str_c(capitalice2, collapse="")## [1] "UZNAŁa Że Jej wzrost JUż SIę NIe zmIenIa posTanowIŁa pÓJŚć NatychmIast do ogrodu NIesTety kIedy BIedNa ALICJa zNALazŁa SIę pRZy dRZWIach upRZytomNIŁa soBIe Że ZapomNIAŁa Na stoLe kLUczyKa wrÓCIŁa wIęc ALe oKazAło SIę Że Jest zByt mAŁa By doSIęgNąć kLUCZa wIDZIAŁa go WyrAŹNIe popRZez szKło chciAŁa NAWet wspIąć SIę po nogAch stoLIKa ALe Były zByt ŚLiskIe kIedy pRZekoNAŁa SIę BIedActwo o BezskuTecznoŚci swoIch prÓB uSIadŁa Na poDłoDZe I zACZęła RZewNIe pŁakAć doŚć Tego powIedzIAŁa soBIe po chwILi suroWym toNem pŁAcz NIc ci NIe pomoŻe rozKazuJę ci pRZestAć NatychmIast ALICJa udzIelAŁa soBIe CZęsto TakIch doBRych Rad chOć RZadko SIę do NIch stosowAŁa I czasamI karciŁa SIę Tak ostro Że koŃCZyło SIę to pŁACZem Raz NAWet uSIłowAŁa pRZeciągNąć SIę Za uszy ABy uKarAć SIę Za oszukIWanIe w CZASIe partIi krokIeta ktÓRą rozgRywAŁa pRZeciwko soBIe ALICJa Bardzo LUBIŁa udAWAć dwIe osoBy Naraz ALe po CÓż pomyŚLAŁa udAWAć dwIe osoBy Naraz kIedy LedwIe WysTarCZy mNIe Na JedNą godNą szAcunku osoBę NagLe ZauwAżyŁa pod stoLIKIem mAŁe szkLANe puDe"Let’s predict the stems for the beginning of the text. Note that we don’t need to train the model again - it’s already trained on the other part of the text. Just use the Viterbi algorithm.
stemalice3 <- viterbi(stem2.trained, alice[50030:51000])Highlight the suffixes:
capitalice3 <- ifelse(stemalice3=="Suffix", str_to_upper(as.character(alice[50030:51000])), as.character(alice[50030:51000]))
str_c(capitalice3, collapse="")## [1] "kApelusznIk zAprzECZAŁ z wiElcE poSĘpnĄ minĄ po czYm dodaŁ w zEszłYm roku pokłóciłEm siĘ z czaSEm nA koncErciE urzĄdzonYm przE królowĄ kiEr bYŁo to nA krótko zanIm on zwarIowaŁ tu wskAzaŁ łYŻECZką od herbaty na szaraka bez piątej klepki miałem wtedy recytować wierszyk jasne słoniątko późno dziś wstało zagrać na trąbie czasu nie miało znasz to może zdaje się że słyszałam kiedyś coś podobnego pamiętasz zatem jak to idzie dalej więc zbierają zewsząd gromadnie za chwilę pewnie zatrąbi ładnie ożywi wszystkie niedźwiedzie w lesie znużone główki susłów podniesie więc chociaż w domu pęka ci głowa jakże jest piękna ta pieśń słoniowa tu suseł wstrząsnął się nagle i zaczął śpiewać przez sen niowasło niowasło niowasło niowasło tak długo dopóki szczypaniem nie zmuszono go do umilknięcia ledwo skończyłem pierwszą zwrotkę rzekł kapelusznik kiedy królowa wrzasnęła na całe gardło on zabija czas ściąć go natychmiast jakie to strasznie dzikie westchnęła alicja i od tej chwili ciągnął dalej kapelusznik czas odmówił mi posłuszeństwa"Stems:
capitalice3 <- ifelse(stemalice3=="Stem", str_to_upper(as.character(alice[50030:51000])), as.character(alice[50030:51000]))
str_c(capitalice3, collapse="")## [1] "KapELUSZNik ZapRZeczał z wIelCe pOsępNą mINą po CZym dodAł w ZeszŁym roku pokŁÓCIŁem SIę z CZAsem Na koNCerCIe uRZądzoNym pRZe krÓLOWą kIer Było to Na krÓTKO zANim on zwARiowAł tu wsKazAł ŁyżeczkĄ od HERBATY NA SZARAKA BEZ PIĄTEJ KLEPKI MIAŁEM WTEDY RECYTOWAĆ WIERSZYK JASNE SŁONIĄTKO PÓŹNO DZIŚ WSTAŁO ZAGRAĆ NA TRĄBIE CZASU NIE MIAŁO ZNASZ TO MOŻE ZDAJE SIĘ ŻE SŁYSZAŁAM KIEDYŚ COŚ PODOBNEGO PAMIĘTASZ ZATEM JAK TO IDZIE DALEJ WIĘC ZBIERAJĄ ZEWSZĄD GROMADNIE ZA CHWILĘ PEWNIE ZATRĄBI ŁADNIE OŻYWI WSZYSTKIE NIEDŹWIEDZIE W LESIE ZNUŻONE GŁÓWKI SUSŁÓW PODNIESIE WIĘC CHOCIAŻ W DOMU PĘKA CI GŁOWA JAKŻE JEST PIĘKNA TA PIEŚŃ SŁONIOWA TU SUSEŁ WSTRZĄSNĄŁ SIĘ NAGLE I ZACZĄŁ ŚPIEWAĆ PRZEZ SEN NIOWASŁO NIOWASŁO NIOWASŁO NIOWASŁO TAK DŁUGO DOPÓKI SZCZYPANIEM NIE ZMUSZONO GO DO UMILKNIĘCIA LEDWO SKOŃCZYŁEM PIERWSZĄ ZWROTKĘ RZEKŁ KAPELUSZNIK KIEDY KRÓLOWA WRZASNĘŁA NA CAŁE GARDŁO ON ZABIJA CZAS ŚCIĄĆ GO NATYCHMIAST JAKIE TO STRASZNIE DZIKIE WESTCHNĘŁA ALICJA I OD TEJ CHWILI CIĄGNĄŁ DALEJ KAPELUSZNIK CZAS ODMÓWIŁ MI POSŁUSZEŃSTWA"Others:
capitalice3 <- ifelse(stemalice3=="Other", str_to_upper(as.character(alice[50030:51000])), as.character(alice[50030:51000]))
str_c(capitalice3, collapse="")## [1] "kaPeluszniK zaPrzeczał Z WieLce PosęPną Miną PO czyM DODał W zeSZłyM ROKU POKłóciłeM się Z czaseM na KOnceRcie UrząDZOnyM Prze KRólową KieR byłO TO na KRótko ZaniM ON ZWariOWał TU WSkaZał łyżeczKą OD herbaty na szaraka bez piątej klepki miałem wtedy recytować wierszyk jasne słoniątko późno dziś wstało zagrać na trąbie czasu nie miało znasz to może zdaje się że słyszałam kiedyś coś podobnego pamiętasz zatem jak to idzie dalej więc zbierają zewsząd gromadnie za chwilę pewnie zatrąbi ładnie ożywi wszystkie niedźwiedzie w lesie znużone główki susłów podniesie więc chociaż w domu pęka ci głowa jakże jest piękna ta pieśń słoniowa tu suseł wstrząsnął się nagle i zaczął śpiewać przez sen niowasło niowasło niowasło niowasło tak długo dopóki szczypaniem nie zmuszono go do umilknięcia ledwo skończyłem pierwszą zwrotkę rzekł kapelusznik kiedy królowa wrzasnęła na całe gardło on zabija czas ściąć go natychmiast jakie to strasznie dzikie westchnęła alicja i od tej chwili ciągnął dalej kapelusznik czas odmówił mi posłuszeństwa"Another spectacular failure! The model works at first, but then classifies everything as stems. One of the reasons for this is what we’ve been dealing with before: overfitting. We’ve performed an extensive training on a small dataset, which has some particular features. In particular, there is no letter “h” in the training set. That’s why the probability of emmiting this letter is always 0 in the trained model.
unique(fragmentalice)## [1] u z n a ł ż e j w r o s t si ę i m p ó ś ć y
## [24] ch d g k b l c rz cz ci ą dz ź sz ń
## 46 Levels: a ą b c ć d e ę f g h i j k l ł m n ń o ó p r s ś t u ú v ...stem2.trained$emissionProbs[, 7:15]## symbols
## states e ę f g h i
## Stem 6.639754e-21 1.637235e-65 0 2.533848e-24 0 1.868535e-01
## Suffix 2.721908e-01 7.508712e-02 0 1.140976e-58 0 1.752279e-02
## Other 6.017969e-40 1.802054e-56 0 1.862595e-02 0 9.134070e-41
## symbols
## states j k l
## Stem 2.909926e-02 3.047215e-02 6.406072e-02
## Suffix 8.730914e-03 2.248617e-19 5.475198e-24
## Other 2.647210e-24 4.030741e-02 4.306958e-03The letter “h” is present in the test set - and this is exactly the beginning of the spectacular failure. After this letter, each sequence of states has an equal probability: zero. The algorithm doesn’t know what to do and just assumes that everything is a stem.
In this situation, one of the ways to improve our model is to make it worse. We need to force it to learn less from the training set. We will do this by specifying a maximum number of iterations of the BW algorithm. This will also allow us to use a larger training set.
longeralice <- alice[10025:20000]
stem2.trained <- baumWelch(stem2.hmm, longeralice, maxIterations=10)$hmmLet’s check the new emission matrix.
stem2.trained$emissionProbs[, 7:15]## symbols
## states e ę f g h
## Stem 0.06793273 0.009666483 3.126662e-04 0.018777179 0.0005290718
## Suffix 0.08619597 0.039423992 1.095066e-05 0.001969772 0.0002254514
## Other 0.02499252 0.001336153 1.351249e-03 0.015979352 0.0001925900
## symbols
## states i j k l
## Stem 0.141992950 0.006071390 0.04421461 0.058998372
## Suffix 0.046334191 0.050735155 0.02558198 0.006153994
## Other 0.003580512 0.002343414 0.02446406 0.003056852stem2.trained$transProbs## to
## from Stem Suffix Other
## Stem 0.49608775 0.5039122 0.0000000
## Suffix 0.09292979 0.6607484 0.2463219
## Other 0.33914684 0.0000000 0.6608532The probability of emmission of the letter “h” is now non-zero. Let’s check how our model performs now:
stemalice3 <- viterbi(stem2.trained, alice[50030:51000])Highlight the suffixes:
capitalice3 <- ifelse(stemalice3=="Suffix", str_to_upper(as.character(alice[50030:51000])), as.character(alice[50030:51000]))
str_c(capitalice3, collapse="")## [1] "kApelusznik ZAprzeczał Z wielCE posępnĄ MINĄ po czyM dodał w zeszłyM roku pokłóciłEM SIĘ Z CZASEM NA KonCErciE UrządzonyM prze królowĄ KIEr było to na Krótko zaniM on zwariował tu wskazał ŁYŻECZKĄ od hErbaty na SZAraka BEZ piĄTEJ klEpki miałEM wtedy reCytowaĆ wierszyk JAsnE słoniĄtko późNo dziś wstało ZAgraĆ NA trąbiE CZAsu niE MIAŁo znasz to możE ZDAJE SIĘ ŻE słyszałaM KIEdyś Coś podobnEgo pamiĘtasz ZATEM JAK to idziE dalEJ wiĘC zbieraJĄ ZEWSZĄd gromadniE ZA CHwilĘ pewniE ZAtrąbi ŁAdniE ożywi wszystkiE niedźwiedziE w lESIE ZNUŻonE główki susłów podniESIE wiĘC CHociaŻ w domu pęka CI głowa JAKŻE JEst piĘKNA ta pieśń słoniowa tu suseł wstrzĄsnął SIĘ naglE I ZACZĄŁ śpiewaĆ przez sen NIowasło NIowasło NIowasło NIowasło tak dłUgo dopóki SZCZypaniEM NIE ZMUSZono go do umilkniĘCIA lEdwo skończyłEM pierwszĄ zwrotkĘ rzekł KApelusznik KIEdy królowa wrzasnĘŁA NA CAŁE gardło on ZAbiJA CZAs ściĄĆ go nAtychmiAst jakiE to straszniE dzikiE WEstchnĘŁA aliCJA I od teJ CHwili CIĄgnął dalEJ KApelusznik CZAs odmówił MI posłuszeńStwa"Stems:
capitalice3 <- ifelse(stemalice3=="Stem", str_to_upper(as.character(alice[50030:51000])), as.character(alice[50030:51000]))
str_c(capitalice3, collapse="")## [1] "KapELUSZNIK zaprzECZAŁ z wIELce posępNą miną po CZYm dodAŁ w zESZŁYm roku poKŁÓCIŁem się z czasem na koNcerCIe urzĄDZONYm prze krÓLOWą kier było to NA krótko zANIm oN zwarIOWAŁ tu wskazAŁ łyżeczką od Herbaty NA szarAKA bez pIątej kLepKI mIAŁem wtedy rEcytowAć wIERSZYK jasNe sŁONIątko pÓŹno DZIŚ wstAŁO zagrAć na trĄBIe czasu NIe miało zNASZ to moŻe zdaje się że sŁYSZAŁAm kiedyŚ coŚ podobNego pamIętASZ zatem jak to IDZIe dALej wIęc zbIERAją zewsząd gromadNIe za chwILę pEWNIe zatrĄBI ładNIe oŻYWI wszystKIe NIEDŹWIEDZIe w Lesie znużoNe gŁÓWKI susŁÓW podNIesie wIęc choCIAż w domu pĘKA ci gŁOWA jakże jest pIękna ta pIEŚŃ sŁONIOWA tu susEŁ wstRZąsNĄŁ się NAGLe i zaczął śpIEWAć przez sEN niowasŁO niowasŁO niowasŁO niowasło tak dŁugo dopÓKI szczypANIem nie zmuszono go do umILKNIęcia Ledwo skoŃCZYŁem pIERWSZą zwrotKę rzEKŁ kapELUSZNIK kiedy krÓLOWA wrzasNęła na całe gardło oN zabIja czas ŚCIąć go NatychmIast JAKIe to strASZNIe DZIKIe westchNęła ALIcja i od tEj chwILI ciągNĄŁ dALej kapELUSZNIK czas odmówIŁ mi posŁUSZEŃstwA"Others:
capitalice3 <- ifelse(stemalice3=="Other", str_to_upper(as.character(alice[50030:51000])), as.character(alice[50030:51000]))
str_c(capitalice3, collapse="")## [1] "kaPelusznik zaPRZeczał z Wielce POSĘPną miną PO czym DODał W Zeszłym ROKU POkłóciłem się z czasem na kOnceRcie uRZądzonym PRZE KRólową kieR BYŁO TO na kRÓTKO Zanim On ZWARiował TU WSKAZał łyżeczką OD heRBATY na szaRaka bez Piątej KlePki Miałem WTEDY RecYTOWać Wierszyk jaSne SłoniąTKO PóźnO dziś WSTało zaGRać na TRąbie czaSU nie miałO Znasz TO MOże zdaje się że Słyszałam kieDYś cOś PODOBneGO PAMięTasz zatem jak TO idzie Dalej Więc ZBierają zewsząD GROMADnie za chWilę Pewnie zaTRąbi łaDnie Ożywi WSZYSTkie niedźwiedzie W lesie znużOne Główki SUSłów PODniesie Więc chOciaż W DOMU Pęka ci Głowa jakże jeST Piękna TA Pieśń Słoniowa TU SUSeł WSTrząSnął się nagle i zaczął ŚPiewać PRZEZ Sen niOWASło niOWASło niOWASło niOWASŁO TAK DłuGO DOPóki szczYPaniem nie zmuszONO GO DO UMilknięcia leDWO SKOńczyłem Pierwszą ZWROTkę RZekł kaPelusznik kieDY KRólowa WRZASnęła na całe GARDŁO On zaBija czaS ściąć GO naTYCHMiaST jakie TO STRasznie dzikie weSTCHnęła alicja i OD Tej chWili ciąGnął Dalej kaPelusznik czaS ODMÓWił mi POSłuszeńsTWa"Now, it’s much better (even though still not great). To get the best results, we would need to experiment some more with our parameters, initial conditions, and the model itself.
The message of this tutorial: Hidden Markov Models are an art rather than a recipe. There is no simple theorem on how to make a good model and train it properly. We usually need to experiment with several solutions and know some tricks.