MeanMean

Cleaning up SPAM with NLP

Mon, 21 Dec 2020 00:00:00 -0500

Hey, it's the holidays. Time to take some PTO/Leave, hang out with family, relax, and work on some side projects. One of the many projects I finally have time for is removal of 'SPAM' messages from one of the games I play from time-to-time. This allows me to play with some NLP and solve some fun problems, like how to score a model quickly while only using a few mb of RAM in the scripting language Lua.

As someone new to Lua, and only vaguely familiar with XGBoost model dumps, there was a lot of learning to be done. However, I was able to achieve an overall accuracy rate of 95%. Not too bad for a first shot.

Introduction

Final Fantasy XI (FFXI) is a Massive Multiplayer Online Game, that I've been playing on and off for about two decades now. I primarily play the game to get in contact with old friends, enjoy the storyline, and just blow off some steam at the end of the day. However, over the last few years the primary game-wide communication system has been poluted with SPAM messages. This is problematic because, this communication system is also where people find groups to do content.

Other solutions do exist to solve this problem, but they are largely just a set of regular expressions. So I thought I would take a stab in creating a quick natural language processing (NLP) solution to see if I can do better.

One way that I can do better is to not exclusively look at two different types of messages, SPAM and not SPAM. Instead, I can look at useful classes of messages that people can decided if they want to see or not.

Content: Content Messages.
RMT: Real Money Trade, messages for buying/selling items using real money.
Merc: People offering to sell content using in-game currency.
JP Merc: People offering to 'level' your character for you.
Chat: Consersations between players.
Buying: Buying items using in-game currency.
Selling: Selling items using in-game currency.
Other: Unknown messages catch-all.

Like all problems there are constraints. Messages need to be scored in real time, on the computer running the game. To avoid maintaining a message log, messages must be considered individually, so we can't infer class by repeated message frequency as part of the scoring process.

Data Collection

I'm not going into the depths of data collection, but to do any data analysis I do need data. In particular, I need data that I can label. I utilized a project that allows for 3rd party addons for the game, windower. This framework allows a user to interact with various components of the game including in-game messaging through the programming language Lua. This allows me to write a quick plugin that records messages received from my character to a MariaDB database on my home server.

Because the addon only runs when I log into the game, it certainly is not a census of all messages, but should provide a reasonable sample of what types of messages are being sent within the game.

After running this for a few months, I was able to aquire, 98,141 messages. Unfortunately, the data does not come pre-labeled, so I manualy labeled 3,570 messages. This accounts for a total of 1,736 unique messages. For anyone interested, I've made this training data available. An sample of the first five and last five rows is provide below to provide context.

	msg	label	n
1	job points 4m/500p dho gates Ž©“®‚Å‘g‚É“ü‚ê‚é	4	124
2	job points š4m/500pšš all time party dho gates autoinvite	4	114
3	job points 500p/4m 0-2100 15m dho gates moh gates igeo 4song fast tachi: jinpu 99999	4	93
4	job points ššš "500p/4mil dho gates very fast. do you need it? all time party. buy? autoinvite. /tell	4	87
5	experience points pl do you need it? 1-99 3m 1-50 2m 50-99 2m escha - zi'tah	4	70
1732	i bet you are	5	1
1733	job points 500p do you need it? buy? dho gates fast kill	4	1
1734	kyou enmerkars earring mercenary can i have it? you can have this. 15m	3	1
1735	ea houppe. 1 ea slops 1 ninja nodowa 2 do you need it? buy? cheap bazaar@ guide stone.	6	1
1736	alexandrite 5.6k x6000 do you need it? buy? (f-8) bazaar	6	1

Show R Code.

From a quick plot of overall counts of each message type, the JP Merc group clarly stands out. Although the messages in this group are rarely unique, they do account for most volume. This matches with my observations within the game. Likewise, the next largest group, Merc, also has similar trends in that there are lots of repeat messages. These two groups are commonly considered spam by most players. Content and Chat messages, the one most useful for most players are quite different from the spammy messages in both uniqueness and quantity.

Unfortunately, these observations don't help much since capturing message frequency would violate one of our requirements for message scoring. Instead, we would need to build features around model content.

Feature Building

Messages in FFXI are brief and organized. The interquartile range of unique messages within my trained data set is 46 to 78 characters. This is a bit more similar to tweets rather than a blog post or a novel. The messages within each message class are also quite similar. Content messages usually mention the activity the player is trying to do, what various jobs are needed to do this activity, and if needed the distribution of items from the activity. Likewise 'selling' messages usually describe the item, price, and a method to find or contact the individual selling the item.

Because of this brevity and organization, classifying distinct messages is fairly straight forward using n-grams and game specific terminology. The n-grams capture the distinct structure of the message, and the game specific terminology serves as a thesaurus to link together synonyms such as 'paladin', 'pld', and 'tank'. Implementation of the methods will be through a bag-of-words type approach, where each n-gram or word occurence in a message will generate a feature.

Show R Code.

Using a little bit of tidy text it is pretty easy to build out the n-gram features to see what are the most common words and phrases. Note that common words like articles are not removed, they actually turn out to be fairly informative since they rarely show up in the spammy messages, but do show up in the 'chat' class.

Rare words from a TF-IDF approach don't really help out here, since they either exclude important and frequent words used to separate classes, or they just identify words that would appear in the game specific terms.

Show R Code.

I used my own personal experience from reviewing messages and being aware of messaging mechanics to build game specific terms. These link similar game terms together which may be difficult to learn with a small data set like the one I have. To create features using these words I simply use common pattern matching strings in the form of regular expressions. These strings are portable between R and Lua, so it makes if fairly straight forward to implement in both langauges.

Note that matching isn't perfect, subsequences of words are captured along with the word. E.g. 'is' would be captured if 'this' was a part of a message. It is possible to fix this, but would require evaluation of matching implementations in R and lua. Furthermore, there are some nuances with the FFXI auto-translate function that is used frequently by users. Auto-translated words have the unfortunate consequence of having no spaces placed between words.

Show R Code.

Model Building

Although a Neural Network approach may work better in theory, I don't have a huge amount of data. I also have a set of features that are likely to work pretty well for more traditional models, so I went with XGBoost for an initial iteration simply because it is fairly easy to interpret the results and extremely easy to score for new languages with multi-class models. This later property is due to the raw model dumps that XGBoost provides for multi-class problems.

If you are not familiar with XGBoost, it's a popular implementation of gradient boosted tree models using regularization. It allows you to fit a succession of simple models (trees), to create an ensemble of simple trees (boosting). To avoid over fitting, regularization is used to limit the impact of trees that provide little input to the model. A good overview can be found on the XGBoost site.

Implementation of an XGBoost model is fairly straight forward. We already split our data early on, so we just need to build a parameter grid; train XGBoost on our training set to find our best parameters, and then see what features we want to keep.

To train I just did a grid search with cross validation to aid in robust parameter selection. The parameters we are evaluating our model over are a reduced set from a prior and more exhaustive run. With this subset, we will still get pretty good performance and a reasonable run time, usuallly 1-2min on modern computers.

Show R Code.

With our best parameters, we are now going to build a full model using all our training data. Based on this output, we are going to pick which features we are going to keep through a Gain threshold. Gain just gives us an idea of how important a variable is by the increase in accuracy after it is used for a split in the tree.

As an implementation note, if we were going to evaluate different gain value thresholds we would do this as part of the parameter selection step.

Show R Code.

Model	Log Loss
Full	0.0663
Reduced	0.0670

Using our gain threshold of 0.001, we end up with 77 out of 174 variables and a minor reduction in model performance. This is a pretty good trade off and will also lower the run time for model scoring.

Model Evaluation

Now that we have our model, we want to check two important model characteristics: (1) Does the model and it's output make sense? (2) How well does the model perform?

To address the first model characteristic, models are helpful in expanding our knowledge and challenging our hypotheses. However, if they are keying in on variables in a nonsensical way, then it is usually an indication that something has gone wrong.

Show R Code.

The initial way I check if a model makes sense is through feature importance. The features here should align with our understanding fo the phenomena we are modeling. If a feature is suprising, then we should do a further investigation into how that feature relates with the response.

Here the most important variables are primarily game term specific features. This ranking makes sense since variations of similar terms are captured by these features, and are present in almost all of these messages. They are also specifically created to relate to different types of content.

Specifically '__job_points' would relate primarily to people selling job points (a sort of RPG leveling system). Likewise, '__jobs' captures a large number of variations of specific jobs (think D&D classes), that would be requested in content messages.

Show R Code.

Model	Log Loss
Full	89%
Reduced	95%

The second model characteristic, model performance, is evaluated through a confusion matrix, model accuracy, and per class True Positive Rates (TPR).

The confusion matrix shows generally good performance, where the diagonal clearly dominates the off-diagonal miss-classifications for all classes. Likewise the model accuracy is 89% for unique messages, and 95% when accounting for duplicate or repeated messages.

	Message Category	TPR	TNR
1	Content	0.91	0.97
2	RMT	1.00	1.00
3	Merc	0.89	0.96
4	JP Merc	0.99	0.99
5	Chat	0.81	0.98
6	Selling (non-Merc)	0.84	0.98
7	Buying (non-Merc)	0.67	0.99
8	Unknown	0.67	1.00

The per class TPR and FPR rates also look fairly good except for the categories 'Unknown' and 'Buying (non-Merc)'. I'm not too concerned about the 'Unknown' category since it's both fairly rare and a general catch-all of strange messages.

'Buying (non-Merc)' is a bit more of an issue. The primary separaters between 'Merc' and the '(non-Merc)' categories are the types of content or items that are being bought or sold. As an example, a Malignance Tabard is only obtained by doing specific content, it cannot directly be bought or sold buy a player. Therefore it is a merc item. But a Raetic Rod +1 can directly be bought or sold buy a player, so it would be a 'Non-Merc' item. The fix to this would be to create more game specific features to capture this, or to just to label more messages so XGBoost can identify these items on its own.

Model Deployment in Lua

To deploy the model, I need to get it out of R and into Lua. This is a five step process:

Dump the XGBoost model to a text format
Read in the trees from the XGBoost dump
Wait for a new Message
Extract features from message
Score the message

I have already written all the code to do this in a github repo function. This also includes a previous model dump from XGBoost.

The first step is extremely easy, we just grab our model and dump it to a text file. Note that we retrain the model using all our data at this point to get the best possible fit out of all of our data.

Show R Code.

The dump looks something like this (note this is from an earlier version of the same model):

