Dave Jarvis' Repositories

# -----------------------------------------------------------------------------
# Copyright 2020, White Magic Software, Ltd.
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
# LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
# OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# Substitute R expressions in a document with their evaluated value. The
# anchor variable must be set for functions that use relative dates.
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------# -----------------------------------------------------------------------------
x <- function( s ) {
  tryCatch( {
    r = eval( parse( text = s ) )

ifelse( is.atomic( r ), r, s );
  },
 s },
  error = function( e ) { s } )
}

# -----------------------------------------------------------------------------
# Retu# ----------------------------------------------------------------------------------------------------------------------------------------------------------# ----------------------------------------------------------------------------------------------------------------------------------------------------------# ----------------------------------------------------------------------------------------------------------------------------------------------------------# ----------------------------------------------------------------------------------------------------------------------------------------------------------# -----------------------------------------------------------------------------
concat <- paste0

# -----------------------------------------------------------------------------.
# -----------------------------------------------------------------------------commas( n-----------------------------------------------------------------------------
# Returns a number as a comma-delimited string. This is a work-around
# until Renjin fixes https://github.com/bedatadriven/renjin/issues/338
# -----------------------------------------------------------------------------
commas <- function( n ) {
  n <- x( n )

  s <- sprintf( "%03.0f", n %% 1000 )
  n <- n %/% 1000

  while( n > 0 ) {
    s <- concat( sprintf( "%03.0f", n %% 1000 ), ',', s )
    n <- n %/% 1000
  }

  gsub( '^0*', '', s )
}

# -----------------------------------------------------------------------------s ----------------------------------------------------------------------------------------------------------------------------------------------------------# -----------------------------------------------------------------------------se( s, n ) ) )
}

# -----------------------------------------------------------------------------
# Pluralise s if n is not equal to 1.
# -----------------------------------------------------------------------------
pl <- function( s, n=2 ) {
  pluralize( s, x( n ) )
}

# -----------------------------------------------------------------------------# ----------------------------------------------------------------------------------------------------------------------------------------------------------# -----------------------------------------------------------------------------
l-----------------------------------------------------------------------------
# Converts the entire# -----------------------------------------------------------------------------
lower <- tolower

# -----------------------------------------------------------------------------# ----------------------------------------------------------------------------------------------------------------------------------------------------------# ----------------------------------------------------------------------------------------------------------------------------------------------------------# ----------------------------------------------------------------------------------------------------------------------------------------------------------# -----------------------------------------------------------------------------# -----------------------------------------------------------------------------
# -----------------------------------------------------------------------------
money <- function( n ) {
  commas( x( n ) )
}

# -----------------------------------------------------------------------------
# -----------------------------------------------------------------------------
timeline <- function( n ) {
  concat( weekday( n ), ", ", annal( n ), " (", season( n ), ")" )
}

# -----------------------------------------------------------------------------
# Rounds to the nearest base value (e.g., round to nearest 10).
#
# @param base The nearest value to round to.
# -----------------------------------------------------------------------------
round.up <- function( n, base = 5 ) {
  base * round( x( n ) / base )
}

# -----------------------------------------------------------------------------
# Computes linear distance between two points using Haversine formula.
# Although Earth is an oblate spheroid, this will produce results close
# enough for most purposes.
#
# @param lat1/lon1 The source latitude and longitude.
# @param lat2/lon2 The destination latitude and longitude.
# @param radius The radius of the sphere.
#
# @return The distance between the two coordinates in meters.
# -----------------------------------------------------------------------------
haversine <- function( lat1, lon1, lat2, lon2, radius = 6371 ) {
  # Convert decimal degrees to radians
  lon1 = lon1 * pi / 180
  lon2 = lon2 * pi / 180
  lat1 = lat1 * pi / 180
  lat2 = lat2 * pi / 180

  # Haversine formula
  dlon = lon2 - lon1
  dlat = lat2 - lat1
  a = sin( dlat / 2 ) ** 2 + cos( lat1 ) * cos( lat2 ) * sin( dlon / 2 ) ** 2
  c = 2 * atan2( sqrt( a ), sqrt( 1-a ) )

  return( radius * c * 1000 )
}