R Code

Data, Actually

4 Comments

♪ I feel it in my fingers, I feel it in my toes. ♪

Christmas is in the air and someone, somewhere is watching Love, Actually. Last year, David Robinson at Variance Explained took the entire script and analyzed the social networks within the film. 

With his interactive shiny app you can select a scene and see which characters have interacted with each other up to that point in the movie.

Early on, you see multiple distinct story lines developing.

Scene 7

Scene 7 - Love Actually

As the movie goes on, more and more characters interact.

Scene 38

Scene 38 - Love Actually

By the end of the movie, the social network has become completely entangled, when most of the characters come together at the school Christmas concert.

Scene 57 

Scene 57

Robinson shares his analysis along with all of his R code and even wraps it all up with a nice message. Find it here.

Awkward Celebrity Couples

Leave a comment

In this post, we’ll take a look at how some famous couples stack up against the age rule of thumb, mentioned in an earlier post. For reference, here are the equations:Dating range calculationsAccording to the rule of thumb, dating someone older than your max or younger than your min would be considered objectionable.

In the graph below, each line represents a relationship. If the line falls within the blue zone, the age difference of the couple was socially acceptable for that portion of their relationship.

celebrity-legend

celebrity_plot

If the graph is confusing to read, hopefully the following diagram helps:How to Read the GraphFor example, looking at the pink solid line for Demi Moore and Ashton Kutcher, the coordinates for the circle are [42,27], so they got married when Demi was 42 and Ashton was 27. The pink triangle at the other end of the line means the relationship ended in divorce. The coordinates for the triangle are [51,35], so their relationship ended when Demi was 51 and Ashton was 351.

Hugh Hefner

Hugh Hefner, the king of icky relationships, almost made it into the zone of social acceptance with his 20 year relationship to second wife, Kimberly Conrad, before their divorce. In his current marriage, 90-year-old Hefner would need to stay alive and married to 30-year-old Crystal Harris until he’s 134 and she’s 74 for the couple to cross into the blue zone.

Woody Allen and Soon-Yi Previn

The 35 year age difference between Woody Allen and his wife, Soon-Yi Previn, isn’t the only thing creepy about this relationship. Woody first became involved with then 21-year-old Soon-Yi when he was still in a relationship with Soon-Yi’s adopted mother, Mia Farrow. He had even adopted some of Soon-Yi’s younger siblings. 

SMM and HJH

At age 40,  Sun Myung Moon, the controversial founder of the Unification Church (the church I was raised in) married his wife when she was just 17. During their 52 year marriage, they had 13 children with varying degrees of craziness, the latest iteration being their youngest son’s arms manufacturing business with endorsement from Donald Trump’s son (read more here).

Donald Trump

Surprisingly, of all the couples, Donald and his wife Melania have the least objectionable partnership, at least based on age alone. They’ve been safely within the blue zone for most of their relationship. Perhaps what makes them an awkward couple is their mismatched levels of attractiveness. (Or because everything about Trump is objectionable.)

Demi Moore

Demi (Guynes) Moore married Freddy Moore when she was 17 and he was 29. Later she switched sides, marrying 27 year old Ashton Kutcher when she was 42. For most of their relationship, the age difference between Demi and Ashton was very close to the blue zone. This could suggest that their awkwardness as a couple was because she was an older female dating a younger male, rather than their relative age difference alone, further evidence that the rule of thumb could use some adjusting.

1. Note: Ages are estimated from Wikipedia, which often only lists the year of marriage or divorce, rather than the exact date. Exact ages at marriage or divorce may be slightly off because of this. ↩

The Code

source("./celeb/plot.R") 
source("./celeb/add_seg.R")
source("./celeb/legend.R")

age_plot() #see "Calculate Your Dating Age Range" post for code