booster[0]
0:[f11<0.5] yes=1,no=2,missing=1
  1:[f194<0.5] yes=3,no=4,missing=3
    3:[f211<0.5] yes=5,no=6,missing=5
      5:[f215<0.5] yes=7,no=8,missing=7
        7:[f64<0.5] yes=11,no=12,missing=11
          11:[f197<0.5] yes=15,no=16,missing=15
            15:[f76<0.5] yes=23,no=24,missing=23
              23:[f210<0.5] yes=27,no=28,missing=27
                27:leaf=-0.0266666692
                28:leaf=-0.00392156886
              24:[f210<0.5] yes=29,no=30,missing=29
                29:leaf=-0.0129032256
                30:leaf=-0.0380228125
            16:leaf=0.11343284
          12:[f129<0.5] yes=17,no=18,missing=17
            17:[f195<0.5] yes=25,no=26,missing=25
              25:[f201<0.5] yes=31,no=32,missing=31
                31:leaf=0.0990595669
                32:leaf=-0.0298507456
              26:leaf=-0.037894737
            18:leaf=0.259561151
        8:leaf=-0.0559531562
      6:[f215<0.5] yes=9,no=10,missing=9
        9:[f210<0.5] yes=13,no=14,missing=13
          13:[f129<0.5] yes=19,no=20,missing=19
            19:leaf=0.164210528
            20:leaf=-0.00784313772
          14:[f129<0.5] yes=21,no=22,missing=21
            21:leaf=0.189473689
            22:leaf=0.323467851
        10:leaf=-0.0519774035
    4:leaf=-0.0562807731
  2:leaf=0.366163135
...

This is in fact a single tree, given that we ran 200 iterations and there are eight categories to classify into, that gives is 1,600 trees that we need to evaluate in lua. This may seem a little daunting, but since these are trees it is fairly simple to write a recursive algorithm that will parse these structures. To do this, we should note that each line of the XGBoost dump has one of three possible line types that describe the tree structure:

booster[m] denotes the 'm'-th tree.
k:[f(xxx) < t] yes=h,no=i,missing=j is a branch of the tree.
- i is the index of the node within this tree.
- [f(xxx) < t] is an inequality determining if the tree will go to 'yes' f(xxx) is the feature in order of its input data set starting at 0, and t is just the value the feature is being compared against.
'i:leaf=s' is a leaf node with index i and log-odd s

In the example lua the parsing of the tree is accomplished in the read_booster function in xgboost_score.lua. It simply creates an implicit tree structure using lua arrays. Each element of the array aligns with the node index in the tree. I do add one to each index of both the features and nodes since Lua starts indexes at 0 unlike XGBoost (written in C++). Each element also contains the following components:

feature that maps to the (xxx) part of f(xxx).
lt_value that aligns with the value t above.
yes_node that aligns with the value j above.
no_node that aligns with the value k above.
missing_node that aligns with the value l above.
leaf the log-odds stored in the terminal node.

This is duplicated for all 1,600 trees and internally consumes no more than 8MB of data.

When a new message comes in we need to extract the features from the message to map to the features created in R. To do this we just use the regular expressions library that windower provides for lua. Here our new message is passed in as clean_text after removing non-ascii text and translating all auto-translate functions to english. As an example, this is the __gil feature we created earlier. It uses the exact same regular expression to achieve a match.

if windower.regex.match(clean_text, "[0-9]+(k|m|gil)") ~= nil then 
  eval_features[i] = 1 
end

Our next step is scoring the incomming message based on the features we just generated. As it turned out, this step was one of the harder bits of this project, not because of the technical difficulties, but in figuring out how XGBoost actually created the score.

When a new message comes in, it has it's features extracted and then we lookup in each tree for a particular message category to figure out what score it gets for each of these message categories.

The lookup step is done through a recursive function I created called eval_tree. It simply iterates over a given tree using the structure we created while reading the original tree in. As an initial condition it checks if a given node in the tree is a branch or a leaf. If we are at a leaf we are done and return our log-odds value, else we evaluate if the feature extracted from the message has a value less than our stored lt_value from our XGBoost dump. If it does, then we go to the yes_node. If the value is missing we follow the default value, equivalent to the yes_node. Otherwise, we go to the no_node. A recursive call is then made to evaluate the selected next node.

eval_tree = function( cur_node, booster, eval)

   -- Is this a branch, branches have a conditional
   if booster[cur_node].lt_value ~= nil then
   
     -- this is a branch, let's check what direction to go
     if( eval[ booster[cur_node].feature ] < booster[cur_node].lt_value ) then
       cur_node = booster[cur_node].yes_node
     elseif( eval[ booster[cur_node].feature ] == 0 ) then
       cur_node = booster[cur_node].missing_node
     else
       cur_node = booster[cur_node].no_node
     end
     
   else
     return( booster[cur_node].leaf)
   end

   return( eval_tree(cur_node, booster, eval) )

end

Remember that each of our 1,600 trees belong to one of eight message categories. So for every message we get 200 values from the leaf nodes associated with a given message category. Each of these values, which are log-odds are then summed up and added to a default value of 0.5. This process is implemented through the parse tree function in my Lua code.


--parse tree
eval_phrase = function( value, booster,classes )  
  xgboost_class = 0 
  score={}
  for i = 1,classes do
    score[i] = 0.5
  end

  for i = 1,table.getn(booster) do
    xgboost_class = xgboost_class + 1
    
    -- iterate over all classes
    if xgboost_class > classes then 
      xgboost_class = 1
    end
    score[xgboost_class] = score[xgboost_class] + eval_tree( 1, booster[i], value) 

  end

  -- combine score
  sum_all = 0
  for i = 1,classes do
    sum_all = sum_all + math.exp(score[i])
  end
  for i = 1,classes do
    score[i] = math.exp(score[i])/sum_all
  end

  return(score)
end

The 0.5 in the log-odds sum was a bit of mystery to figure out, as I had to search through all the XGBoost documentation and ended up diving into the source code to figure out why the sum of of log-odds was not giving me the right value. However, it makes sense since it provides a prior to dampen extreme differences in log-odds when there are few informative trees.

The final step is to use the softmax function to determine the probability that a given message belongs to a particular class. Here, I've just let the sum of log-odds of message category $g$ be $S_g$ . Finally, to end up with our probability estimate with softmax we just need to feed our sum of squares plus our prior into the softmax function:

Now we have probabilities for each class of our message, and can block the message types we don't want to see. The result can be seen below where the message screen on the left is fairly free of spammy messages (Necessary), and the screen on the right has primarily spammy messages (Sufficient).

Conclusion

Through this blog post we have gone through quite a journey. We started off with a problem of message spam, used our ML insights to come up with a quick model, and produced a meaningful solution. The model attains a 95% accuracy rate for all messages, and fairly good TPR and FPR rates on a per category basis. A few more features could probably be generated to improve performance, but this serves as an excellent initial solution.

From my github stats, it looks like there have been over 200 users of this plugin, as of December 1st and hopefully more as I push out new features like automatic model updating.

Again, happy holidays and let's see your holiday ML projects!

All FFXI content and images © 2002-2020 SQUARE ENIX CO., LTD.
FINAL FANTASY is a registered trademark of SQUARE ENIX CO., LTD.

Grand Central Dispatch

Sat, 29 Aug 2020 00:00:00 -0400

About a decade late, but I decided to give Grand Central Dispatch (GCD) a go in R. GCD is fairly similar to OpenMP as it provides a simplified interface for pthreads. Since its release for Mac OS X 10.6 in 2009, GCD has been ported to a number of operating systems through libdispatch. As of this writing, libdispatch is primarily available on Linux and Apple's operating systems using the Clang compiler. GCC may work, but I have not had any luck.

The most notable aspect of GCD is that it provides a native multithreading environment in Apple's operating systems. This includes MacOS and iOS. Not true for OpenMP since the removal of GCC from Mac OS X Snow Leopard. So if you are trying to get the most performance for all of your customers, GCD may provide some benefit for a lot of #ifdefs.

If you have used OpenCL GCD should be familiar. This is due to OpenCL and GCD both using queues and code blocks. However, you aren't forced to use code blocks, as GCD provides _f variants of the dispatch commands to allow the use of standard C functions. Queues are provided in two main flavors, serial and concurrent. Serial queues are exactly what they sound like, they provide a FIFO (First In First Out) queue. Therefore, tasks are executed and completed in sequence. Concurrent queues are non-blocking queues in that they execute in order, but do not wait for completion. A simple concurrent queue can be created through dispatch_get_global_queue, this function has two inputs. The first is the Quality of Service (QoS) for the queue, the second is reserved for future use and can be set to 0 or NULL.


dispatch_queue_global_t dispatch_get_global_queue(intptr_t qos, uintptr_t flags)

The quality of service will allow flexibility in your R package. You could have one high priority queue to draw a real-time plot, and have a lower priority queue for pulling data from websites in the background. The level of the queue is set by one of three enumerated values:

DISPATCH_QUEUE_PRIORITY_HIGH = 2,
DISPATCH_QUEUE_PRIORITY_DEFAULT = 0,
DISPATCH_QUEUE_PRIORITY_LOW = -2

Higher QoS will force your queue to run before other tasks in your system.

dispatch_queue_global_t dispatch_get_global_queue will only create a concurrent queue, but you can use dispatch_queue_create to create either queue type:


dispatch_queue_t dispatch_queue_create(const char *label, dispatch_queue_attr_t qt)

The first input provides a label for debugging etc, it can be anything including NULL, the second identifies queue type from one of the enumerated values below:

DISPATCH_QUEUE_SERIAL or NULL
DISPATCH_QUEUE_CONCURRENT

Once you have a queue, you probably want to stick somethign in it. The dispatch commands will get you there. dipatch_apply and likewise dispatch_apply_f will solve this problem for you, they will enqueue your request and run it a fixed number of times. The former function will be used for code blocks while the later will be used for standard functions.

To give you a bit of flavor behind GCD, a parallel for-loop can be created through the following function.


// inner kernel using GCD
void R_parallel_inner_kernel_gcd( double * x, double * y, int * n ) {

  // concurrent queue
   dispatch_queue_t my_queue = dispatch_get_global_queue(0, 0);

  // for like loop
  dispatch_apply (*n, my_queue, ^(size_t idx){

      size_t j;
      double tmp = 0;

      for( j = 0; j < *n; j++) {
        tmp += (x[idx] - y[j]) * (x[idx] - y[j]);
      }

      x[idx] = tmp;

  });
}

Here you can see the code block is being applied to the dispatch and running n times using the iterator idx. The code block is just a rolled up function that allows the creation of private variables such as tmp and j and shares the data from y and x.

This should be enough for you to get playing with GCD, further documentation exists at the Apple GitHub page.

For comparison against OpenMP, I re-wrote the code below for some performance testing. As you can see, the code is fairly similar, but unlike above, failure for having OpenMP available will allow the code to run as designed unlike the GCD case.


// inner kernel using OpenMP
void R_parallel_inner_kernel_omp( double * x, double * y, int * n ) {

  size_t idx,j;
  double tmp;

  #pragma omp parallel 
  {
    #pragma omp for
    for( idx = 0; idx < *n; idx++) {
      tmp = 0;
      for( j = 0; j < *n; j++) {
        tmp += (x[idx] - y[j]) * (x[idx] - y[j]);
      }
      x[idx] = tmp;
    }
  }
  return;
}

Running the code on an older 12-core, 24-thread (3.3GHz) 2012 MacPro running Mac OS Catalina, I received the following timings for GCC 9 (average 100 runs).


With OpenMP: 0.46 sec elapsed
Without GCD or OpenMP: 9.05 sec elapsed

GCD wasn't tested since I couldn't get it working with GCC in this case. Using homebrew's LLVM (Version 10), I received the following timings on the same system (average 100 runs).


With GCD: 0.53 sec elapsed
With OpenMP: 0.54 sec elapsed
Without GCD or OpenMP: 9.08 sec elapsed

