Automatic edX Pdf Handout creator

Question

I am trying to make an automatic handout creator for my courses on edX. It took me a long time to do it...

(If you don't know edX: https://www.edx.org/)

I wrote a program that adds to each slide provided by edX the coressponding subtitiles that were spoken in the video File.

How: I extract the subscripts timestamps -> I use the timestamps to extract a set of frames from the video file (the frame that is shown in the middle of a subscript time range) -> then I compare the frames with the provided slides to find the position of the slides in the video -> then I use this information to add under each slide the coressponding subtitle text.

In the end, each page should look like this: (the grey border, is only placed here to distinguish the page from the white website background)

Now to the code:

1. I download the videos as ".mov" into a video folder, the subscript text file into a subscript folder and the slides (converted to imgaes ".jpg" ) into a slides folder.

2. Then I run the following code: (I added comments)

I import the subrib files (subtitiles)

Source : Merge transcript and corresponding slides from video

(**Import SubRib File**)

(*File Path*)

subRibFile = 
  "file_path" <> ".srt";

(*Import as string*)

subRip = ReadList[subRibFile, String];

(*Get Time Intervals [h:min:sec:milliosec]*)

subtitleTimings = 
  StringSplit[
   StringReplace[
    Select[subRip, 
     StringMatchQ[#, {__ ~~ Whitespace ~~ "-->" ~~ 
         Whitespace ~~ __}] &], "," -> "."], 
   Whitespace ~~ "-->" ~~ Whitespace];

(*Convert Time Intervals to seconds*)