#colors
dark_blue <- rgb(68,84,106, max = 255)
blue <- rgb(96,147,125, max = 255)
yellow <- rgb(217,192,7, max = 255)
purple <- rgb(122,98,145, max = 255)
pink <- rgb(247,190,202, max = 255)
hot_pink <- rgb(201,6,45, max = 255)

#plot couples

####Hugh Hefner and Kimberly Conrad
add_seg(26,63,47,84, end = "divorce", col = dark_blue, 
     lty = 'dashed')

####Hugh Hefner and Crystal Harris
add_seg(26,86,30,90, end = "", col = dark_blue)

####Woody Allen and Soon-Yi Previn
add_seg(26,61,45,80,end="", col = purple)

####Rev. and Mrs. Moon
add_seg(17,40,69,92, end = "death", col = yellow)

####Donald Trump and Melania Trump
add_seg(35,58,46,69,end="",col = blue)

####Demi Moore and Freddy Moore
add_seg(17,29,22,34, end = "divorce", col = hot_pink , 
     lty = 'dashed')

####Demi Moore and Ashton Kutcher
add_seg(42,27,51,35,end = "divorce", col = hot_pink)

celeb_legends()


#add_seg.R
add_seg <- function(x1,y1,x2,y2,end="",...){
 
     segments(x1,y1,x2,y2,lwd=1.5,...) #plot line segments
     points(x1,y1,pch=16,...)          #plot left endpoint
 
     #add endpoint
     if (end == "divorce") points(x2,y2, pch = 17,...)
          else (
               if (end == "death") points(x2,y2, pch = 15,...)
          )
}


#legends.R
celeb_legends <- function(){
 
     #empty plot
     plot(1, type="n", axes=FALSE, xlab="", ylab="")
 
     #main legend
     legend("topleft", 
          c("Hugh Hefner and Crystal Harris",
          "Hugh Hefner and Kimberley Conrad",
          "Woody Allen and Soon-Yi Previn",
          "Sun Myung and Hak Ja Han Moon",
          "Donald and Melania Trump",
          "Demi Moore and Freddy Moore",
          "Demi Moore and Ashton Kutcher"), 
          col=c(dark_blue,dark_blue,purple,yellow,
               blue,hot_pink,hot_pink),
          lty=c(1,2,1,1,1,2,1), lwd=2,
          inset = .02, bty="n")
 
 
     #endpoints legend
     legend("topright", 
          c("marriage", "divorce","death"), 
          col=hot_pink, pch = c(16,17,15), 
          inset = .02, bty = "n")
}

 

Calculate Your Dating Age Range

16 Comments

Inspired by this xkcd comic, I built an interactive graph and calculator. You can use it to test whether your current relationship is socially acceptable or to calculate what age is too young or too old for you to date. (It might take a few seconds to load.)

dating age range graph sliders

The Equations

For the occasions when you need to quickly calculate whether pursuing a person of a particular age would be objectionable, here are the formulas:

Dating range calculations

So according to this, I could date a guy between the ages of 21 and 42. Personally, it’s wider than I’d probably date. My preferred minimum would be around 25 and maximum around 38, but for a rule of thumb, the calculations don’t seem too far off.

However, the older we get, the calculations start getting outrageous: A 51 year old can date an 88 year old? At 60 you can date anyone between the age of 37 and 106?  Something seems off.

How well do the formulas work?

Lucky for us, Psychology Today investigated this question by studying whether these formulas reflect people’s real preferences.

Here’s a summary of their findings:

  • Men’s preferred minimum age for a partner is close to the formula’s minimum.
  • Both sexes’ preferred maximum age is much younger than what the formula calculates.
  • Women’s preferred minimum acceptable age is older than what the formula calculates.
  • The younger you are, the more accurate the calculations.

You can read more here.

Now, who will create a more accurate calculation?

The Code

For anyone interested in learning how I built this app, here’s the code. If you know R, Shiny apps are surprisingly easy to create. Check out the tutorials at shiny.rstudio.com.

# range.R