Switching to my laptop running the same operationg system, a 2017 13" MacBook Pro with an i5 (2.3GHz, dual-core 4-thread) CPU, I had results that actually went in the other direction using homebrew LLVM (Version 10) (average 100 runs).


With GCD: 2.92 sec elapsed
With OpenMP: 3.00 sec elapsed
Without GCD or OpenMP: 11.51 sec elapsed

Using GCC 9, I also repeated the same compilation again using the same flags (average 100 runs).


With OpenMP: 3.21 sec elapsed
Without GCD or OpenMP: 11.61 sec elapsed

We can see that the performance measures differ quite a bit between OpenMP and GCD, even when running a fairly simple program over different hardware. Further testing would be required to better understand the conditions that cause OpenMP to be more performant than GCD. One idea could be the number of cores, or optimzation for specific processors. Perhapse another blog post for that!

For those interested in getting their feet wet a bit more, I have created a reference template for GCD with make files to choose the best parallel implementation for your code (rgcd-template). Included are timing tests and the code samples shown.

Mysteriously Slow sample

Sat, 28 Jul 2018 00:00:00 -0400

Hi everyone, I'm at JSM 2018 right now, so feel free to drop by my session or drop by in the halls! Just give me a tweet!

Back to the meat-and-potatoes of this post. A while ago I was running good old sample and comparing its performance to my lpm2_kdtree function in the BalancedSampling package (Grafström and Lisic, 2016). In this comparison I noticed that sample was in some cases slower than my balanced sampling method when using sampling weights.

library(BalancedSampling)
library(ggplot2)

# sampling proportion
f <- 0.1

# population size 
N_values <-  seq(from=5000, to=100000,length=10)

set.seed(99)

pi <- runif(100000)

result <- c()

for( N in N_values) {
  # get sample size 
  n <- round(f*N)

  ## run lpm2-kdtree

  start_time <- proc.time()[3]
  # to make things even we normalize pi
  pi_tmp <- pi[1:N] * n/sum(pi)
  # we probably don't want to balance by pi_tmp, but 
  # for checking speed this is fine
  lpm2_kdtree(pi_tmp,pi_tmp)
  end_time <- proc.time()[3] - start_time

  result <- rbind(result, c(f, N, 1, end_time ))

  ## run sample 

  index <- 1:N

  start_time <- proc.time()[3]
  # to make things even we normalize pi
  sample(index,size=n,prob=pi_tmp)
  end_time <- proc.time()[3] - start_time

  result <- rbind(result, c(f, N, 2, end_time ))
}


colnames(result) <-
  c('SamplingFraction', 'PopulationSize', 'Method','RunTime')
result <- as.data.frame(result)

result[c('SamplingFraction','Method')] <-
  lapply(result[c('SamplingFraction','Method')], as.factor)
levels(result$Method) <- c("lpm2_kdtree","sample")

ggplot( aes(x=PopulationSize, y=RunTime, class=Method), data=result)+
  geom_line(aes(color=Method)) +
  ylab("Run Time (s)") +
  xlab("Population Size")

Figure 1: Lpm2_kdtree vs R sample.

How could this be?

Let's condsider a few possible reasons.

Are you running an old version of R?

No, this was done with R 3.5.0, but results hold on 3.5.1.

Is this because you are a freedom hating Mac user?

Nope, I get similar results in Linux

Is this due to the revsort in ProbSampleNoReplace found in random.c?

How amazingly prescient of you! If you track down the code path, the method used for sampling has a revsort call right at the begining (Line 323). Some basic testing seems to identify this as the likely culprit. Therefore, it might be possible to speed up sampling by checking if the probabilities are sorted.

Keep in mind that there are likely good reasons for R to use this method relative to others, including the alternative method below. One is computational stability, split sampling through the pivotal methods tends to work well when sample sizes aren't extremely small. However, I don't have any good comparisons of methods, if anyone knows please let me know, doing a literature search on this is pretty far down on my todo list.

That's great, but what can I do to improve my weighted or PPS sampling?

Well, I wrote a quick pivotal method implementation (think LPM2 without balancing) that seems to work. It's available as split_sample on my github version of BalancedSampling. There is also UPrandompivotal in the sampling package (Tillé and Matei, 2016). However, my implementation seems to be considerably faster. We will take a look at this in another blog post.

Finally, keep in mind that split_sample probably isn't as well tested as UPrandompivotal. So I'm happy to take any feedback.

library(devtools)
install_github("jlisic/BalancedSampling")
library(BalancedSampling)
library(ggplot2)
library(sampling)

# sampling proportion
f <- 0.1

# population size 
N_values <-  seq(from=5000, to=100000,length=10)

set.seed(99)

pi <- runif(100000)

result <- c()

for( N in N_values) {
  # get sample size 
  n <- round(f*N)

  ## run lpm2-kdtree

  start_time <- proc.time()[3]
  # to make things even we normalize pi
  pi_tmp <- pi[1:N] * n/sum(pi)
  # we probably don't want to balance by pi_tmp, but 
  # for checking speed this is fine
  lpm2_kdtree(pi_tmp,pi_tmp)
  end_time <- proc.time()[3] - start_time

  result <- rbind(result, c(f, N, 1, end_time ))


  ## run pivotal method (BalancedSampling) 

  index <- 1:N

  start_time <- proc.time()[3]
  # to make things even we normalize pi
  pi_tmp <- pi[1:N] * n/sum(pi)
  split_sample(pi_tmp)
  end_time <- proc.time()[3] - start_time

  result <- rbind(result, c(f, N, 2, end_time ))


  ## run pivotal sampling (sampling) 

  index <- 1:N

  start_time <- proc.time()[3]
  # to make things even we normalize pi
  pi_tmp <- pi[1:N] * n/sum(pi)
  UPrandompivotal(pi_tmp)
  end_time <- proc.time()[3] - start_time

  result <- rbind(result, c(f, N, 3, end_time ))
}


colnames(result) <-
  c('SamplingFraction', 'PopulationSize', 'Method','RunTime')
result <- as.data.frame(result)

result[c('SamplingFraction','Method')] <-
  lapply(result[c('SamplingFraction','Method')], as.factor)
levels(result$Method) <-
  c("lpm2_kdtree","BalancedSampling::split_sample",
    "sampling::UPrandompivotal")

ggplot( aes(x=PopulationSize, y=RunTime, class=Method), data=result)+
  geom_line(aes(color=Method)) +
  ylab("Run Time (s)") +
  xlab("Population Size")

Figure 2: Lpm2_kdtree vs BalancedSampling::split_sample vs sampling::UPrandompivotal.

Have a great JSM!

References

Grafström, A., Lisic, J.: BalancedSampling: balanced and spatially balanced sampling. R package version 1.5.2. https://CRAN.R-project.org/package=BalancedSampling. Accessed August 28, 2018. (2016)

Tillé, Y., Matei, M.: sampling: Survey Sampling. R package version 2.8. https://CRAN.R-project.org/package=sampling. Accessed August 28, 2018. (2016)

Making Your .C Less NOTEworthy

Fri, 12 Jan 2018 00:00:00 -0500

If you are a package maintainer, you may have noticed the following new notes from your code checks: Found no calls to: ‘R_registerRoutines’, ‘R_useDynamicSymbols’ If you are using Rcpp you can easily fix this by refreshing the auto-generated function registration. However, if you have a lot of C code that uses the .C() interface, then you need to make a few changes. In this blog post, I'll use my updated meanShiftR package as an example of how to quickly fix your code.

The first thing you need to do is to examine your C code and determine your parameter types for each of the functions you call from R using .C(). In meanShiftR I have two C functions that I call from R. The first function R_meanShift has a function prototype that looks like this:


/* mean shift function prototype*/
void R_meanShift(
  double * query,                /* data to query for, in row major form */
  double * train,                /* reference data, in row major form */
  int * assignment,              /* assignment */
  int * queryRowPtr,             /* number of rows of query data */
  int * trainRowPtr,             /* number of rows of reference data */
  int * queryColPtr,             /* number of columns of query and reference*/
  int * nNeighborsPtr,           /* number of neighbors */
  int * iterationsPtr,           /* number of iterations */
  double * bandwidth,            /* bandwidth */
  double * alphaPtr,             /* ms to newton ajustment parameter */
  double * epsilonPtr,           /* min l2 dist for convergence  */
  double * epsilonClusterPtr,    /* min l2 dist for clustering */
  int * kernelEnumPtr,           /* kernel type */
  int * algorithmEnumPtr,        /* algorithm type */
  int * intParameters,           /* kernel and alg dependent parameters */
  int * dblParameters            /* kernel and alg dependent parameters */
  );

The second function R_knnhas a function prototype that looks like this:


/* R_knn function prototype */
void R_knn( 
  double * queryPoints,  /* point to query for */
  double * x,            /* data to reference for the query 
                            (what we build our tree from) */
  int * xnrowPtr,        /* number of rows of x */
  int * nrowPtr,         /* number of rows from query points */
  int * ncolPtr,         /* number of columns for both queryPoints and x */
  double * kDist,        /* distance vector (we return this) */
  int * indexInt,        /* index of neighbors (we return this) */
  int * kPtr,            /* number of nearest neighbors */
  double * weight,       /* used for weighted distance calculations */
  int * leafSizePtr,     /* number of nodes in the k-d tree leaf nodes */
  double * maxDist       /* maximum distance l2^2 to look for neighbors */
 );

With this information, I can register these function in four pretty painless steps. (1) Include the R_ext/Rdynload.h in a header file. (2) Create R_NativePrimitiveArgTypes for each C function that you call with .C(). (3) Register our C functions as an R_CMethodDef array. (4) Finally, we create a function that is run when we load our function through R; in this function we register our C functions using R_registerRoutines.

To detail this process, I have created an example C file identifying each of these steps. This isn't necessary, but can simplify things if you call C functions from R that have prototypes defined in separate files. To make things easy to apply to your code, I have included a complete example below, and will then go over each of these steps.


/* init.c */
#include <stdio.h> 
#include <stdlib.h>

#include "R.h"
#include "Rinternals.h"
#include "Rmath.h"

/*************************************/
/* STEP:  1. This header file is new */
/*************************************/
#include   

#include "kdtree.h"
#include "meanShift.h"

#if defined _OPENMP
  #include 
#endif

/*************************************/
/* Register SO's                     */

/*************************************/
/* STEP:  2. Create R_NativePrimitiveArgTypes 
             for each function */
/*************************************/

static R_NativePrimitiveArgType R_meanShift_t[] = {
      REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, INTSXP, INTSXP, INTSXP, 
      REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP
};

static R_NativePrimitiveArgType R_knn_t[] = {
      REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, REALSXP, INTSXP, INTSXP, 
      REALSXP, INTSXP, REALSXP
};

/*************************************/
/* STEP:  3. This is where we register 
             our C functions as an R_CMethodDef array */
/*************************************/

static const R_CMethodDef cMethods[] = {
     {"R_meanShift", (DL_FUNC) &R_meanShift, 14, R_meanShift_t},
     {"R_knn", (DL_FUNC) &R_knn, 14, R_knn_t},
        {NULL, NULL, 0, NULL}
};

