6
$\begingroup$

This code

Needs["Calendar`"];
days = {Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday};
c = Count[
     Flatten[Table[
       DayOfWeek[{y, m, 13}], {y, 2000, 2399}, {m, 12}]], #] & /@ days;
TableForm[
  { days, c, PaddedForm[#, {6, 4}] & /@ (100. c/Plus @@ c), 
      ToString //@ Flatten[Position[Sort[c, Greater], #]] & /@ c}, 
        TableDirections -> {Row, Column}, 
          TableHeadings -> {{"day", "numbers of 13s", "percentage", "rank"}, 
            None}]

will give this table: (counts of 13ths over days of week, using 400 years data)

enter image description here

(this is used as an illustration of interesting fact that 13th is more likely to be Friday than any other day of week)

How can I obtain a table that counts Fridays over days of month (1st, 2nd, ...) also over 400 years?

Improve this question
$\endgroup$
  • $\begingroup$ Do I understand the data needs correctly - you want over the 400 year period, a tally of Fridays by the day of month they fell on (regardless of month), that you'll then tabulate? $\endgroup$ – ciao Jul 6 '14 at 7:51
  • $\begingroup$ Correct. @rasher $\endgroup$ – VividD Jul 6 '14 at 7:52
  • $\begingroup$ Isn't the first position of Friday an artefact of your choice of start and end year? If you choose {y, 1993, 2402} Wednesday will be first. $\endgroup$ – Sjoerd C. de Vries Jul 7 '14 at 11:08
  • 1
    $\begingroup$ Paraskevidekatriaphobia... ubpdqn.wordpress.com/2012/04/13/paraskevidekatriaphobia (just for amusement) $\endgroup$ – ubpdqn Jul 7 '14 at 12:52
  • $\begingroup$ @SjoerdC.deVries 400 years is chosen on purpose - that's period of Gregorian calendar, and number of days is fortunately divisible by 7, so any full 400 years weekday/monthday pattern is repeated forever. You chose 410 years, but this result doesn't mean anything, no conclusion regarding probability can be deduced. :) $\endgroup$ – VividD Jul 7 '14 at 19:43
4
$\begingroup$

Some further observations:

data = Cases[DayRange[{401, 1, 1}, {2400, 12, 31}, Friday], {y_, _, 13} -> y];

x = Length /@ Split[data];

{Min@x, Max@x, N[Mean@x, 10]}

{1, 3, 1.720000000}

There are EXACTLY 1.72 Fridays 13th per year over a 400 year period. This can be calculated as follows:

The Gregorian calendar follows a pattern of leap years which repeats every 400 years. There are 4800 months in 400 years, therefore with 688 from the above tables:

N[12*688/4800, 10]

1.720000000

Count[x, #] & /@ {1, 2, 3}

{855, 850, 295}

Pattern of the 295 years with three Fridays 13th:

three = Length /@ Rest@Most@Cases[Split[x /. (1 | 2) -> 0], {___, 0, ___}];

ListPlot[three, AxesOrigin -> {0, 0}, Filling -> Bottom, 
 Ticks -> {Range[0, 295, 59], {2, 5, 10, 11}}, ImageSize -> 600]

enter image description here

This pattern is regular with a repetition of 59 (which is the 17th prime number) years:

Differences@Flatten@Position[three, 11]

{59, 59, 59, 59}

The next scary years are:

 Cases[Split@Cases[DayRange[{2014, 1, 1}, {2099, 12, 31}, Friday], {y_, _, 13}
     :>y], {y_, _, _} :> y]

{2015, 2026, 2037, 2040, 2043, 2054, 2065, 2068, 2071, 2082, 2093, 2096, 2099}

Improve this answer
$\endgroup$
  • $\begingroup$ nice..."lucky" to "unlucky" years...but which are which?...now off to count some black cats... $\endgroup$ – ubpdqn Jul 7 '14 at 13:04
12
$\begingroup$ 
data = Cases[DayRange[{2000, 1, 1}, {2399, 12, 31}, Friday], {y_, m_, d_} :>d] // Tally // Sort;

TableForm[data[[ ;; ;; 2]], TableHeadings -> {None, {"Day", "Number of Fri."}}]

Mathematica graphics

(Reverse@SortBy[data, Last])[[;; 5]]

{{27, 688}, {20, 688}, {13, 688}, {6, 688}, {25, 687}}
Improve this answer
$\endgroup$
  • $\begingroup$ Thanks, very nice and simple answer! This gives me the result that Fridays are most likely to be 6th, 13th, 20th, and 27th - again scary result! $\endgroup$ – VividD Jul 6 '14 at 8:01
  • 3
    $\begingroup$ @VividD If the 13th of the month is most likely to be a Friday, and a week lasts 7 days, then it's logical that the 6th, 20th and 27th will also most likely be a Friday. $\endgroup$ – shrx Jul 6 '14 at 12:36
  • $\begingroup$ @oska - thanks for editing in table & details - I had to hit the sack right after posting... $\endgroup$ – ciao Jul 6 '14 at 19:27
  • $\begingroup$ @rasher My pleasure, I just hope I didn't destroy it ;) I don't have v9 :D $\endgroup$ – Öskå Jul 6 '14 at 20:20
5
$\begingroup$ 
Sort@Tally[DayRange[{2000, 1, 1}, {2399, 12, 31}, Friday][[All, 3]]]
% == data (* from rasher's post *)
(* True *)

or 

Tally[Sort[DayRange[{2000, 1, 1}, {2399, 12, 31}, Friday][[All, 3]]]]

or

Through[{First, Length}[#]] & /@ 
            Split[Sort[DayRange[{2000, 1, 1}, {2399, 12, 31}, Friday][[All, 3]]]]

or

Through[{First, Length}[#]] & /@ 
            Gather[Sort[DayRange[{2000, 1, 1}, {2399, 12, 31}, Friday][[All, 3]]]]

All give the same result.

And

Commonest[DayRange[{2000, 1, 1}, {2399, 12, 31}, Friday][[All, 3]]]
(*  {6, 13, 20, 27}  *)
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.