# Calculate dating range and create text

range <- function(age){
 
     max_age <- function(x) 2*x - 14
     min_age <- function(x) .5*x + 7
 
     youngest <- min_age(age)
     oldest <- max_age(age)
 
     paste("You can safely date someone between the ages of ", 
          floor(youngest), " and ", floor(oldest), 
          ".", sep = "" )

}


# plot.R

age_plot <- function(){
     
     #set equations for lines
     top <- function(x) 2*x - 14
     bottom <- function(x) .5*x + 7
 
     #set the shading color
     color = rgb(232, 240, 237, max = 255, alpha = 225)
 
     # graph top line and titles
     curve(top, xlim = c(18,100), ylim = c(18,100),
          xlab = "your age", ylab = "your partner's age", 
          main = "Socially Acceptable Dating Range",
          col = color)
 
     # fill between lines
     top.x <- seq(0,110,.01)
     bottom.x <- seq(0,110,.01)
     top.y <- top(top.x)
     bottom.y <- bottom(bottom.x)
     x <- c(bottom.x, rev(top.x))
     y <- c(bottom.y, rev(top.y))
 
     polygon(x, y, col = color, border = color)
 
     # graph bottom line to add border again 
     # (there must be a better way!)
     par(new=TRUE)
     curve(bottom, xlim = c(18,100), ylim = c(18,100),
          xlab = "", ylab = "", col = color)
 
     # add legend
     legend(23,90, legend = "Acceptable" , 
          cex = .9, pch = 15, bty = "n", 
          col = color, pt.cex = 2)
}



# ui.R age_range

library(shiny)

shinyUI(fluidPage(

   # Sidebar with a slider input for each age
   sidebarLayout(
     sidebarPanel(
 
          br(),
          sliderInput("your_age",
               "Select your age:", min = 18,
               max = 100, value = 40
          ),
          br(),
          sliderInput("partners_age",
               "Select your partner's age:", min = 18,
               max = 100, value = 40
          ),
          br(),
 
          # Display the text
          strong("Acceptable Dating Range:"),
          textOutput("text1"),
          br()
     ),
 
     # Display the Acceptable Age Range Graph
     mainPanel(
          br(),
          plotOutput("plot")
     )
 )
))

# server.R Age Range Graph

library(shiny)
source("plot.R")
source("range.R")

shinyServer(function(input, output) {
 
 
     output$plot <- renderPlot({
 
          age_plot()
 
          # graph data point, using input from sliders
          points(input$your_age, input$partners_age, pch=20)
 
     })
 
     # Create text using input from your_age slider
     output$text1 <- renderText({
          range(input$your_age)
 
     })
})

 

If only love were so simple

4 Comments

In case you’ve ever wondered how to graph a heart in R, I’ve figured it out for you. No need to thank me. Pink Heart Graph R

Maybe it could be featured on a nerdy valentine?

The Equations

Heart Graph Equations

 

 

 

 

 

The R Code

###Filled Heart
##Plot the top
  top <- function(x) (1-(abs(x)-1)^2)^.5
  pink <- rgb(201, 6, 45, max = 255)   #set color
  plot(top, xlim=c(-2,2), ylim=c(-3,1),
   ylab="y", col=pink, main="Heart")
##Plot the v
  par(new=TRUE) 
  v <- function(x) -3*(1-(abs(x)/2)^.5)^.5 
  plot(v, xlim=c(-2,2), ylim=c(-3,1),
    ylab="y", col=pink)
##Fill the Graph
  top.x <- seq(-2,2, .01)   #x coordinates for top
  v.x <- seq(-2,2, .01)     #x coordinates for v 
  top.y <- top(v.x)        #y coordinates for top
  v.y <- v(v.x)            #y coordinates for v
  x <- c(v.x, rev(top.x))    #put the coordinates together
  y <- c(v.y, rev(top.y))
  polygon(x, y, col=pink, border=pink)