/*************************************/
/* STEP: 4. This is our boilerplate 
           registration of our C code */
/*************************************/
void R_init_myLib(DllInfo *info)
{
     R_registerRoutines(info, cMethods, NULL, NULL, NULL);
     R_useDynamicSymbols(info, TRUE); 
}

We will start at step two, step one was just including the header file. Step two involves creating an array of an enumerated types for each C function we call from R, where the enumerated types are from standard R SEXP enumerations: INTSXP for integers, REALSXP for doubles, CHARSXP for characters, etc... Each of these types are detailed in the R Internals Manual . Each array is created with type R_NativePrimitiveArgType and we will be using it in the next step.

In step three we register our functions with the function name, our enumerated array from the last step, and the number of parameters. We register them through an array of function arrays, where a function array of a function named foo with enumerated array foo_t using three parameters would look like:


{"foo", (DL_FUNC) &foo, 3, foo_t}

This array of function arrays is NULL terminated with function array {NULL, NULL, 0, NULL}. The array type we use is R_CMethodDef and we need to make sure we register all our C functions in this array.

Finally in step four we put it all together in a function that registers our C functions when we load the shared object.



void R_init_myLib(DllInfo *info)
{
     R_registerRoutines(info, cMethods, NULL, NULL, NULL);
     R_useDynamicSymbols(info, TRUE); 
}

That's it!, now update your packages!

The Statistician's Apprentice: An Introduction to the SWP Operator

Tue, 13 Dec 2016 00:00:00 -0500

The sweep operator as defined in (Dempster, 1969), commonly referred to as the SWP operator, is a useful tool for a computational statistician working with covariance matrices. In particular, the SWP operator allows a statistician to quickly regress all variables against one specified variable, obtaining OLS estimates for regression coefficients and variances in a single application. Subsequent applications of the SWP operator allows for regressing against more variables.

In this blog post, I will define the sweep operator, provide an application of the sweep data to simulated data, and provide some references for further study. Examples will be provided in R through the ISR3 package (Lisic, 2016).

The basic SWP operator is parameterized by a matrix and a set of indices associated with rows and columns of the matrix being swept. E.g. to sweep the matrix by the index, such that , the operator has the form . The operator may also be written more descriptively by listing the elements of as . The application of the SWP operator to the row and column of produces a new matrix with elements

As an example, consider the application of the SWP operator to the first row and column of the covariance matrix for the random variables ,

resulting in

How is this useful? Well, if we substitute the covariance matrix with the sample covariance matrix, where is an estimator of and

is an estimator of

, then by sweeping by the

index,

, we can get the simple linear regression (SLR) estimates for

for all

where

is the simple linear model estimator of the regression coefficient for the linear model

for

is the inverse of the covariance matrix of

unscaled by

, and

is the sample covariance of the residuals from the regression models on

unscaled by

Example

Lets try this with some real data. I have used the SWP function included with the ISR3 package.

library(ISR3)

set.seed(12)
n <- 100
p <- 3

# generate a positive definite matrix for covariance
Sigma <- rWishart(1,p+1,diag(p))[,,1]
Sigma_inv <- chol2inv(chol(Sigma))
Sigma_inv_chol <- chol(Sigma_inv)

# generate 'n' multivate normal deviates
X <- Sigma_inv_chol %*% matrix(rnorm(n*p),nrow=p)
X <- t(X)
colnames(X) <- sprintf("X_%d",1:p)

XX <- t(X) %*% X

#Sweep by the first row/column of XX
SWP_1 <- SWP(XX,1)

SWP_1

##              X_1        X_2         X_3
## X_1 -0.002381092  0.1375626 -0.01674788
## X_2  0.137562633 50.0987932 -4.95181624
## X_3 -0.016747875 -4.9518162 41.73979419

We can compare this output with the results from the simple linear models

and

# linear models
fit_21 <- lm(X_2 ~ -1 + X_1, data=as.data.frame(X))
fit_31 <- lm(X_3 ~ -1 + X_1, data=as.data.frame(X))

# SLR coefficents for X_1
print(fit_21$coefficients)

##       X_1 
## 0.1375626

print(fit_31$coefficients)

##         X_1 
## -0.01674788

# sum of squares
print(sum(fit_21$residuals^2))

## [1] 50.09879

print(sum(fit_31$residuals^2))

## [1] 41.73979

# covariance between X_2 and X_3 given X_1
print(sum(fit_21$residuals * fit_31$residuals))

## [1] -4.951816

# negative inverse of the covariance matrix of X_1
print( -1/((n-1)*var(X[,1])) )

## [1] -0.002381293

Here we see that the coefficients from lm match up to our swept results. Likewise, the diagonal terms for the second and third column are equivalent to the sum of squares or the residuals. The remaining unmatched term is just the negative inverse of the covariance matrix of

unscaled by

A subsequent sweep on the second rows and columns produces the matrix,

where

is now the inverse covariance matrix of

and

is the matrix

Again, we can quickly check the results by comparing the output from lm to our SWP operator.

A final sweep by the third row and column produces , the negative inverse of the unscaled covariance matrix of . This can be quickly verified through R:

SWP(XX,1:3) + chol2inv(chol(XX))

##              X_1          X_2          X_3
## X_1 0.000000e+00 0.000000e+00 1.355253e-20
## X_2 0.000000e+00 3.469447e-18 8.673617e-19
## X_3 1.355253e-20 8.673617e-19 0.000000e+00

Undo!

We can also undo sweeps with the reverse sweep (RSWP) operator through the following element-wise operations

Caution should be used when reverse sweeping, as in application

is not necessarily equal to

due to floating point error. In particular when the matrix is ill-conditioned there may be considerable departure between the calculated identity and the original matrix.

What Next?

A few good references on the subject beyond (Dempster, 1969) can be found in (Goodknight, 1979) and (Little and Rubin, 2014). There are a few slight differences between these implementations, but all generally do the same thing.

One function that doesn't do the same thing is the sweep function in R. This function can be used to write a SWP implementation, but doesn't sweep by itself.

Code examples can be found in the ISR3 package on CRAN and in lots of other packages. Examples in C can be found in ISR3 and as an internal function in the MNP package (Imai and Van Dyk, 2013).

Enjoy your sweeping, next time I'll go over sweeping with the generalized inverse!

References

Dempster, A.P. (1969). Elements of continuous multivariate analysis. Reading, MA: Addison-Wesley.

Goodnight, J. H. (1979). A tutorial on the SWEEP operator. The American Statistician, 33(3), 149-158.

Imai, K., and Van Dyk, D. A. (2013). MNP: R Package for fitting the Multinomial Probit Model, R package version 2.6-4, https://CRAN.R-project.org/package=MNP

Lisic, J. J. (2016). ISR3: Iterative Sequential Regression, R package version 0.98, https://CRAN.R-project.org/package=ISR3

Little, R. J., and Rubin, D. B. (2014). Statistical analysis with missing data. John Wiley & Sons.

meanShiftR

Sun, 28 Aug 2016 00:00:00 -0400

In this blog post, I will be introducing the meanShiftR package. meanShiftR is a rewrite of my original mean shift R package from 2013, based on the Fast Library for Approximate Nearest Neighbors (FLANN). The meanShiftR package is focused on providing to R users the most computationally efficient mean shift implementations available in the literature. This includes approximations to the mean shift algorithm through kernel truncations and approximate nearest-neighbor (ANN) approaches.

The mean shift algorithm is a steepest ascent classification algorithm, where classification is performed by fixed point iteration to a local maxima of a kernel density estimate. This method is originally credited to (Fukunaga and Hostetler, 1975), but didn't see wide-scale adoption until it was popularized by (Cheng, 1995). This algorithm has a fairly simple form of a convex combination of the support of the kernel density estimate, where the weight is calculated from the function , the derivative of kernel . In the computer science literature this function is commonly refered to as the profile and is refered to as the shadow kernel.

The explicit formulation of the mean shift for (the point being classified) is,

Where, the support is defined by the points in

and kernel bandwidth paramter is identified as

is assumed to be of full rank and symmetric in this formula.

This algorithm identifies local maxima by updating at each iteration, starting with a set of initial points. Iteration continues until a fixed number of iterations is met or where is an acceptable tolerance.

R Implementations

On CRAN there are two other packages that perform the mean shift algorithm, MeanShift and LPCM. The MeanShift package provides multi-core acceleration, a large number of kernels, and support for blured mean shift. LPCM provides a fast and effective mean shift implementation, as well as plotting and diagnostic tools. LPCM is restricted to just Gaussian kernels and does not provide any multi-core acceleration.

The meanShiftR package presented here is considerably faster than the prior two packages, but currently lacks diagnostic tools and support for more kernels. Instead, the meanShiftR package provides a number of ways to speed mean shift. This includes a generalized Gaussian variant of the mean shift (Lisic, 2015) providing accelerated convergence at the expense of some numerical stability, and support for support truncation with nearest neighbor and approximate nearest neighbor searches. Furthermore, this mean shift implementaiton allows for mean shifting on a separate data set than the kernel support, a feature missing in the other two packages.

A quick speed comparison was done between the three packages, this was performed on a 13" MacBook Pro with a dual-core hyper-threaded CPU. In this configuration the default number of cores used by MeanShiftR is four. A slight change had to be done to the MeanShift package to provide similar results, mainly the terminal condition had to be modified to be equivalent to meanShiftR and LPCM. This terminal condition is simply the relative L distance.

library(meanShiftR)
library(LPCM)
library(MeanShift)

# set a seed to make this reproducible 
set.seed(100)

# set the number of iterations to test 
# (we will terminate well before this)
iter <- 1000

# set the number of points to simulate
n <- 500

# set the bandwidth
h <- c(0.5,0.5)

# create example data
x1 <- matrix( rnorm( n ),ncol=2)
x2 <- matrix( rnorm( n ),ncol=2) + 2
x <- rbind( x1, x2 )

#plot initial points
plot(x, col=rep(c('red','green'),each=n/2),
     cex=2, xlab='x',ylab='y',pch=20)

########### meanShiftR ###################
run.time <- proc.time()
result <- meanShift(
  x,
  x,
  algorithm="KDTREE",
  bandwidth=h,
  alpha=0,
  iterations = iter,
  parameters=c(10,100)
)
meanShiftR_kd_runtime <- (proc.time()-run.time)[3]

# assignment
meanShiftR_kd_assignment <- result$assignment

# value
meanShiftR_kd_value <- result$value


########### meanShiftR ###################
run.time <- proc.time()
result <- meanShift(
  x,
  x,
  bandwidth=h,
  alpha=0,
  iterations = iter
)
meanShiftR_runtime <- (proc.time()-run.time)[3]

# assignment
meanShiftR_assignment <- result$assignment

# value
meanShiftR_value <- result$value


########### LPCM ###################
runtime <- proc.time()
result <- ms(
            x,
            h=h,
            scaled=FALSE,
            iter=iter,
            plotms=-1)
LPCM_runtime <- (proc.time()-runtime)[3]

# assignment
LPCM_assignment <- result$cluster.label

# value
LPCM_value <- result$cluster.center[LPCM_assignment,]


