Kickstarter Data

https://www.kaggle.com/kemical/kickstarter-projects

Questions

1. Which project categories have viewers that give the highest average donation?
2. Per category, what’s the success to failure rate/ratio of all projects?
3. What Kickstarter categories have been most popular over time?

library(tidyverse)
library(lubridate)
library(scales)
library(MASS)
library(viridis)

# Use progress=FALSE to remove the progress bar!
ks2018 <- read_csv("./data/ks-2018.csv",col_names=TRUE, progress=FALSE) 

Parsed with column specification:
cols(
  ID = col_integer(),
  name = col_character(),
  category = col_character(),
  main_category = col_character(),
  currency = col_character(),
  deadline = col_date(format = ""),
  goal = col_double(),
  launched = col_datetime(format = ""),
  pledged = col_double(),
  state = col_character(),
  backers = col_integer(),
  country = col_character(),
  `usd pledged` = col_double(),
  usd_pledged_real = col_double(),
  usd_goal_real = col_double()
)

# Get rid of spaces in column names, replace with underscore
colnames(ks2018) <- gsub(" ", "_",colnames(ks2018))

Which project categories have viewers that give the highest average donation?

Technology

# Roll up dataset into mean pledge per backer per category
pledgeByCat <- ks2018 %>%
    group_by(main_category) %>%
    summarize(
        pledged=sum(usd_pledged, na.rm = TRUE),
        backers=sum(backers, na.rm = TRUE),
        avg=pledged/backers) %>%
    arrange(desc(avg))
# Change main_category into a factor so ggplot will honor the sort order
pledgeByCat$main_category <- factor(pledgeByCat$main_category, levels=pledgeByCat$main_category)
# Plot bar chart of mean pledges
pledgeByCatPlot <- ggplot(pledgeByCat, aes(x=main_category,y=avg,fill=avg)) + geom_col() + labs(title="Avg Pledge By Category Per Backer", x="Category",y="Avg Pledge Per Backer") + theme(axis.text.x=element_text(angle=90),legend.position = "null")
print(pledgeByCatPlot)

Per category, whats the success to failure rate/ratio of all projects?

Dance has the highest success rate, but a low number of projects overall

# Roll up dataset
successPerCat <- ks2018 %>%
    group_by(main_category) %>%
    summarize(
        fails = sum(state == "failed", na.rm = TRUE),
        success = sum(state == "successful", na.rm = TRUE),
        success_rate = success / (success + fails) * 100
    ) %>%
    arrange(desc(success_rate))

# Change main_category into a factor so ggplot will honor the sort order
successPerCat$main_category <- factor(successPerCat$main_category, levels=successPerCat$main_category)

# Plot bar chart
successPerCatPlot <- ggplot(successPerCat, aes(x=main_category,y=success_rate,fill=success_rate)) + geom_col() + labs(title="Percent Success Per Category", x="Category",y="Percentage Successes") + theme(axis.text.x=element_text(angle=90),legend.position = "null")

print(successPerCatPlot)

failTotals <- ggplot(successPerCat, aes(x=main_category,y=fails)) + geom_col()

successAndFails <- failTotals + geom_col(position="dodge", aes(y=success,fill=factor(success))) + theme(axis.text.x=element_text(angle=90),legend.position = "null")

print(successAndFails)

successPerCat <- ks2018 %>%
  filter(state %in% c("successful", "failed")) %>%
  group_by(main_category, state) %>%
  summarize(category_count=n()) %>%
  mutate(category_percent=category_count/sum(category_count)) %>%
  arrange(desc(state), category_percent)

# Change main_category into a factor so ggplot will honor the sort order
successPerCat$main_category <- factor(successPerCat$main_category,
                                      levels=unique(successPerCat$main_category))

print(successPerCat$main_category)

successTotals <- ggplot(successPerCat, aes(x=main_category, y=category_percent, fill=state)) + geom_col()
successAndFails <- successTotals + 
  geom_col(position="fill") + 
  scale_fill_discrete(breaks=c("successful", "failed")) + 
  scale_y_continuous(labels=scales::percent) +
  theme(axis.text.x=element_text(angle=90),legend.position = "null")

