2015/10/20

Paging Widget for Shiny Apps

In my last post I described how I built a shiny application called “DFaceR”
that used Chernoff Faces to plot multidimensional data. To improve application
response time during plotting, I needed to split large datasets into more
manageable “pages” to be plotted.

Rather than take the path of least resistance and use either numericInput or
sliderInput widgets that come with shiny to interact with paginated data, I
wanted nice page number and prev/next buttons like on a dataTables.js table.

In this post, I describe how I built a custom shiny widget called pager-ui
to achieve this.


Prior to starting, I did some research (via google) for any preexisting shiny
paging solutions. However, nothing matched what I wanted. So I set forth and
built my own solution using the following framework:

  • a couple of hidden numeric inputs to store the current page and total number
    of pages
  • jquery event handlers bound to change events on the above numeric inputs
  • a javascript function to render page number buttons based on the currently
    selected page and the total number of pages

The solution I deployed with DFaceR used a template javascript file that was updated
with the containing pager-ui element id when the widget was added to ui.R.
Reading, reacting to, and updating the widget required directly accessing the
hidden numeric inputs in server.R.

While this worked, it was not the formal way to build a custom input widget as
described by this shiny developer article.
Thankfully, only a little extra work was needed to build it the correct way.

Custom widget components

According to the developer article, a custom input requires the following:

  • javascript code to
    • define the widget’s behavior (i.e. jQuery event handlers)
    • register an input binding object with shiny
  • an R function to add the HTML for the widget to ui.R

Widget layout

For reference, the (simplified) pager widget HTML is:

<div class="pager-ui">
  <!-- Input fields that Shiny will react to -->
  <div class="hidden">
    <input type="number" class="page-current" value="1" />
    <input type="number" class="pages-total" value="10" />
  </div>

  <div class="page-buttons">
    <!-- Everything in here is dynamically rendered via javascript -->

    <span class="btn-group">
      <button class="btn btn-default page-prev-button">Prev</button>
      <button class="btn btn-default page-next-button">Next</button>
    </span>

    <span class="btn-group">
      <!-- button for the current page has class btn-info -->
      <button class="btn btn-info page-num-button" data-page-num="1">1</button>

      <!-- other buttons have class btn-default -->
      <button class="btn btn-default page-num-button" data-page-num="2">2</button>

      <!-- ... rest of page num buttons ... -->
    </span>

  </div><!-- /.page-buttons -->
</div><!-- /.pager-ui -->

As a personal preference, I’ve put the prev and next buttons together in
their own btn-group because it keeps their positions in the page consistent
rather than have them jump around depending on how many page buttons are rendered.

Also note that the page-num buttons encode their respective page numbers in
data-page-num attributes.

Everything in the div.page-buttons element is rendered dynamically via javascript.

The javascript …

As is probably the case with most widgets for shiny, most of the code for
pager-ui is written in javascript. This is understandable since much of the
user facing interactivity happens in a web browser.

Making the widget behave

The pager widget has the following behaviors:

  • in/de-crease the current page number with next/previous button clicks
  • set the current page number with page number button clicks
  • rerender the buttons as needed when the current page number changes
  • rerender the buttons as needed when the total number of pages changes

To keep things a little DRY, I use a simple object for accessing the specific
pager-ui element being used:

PagerUI = function(target, locate, direction) {
  var me = this;

  me.root = null;
  me.page_current = null;
  me.pages_total = null;

  if (typeof locate !== 'undefined' && locate) {
    if (direction === 'child') {
      me.root = $(target).find(".pager-ui").first();
    } else {
      // default direction is to search parents of target
      me.root = $(target)
        .parentsUntil(".pager-ui")
        .parent();  // travers to the root pager-ui node
    }
  } else {
    // pager-ui node is explicitly specified
    me.root = $(target);
  }

  if (me.root) {
    me.page_current = me.root.find(".page-current");
    me.pages_total = me.root.find(".pages-total");
  }

  return(me);
};

This takes a selector or jQuery object in target for either specifying the
specific pager-ui container used, or a starting point (e.g. a child button)
from which to search for the container.

This keeps the event handler callbacks relatively short and easier to maintain.
In total, there are four event handlers which map directly to the behaviors
described above, all of them delegated to the document node of the DOM.