########### MeanShift ###################
options(mc.cores = 4)
z <- t(x)
runtime <- proc.time()
result <- msClustering(
            X=z,
            h=h,
            kernel="gaussianKernel",
            tol.stop=1e-08,
            tol.epsilon=1e-04,
            multi.core=T)
MeanShift_runtime <- (proc.time()-runtime)[3]

MeanShift_assignment <- result$labels
MeanShift_value <- t(result$components[,result$labels])

# print 
plot(x, col=sapply(meanShiftR_assignment,function(x)c('red','green','blue')[x]),
   cex=1.5, xlab='x',ylab='y',pch=20)

result <- data.frame(
  runtime=c( meanShiftR_runtime,
                meanShiftR_kd_runtime,
                LPCM_runtime,
                MeanShift_runtime),
  maxDiff=c(max(abs(meanShiftR_value - LPCM_value)),
               max(abs(meanShiftR_kd_value - LPCM_value)),
               0,
               max(abs(MeanShift_value - LPCM_value))
               ),
  assignmentDiff=c(sum(meanShiftR_assignment != LPCM_assignment),
               sum(meanShiftR_kd_assignment != LPCM_assignment),
               0,
               sum(MeanShift_assignment != LPCM_assignment)
               )
  )

colnames(result) <- c('Run-Time',
                      'Maximum Absolute Difference',
                      'Label Disagreements')

rownames(result) <- c('meanShiftR',
                      'meanShiftR K-D Tree',
                      'LPCM ms',
                      'meanShift msClustering')

library(xtable)
print(xtable(result,digits=6,display=c('s','f','f','d')), type='html')

	Run-Time	Maximum Absolute Difference	Label Disagreements
meanShiftR	0.304000	0.000000	0
meanShiftR K-D Tree	4.871000	0.000000	0
LPCM ms	2.425000	0.000000	0
meanShift msClustering	43.168000	0.000000	0

Figure 1: Original image.

Figure 2: Classified image.

Here we can see some pretty good performance results for meanShiftR relative to the other R packages. Unfortunately the k-d tree based implementation wasn't as fast as I would have liked, but its utility is really in tuncated support kernels. Support for these kernels will be added later.

It is unclear why the performance of MeanShift was so poor relative to the other approaches. To verify that it was not a function of the parallel implementation, the algorithm was run with one thread achieving approximately 50% of the performance with mc.cores=4.

Diagnostic plots are not yet included, but convergence path plots can be easily generated by looping over single iterations. An example is provided below, with results in Figure 3.

library(meanShiftR)
library(LPCM)
library(MeanShift)

# set a seed to make this reproducible 
set.seed(100)

# set the number of iterations to test 
# (we will terminate well before this)
iter <- 10

# set the number of points to simulate
n <- 500
m <- 20

# set the bandwidth
h <- c(0.5,0.5)

# create example data
x1 <- matrix( rnorm( n ),ncol=2)
x2 <- matrix( rnorm( n ),ncol=2) + 2
x <- rbind( x1, x2 )

# create some test data for diagnostic plots
y1 <- matrix( rnorm( m ) ,ncol=2)
y2 <- matrix( rnorm( m ),ncol=2) + 2
y <- rbind( y1, y2 )

plot(x, col=rep(c('salmon','greenyellow'),each=n/2),
   cex=1.5, xlab='x',ylab='y',pch=20)

points(y,col=rep(c('red','green'),each=m/2),
       cex=2,pch=19)

points(y,cex=2)

########### meanShiftR ###################

#initial run
result <- meanShift(
    y,
    x,
    algorithm="KDTREE",
    bandwidth=h,
    alpha=0,
    iterations = iter,
    parameters=c(10,100)
)

y0 <- rbind(y,result$value)

for( i in 2:iter) {

  result <- meanShift(
    result$value,
    x,
    algorithm="KDTREE",
    bandwidth=h,
    alpha=0,
    iterations = 1,
    parameters=c(10,100)
  )

  # concate on the result
  y0 <- rbind(y0,result$value)
}

# plot the paths

for( i in 1:m ) {
  pointIndex <- seq(from=0,to=(m*(iter-1)),by=m)+i
  points(y0[pointIndex,] , type='l',lwd=2)
}

Figure 3: Convergence paths.

Future Plans

Due to issues with stack size limits in .C, I was unable to directly submit the original FLANN based package to CRAN, therefore a complete rewrite in C has been initiated. This 0.50 release, is the first release on-the-way to 1.00, where feature parity will be met with the original code. The release map for this package follows four more planned releases:

0.50 - Initial release.
0.60 - Distance-based k-d trees, and support for popular kernels.
0.70 - Dual-tree acceleration (Wang et al., 2007).
0.80 - Fast Guassian Transform acceleration (Xia et. al. 2010).
0.90 - Merge-Tree acceleration (Lisic, 2015).
1.00 - Smoothing the support and diagnostic tools.

References

Cheng, Y. (1995). Mean shift, mode seeking, and clustering. IEEE transactions on pattern analysis and machine intelligence, 17(8), 790-799.

Fukunaga, K., & Hostetler, L. (1975). The estimation of the gradient of a density function, with applications in pattern recognition. IEEE Transactions on information theory, 21(1), 32-40.

Lisic, J. (2015). Parcel Level Agricultural Land Cover Prediction (Doctoral dissertation, George Mason University).

Wang, P., Lee, D., Gray, A. G., & Rehg, J. M. (2007, March). Fast Mean Shift with Accurate and Stable Convergence. In AISTATS (pp. 604-611).

Xiao, C., & Liu, M. (2010, September). Efficient Mean‐shift Clustering Using Gaussian KD‐Tree. In Computer Graphics Forum (Vol. 29, No. 7, pp. 2065-2073). Blackwell Publishing Ltd.

Elizabeth!

Sun, 07 Aug 2016 00:00:00 -0400

Over the last few months I have been spending my nights taking care of my newly born second daughter. Keeping me company during the sleepless wee hours of the morning was the Reconcilable Differences Podcast. In episode 17 of this podcast, It's Devastating, there was an open question placed by John Siracusa with regard to how baby names change over time, and if there were any sudden changes. In this blog post, part of my investigation of podcast theme series, I will take a look at these two questions. I will also provide my source code in the spirit of reproducible research.

Short a few apostles
The names of the 1880s
Name distribution
Name change
From the island to the wall
In the end

Short a Few Apostles

I used the babynames package in R to perform this analysis. The R package babynames by Hadley Wickham provides a nifty way to get baby names and related information from the Social Security Administration and other government agencies. Downloading the data and plotting the name John relative to Jon over time can be done with a few simple commands.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# get the names
theJNames <-babynames %>%
  filter(name %in% c('Jon','John') & sex == 'M')

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=theJNames, aes(x=year,y=prop)) +
  geom_line(aes(color=name),size=1.5) +
  labs(
    title='Jon v.s. John',
    y="Proportion of new SSN applications",
    x="Year")
plot(p)

Figure 1: Proportions of the names Jon and John over time.

With this little bit of work, we can see that the proportion of babies named John is strictly larger than Jon, but is also on a fairly substantial decline. Out of curiosity, let's check James. Why James? It seems that just about everyone I know that is male and in their 70s is named James.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# get the names
theJNames <-babynames %>%
  filter(name %in% c('James') & sex == 'M')

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=theJNames, aes(x=year,y=prop)) +
  geom_line() +
  labs(
    title='James',
    y="Proportion of new SSN applications",
    x="Year")

maxYear <- theJNames$year[which.max(theJNames$prop)]

plot(p)

Figure 2: Proportions of the name James over time.

So it looks like we hit peak James in maxYear=1944. So this seems to line up with my observations.

For the data pedantic, which should be everyone, this list of baby names is derived from Social Security Card applications. Since the social security administration didn't exist until 1935 and didn't start issuing cards until 1937, the names from 1880-1937 are likely to be a bit incomplete.

The Names of the 1880s

So John and James had downward trends in the coverage of new babies, does this hold for other names? Let's see what the top names in the 1880s are and where they are today, likewise let's see what the top names in 2014 are and how they have historically trended.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# dream of the 1880s
# ladies first
oldNamesData <- babynames %>%
  filter(year == 1880 & sex =='F')

#baby names are presorted
oldNames <- head(oldNamesData$name,n=7)
oldNamesData <- filter(babynames, name %in% oldNames & sex == 'F')
oldNamesData$name <- as.factor(oldNamesData$name)

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=oldNamesData, aes(x=year,y=prop)) +
  geom_line(aes(color=name)) +
  labs(
    title='Top 1880 Female Names',
    y="Proportion of new SSN applications",
    x="Year")

maxYear <- theJNames$year[which.max(theJNames$prop)]

plot(p)

Figure 3: Old time female names over time.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# 2014 females
newNamesData <- babynames %>%
  filter(year == 2014 & sex =='F')

#baby names are presorted
newNames <- head(newNamesData$name,n=7)
newNamesData <- filter(babynames, name %in% newNames & sex == 'F')
newNamesData$name <- as.factor(newNamesData$name)

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=newNamesData, aes(x=year,y=prop)) +
  geom_line(aes(color=name)) +
  labs(
    title='Top 2014 Female Names',
    y="Proportion of new SSN applications",
    x="Year")

plot(p)

Figure 4: New female names over time.

Now for the gents.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# dream of the 1880s
oldNamesData <- babynames %>%
  filter(year == 1880 & sex =='M')

#baby names are presorted
oldNames <- head(oldNamesData$name,n=5)
oldNamesData <- filter(babynames, name %in% oldNames & sex == 'M')
oldNamesData$name <- as.factor(oldNamesData$name)

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=oldNamesData, aes(x=year,y=prop)) +
  geom_line(aes(color=name)) +
  labs(
    title='Top 1880 Male Names',
    y="Proportion of new SSN applications",
    x="Year")

maxYear <- theJNames$year[which.max(theJNames$prop)]

plot(p)

Figure 5: Old time male names over time.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# males in 2014
newNamesData <- babynames %>%
  filter(year == 2014 & sex =='M')

#baby names are presorted
newNames <- head(newNamesData$name,n=5)
newNamesData <- filter(babynames, name %in% newNames & sex == 'M')
newNamesData$name <- as.factor(newNamesData$name)

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=newNamesData, aes(x=year,y=prop)) +
  geom_line(aes(color=name)) +
  labs(
    title='Top 2014 Male Names',
    y="Proportion of new SSN applications",
    x="Year")

plot(p)

Figure 6: New male names over time.

The interesting bit about both of these results is that the popularity of names seems to be fairly short lived in modern times. This can be seen in the popular names from 2014 poping up from nowhere, with the exception of William and maybe Emily.

Name Distribution

That was a lot of fun, but let's get back to the question of how people have labeled their children over time. What we can hypothesize from the prior results is that there is an abundance of new names over the last century.

So let's take a look at this new diversity in child naming. One way to look at this diversity is to just to plot the number of distinct names for each year and see how this changes over time (Figure 7.).

library(ggplot2)
library(babynames)


# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# quick aggregation function, there is a dplyr function for this as well
uniqueNames <- aggregate(prop ~ year+sex, data=babynames,
                         function(x) length(x))

# plot the number of unique names from new SSN applications 
# over time
p <- ggplot(data=uniqueNames, aes(x=year,y=prop)) +
  geom_line(aes(color=sex)) +
  labs(
    title='Number of Unique New Names over Time',
    y="Proportion of new SSN applications",
    x="Year")