print(successAndFails)

Trends in kickstarter categories over time

Hypothesis: kickstarter began with mainly tech projects and then expanded over time

# Roll up dataset to number of projects per category per year
catOverTime <- ks2018 %>%
    mutate(year=year(deadline)) %>%
    group_by(main_category,year) %>%
    summarize(cat_total=n()) %>%
    filter(year < 2018) %>%
    arrange(cat_total)
# Line chart of projects per category per year
catOverTimePlot <- ggplot(
    catOverTime, 
    aes(x=year,y=cat_total,colour=main_category)) + geom_line()
print(catOverTimePlot)

# Unfortunately this isn't super readable?

Retrying the above data with a modified dplyr filter and a density plot, to try and get a better visual of the data

Is there a way to reduce the number of distinct categories so we can only view the top 10% most popular categories?

# Roll up dataset to number of projects per category per year
# Remove summarize because that frontloads the process that the density plot wants to do
# which is counting the number of events
catOverTime2 <- ks2018 %>%
    mutate(year=year(deadline)) %>%
    group_by(main_category,deadline) %>%
    filter(year < 2018) %>%
    arrange(deadline)
# Density plot of projects
# histogram - plotting frequency of an event in the y axis, versus the scale/groups in the x axis
catDensity <- ggplot(
    catOverTime2,
    aes(x=deadline,fill=main_category,colour=main_category)) + geom_density(alpha = 0.1)
print(catDensity)

Trying a heatmap to visualize the trends in categories

According to our heat map, art projects like film/video and music were most popular. Games and technology did not become popular categories until later.

# Redo rolling up dataset to include deadline vector
catHeat <- ks2018 %>%
    mutate(year=year(deadline)) %>%
    group_by(main_category,year) %>%
    summarize(
        cat_total=n(), 
        deadline=deadline[1]) %>%
    filter(year < 2018) %>%
    arrange(year)
# Heatmap of categories over time
catHeatPlot <- ggplot(
    catHeat, 
    aes(x=year,y=main_category)) + 
    geom_tile(aes(fill=cat_total)) + 
    scale_fill_gradient(low = 'white', high = 'red') +
    scale_x_continuous(breaks = function(x) unique(floor(pretty(x)))) + 
    labs(title="Most Popular Kickstarter Categories Per Year", x="Year",y="Main Category")
print(catHeatPlot)

Notes

summarize will strip out anything that isnt in the group by, mutation, or in the summarize itself so you need to reference rows in the summarize if you want to include them but they’re not in group by or mutate

Has kickstarter peaked in its popularity as a crowdfunding platform?

There was a peak in Kickstarter popularity in 2015, and its popularity has declined since then

# Define density function
get_density <- function(x, y, n = 100) {
  dens <- MASS::kde2d(x = x, y = y, n = n)
  ix <- findInterval(x, dens$x)
  iy <- findInterval(y, dens$y)
  ii <- cbind(ix, iy)
  return(dens$z[ii])
}
# Frequency of projects y axis, x axis over time
popOverTime <- ks2018 %>%
    group_by(deadline) %>%
    summarize(count=n()) %>%
    mutate(density=get_density(as.integer(deadline), count))
# Scatterplot with a trend line
popOverTimePlot <- ggplot(popOverTime, aes(x=deadline,y=count,color=density)) +
    geom_point() +
    geom_smooth(method="loess", color="Dark Blue") +
    scale_y_continuous(limits=c(0, 400)) + # Remove values over 500
    scale_x_date(date_breaks = "1 year",
                 labels=date_format("%Y"),
                 limits = as.Date(c('2009-01-01','2018-01-01'))) +
    labs(title="Frequency of Kickstarter Projects over Time") +
    scale_color_viridis() +
    theme(legend.position="none")
print(popOverTimePlot)