First, one to handle clicks from page-number buttons:

// delegate a click event handler for pager page-number buttons
$(document).on("click", "button.page-num-button", function(event) {
  var $btn = $(event.target);
  var page_num = $btn.data("page-num");
  var $pager = new PagerUI($btn, true);

  $pager.page_current
    .val(page_num)
    .trigger("change");

});

Next, a couple to handle clicks from previous and next buttons:

$(document).on("click", "button.page-prev-button", function(event) {
  var $pager = new PagerUI(event.target, true);

  var page_current = parseInt($pager.page_current.val());

  if (page_current > 1) {
    $pager.page_current
      .val(page_current-1)
      .trigger('change');
  }

});

$(document).on("click", "button.page-next-button", function(event) {
  var $pager = new PagerUI(event.target, true);

  var page_current = parseInt($pager.page_current.val());
  var pages_total = parseInt($pager.pages_total.val());

  if (page_current < pages_total) {
    $pager.page_current
      .val(page_current+1)
      .trigger('change');
  }

});

Finally, a couple handlers to catch change events on the hidden numeric fields
and rerender the widget:

// delegate a change event handler for pages-total to draw the page buttons
$(document).on("change", "input.pages-total", function(event) {
  var $pager = new PagerUI(event.target, true);
  pagerui_render($pager.root);
});

// delegate a change event handler for page-current to draw the page buttons
$(document).on("change", "input.page-current", function(event) {
  var $pager = new PagerUI(event.target, true);
  pagerui_render($pager.root);
});

Rendering is done via the pagerui_render() function. It is pretty long so
check out the source (linked below) for the full details. In a nutshell it:

  • renders all of the page-number buttons needed for the following cases, using
    ... spacer buttons when necessary:

    • current page is within the first 3 pages
    • current page is within the last 3 pages
    • current page is somewhere in the middle
  • sets the enabled state of the prev and next buttons depending on the currently
    selected page (e.g. the prev button is disabled if the current page is 1).

Shiny registration

To fully tie the widget to shiny it needs to be “registered”. This basically
provides a standard interface between the widget and shiny’s core javascript
framework via an input binding object.

The shiny input binding for pager-ui is:

var pageruiInputBinding = new Shiny.InputBinding();
$.extend(pageruiInputBinding, {
  find: function(scope) {
    return( $(scope).find(".pager-ui") );
  },
  // getId: function(el) {},
  getValue: function(el) {
    return({
      page_current: parseInt($(el).find(".page-current").val()),
      pages_total: parseInt($(el).find(".pages-total").val())
    });
  },
  setValue: function(el, value) {
    $(el).find(".page-current").val(value.page_current);
    $(el).find(".pages-total").val(value.pages_total);
  },
  subscribe: function(el, callback) {
    $(el).on("change.pageruiInputBinding", function(e) {
      callback(true);
    });
    $(el).on("click.pageruiInputBinding", function(e) {
      callback(true);
    });
  },
  unsubscribe: function(el) {
    $(el).off(".pageruiInputBinding");
  },
  getRatePolicy: function() {
    return("debounce");
  },

  /**
   * The following two methods are not covered in the developer article, but
   * are documented in the comments in input_binding.js
   */
  initialize: function(el) {
    // called when document is ready using initial values defined in ui.R
    pagerui_render(el);
  },
  receiveMessage: function(el, data) {
    // This is used for receiving messages that tell the input object to do
    // things, such as setting values (including min, max, and others).
    if (data.page_current) {
      $(el).find(".page-current")
        .val(data.page_current)
        .trigger('change');
    }

    if (data.pages_total) {
      $(el).find(".pages-total")
        .val(data.pages_total)
        .trigger('change');
    }
  }
});

Shiny.inputBindings
  .register(pageruiInputBinding, "oddhypothesis.pageruiInputBinding");

Let’s break this apart …

There are nine methonds defined in the interface. The first seven are documented
by the developer article,

  • find: locate the widget and return a jQuery object reference to it
  • getValue: return the widget’s value (can be JSON if complex)
  • setValue: not used
  • subscribe: binds event callbacks to the widget, optionally specifying use of
    a rate policy. Note the use of jQuery event namespacing
  • unsubscribe: unbinds event callbacks on the widget - again using jQuery event
    namespacing
  • getRatePolicy: specifies the rate policy to used - either “throttle” or
    “debounce”