plot(p)

Figure 7: Number of unique names over time.

Clearly this is an increase in distinct names. This increase in new names could be a function of the change in population size, but it is likely more complicated than that. Immigration from non-European countries may play a large roll in this change, but that would require a bit more work than I'm willing to put into this blog post.

Another way to look at this data is to plot the sorted proportions. Plotting the sorted proportions will provide some insights into the distribution of the names. If the proportions are uniformly distributed, this implies no real preference towards a particular name. If the proportions are highly skewed, then the population likely has a large number of uncommon names and a small number of popular names. To limit the number of plots, I just took a quick look at the plots of proportions for 1890 (YouTube) and 1990 (YouTube). To make things simple I just pooled male and female names together.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# get names
namesDensity <- babynames %>% filter(year %in% c(1890,1990)) %>%
  group_by(sex,year) %>%
  mutate(index=1:length(prop)) %>%  # create an index
  ungroup(sex,year)

namesDensity$Year <- as.factor(namesDensity$year)

namesDensity1890 <- filter(namesDensity, Year==1890)
namesDensity1890 <-
  namesDensity1890[sort(namesDensity1890$prop, index.return=T)$ix,]

namesDensity1990 <- filter(namesDensity, Year==1990)
namesDensity1990 <-
  namesDensity1990[sort(namesDensity1990$prop, index.return=T)$ix,]

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=namesDensity1890, aes(x=index,y=prop)) +
  geom_line(aes(color=Year)) +
  labs(
    title='Plot of Decreasing Name Porportions in 1890',
    y="Proportion of new SSN applications",
    x="Number of Names")

plot(p)

p <- ggplot(data=namesDensity1990, aes(x=index,y=prop)) +
  geom_line(aes(color=Year)) +
  labs(
    title='Plot of Decreasing Name Porportions in 1990',
    y="Proportion of new SSN applications",
    x="Number of Names")

plot(p)

Figure 8: Plot of decreasing proportions in 1890.

Figure 9: Plot of decreasing proportions in 1990.

There are a few interesting characteristics about these two plots. The first characteristic we saw before in Figure 7., the number of the unique names. Here we can see the number of unique names increased eight times over one hundred years. So clearly there are more names out there, but how are they distributed? This can be seen clearly in both plots, there are a small number of common names and a much larger number of uncommon names. Finally, the magnitudes of these proportions are interesting, in 1890 the most popular names covered about 7% of the total population of new SSN applicants, while this was down to 3% in 1990.

Name Change

Were there any large changes in names over time? this is a bit more difficult question to answer, but let's have a go at it. What we need to do is to look at changes by a given lag, e.g. how do the names at time compare to names at tie where is a whole number.

Let's take a look at the change with , and use the mean squared difference between names. The mean squared difference is calculated as

where each proportion is identified as

, the set of names in year

. If the name is observed in year

but not in

the proportion is set to 0.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

result <- c()
k <- 1

# get the change in proportion
for(t in 1880:(2014-k)) {

  # get the names at t
  currentName <-babynames %>% filter( sex=='M' & year==t)

  # get the names at t+k
  currentNamePlusK <-babynames %>% filter(sex=='M' & year==t+k)

  #join the two years together by name
  check <- left_join(currentName, currentNamePlusK, by=c("name"="name"))
  check[is.na(check)] <- 0

  result <- c( result, mean((check$prop.x - check$prop.y)^2) )
}

result <- cbind(1880:(2014-k),result)
result <-as.data.frame(result)
names(result) <- c('year','change')

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=result, aes(x=year,y=change)) +
  geom_line(size=1.5) +
  labs(
    title='Changes in Yearly Name Proportion',
    y="Mean of Squared Changes in Proportion",
    x="Year")
plot(p)

Figure 10: Name change over time.

This plot is pretty interesting. We see some early on changes around 1890 and 1900, followed by a spike around 1910; then in close to 1970 we have another spike. My best guess would be the 1970 change would be associated with the black power movement that peaked in 1970, and the earlier changes are likely due to immigration events.

If we do a little bit of Google sleuthing we can see in this plot that there seems to be a bit of correlation between these early events and immigration, but not the massive spike in immigration that occurs in 1990. Looking at Wikipedia we can see that around the turn of the century there was a large amount of movement from northern, southern, and eastern Europe to the United States.

However, the massive spike in 1990 doesn't seem to be associated with a massive change in source countries, as seen in this plot. Of course this plot is of regions of birth, which I'll assume is a better indicator of future baby names than country of emigration. Still, as mentioned earlier, the names pre 1937 are a bit incomplete, so the earlier changes in name might be an anomaly in the data, and I certainly don't want to assume some degree of causal relationship.

From the island to the wall

Just for fun, let's look at some popular TV and Movie names over time for males and females.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# get the names
tvNames <-babynames %>%
  filter(name %in%
           c('Bilbo',
             'Aragorn',
             'Gandalf',
             'Boromir',
             'Faramir',
             'Legolas',
             'Frodo',
             'Gilligan',
             'Tyrion'
             ) & sex == 'M')

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=tvNames, aes(x=year,y=prop)) +
  geom_line(aes(color=name),size=1.5) +
  labs(
    title='TV and Movie Names, Male',
    y="Proportion of new SSN applications",
    x="Year")
plot(p)

Figure 11: TV and Movie names over time, Male.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# get the names
tvNames <-babynames %>%
  filter(name %in%
           c('Ginger',
             'Sansa',
             'Arya',
             'Daenerys',
             'Cersei',
             'Arwen'
             ) & sex == 'F')

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=tvNames, aes(x=year,y=prop)) +
  geom_line(aes(color=name),size=1.5) +
  labs(
    title='TV and Movie Names, Female',
    y="Proportion of new SSN applications",
    x="Year")
plot(p)

Figure 12: TV and Movie names over time, Female.

In the end

This was a lot of fun. Please let me know via Twitter or email if you would like to see anymore analysis. If I find some free time I would like to build an interactive website for this data, but in the mean time please feel to play around with the code I have provided.

library(ggplot2)
library(babynames)
library(dplyr)
library(magrittr)

# big plots, because I'm old and blind
theme_set(theme_gray(base_size = 18))

# get the names
theJNames <-babynames %>%
  filter(name %in% c('Fin') & sex == 'M')

# plot the proportion of new SSN applications 
# with the names over time
p <- ggplot(data=theJNames, aes(x=year,y=prop)) +
  geom_line(aes(color=name),size=1.5) +
  labs(
    title='Fin',
    y="Proportion of new SSN applications",
    x="Year")
plot(p)

Figure 13: Proportion of males named Fin over time.

As far as future work goes, I'll probaby take a look at the recent release of data on hard drive reliablility from Backblaze.

Kernels for everyone!

Tue, 02 Aug 2016 00:00:00 -0400

During my dissertation, I spent a lot of time working on spatial kernel estimates. Where spatial kernel estimates are defined as a convolution of a spatial suppport ,

A simple example of this estimate is a Gaussian filter or blur in more common parlance. In the Guassian filter,

is the normal density function

, with the location parameter

and scale parameter

equal to the bandwidth

The kernelDensityEstimates package provides a means to apply these estimates to raster S4 objects from the raster R package. Each function preserves NA values, and uses OpenMP for acceleration. However, all processing is done in memory, so there is no support for extremely large images.

The rasterKernelEstimates R package is currently not on CRAN, but will be after the documentation is cleaned up. Furthermore, the implementation of the kernels is currently non-optimal, and a fair bit of work can be done to speed them up a bit more. For those interested in helping out, the code is on my github page.

A short example of each function is provided below with some basic performance metrics. All timings are done on a Late 2013 MacBook Pro 13" with a dual-core 2.4Ghz i5 running R 3.3.1 compiled under gcc 6.1.0.

rasterLocalSums
rasterLocalQuantiles
rasterLocalMoments
rasterLocalCategoricalModes

rasterLocalSums

The function rasterLocalSums calculates a weighted sum of pixel values in a spatial neighborhood defined by the matrix W,

This is similar to the raster library function focal when fun is not specified. In fact, the results are identical when padding is used in the focal call.

library(raster)
library(rasterKernelEstimates)

set.seed(100)
n <- 500

# create a raster object
r <- raster::raster( matrix(rnorm(n^2),n,n))

# create a weight matrix
W <- raster::focalWeight(r,c(1,0.04),type='Gauss')

# apply the weight with rasterKernelEstimates
run.time <- proc.time()
rLocalKDE1 <- rasterLocalSums(r,W)
print(proc.time() - run.time)

##    user  system elapsed 
##   0.975   0.004   0.325

# apply the weight with the raster packages focal
run.time <- proc.time()
rLocalKDE2 <- raster::focal(r,W,pad=TRUE)
print(proc.time() - run.time)

##    user  system elapsed 
##   0.667   0.008   0.678

# plot original image
plot(r)

# plot the smoothed image
plot(rLocalKDE1)

# print out the max abs difference
print(
sprintf(
  "The maximum absolute difference = %f.",
    max(abs(values(rLocalKDE1) - values(rLocalKDE2)
    ),na.rm = T))
)

## [1] "The maximum absolute difference = 0.000000."

Figure 1: Original image.

Figure 2: Smoothed.

rasterLocalQuantiles

The function rasterLocalQuantiles calculates the quantile of pixel values in a spatial neighborhood defined by the matrix W;

where

is a random variable on the support of

, a spatial neighborhood about point

This result should generally be reproducible using the raster library function focal when fun is specified as quantile. Because quantiles do not necessarily fall exactly on order statistics there is a need to map quantiles between a function of the order statistics. In the rasterLocalQuantiles function this mapping is done to the closest odd-valued-index order statistic. E.g. if the quantile falls between the first and second order statistic. This approach matches the inverse empirical cdf transform used by the type=1 transform in the stats::quantile function. Note that the quantile function applied to raster objects calculates the quantile from all pixels, not local quantiles.

As far as applications go, this function is particularly useful when working with data with a large number of outliers.

library(raster)
library(rasterKernelEstimates)


set.seed(100)
n <- 100

# create a raster object with extreme values
r <- raster::raster( matrix(rcauchy(n^2),n,n))

# create a weight matrix
W <- matrix(1,nrow=3,ncol=3)

# calculate local median
run.time <- proc.time()
rLocalKDE1 <- rasterLocalQuantiles(r,W,q=30)
print(proc.time() - run.time)

##    user  system elapsed
##   0.018   0.001   0.010

# calculate local median
run.time <- proc.time()
rLocalKDE2 <- raster::focal(
  r, W, pad=TRUE,
  fun=function(x) stats::quantile(x,probs=0.3,na.rm=T,type=1),
  padValue=NA)
print(proc.time() - run.time)

##    user  system elapsed
##   1.245   0.010   1.268

# plot boxplot of original image
boxplot(r)

# plot the smoothed image
plot(rLocalKDE1)

# print out the max abs difference
print(
sprintf(
  "The maximum absolute difference = %f.",
    max(abs(values(rLocalKDE1) - values(rLocalKDE2)
    ),na.rm = T))
)

## [1] "The maximum absolute difference = 0.000000."