timesSeconds = 
  Partition[
   UnitConvert[
    Total[DateValue[
        DateObject[#], {"Hour", "Minute", "Second", "Millisecond"}, 
        Quantity]] & /@ Flatten[subtitleTimings], "Seconds"], {2}];

Then I import the video file:

videoFile = 
  "file_path" <> ".mov";

(*Get Frame Rate*)

frameRate = Quantity[Import[videoFile, "FrameRate"], 1/"Seconds"];

(*Get frame number of the start and end of a subtitile *)

framesStartEnd = Round[timesSeconds*frameRate];

(*Get Frmae Numbers in between start and end of each subtitile*)

frameList = 
  Round[(First /@ framesStartEnd + Last /@ framesStartEnd)/2];

(*Import those frames*)

frames = Import[videoFile, {"ImageList", frameList}];

Then I Import the images of the slides:

SetDirectory["path to folder of images"];

(* Extract all images from folder*)

images = FileNames["*.jpg"];
slides = Import[#] & /@ images;

Print["Got all slides!"];

Now I find the position of each slide within the frames of the video -> Recognizing the slides in the video frame. Source:Extract timestamp of specific frames in video

(**Analyze the frames to find position of the slides in the video**)
(*Scale Down the images for faster image analysis*)

res = 48; smallframes = 
 Flatten[ImageData[ImageResize[#, {res, res}]], 1] & /@ 
  frames; smallslides = 
 Flatten[ImageData[ImageResize[#, {res, res}]], 1] & /@ slides;
Print["Resized all images for immage analysis!"];

(*Create Comparaison (slides/frames) metrics*)

SimilarColor[a_, b_] := If[And @@ ((# < 0.05) & /@ ((a - b)^2)), 1, 0];

(*Label each frame according to the most likly slide number*)

Print["Comparing all frames with all slides: "];
labels = Monitor[Table[
    With[
      {score = 
        Total@MapThread[SimilarColor, {#, smallframes[[i]]}] & /@ 
         smallslides},
      Position[score, Max[score]]][[1, 1]], {i, Length[frames]}], i];

Now I find the range of frames which show the same slide -> To know the range of subtiles to add to the specific slide. Source: List of same images -> Find intervals of same images

similarFrames = 
  SplitBy[Transpose[{#, Range@Length@#}], First][[;; , {1, -1}, 2]] &@
   labels;

I remove slides which were not shown in the video (can happen):

(**Remove Unseen Slides**)

(*Sometimes there are more slides given than do appear in the video, \
therefore one makes a new list of slides with only the slides which \
appear in the video*)

slidesToKeep = DeleteDuplicates[labels];
(*Extracts only those slides*)
slidesKeeped = Part[slides, slidesToKeep ];

I extract the text blocks for each slide from the subtitles:

(**Extract Text for each slide**)

(*Get Timestaps of the beginning of each subscript*)

timeStamps = First /@ timesSeconds;
(*Extract the transcript \[Rule] {{slideNumber,text}}*)
transcripts = 
  Split[Select[
    subRip, ! 
      StringMatchQ[#, {__ ~~ Whitespace ~~ "-->" ~~ 
         Whitespace ~~ __}] &], DigitQ[#] &];

(*Extract all text for each slide*)

onlyText = transcripts[[All, 2]];
text = Map[ToString, 
   onlyText[[#[[1]] ;; # [[2]] ]] & /@ similarFrames];

I filter a bit the text:

(**Clean Text**)

filter1 = StringReplace[text, "," -> ""];
filter2 = StringReplace[filter1, "<i>" -> ""];
textProccessed = StringReplace[filter2, "</i>" -> ""];
textSlide = 
  StringReplace[StringReplace[#, "{" -> ""], "}" -> ""] & /@ 
   textProccessed;

I create two lists.

1. The images: the slides

2. The text: which goes with every slide.

images = Image[#, ImageSize -> Full] & /@ slidesKeeped;
text = textSlide;

I create the Layout. Source: Layout: Images and Text

exportIm = Panel[Style[Grid[{
        {images[[#]], SpanFromLeft},
        {TextCell[Row[{text[[#]]}], TextJustification -> 1, 
          Hyphenation -> False], SpanFromLeft}, {}, {"Notes: "}}, 
       Frame -> {{False, False}, {True, True, True, False}, {False}}, 
       BaseStyle -> ImageSizeMultipliers -> 1], 7, 
      FontFamily -> "Helvetica", Background -> White], 
     Background -> White, ImageSize -> {210, 297}*2] & /@ 
   Range[Length[images]];

Finally, I export the individual slides (I do not merge them into one PDF because MA is quiet slow with that -> do it with external software):

SetDirectory[
   "path_to_export"];

 Export[ToString[#] <> ".pdf", exportIm[[#]]] & /@ 
   Range[Length[exportIm]];

The program works, but is still not reliable. Sometimes it does not identify the slides in the correct order or there is text missing.

Therefore, I would be awesome, if you could help me to make it more robust !

Here are two MOOC courses to test the program and improve it: https://www.dropbox.com/sh/raajt9qetqnj7p9/AACEV3PhjhRmwTDjvdtcnEc3a?dl=0

The first one (2) has the tricky part, that within the mooc video they show not only slides, but also at a certain time a short video, which messes up the result.

There are also some difficulties with the second (3), as it fails to indentify the slides in the correct order and the text also has some problems.

I looking forward seeing your suggestions and improvements ! :)

DOWNLOAD complete code (thanks to @jjc385) here: https://github.com/jjc385/mmase-159065_annotated-lecture-slides/blob/master/pasted-OP-code.m

Check Your Code

To check that your code works correctly, I have created a pdf for video 2, which shows the slide number, the slide and the start and end subtitles for each slide. Please download it here: https://www.dropbox.com/s/hdxajnfve0nzf5i/Slides%20and%20Subtitles%20Start_End%20for%202.pdf?dl=0

The correct identification of the slides of the later video should be: 1,2,3,4,5,4,6,7,8,9,10,11,12,13,12,13,14,13,15,16,17,18

Be careful: There are repeating slides !

Answer 1

I'll start with two improvements:

Extracting frames

I couldn't import .mov files the way you do, because I don't have QuickTime. It turns out using ffmpeg is much faster. Another nice feature is that we can pass the time of the frame we want to get, so we do not need to bother about the frame number. I denote the number of the video videoNumber (would be 2 or 3). The following function converts a time in seconds into a string in the required format:

TimeString[s_] := DateString[s, {"Hour",":","Minute",":","Second",".","Millisecond"}];

Then we go through each time in timeSeconds, extract the frame and load it.

SetDirectory[NotebookDirectory[] <> "Videos"];
frames = Monitor[Table[
    ReadList["!ffmpeg -y -ss " <> 
      TimeString[(timesSeconds[[i, 1, 1]] + timesSeconds[[i, 2, 1]])/2]
      <> " -i " <> ToString[videoNumber] <> ".mov -frames:v 1 tmp.jpg"];
    Import["tmp.jpg"], {i, Length[timesSeconds]}], 
  ToString[i] <> "/" <> ToString@Length[timesSeconds]];
DeleteFile["tmp.jpg"];

Recognizing the slides

I implement your suggestion to use the knowledge that the slides have to appear in a given order, enhance the images before comparison and additionally use a text based comparison for difficult cases.

By pixel color

The slides you show in the video and the slides that you provided can be quite different. In particular the brightness can differ significantly. One way around this is to preprocess the images before comparison. One could try many different functions here, I use ImageExposureCombine and a Gamma correction to better see the details for different brightness.

enhance[img_] := Sharpen@ImageExposureCombine[{img, ImageAdjust[img, {0, 0, 4}]}];

As in your question, we scale down the images for the analysis to speed it up:

res = 48;
smallSlides = enhance@ImageResize[#, {res, res}] & /@ slides;
smallFrames = enhance@ImageResize[#, {res, res}] & /@ frames;

The similarity of two images is measured by the function score, where, in contrast to the first version of this answer, I use ColorDistance to judge how similar two images are. This is still the same idea, but now relying on a built-in function.

score[frame_, slide_] := score[frame, slide] = 
  If[slide <= 0 || slide > Length[slides], 0,
    1 - ImageData[ImageResize[ColorDistance[smallSlides[[slide]], 
      smallFrames[[frame]]], {1, 1}]][[1, 1]]^0.1];

The exponent of 0.1 is only a rescaling of the score, which makes it "more strict" and thus more comparable to the following text-based comparision.

By text

Sometimes the arrangement of the provided slides differs from the slides in the video. In this case the similarity test will not be helpful. We use a comparison based on TextRecognize in these cases, which is slow but handles different arrangements well.
To give an idea of what we have to distinguish in the data: This is one of the video frames.

Is it the following slide?

Or is it maybe this slide:

The text-based score is basically the percentage of english words (as given in WordList[]) that are found in both the frame and the slide. Restricting to english words filters out garbage of TextRecognize. In the given example it actually detects that the second slide is "shown" in the video. The code:

Clear[textscore];
Clear[slidewords];
Clear[framewords];
slidewords[slide_] := slidewords[slide] = 
   Intersection[ToUpperCase[WordList[]], 
    ToUpperCase@StringSplit@
      TextRecognize[LocalAdaptiveBinarize[slides[[slide]], 50], Language -> "English"]];
framewords[frame_] := framewords[frame] = 
    Intersection[ToUpperCase[WordList[]], 
     ToUpperCase@StringSplit@
       TextRecognize[LocalAdaptiveBinarize[frames[[frame]],50], Language -> "English"]];;
textscore[frame_, slide_] := 
  If[slide <= 0 || slide > Length[slides], 0,
   Length@Intersection[framewords[frame], slidewords[slide]]/
    Max[Length[framewords[frame]], Length[slidewords[slide]]]];

And when to use which method

We go through all frames to label them by the slide they are showing. While we do this, we keep track of the currentSlide. We can allow jumps between the slides up to a given step size, for example two. This is useful, because sometimes there are videos and then we go back to the previous slide. We always pick the step with the highest score, but we stay if all scores are below some threshold (for example 10%). By default we use the color comparison by pixel, because it is fast. But if the two best scores are close (for example 95%), and the frame has text on it, we choose to use the TextRecognize-based scoring. This is the code:

currentSlide = 1;
labels = Monitor[Table[
    stepscores = 
     Append[Table[{step,score[i, currentSlide + step]}, {step, {-1, 0, 1, 2}}], {0,0.1}];
    If[(Max[stepscores[[All, 2]]] <= 0.1 || 
        Sort[stepscores[[All, 2]], Greater][[2]] > 
         0.95 Max[stepscores[[All, 2]]]) && Length[framewords[i]] > 0,
      stepscores = (stepscores + 
          Append[Table[{step, textscore[i, currentSlide + step]},
                  {step, {-1, 0, 1, 2}}], {0, 0.1}])/2;
     ];
    {bestStep, bestScore} = TakeLargestBy[stepscores, Last, 1][[1]];
    currentSlide += bestStep;
    currentSlide, {i, Length[frames]}], 
   ProgressIndicator[i/Length[frames]]];

The code seems to be pretty robust, but I'm happy to discuss further improvements.

Manual correction

If the slides would look completely different than what is shown in the video, or for some other reason we want to enforce a different association, the following code allows to conveniently change it by hand.

Manipulate[Dynamic[
  If[correction == 1, 
   With[{l = labels[[frame]]}, 
    If[l < Length[slides], 
     For[j = 0, 
      j <= Length[labels] - frame && labels[[frame + j]] == l, 
      labels[[frame + j]]++; j++]]]; correction = 0];
  If[correction == -1, 
   With[{l = labels[[frame]]}, 
    If[l >= 2, 
     For[j = 0, 
      j <= Length[labels] - frame && labels[[frame + j]] == l, 
      labels[[frame + j]]--; j++]]]; correction = 0];
  {{"frame " <> ToString[frame] <> ":", 
     "slide " <> ToString[labels[[frame]]] <> ":"}, {Quiet@
      Show[frames[[frame]], ImageSize -> 320], 
     Quiet@Show[slides[[labels[[frame]]]], ImageSize -> 320]}} // 
   TableForm, TrackedSymbols -> activ],
  {{activ, {}}, {All -> "ON", {} -> "OFF"}}, {frame, 1, 
  Length[frames], 1, AnimationRate -> 2, RefreshRate -> 60, 
  Appearance -> "Open"}, {{correction, 0}, {1 -> "+", -1 -> "-"}}]