and are pretty close to the boilerplate examples with only a few custom changes.

First, the getValue method returns a JSON object with two properties
(page_current and pages_total):

getValue: function(el) {
  return({
    page_current: parseInt($(el).find(".page-current").val()),
    pages_total: parseInt($(el).find(".pages-total").val())
  });
}

This means that when the widget is accessed in server.R via the input object,
it will return a list() with the following structure:

List of 2
 $ page_current: int 1
 $ pages_total : int 4

Second, event callbacks are subscribed with a “debounce” rate policy:

subscribe: function(el, callback) {
  $(el).on("change.pageruiInputBinding", function(e) {
    callback(true);
  });
  $(el).on("click.pageruiInputBinding", function(e) {
    callback(true);
  });
},
getRatePolicy: function() {
  return("debounce");
}

This prevents excessive callback executions, and subsequent weird behavior, if
the prev and next buttons are clicked too rapidly.

The last two methods of the input binding,

  • initialize
  • receiveMessage

are ones that I added based on documentation I found in shiny’s
source code for input bindings.

The initialize method is called when the document is ready, which I found
necessary to, well, initialize the widget with default values. For this widget,
all that needs to happen is for it to be rendered for the first time.

initialize: function(el) {
  // called when document is ready using initial values defined in ui.R
  pagerui_render(el);
}

The receiveMessage method is used to communicate with the widget from server.R.
In most cases, this will send a data update, but one could imagine other useful
messages that could be sent.

receiveMessage: function(el, data) {
  // This is used for receiving messages that tell the input object to do
  // things, such as setting values (including min, max, and others).
  if (data.page_current) {
    $(el).find(".page-current")
      .val(data.page_current)
      .trigger('change');
  }

  if (data.pages_total) {
    $(el).find(".pages-total")
      .val(data.pages_total)
      .trigger('change');
  }
}

To finish up the input binding, it is registered with:

Shiny.inputBindings
  .register(pageruiInputBinding, "oddhypothesis.pageruiInputBinding");

As a good measure, I placed all of the above javascript in an
immediately invoked function expression:

(function(){
  // ... code ...
}());

to ensure that I didn’t inadvertently overwrite any variables in the global scope.

All of the above javascript lives in one file that is placed in:

<app>
|- ui.R
|- server.R
|- global.R
+- www/
   +- js/
      +- input_binding_pager-ui.js  <-- here

The R code …

Compared to the javascript code, the R code is fairly simple. There are two
functions:

  • pageruiInput(): to put the widget in the layout, used in ui.R
  • updatePageruiInput(): to update the widget with new data, used in server.R

Generating the HTML for the widget

The widget requires two javascript files:

  • input_binding_pager-ui.js containing all the behavior and shiny input binding code
  • underscore-min.js a dependency of pagerui_render()

These files only need to be referenced in the app once, regardless of how many
pager-ui widgets are used. Therefore, they are added using singleton() in
the R code:

tagList(
  singleton(
    tags$head(
      tags$script(src = 'js/underscore-min.js'),
      tags$script(src = 'js/input_binding_pager-ui.js')
    )
  ),

  # ... rest of html generation code ...
)

The rest of the HTML generation code follows the layout specified earlier with
special considerations for making the numeric input field ids unique by propagating
the pager-ui id, and setting default numeric values.

pageruiInput = function(inputId, page_current = NULL, pages_total = NULL) {
  # construct the pager-ui framework
  tagList(
    singleton(
      tags$head(
        tags$script(src = 'js/underscore-min.js'),
        tags$script(src = 'js/input_binding_pager-ui.js')
      )
    ),

    # root pager-ui node
    div(
      id = inputId,
      class = 'pager-ui',

      # container for hidden numeric fields
      div(
        class = 'hidden',

        # numeric input to store current page
        tags$input(
          id = paste(inputId, 'page_current', sep='__'),
          class = 'page-current',
          type = 'number',
          value = ifelse(!is.null(page_current), page_current, 1),
          min = 1,
          max = ifelse(!is.null(pages_total), pages_total, 1)
        ),

        # numeric input to store total pages
        tags$input(
          id = paste(inputId, 'pages_total', sep='__'),
          class = 'pages-total',
          type = 'number',
          value = ifelse(!is.null(pages_total), pages_total, 0),
          min = 0,
          max = ifelse(!is.null(pages_total), pages_total, 0)
        )
      ),

      # container for pager button groups
      div(
        class = 'page-buttons',

        # prev/next buttons
        span(
          class = 'page-button-group-prev-next btn-group',
          tags$button(
            id = paste(inputId, 'page-prev-button', sep='__'),
            class = 'page-prev-button btn btn-default',
            'Prev'
          ),
          tags$button(
            id = paste(inputId, 'page-next-button', sep='__'),
            class = 'page-next-button btn btn-default',
            'Next'
          )
        ),

        # page number buttons
        # dynamically generated via javascript
        span(
          class = 'page-button-group-numbers btn-group'
        )
      )
    )
  )
}