Figure 3: Box plot of the Cauchy distributed values in the raster r.

Figure 4: Smoothed.

rasterLocalMoments

The function rasterLocalMoments calculates up to the second moment over the weighted matricies Wmu and Wvar,

and

The difference between the mean call here and rasterLocalSums is the normalization of the weights. This ensures the weights sum to one.

library(raster)
library(rasterKernelEstimates)

set.seed(100)
n <- 200

# create a raster object of two populations
r <- raster::raster(
  cbind( matrix(rnorm(n^2),n,n), matrix(rnorm(n^2,2,2),n,n)) )


# create a weight matrix
W <- raster::focalWeight(r,c(1,0.04),type='Gauss')

# calculate the weighted local mean and variance
run.time <- proc.time()
rLocalKDE1 <- rasterLocalMoments(r,W)
print(proc.time() - run.time)

##    user  system elapsed 
##   0.343   0.002   0.102

# plot original image
plot(r)

# plot the weighted mean
plot(rLocalKDE1$mu)

# plot the weighted variance
plot(rLocalKDE1$var)

Figure 5: Original image.

Figure 6: Local weighted mean of the original image.

Figure 7: Local weighted variance of the original image.

rasterLocalCategorical Modes

The function rasterLocalCategoricalModes calculates a categorical mode from a raster image over the weighted spatial neighborhood devined by the matrix W,

where

is the set of unique categories in r.

library(raster)
library(rasterKernelEstimates)

set.seed(100)
n <- 100

# create a categorical raster
r <- raster::raster(
  matrix( sample(-4:4,size=n^2,replace=T),n,n)
  )


# create a weight matrix
W <- matrix(1,9,9)

# calculate the weighted local mean and variance
run.time <- proc.time()
rLocalKDE1 <- rasterLocalCategoricalModes(r,W)
print(proc.time() - run.time)

##    user  system elapsed 
##   0.030   0.000   0.011

# plot original image
plot(r)

# plot the weighted mean
plot(rLocalKDE1)

Figure 8: Original image.

Figure 9: Local weighted mode of the original image.

On a finite time scale

Fri, 29 Jul 2016 00:00:00 -0400

It was rumored that updates to the MacBook Pro were coming at WWDC. These rumors did not pan out. Instead it looks like the new MacBook Pro will be landing sometime later this year, possibly due to delays in availability of high end Skylake 45w mobile parts. This seems plausible, given that Intel only released its Skylake quad core NUC in mid-May. The magnitude of these delays has certainly made its way around the tech press, but are these delays really exceptional?

This quick exploratory analysis of the significance of these delays was performed using historical delays between iterations. The source of this release dates was from the Wikipedia pages for each of these products. A csv file including this data has been made available here. For the retina and non-retina release dates are given for only the retina versions of products once they become available.

Notably absent from this analysis is the MacBook Air and MacBook. In the former case the dates were not present on the Wikipedia article, and in the later case there wasn't sufficient data to do anything but interpolate.

Overview

For this exploratory analysis two models were used. The first model, linear regression with one predictor (see Figure 1.), assumes that there is a constant interval between releases over time. Deviations from this release cycle are just model error. The second model is a differenced regression model. In this linear model, release dates are replaced with differences between release dates. This allows for a trend in the release dates, such as increasing delays between releases.

This analysis treats future releases and delays as a prediction problem. Therefore, prediction intervals are used to determine significance. The level of significance is set to 5% for the two sided interval, however our interest is really at large delays giving us a one-sided confidence level of to 2.5% for our analysis. Inference including point estimates and prediction intervals are based on standard ordinary least squares (OLS) assumptions. In both models, time is treated as the dependent variable with product iteration as the independent variable. Time is represented as days since epoch, where epoch is set at 0 equal to January 1, 1970.

This problem is actually a wait-time problem, so normality is used as an approximation to modeling with gamma distributed errors or other slightly more difficult approaches. Still, the regression approach seems to be 'good enough' for this blog post. In the future I'll revisit more complex models.

macRelease <- read.csv('macrelease.csv')

macRelease$releaseDate <- as.Date(
  macRelease$Release.date,
  format="%d %B %Y")

library(ggplot2)
theme_set(theme_gray(base_size = 20))

# plot product release dates by iteration
p <- ggplot(macRelease,
            aes(x=Iteration, y=releaseDate, group=Product))

p + geom_line(aes(color=Product),size=1) +
  geom_point(aes(color=Product),size=3) +
  labs(
    title='Apple Product Iteration by Release Date',
    y="Release Date")

Figure 1: Linear regression models by Product.

The significance of the results differ considerably by model. According to the first model used, all but the 27" iMac are past the expected release date. Of these delayed products, all but the 21.5" iMac, has a significant delay.

# linear model by product
library(dplyr)

#get unique factors as string
currentProducts <- unique(macRelease$Product)

# create a place to save our predictions
releaseInterval <- c()

# get a specific product
for( i in 1:length(currentProducts)) {
  currentProduct <- filter(macRelease,Product==currentProducts[i])

  # produce a product scatterplot with a linear model overlay 
  p <- ggplot(currentProduct, aes(x=Iteration, y=releaseDate)) +
    geom_point()
  p <- p + geom_smooth(method ="lm",se=TRUE) +
    labs(
      title=currentProducts[i],
      x="Iteration",
      y="Release Date")

  plot(p)

  # converting time to something linear we do our prediction
  fit <- lm( as.numeric(releaseDate) ~ Iteration, data=currentProduct)
  pred <- predict(
    fit,
    data.frame( Iteration=nrow(currentProduct)+1),
    interval="prediction")

  releaseInterval <- rbind( releaseInterval, pred)
}

rownames(releaseInterval) <- currentProducts

# using epoch we get a date range conversion
start.date <- as.Date("1970-01-01")
releaseInterval <- as.data.frame(releaseInterval)
releaseInterval$fit <-  as.character(as.Date(releaseInterval$fit,origin=start.date))
releaseInterval$lwr <-  as.character(as.Date(releaseInterval$lwr,origin=start.date))
releaseInterval$upr <-  as.character(as.Date(releaseInterval$upr,origin=start.date))

Summary of Expected Release Dates and a 95% Prediction Interval
Product	Expected Release Date	Lower Bound	Upper Bound
iMac 27	2017-03-28	2016-02-02	2018-05-22
iMac 21.5	2016-06-19	2015-06-13	2017-06-27
Mac Mini	2014-01-26	2012-03-02	2015-12-22
Mac Pro	2015-04-15	2014-06-20	2016-02-08
MacBook Pro 13	2016-01-02	2015-07-08	2016-06-29
MacBook Pro 15	2015-07-11	2014-10-10	2016-04-09

The second model is a bit more accepting of delays. The MacBook Pros and the Mac Pro have significant delays, marginally so for the Mac Pro. The significance of the 15" MacBook Pro is in part to it's highly regular release schedule. The negative values in the lower bound indicate that the normality assumption may be problematic.

Summary of Expected Delays Between Products and a 95% Prediction Interval
Product	Expected Delay (Days)	Lower Bound	Upper Bound	Delay as of 29 July, 2016
iMac 27	213.61	-242.05	669.27	290.00
iMac 21.5	317.64	-244.61	879.90	290.00
Mac Mini	565.73	-101.98	1233.44	653.00
Mac Pro	603.40	257.63	949.17	953.00
MacBook Pro 13	220.33	0.09	440.57	508.00
MacBook Pro 15	273.71	113.57	433.85	437.00

In both models the delay before the release of the latest Mac Mini is a fairly significant outlier. This increase in delay may indicate a change in update frequency. If this is a change in frequency, then inference using the first model with OLS assumptions is inappropriate due to the error term not being identically distributed. The presence of a good covariate may fix this issue, but it is unknown what covariate would describe this delay. The difference model may also be inappropriate under this change due the presence of heteroscedasticity.

diffInterval <- c()

#get a specific product
for( i in 1:length(currentProducts)) {
  currentProduct <- filter(macRelease,Product==currentProducts[i])

  # get differences
  refreshDiff <- cbind(
    diff(currentProduct$releaseDate),
    2:nrow(currentProduct)
  )

  # add on some column names and make a data frame
  colnames(refreshDiff) <- c('Days','Iteration')
  refreshDiff <- as.data.frame(refreshDiff)

    # converting time to something linear we do our prediction
  fit <- lm( as.numeric(Days) ~ Iteration, data=refreshDiff)
  pred <- predict(
    fit,
    data.frame( Iteration=nrow(refreshDiff)+1),
    interval="prediction")

  # get the difference between the last date, and today's date
  todayDiff <- as.numeric(Sys.Date() - last(currentProduct$releaseDate) )

  diffInterval <- rbind( diffInterval, c(pred,todayDiff))

  # plot the times betweeen iteration
  p <- ggplot(refreshDiff, aes(x=Iteration, y=as.numeric(Days))) +
    geom_point()
  p <- p + geom_smooth(method="lm") +
    labs(
      title=currentProducts[i],
      x="Iteration",
      y="Days Between Release") +
    geom_hline(yintercept=todayDiff, col='red')

  plot(p)
}

rownames(diffInterval) <- currentProducts

Product Release Dates

iMac 27"

Expected Update: 2017-03-28 with 95% prediction interval (2016-02-02, 2018-05-22).

Looking at the 27" iMac we can see that it is frequently updated. The substance of the updates may be in question, but it certainly is at least getting some love.

Figure 2: Linear regression model of the 27" iMac.

Furthermore, we can see a decrease in time between updates, and the 27" iMac is the only current product to get the Skylake treatment. The number of iterations and variability in release dates make this analysis problematic, so the prediction interval takes us way out to mid 2018.

Figure 3: Differenced linear regression models of the 27" iMac; the red line indicates the current delay as of 29 July, 2016.

iMac 21.5"

Expected Update: 2016-06-19 with 95% prediction interval (2015-06-13, 2017-06-27).

The 21.5" iMac is a bit of an oddity; it is still using Broadwell, possibly due to its reliance on integrated graphics. Despite the slightly older CPU architecture, relative to it's big sister, this mac is still being regularly updated. As some degree of evidence that someone at Apple cares about this product, it did make its way into the Retina-age last update.

Figure 4: Linear regression model of the 21.5" iMac.

As before with the 27" iMac, the data is a bit of a mess. Looking at the plot of iterations verse days between releases, the slope has a fair bit of play leading to the fairly wide prediction interval.

Figure 5: Differenced linear regression models of the 21.5" iMac; the red line indicates the current delay as of 29 July, 2016.

Mac Mini

Expected Update: 2014-01-26 with 95% prediction interval (2012-03-02, 2015-12-22).

The first obvious thing about the expected update date and associated prediction interval is that the lower bound occurs before the release of the prior Mac Mini. This implies that a model with normal errors is unlikely to be appropriate. The second thing, possibly more obvious, is that the point estimate (expected update date) is over two years ago, furthermore only about three months after the last release date. The last release date being an extreme outlier. Ideally, these estimates should be revisited with an improved model.

Figure 6: Linear regression model of the Mac Mini.

The second model, for the expected delay, is more forgiving. The upper bound of the prediction interval is close to 3.5 years, giving us another 1.5 years or so to call the delay significant.