To update the widget from server.R there is an updatePageruiInput() function
whose body was effectively copied from other update*() functions that are used
for other inputs (notably text and numeric inputs).

updatePageruiInput = function(
  session, inputId, page_current = NULL, pages_total = NULL) {

  message = shiny:::dropNulls(list(
    page_current = shiny:::formatNoSci(page_current),
    pages_total = shiny:::formatNoSci(pages_total)
  ))

  session$sendInputMessage(inputId, message)
}

Thus, to add a pager-ui widget to a shiny ui:

# ui.R
shinyUI(pageWithSideBar(
  headerPanel(...),
  sidebarPanel(...),
  mainPanel(
    pageruiInput(inputId='pager', page_current = 1, pages_total = 1),
    ...
  )
))

On the server side, the value from the widget is accessed by:

# server.R
shinyServer(function(input, output, session) {
  # ...

  pager_state = reactive({
    input$pager
  })

  # ...
}

which will return a list with two elements page_current and pages_total.

To update the widget from server.R simply call updatePageruiInput() as needed:

# server.R
shinyServer(function(input, output, session) {
  # ...

  observeEvent(
    eventExpr = {
      input$btn_update_page
    },
    handlerExpr = {
      new_page = # ... code to determine new page ...
      updatePageruiInput(session, 'pager', page_current = new_page)
    }
  )

  # ...
})

See for yourself

The source code for a demo shiny app that uses this widget, and contains all the
code needed to add this widget to other apps is
available on Github.

Happy paging.

Written with StackEdit.

2015/10/10

Facing your data

A few years ago, I came across a post on FlowingData about using Chernoff Faces as a fun way to visualize multidimensional data:

> The assumption is that we can read people's faces easily in real life, 
> so we should be able to recognize small differences when they represent data. 
> Now that's a pretty big assumption, but debate aside, they're fun to make.

I showed this concept to a coworker, who found it amusing and championed (albeit in jest) making an application to enable scientists at our company to use faces as a standard visualization for data analysis and reporting. From that point on it was one of our running jokes to “face” our data. Unfortunately, being that the company was small and everyone (including myself) was always busy, there was rarely any spare time to devote to this. That is, until now …

I recently accepted a position at UCSD and had a week off between the last day at my old job and the first day at my new job. I thought this would be a good time to build a shiny application for plotting data with Chernoff Faces.

Chernoff Faces in R

To plot Chernoff Faces in R, one uses the faces() function from the aplpack package:

library(aplpack)
#> Loading required package: tcltk
faces(mtcars)
#> effect of variables:
#>  modified item       Var   
#>  "height of face   " "mpg" 
#>  "width of face    " "cyl" 
#>  "structure of face" "disp"
#>  "height of mouth  " "hp"  
#>  "width of mouth   " "drat"
#>  "smiling          " "wt"  
#>  "height of eyes   " "qsec"
#>  "width of eyes    " "vs"  
#>  "height of hair   " "am"  
#>  "width of hair   "  "gear"
#>  "style of hair   "  "carb"
#>  "height of nose  "  "mpg" 
#>  "width of nose   "  "cyl" 
#>  "width of ear    "  "disp"
#>  "height of ear   "  "hp"

As shown above, the side-effects of this function are:

  • a plot of faces, each representing individual rows of the data
  • a printed data.matrix displaying how variables (columns) in the data are mapped to facial features.
Aesthetics of the faces aside, they do make it easy to identify similarly peforming cars in the mtcars data set - e.g. Honda Civic, Toyota Corolla, and Fiat 128.

There are a couple quirks:

  • data needs to be all numeric - any character or factor columns need to be handled (converted) appropriately
  • the face drawing algorithm takes a bit of time - I wouldn’t recommend it for input data with more than 500 observations. In my opinion, anything more than a 10x10 grid of faces becomes visually overwhelming.

Cleaning your face … data

Because the data to faces() needs to be numeric, here’s what happens when trying to draw faces using the iris data set:

faces(iris)
#> Error in x - min(x): non-numeric argument to binary operator

This error occurs because the Species column is a factor:

str(iris)
#> 'data.frame':    150 obs. of  5 variables:
#>  $ Sepal.Length: num  5.1 4.9 4.7 4.6 5 5.4 4.6 5 4.4 4.9 ...
#>  $ Sepal.Width : num  3.5 3 3.2 3.1 3.6 3.9 3.4 3.4 2.9 3.1 ...
#>  $ Petal.Length: num  1.4 1.4 1.3 1.5 1.4 1.7 1.4 1.5 1.4 1.5 ...
#>  $ Petal.Width : num  0.2 0.2 0.2 0.2 0.2 0.4 0.3 0.2 0.2 0.1 ...
#>  $ Species     : Factor w/ 3 levels "setosa","versicolor",..: 1 1 1 1 1 1 1 1 1 1 ...

Converting this column to its numeric equivalent successfully creates faces:

set.seed(1234)
sample_rows = sample(1:nrow(iris), 25)

tmp = iris[sample_rows,]
tmp$Species = as.numeric(tmp$Species)
faces(tmp, print.info=F)

Alternatively, the Species column could be excluded from the data sent to faces() and used for labeling:

tmp = iris[sample_rows,]
labels = as.character(tmp$Species)
tmp = tmp[-which(colnames(tmp) == 'Species')]
faces(tmp, labels = labels, print.info=F)

Considering the above, a couple helper functions are in order. One to produce labels from character columns:

label_data = function(data) {
  if (is.null(data)) {
    return(NULL)
  }

  col_classes = sapply(data, class)
  cols_char = which(sapply(data, inherits, what='character'))

  labels = NULL
  if (length(cols_char)) {
    if (length(cols_char) > 1) {
      labels = do.call(paste, c(as.list(data[,cols_char]), sep=', '))
    } else {
      labels = data[[cols_char]]
    }
  }

  return(labels)
}

and one to remove any character columns and convert factor columns to numeric values:

clean_data = function(data) {
  # faces expects a data.matrix-like object with all numeric columns

  if (is.null(data)) {
    return(NULL)
  }

  col_classes = sapply(data, class)
  cols_char = which(sapply(data, inherits, what='character'))
  cols_fctr = which(sapply(data, inherits, what='factor'))

  # try to preserve character columns as labels (row.names)
  if (length(cols_char)) {

    tryCatch({
        row_names = if (length(cols_char) > 1) {
          do.call(paste, c(as.list(data[,cols_char]), sep=', '))
        } else {
          data[[cols_char]]
        }
        rownames(data) = row_names

      },
      error = function(e) {
        # unable to parse rownames, drop completely
        message(sprintf('unable to assign row names: %s', e$message))
      },
      finally = {
        data = data[-cols_char]
      }
    )

  }

  # convert factor columns to integer
  if (length(cols_fctr)) {
    data[,cols_fctr] = sapply(data[,cols_fctr], as.integer)
  }

  return(data)
}

Paginated faces

Plotting faces() for all 150 rows in the iris dataset takes nearly three seconds on my 5yr old laptop:

system.time({faces(clean_data(iris), print.info=F)})
#>    user  system elapsed 
#>    2.61    0.23    2.84

So providing smaller chunks of data to faces() will be necessary to keep a shiny application nice and responsive. Splitting iris into multiple 50-row “pages” is much more snappy:

system.time({
  sample_rows = 1:50
  faces(clean_data(iris)[sample_rows,], print.info=F)
})
#>    user  system elapsed 
#>    0.86    0.11    0.97
system.time({
  sample_rows = 51:100
  faces(clean_data(iris)[sample_rows,], print.info=F)
})
#>    user  system elapsed 
#>    0.89    0.08    0.97
system.time({
  sample_rows = 101:150
  faces(clean_data(iris)[sample_rows,], print.info=F)
})
#>    user  system elapsed 
#>    0.89    0.07    0.95

While faces() can perform normalization, it only operates on the data provided. Paging prior to calling faces() requires that the entire data set be normalized beforehand. Hence a scale_data() function is needed:

scale_data = function(data) {
  # normalizes data to [-1,1] which faces(scale=T) does
  apply(data, 2, function(x) {
    (x - min(x)) / (max(x) - min(x)) * 2 - 1
  })
}

Thus the workflow to produce faces for any given page of data is:

data = scale_data(clean_data(raw_data))
page_rows = # ... code to create a list of row indices for pages ... #

# for page_num in 1:length(page_rows) ...
data_page = data[page_rows[[page_num]], ]
face_page = faces(data_page, scale=F, print.info=F, plot.faces=F)
plot(face_page)

Shiny faces

The complete application, DFaceR (pun intended), is published on shinyapps.io. Source code is available on GitHub.

All of the core face plotting functionality was straight forward to build into a shiny application. The tricky part was building the data paging functionality.

The path of least resistance would have been to use either a numericInput or sliderInput to page through the data. However, I wanted nice page number and prev/next buttons as can be gotten on a dataTables.js table. A quick internet search produced nothing that matched my needs. So, I created my own widget for this which I’ll describe in more detail in an upcoming post.

For now, enjoy “facing” your data.

Written with Rmarkdown and StackEdit.

2015/01/21

Easy error propagation in R

In a previous post I demonstrated how to use R’s simple built-in symbolic engine to generate Jacobian and (pseudo)-Hessian matrices that make non-linear optimization perform much more efficiently. Another related application is Gaussian error propagation.

Say you have data from a set of measurements in variables x and y where you know the corresponding measurement errors (dx and dy, typically the standard deviation or error from a set of replicates or a calibration curve). Next you want to create a derived value defined by an arbitrary function z = f(x,y). What would the corresponding error in value of z, i.e. dz = df, be?

If the function f(x,y) is a simple sum or product, their are simple equations for determining df. However, if f(x,y) is something more complex, like:

z=f(x,y)=xy(x+y)2

you’ll need to use a bit of calculus, specifically the chain rule:

df=(dxfx)2+(dyfy)2+...

Applying the above equation allows for the derivation of Gaussian error propagation for any arbitrary function. So how does one do this in R? Again, the D() function and R expression() objects come to our rescue.

Say the definition of z (ergo f(x,y)) is defined in an R formula:

> f = z ~ (x-y)/(x+y)^2

If you probe the structure of a formula object you get:

> str(f)
Class 'formula' length 3 z ~ (x - y)/(x + y)^2
  ..- attr(*, ".Environment")=<environment: R_GlobalEnv>

What’s key is the “length 3” bit:

> f[[1]]; f[[2]]; f[[3]]
`~`
z
(x - y)/(x + y)^2

The code above shows us that a formula object can be subsetted into its constituent parts:

  1. the formula operator: ~
  2. the left-hand side (LHS) of the formula: z
  3. the right-hand side (RHS) of the formula: (x - y)/(x + y)^2

The class() of the RHS is a call, which is close enough to an R expression that both all.vars() and D() work as expected to generate the mathematical expressions for the partial derivatives with respect to each variable:

> all.vars(f[[3]])
[1] "x" "y"

> lapply(all.vars(f[[3]]), function(v) D(f[[3]], v))
[[1]]
1/(x + y)^2 - (x - y) * (2 * (x + y))/((x + y)^2)^2

[[2]]
-(1/(x + y)^2 + (x - y) * (2 * (x + y))/((x + y)^2)^2)

These expressions need to be modified a bit - i.e. in this case they need to be multiplied by dx and dy, respectively and then squared. What’s returned from D() is a call object, so the elements above need to be converted to character to manipulate them accordingly. This is done with deparse().

> lapply(all.vars(f[[3]]), function(v) deparse(D(f[[3]], v)))
[[1]]
[1] "1/(x + y)^2 - (x - y) * (2 * (x + y))/((x + y)^2)^2"

[[2]]
[1] "-(1/(x + y)^2 + (x - y) * (2 * (x + y))/((x + y)^2)^2)"

The final error propagation expression is created with a bit of string manipulation:

> sprintf('sqrt(%s)', 
    paste(
        sapply(all.vars(f[[3]]), function(v) {
            sprintf('(d%s*(%s))^2', v, deparse(D(f[[3]], v)))
        }), 
        collapse='+'
    )
  )
[1] "sqrt((dx*(1/(x + y)^2 - (x - y) * (2 * (x + y))/((x + y)^2)^2))^2+(dy*(-(1/(x + y)^2 + (x - y) * (2 * (x + y))/((x + y)^2)^2)))^2)"

Now that we’ve got the basics down, let’s test this out with some data …

> set.seed(0)
> data = data.frame(
    x  = runif(5), 
    y  = runif(5), 
    dx = runif(5)/10, 
    dy = runif(5)/10
  )
> data
          x         y          dx         dy
1 0.8966972 0.2016819 0.006178627 0.07698414
2 0.2655087 0.8983897 0.020597457 0.04976992
3 0.3721239 0.9446753 0.017655675 0.07176185
4 0.5728534 0.6607978 0.068702285 0.09919061
5 0.9082078 0.6291140 0.038410372 0.03800352

and with a little help from dplyr:

> library(dplyr)
> data %>%
+   mutate_(.dots=list(
+     # compute derived value
+     z  = deparse(f[[3]]),
+     
+     # generates a mathematical expression to compute dz
+     # as a character string
+     dz = sapply(all.vars(f[[3]]), function(v) {
+             dfdp = deparse(D(f[[3]], v))
+             sprintf('(d%s*(%s))^2', v, dfdp)
+           }) %>%
+           paste(collapse='+') %>%
+           sprintf('sqrt(%s)', .)
+       ))
          x         y          dx         dy           z         dz
1 0.8966972 0.2016819 0.006178627 0.07698414  0.57608929 0.14457245
2 0.2655087 0.8983897 0.020597457 0.04976992 -0.46718831 0.03190297
3 0.3721239 0.9446753 0.017655675 0.07176185 -0.33019871 0.01978697
4 0.5728534 0.6607978 0.068702285 0.09919061 -0.05778613 0.07604809
5 0.9082078 0.6291140 0.038410372 0.03800352  0.11809201 0.02424023

Taking this a step further, this method can be wrapped in a chainable function that determines the name of new variables from the LHS of a formula argument:

mutate_with_error = function(.data, f) {
  exprs = list(
      # expression to compute new variable values
      deparse(f[[3]]),

      # expression to compute new variable errors
      sapply(all.vars(f[[3]]), function(v) {
        dfdp = deparse(D(f[[3]], v))
        sprintf('(d%s*(%s))^2', v, dfdp)
      }) %>%
        paste(collapse='+') %>%
        sprintf('sqrt(%s)', .)
  )
  names(exprs) = c(
    deparse(f[[2]]),
    sprintf('d%s', deparse(f[[2]]))
  )

  .data %>%
    # the standard evaluation alternative of mutate()
    mutate_(.dots=exprs)
}

Thus, adding new derived variables and propagating errors accordingly becomes relatively easy:

> set.seed(0)
> data = data.frame(x=runif(5), y=runif(5), dx=runif(5)/10, dy=runif(5)/10)
> data
          x         y          dx         dy
1 0.8966972 0.2016819 0.006178627 0.07698414
2 0.2655087 0.8983897 0.020597457 0.04976992
3 0.3721239 0.9446753 0.017655675 0.07176185
4 0.5728534 0.6607978 0.068702285 0.09919061
5 0.9082078 0.6291140 0.038410372 0.03800352

> data %>% mutate_with_error(z ~ (x-y)/(x+y)^2)
          x         y          dx         dy           z         dz
1 0.8966972 0.2016819 0.006178627 0.07698414  0.57608929 0.14457245
2 0.2655087 0.8983897 0.020597457 0.04976992 -0.46718831 0.03190297
3 0.3721239 0.9446753 0.017655675 0.07176185 -0.33019871 0.01978697
4 0.5728534 0.6607978 0.068702285 0.09919061 -0.05778613 0.07604809
5 0.9082078 0.6291140 0.038410372 0.03800352  0.11809201 0.02424023

Written with StackEdit.