The Mac Mini did present a problem with an extended delay between the last and current iteration. The reason for this delay is unclear, making the identification of a good covariate such as Intel processor road maps problematic. The problem with the Intel road map covariate, is that there are CPUs available that fit the price and thermal requirements held by prior Mac Minis. These CPUs, available as of September 2015, include Intel Skylake i5 6260U, 6267U, and 6287U CPUs with the Intel i7 6567U for a high end SKU. Without a good covariate to help explain this change, the observations may indicate a change in release rate. If this is a change in release rate, it will be considerably more difficult to model the Mac Mini without moving to non-linear models.

Figure 7: Differenced linear regression models of the Mac Mini; the red line indicates the current delay as of 29 July, 2016.

geekBench <- read.csv('geekbench.csv')

library(ggplot2)
theme_set(theme_gray(base_size = 20))

# plot product release dates by iteration
p <-
  ggplot(geekBench, aes(x=Product,y=GeekbenchScore, fill=Benchmark)) +
  geom_bar(stat="identity",position="dodge") + coord_flip() +
  labs(
    title='Apple Product Iteration by Geekbench Score',
    y="Geekbench Score")

plot(p)

There is also a chance that the model has been discontinued. Apple's Mac Mini advertisement page certainly doesn't help, where the mac mini is pictured next to a discontinued apple display.

Under the assumption that Apple likes to make a profit, we could use sales figures to get an idea if this product is likely to be discontinued (assuming that Apple isn't selling at a loss). Unfortunately, we don't have sales figures for the mac mini. Instead Amazon's Best Sellers could be used as at least a measure of popularity relative to other products. In this listing (as of 10:18AM EST on July 29, 2016) the mac mini holds place seven and eight with the 21.5" iMac showing up in ninth and the 27" iMac in twelfth. Although it is unclear what the window the sales are aggregated over ("Updated Hourly" doesn't necessarily imply single hour aggregation), the sales positions do imply someone is buying these.

For those interested, the eighth place product was the base model ($449) with a 1.4Ghz (2.7GHz Turbo Boost) CPU, 4GB of RAM and a 500GB hard drive. The seventh place Mac Mini ($649) had 8GB of RAM, a 2.6GHz (3.1GHz Turbo Boost) CPU and a 1TB hard drive.

This popularity is a bit surprising, given no real increase in single-core performance since 2011 and a decrease in multi-core performance since dropping the quad core model (Figure 8). However, the mac mini is only $449 at Amazon, a good $550 cheaper than the 21.5" iMac. This price and demand for some macOS based desktop computing seems to keep this product around, likely without much change in price or performance.

Figure 8: Rough summary of Geekbench 3 results for the Mac Mini.

Mac Pro

Expected Update: 2015-04-15 with 95% prediction interval (2014-06-20, 2016-02-08).

The first model (Figure 9.) shows a fairly regular update cycle for the Mac Pro. Based on this regularity we would expect an update sometime around last month. This of course hasn't happened, as seen by my aging 2006 Mac Pro and my full piggy bank. This change in release date can't be adequately explained by lack of drop in CPU replacements, given that the 2011 pin Haswell and Broadwell chips have been skipped. Therefore, it is unclear if Apple is waiting for the next Intel chip or the second coming for a future update.

Figure 9: Linear regression model of the Mac Pro.

The second model (Figure 10.) agrees with the first with respect to the delay being significant. This model further shows an increase in the delay between releases; as mentioned earlier, there doesn't seem to be any obvious reason for this delay.

Figure 10: Differenced linear regression models of the Mac Pro; the red line indicates the current delay as of 29 July, 2016.

Like the Mac Mini, Apple doesn't provide breakouts for sales for just the Mac Pro so it is hard to determine if it was a flop or not. Even if it was a flop, there is always the argument for an aspiration product. But, it is not clear if this product is really aspiring, or if gazes have moved to more mobile devices.

MacBook Pro 13"

Expected Update: 2016-01-02 with 95% prediction interval ( 2015-07-08, 2016-06-29).

There isn't that much to say about the MacBook Pro 13", it's late. Furthermore, it's significantly late relative to other delays. Current rumors point to a release in Q4 2016, so the wait should come to an end soon.

Figure 11: Linear regression model of the MacBook Pro 13".

The second model points to a decrease in delays, but the variability is sufficiently high to reverse directions after a few late releases.

Figure 12: Differenced linear regression models of the MacBook Pro 13"; the red line indicates the current delay as of 29 July, 2016.

MacBook Pro 15"

Expected Update: 2015-07-11 with 95% prediction interval (2014-10-10, 2016-04-09).

Like the 13" model the 15" MacBook Pro is likely to get an update soon. Unlike the 13", the 15" model seemed to have slightly less variance, this seems to be at least in part due to the discrete GPU in the more recent models. If we take a look at the last update in the MacBook Pro line, it met it's release date not by upgrading the CPU but by only upgrading the GPU.

Figure 11: Linear regression model of the MacBook Pro 15".

As far as the change in release rate goes, it seems to be increasing. It will be interesting to see if this change extends to align with Intel's latest delays on Kaby Lake, or if Apple is happy to just exchange discrete graphics to keep up the cadence.

Figure 14: Differenced linear regression models of the MacBook Pro 15"; the red line indicates the current delay as of 29 July, 2016.

Predicting Agriculture, Poorly (Part I)

Sun, 24 Jul 2016 00:00:00 -0400

Crop rotation is an agricultural production practice to increase yield, mitigate disease, and control pests. This production practice involves growing crops in specific sequences to improve the quality of soil for the following crop. A common example in the United States is the practice of growing soybeans before corn. In this example soybeans fixate nitrogen in the soil leading to an increase in yield and reduction in fertilizer consumption.

Provided that this production process is prevalent and we have some data regarding where and when particular crops grow, then a stochastic process such as a Markov chain can be used to predict what will be grown where. Luckily, the United States Department of Agriculture's (USDA) Cropland Data Layer (CDL) can be used to obtain crop location anywhere in the continental United States from 2008-2015. The literature on this subject for major crops including corn, soybeans, winter wheat, cotton and peanuts points towards a high degree of employment of crop rotation across the continental United States. An analysis of the CDL data by (Sahajpal, 2013) showed that 90% of Iowa's crop production could be represented with three different crop rotations, and 80% of the U.S. crop production could be described with 180 unique rotations. Crop rotation analysis by (Boryan, 2014) examined corn and soybean rotations in the corn belt from 2004 to 2008. This analysis showed that over 45% of the total cultivated acreage in Iowa, 32% of Illinois, and 20% of Nebraska could be explained by corn-to-soy rotations. Further analysis showed that particular rotation patterns are spatially associated with particular regions. An example of this can be seen along the Platte river in Nebraska where 65%, 49%, and 50% of the cultivated acreage within Hall, Chase, and Dawson Counties respectfully grew corn for at least four out of the five years studied, while the statewide cultivated acreage covered by continuous or near-continuous corn cropping was much lower. Similar activity was seen in Iowa and Illinois.

Model Development

In the United States crop rotation can be observed for most major row crops such as corn, soybeans, and wheat. A naive model will be introduced using a simple Markov chain to assist in prediction. Future models in this blog will build on this model, and use this simple model as a benchmark.

A Naive Approach

A stochastic processes is an ordered sequence of random variables. The relationship between these variables can be described by a stochastic model, such models are a typical way to capture changes in states such as crop rotations. A general form of a categorical stochastic model for land use is

where

is a categorical random variable for classes

indexed by time

in a set of temporal indexes

, and

a spatial location in a region

. In this model the current land use or state is a function of the prior states and random error

. If we were to make the naive assumption that each land use unit is an independent realization of a stationary in time Markov Chain, where a Markov Chain is a stochastic process satisfying

under these conditions the stochastic model can be written as

The term stationary when applied to a stochastic process implies that the distribution is invariant to the index of the process. Stationarity can be applied to time, space or both. For the purposes of this simple model we will assume that

is stationary in time, and each observed transition is independent and identically distributed. Future models will relax these restrictions. Since the transition probabilities are stationary in time, then the process can be also described via a single transition or stochastic matrix,

where

for any

. Under the typical assumption that each row of

follows a multinomial distribution conditioned on the prior state, then estimates of

can be easily be estimated via maximum likelihood.

Example

The maximum likelihood estimates are simply the observed transitions for each prior state divieded by the total number of observed transitions from the prior state. To calculate these reatios we need to aggregate the year-to-year transition data from the CDL pixels for Iowa. Note that due to resampling, this may take a considerable amount of time (hours) depending on your system. To speed things up the results csv is provided through the website.

Now that you have the data, hopefully from downloading it, we can start working with it:

library(dplyr)
library(magrittr)
library(tidyr)

library(devtools)
install_github('jlisic/cdlTools')
library(cdlTools)

# read in csv file
cropChange <- read.csv("Iowa_2008_2015_change.csv")

# create a major crop type identifier
# preference is given to corn for corn/soy multiple cropping
justSoy <- setdiff(soybeans,corn)

# Major crop identifier: 
# 0 non Cultivated
# 1 other cultivated
# 2 soybeans (but no dual crop soybeans and corn)
# 3 corn
cropChange$cropTypeFrom <- cropChange$In %in% cultivated
cropChange$cropTypeFrom <- cropChange$In %in% justSoy + cropChange$cropTypeFrom
cropChange$cropTypeFrom <- 2*cropChange$In %in% corn + cropChange$cropTypeFrom

cropChange$cropTypeTo <- cropChange$Out %in% cultivated
cropChange$cropTypeTo <- cropChange$Out %in% justSoy + cropChange$cropTypeTo
cropChange$cropTypeTo <- 2*cropChange$Out %in% corn + cropChange$cropTypeTo

#create a tidy transition matrix
K.tidy <- cropChange %>%                 # get data
  group_by(cropTypeTo, cropTypeFrom)%>%  # group by unique To and From
  summarize(totalPixels=sum(Pixels))     # sum pixels in each group

# create the transition matrix K
K <- spread(K.tidy,cropTypeTo,totalPixels) %>% select(2:5)
K <- K/rowSums(K)
rownames(K) <- colnames(K) <- c('nonCult','cult','soybeans','corn')
print(K)

##             nonCult        cult   soybeans       corn
## nonCult  0.81769249 0.019130333 0.06618133 0.09699585
## cult     0.30518990 0.174452328 0.17803400 0.34232377
## soybeans 0.05949642 0.008826269 0.37963993 0.55203739
## corn     0.06057745 0.010194854 0.39156959 0.53765810

Next time, we will compare these results to some federal statistics.

References

Boryan, Claire, et al. "Monitoring US agriculture: the US department of agriculture, national agricultural statistics service, cropland data layer program." Geocarto International 26.5 (2011): 341-358.

Boryan, Claire G., Zhengwei Yang, and Patrick Willis. "US geospatial crop frequency data layers." Agro-geoinformatics (Agro-geoinformatics 2014), Third International Conference on. IEEE, 2014.

Sahajpal, R., et al. "Generating a Crop Rotation Dataset for the US and its Application in Inferring Land Use Change Induced Wetland Losses in the Prairie Pothole Region." AGU Fall Meeting Abstracts. Vol. 1. 2013.