Package 'dipsaus'

Description

Left-hand side checked assignment Provides a way to assign default values to variables. If the statement 'lhs' is invalid or NULL, this function will try to assign value, otherwise nothing happens.

Usage

lhs %?<-% value

Arguments

Value

Assign value on the right-hand side to the left-hand side if lhs does not exist or is NULL

Examples

# Prepare, remove aaa if exists
if(exists('aaa', envir = globalenv(), inherits = FALSE)){
  rm(aaa, envir = globalenv())
}

# Assign
aaa %?<-% 1; print(aaa)

# However, if assigned, nothing happens
aaa = 1;
aaa %?<-% 2;
print(aaa)

# in a list
a = list()
a$e %?<-% 1; print(a$e)
a$e %?<-% 2; print(a$e)

Description

Plus-minus operator

Usage

a %+-% b

Arguments

Value

a +/- b, the dimension depends on a+b. If a+b is a scalar, returns a vector of two; in the case of vector, returns a matrix; all other cases will return an array with the last dimension equal to 2.

Examples

# scalar
1 %+-% 2   # -1, 3

# vector input
c(1,2,3) %+-% 2   # matrix

# matrix input
matrix(1:9, 3) %+-% 2   # 3x3x2 array

Description

Right-hand side checked assignment Provides a way to avoid assignment to the left-hand side. If the statement 'value' is invalid or NULL, this function will not assign values and nothing happens.

Usage

lhs %<-?% value

Arguments

Value

Assign value on the right-hand side to the left-hand side if value does exists and is not NULL

Examples

# Prepare, remove aaa if exists
if(exists('aaa', envir = globalenv(), inherits = FALSE)){
  rm(aaa, envir = globalenv())
}

# aaa will not be assigned. run `print(aaa)` will raise error
aaa %<-?% NULL

# Assign
aaa %<-?% 1
print(aaa)

# in a list
a = list()
a$e %<-?% bbb; print(a$e)
a$e %<-?% 2; print(a$e)

Description

A JavaScript style of creating functions

Usage

args %=>% expr

Arguments

Value

A function that takes args as parameters and expr as the function body

Examples

# Formal arguments
c(a) %=>% {
  print(a)
}

# Informal arguments
list(a=) %=>% {
  print(a)
}

# Multiple inputs
c(a, b = 2, ...) %=>% {
  print(c(a, b, ...))
}

# ----- JavaScript style of forEach -----
# ### Equivalent JavaScript Code:
# LETTERS.forEach((el, ii) => {
#   console.log('The index of letter ' + el + ' in "x" is: ' + ii);
# });

iapply(LETTERS, c(el, ii) %=>% {
  cat2('The index of letter ', el, ' in ', sQuote('x'), ' is: ', ii)
}) -> results

Description

Get an element with condition that it must be from a list or vector

Usage

lhs %OF% rhs

Arguments

Value

Returns an element of length one that will be from rhs

Examples

# C is from LETTERS, therefore returns `C`
"C" %OF% LETTERS


# `lhs` is not from `rhs`, hence return the first element of LETTERS
'9' %OF% LETTERS
NULL %OF% LETTERS

# When there are multiple elements from `lhs`, select the first that
# matches the constraint
c('9', "D", "V") %OF% LETTERS

Description

Abstract Map to store key-value pairs

Description

This class is inspired by https://cran.r-project.org/package=txtq. The difference is AbstractQueue introduce an abstract class that can be extended and can queue not only text messages, but also arbitrary R objects, including expressions and environments. All the queue types in this package inherit this class.

Abstract Public Methods

Methods start with @... are not thread-safe. Most of them are not used directly by users. However, you might want to override them if you inherit this abstract class. Methods marked as "(override)" are not implemented, meaning you are supposed to implement the details. Methods marked as "(optional)" usually have default alternatives.

initialize(...) (override)

The constructor. Usually three things to do during the process: 1. set get_locker free_locker if you don't want to use the default lockers. 2. set lock file (if using default lockers). 3. call self$connect(...)

get_locker(), free_locker() (optional)

Default is NULL for each methods, and queue uses an internal private$default_get_locker and private$default_free_locker. These two methods are for customized locker, please implement these two methods as functions during self$initialization get_locker obtains and lock access (exclusive), and free_locker frees the locker. Once implemented, private$exclusive will take care the rest. Type: function; parameters: none; return: none

@get_head(), @set_head(v) (override)

Get head so that we know where we are in the queue self$@get_head() should return a integer indicating where we are at the queue self$@set_head(v) stores that integer. Parameter v is always non-negative, this is guaranteed. Users are not supposed to call these methods directly, use self$head and self$head<- instead. However, if you inherit this class, you are supposed to override the methods.

@get_total(), @set_total(v) (override)

Similar to @get_head and @set_head, defines the total items ever stored in the queue. total-head equals current items in the queue.

@inc_total(n=1) (optional)

Increase total, usually this doesn't need to be override, unless you are using files to store total and want to decrease number of file connections

@append_header(msg, ...) (override)

msg will be vector of strings, separated by "|", containing encoded headers: ‘time', 'key', 'hash', and 'message'. to decode what’s inside, you can use self$print_items(stringr::str_split_fixed(msg, '\|', 4)). Make sure to return a number, indicating number of items stored. Unless handled elsewhere, usually return(length(msg)).

@store_value(value, key) (override)

Defines how to store value. 'key' is unique identifier generated from time, queue ID, and value. Usually I use it as file name or key ID in database. value is an arbitrary R object to store. you need to store value somewhere and return a string that will be passed as 'hash' in self$restore_value.

restore_value(hash, key, preserve = FALSE) (override)

Method to restore value from given combination of 'hash' and 'key'. 'hash' is the string returned by @store_value, and 'key' is the same as key in @store_value. preserve is a indicator of whether to preserve the value for future use. If set to FALSE, then you are supposed to free up the resource related to the value. (such as free memory or disk space)

@log(n = -1, all = FALSE) (override)

get n items from what you saved to during @append_header. n less equal than 0 means listing all possible items. If all=TRUE, return all items (number of rows should equals to self$total), including popped items. If all=FALSE, only return items in the queue (number of rows is self$count). The returned value should be a n x 4 matrix. Usually I use stringr::str_split_fixed(..., '\|', 4). Please see all other types implemented for example.

@reset(...) (override)

Reset queue, remove all items and reset head, total to be 0.

@clean() (override)

Clean the queue, remove all the popped items.

@validate() (override)

Validate the queue. Stop if the queue is broken.

@connect(con, ...) (override)

Set up connection. Usually should be called at the end of self$initialization to connect to a database, a folder, or an existing queue you should do checks whether the connection is new or it's an existing queue.

connect(con, ...) (optional)

Thread-safe version. sometimes you need to override this function instead of @connect, because private$exclusive requires lockfile to exist and to be locked. If you don't have lockers ready, or need to set lockers during the connection, override this one.

destroy() (optional)

Destroy a queue, free up space and call delayedAssign('.lockfile', {stop(...)}, assign.env=private) to raise error if a destroyed queue is called again later.

Public Methods

Usually don't need to override unless you know what you are doing.

push(value, message='',...)

Function to push an arbitrary R object to queue. message is a string giving notes to the pushed item. Usually message is stored with header, separated from values. The goal is to describe the value. ... is passed to @append_header

pop(n = 1, preserve = FALSE)

Pop n items from the queue. preserve indicates whether not to free up the resources, though not always guaranteed.

print_item(item), print_items(items)

To decode matrix returned by log(), returning named list or data frame with four heads: 'time', 'key', 'hash', and 'message'.

list(n=-1)

List items in the queue, decoded. If n is less equal than 0, then list all results. The result is equivalent to self$print_items(self$log(n))

log(n=-1,all=FALSE)

List items in the queue, encoded. This is used with self$print_items. When all=TRUE, result will list the records ever pushed to the queue since the last time queue is cleaned. When all=FALSE, results will be items in the queue. n is the number of items.

Public Active Bindings

id

Read-only property. Returns unique ID of current queue.

lockfile

The lock file.

head

Integer, total number of items popped, i.e. inactive items.

total

Total number of items ever pushed to the queue since last cleaned, integer.

count

Integer, read-only, equals to total - head, number of active items in the queue

Private Methods or properties

.id

Don't use directly. Used to store queue ID.

.lockfile

Location of lock file.

lock

Preserve the file lock.

exclusive(expr,...)

Function to make sure the methods are thread-safe

default_get_locker()

Default method to lock a queue

default_free_locker

Default method to free a queue

Description

Action Button but with customized styles

Usage

actionButtonStyled(
  inputId,
  label,
  icon = NULL,
  width = NULL,
  type = "primary",
  btn_type = "button",
  class = "",
  ...
)

Arguments

Value

'HTML' tags

See Also

updateActionButtonStyled for how to update the button.

Examples

# demo('example-actionButtonStyled', package='dipsaus')

library(shiny)
library(dipsaus)

ui <- fluidPage(
  actionButtonStyled('btn', label = 'Click me', type = 'default'),
  actionButtonStyled('btn2', label = 'Click me2', type = 'primary')
)


server <- function(input, output, session) {
  btn_types = c('default', 'primary', 'info', 'success', 'warning', 'danger')
  observeEvent(input$btn, {
    btype = btn_types[((input$btn-1) %% (length(btn_types)-1)) + 1]
    updateActionButtonStyled(session, 'btn2', type = btype)
  })
  observeEvent(input$btn2, {
    updateActionButtonStyled(session, 'btn',
                             disabled = c(FALSE,TRUE)[(input$btn2 %% 2) + 1])
  })
}


if( interactive() ){
  shinyApp(ui, server, options = list(launch.browser=TRUE))
}

Description

If key is missing, it'll be created, otherwise ignored or overwritten.

Usage

add_to_session(
  session,
  key = "rave_id",
  val = paste(sample(c(letters, LETTERS, 0:9), 20), collapse = ""),
  override = FALSE
)

Arguments

Value

If session is shiny session, returns current value stored in session, otherwise returns NULL

Description

Convert functions to pipe-friendly functions

Usage

as_pipe(
  x,
  ...,
  call,
  arg_name,
  .name = arg_name,
  .env = parent.frame(),
  .quoted = FALSE
)

Arguments

Value

If x is missing, returns a function that takes one argument, otherwise run the function with given x

Examples

# modify a function call
vary_title <- as_pipe(call = plot(1:10, 1:10),
                      pch = 16,
                      arg_name = 'main',
                      .name = 'title')
vary_title

# vary_title is pipe-friendly with `pch` default 16
vary_title(title = 'My Title')

# `pch` is explicit
vary_title(title = 'My Title', pch = 1)

# other variables are implicit
vary_title(title = 'My Title', type = 'l')


# modify a function

f <- function(b = 1, x){ b + x }
f_pipable <- as_pipe(call = f, arg_name = 'x')
f_pipable

f_pipable(2)

# Advanced use

# Set option dipsaus.debug.as_pipe=TRUE to debug
options("dipsaus.debug.as_pipe" = TRUE)

# Both `.(z)` and `z` work

image2 <- as_pipe(call = image(
  x = seq(0, 1, length.out = nrow(z)),
  y = 1:ncol(z),
  z = matrix(1:16, 4),
  xlab = "Time", ylab = "Freq",
  main = "Debug"
), arg_name = 'z')

# main can be overwritten
image2(matrix(1:50, 5), main = "Production")


# reset debug option
options("dipsaus.debug.as_pipe" = FALSE)

Description

Ask a question and read from the terminal in interactive scenario

Usage

ask_or_default(..., default = "", end = "", level = "INFO")

Arguments

Details

The prompt string will ask a question, providing defaults. Users need to enter the answer. If the answer is blank (no space), then returns the default, otherwise returns the user input.

This can only be used in an interactive session.

Value

A character from the user's input, or the default value. See details.

See Also

cat2, readline, ask_yesno

Examples

if(interactive()){
ask_or_default('What is the best programming language?',
               default = 'PHP')
}

Description

Ask a question and read from the terminal in interactive scenario

Usage

ask_yesno(
  ...,
  end = "",
  level = "INFO",
  error_if_canceled = TRUE,
  use_rs = TRUE,
  ok = "Yes",
  cancel = "No",
  rs_title = "Yes or No:"
)

Arguments

Details

The prompt string will ask for an yes or no question. Users need to enter "y", "yes" for yes, "n", "no" or no, and "c" for cancel (case-insensitive).

This can only be used in an interactive session.

Value

logical or NULL or raise an error. If "yes" is entered, returns TRUE; if "no" is entered, returns FALSE; if "c" is entered, error_if_canceled=TRUE will result in an error, otherwise return NULL

See Also

cat2, readline, ask_or_default

Examples

if(interactive()){
ask_yesno('Do you know how hard it is to submit an R package and ',
          'pass the CRAN checks?')
ask_yesno('Can I pass the CRAN check this time?')
}

Description

Evaluate expression in async_expr

Usage

async(expr)

Arguments

See Also

async_expr

Description

Apply R expressions in a parallel way

Usage

async_expr(
  .X,
  .expr,
  .varname = "x",
  envir = parent.frame(),
  .pre_run = NULL,
  .ncore = future::availableCores(),
  ...
)

Arguments

Details

async_expr uses lapply and future::future internally. Within each loop, an item in ".X" will be assigned to variable "x" (defined by ".varname") and enter the evaluation. During the evaluation, function async is provided. Expressions within async will be evaluated in another session, otherwise will be evaluated in current session. Below is the workflow:

• Run .pre_run

• For i in seq_along(.X):

  • 1. Assign x with .X[[i]], variable name x is defined by .varname

  • 2. Evaluate expr in current session.

    • a. If async is not called, return evaluated expr

    • b. If async(aync_expr) is called, evaluate aync_expr in another session, and return the evaluation results if aync_expr

Value

a list whose length equals to .X. The value of each item returned depends on whether async is called. See details for workflow.

Description

Wrapper for future.apply::future_lapply

Usage

async_flapply(X, FUN, ...)

Arguments

See Also

future_lapply

Description

This function has been deprecated. Please use lapply_callr instead.

Usage

async_works(
  X,
  FUN,
  ...,
  .globals = NULL,
  .name = "Untitled",
  .rs = FALSE,
  .wait = TRUE,
  .chunk_size = Inf,
  .nworkers = future::availableCores(),
  .simplify = FALSE,
  .quiet = FALSE,
  .log
)

Arguments

Details

Unlike future package, where the global variables can be automatically detected, async_works require users to specify global variables explicitly via .globals

async_works is almost surely slower than future.apply packages. However, it provides a functionality that future.apply can hardly achieve: being non-block. When setting .wait=FALSE, the process will run in the background, and one may run as many of these tasks as they want. This is especially useful when large data generating process occurs ( such as read in from a file, process, generate summarizing reports).

Value

If .wait=TRUE, returns the applied results of FUN on each of X. The result types depend on .simplify (compare the difference between lapply and sapply). If .wait=FALSE, then returns a function that can check the result. The function takes timeout argument that blocks the session at most timeout seconds waiting for the results. See examples.

Examples

## Not run: 
# requires a sub-process to run the code

# Basic usage
a <- 1
async_works(1:10, function(ii){
  ii + a # sub-process don't know a, hence must pass a as globals
}, .globals = list(a = a))

# non-blocking case
system.time({
  check <- async_works(1:10, function(ii){
    # simulating process, run run run
    Sys.sleep(ii)
    Sys.getpid()
  }, .wait = FALSE)
})

# check the results
res <- check(timeout = 0.1)
attr(res, 'resolved') # whether it's resolved

# block the session waiting for the results
res <- check(timeout = Inf)
attr(res, 'resolved')



## End(Not run)

Description

Get attached package names in current session (Internally used)

Usage

attached_packages(include_base = FALSE)

Arguments

Value

characters, package names that are attached in current session

Description

Save "Base64" Data to Images

Usage

base64_to_image(data, path)

Arguments

Value

Absolute path of the saved file

Description

Decode "Base64" data to its generating characters

Usage

base64_to_string(what)

Arguments

Value

String

Examples

input <- "The quick brown fox jumps over the lazy dog"

# Base64 encode
what <- base64enc::base64encode(what = charToRaw(input))

# Base64 decode
base64_to_string(what)

Description

Compatible with results from package 'base64url', but implemented with package 'base64enc'. I simply do not like it when I have to depend on two packages that can achieve the same goal. This implementation is slower. If you have 'base64url' installed, please use that version.

Usage

base64_urlencode(x)

base64_urldecode(x)

Arguments

Value

character vector of the same length as x

Examples

x = "plain text"
encoded = base64_urlencode(x)
decoded = base64_urldecode(encoded)
print(encoded)
print(decoded)

Description

Provides five methods to baseline an array and calculate contrast.

Usage

baseline_array(
  x,
  along_dim,
  baseline_indexpoints,
  unit_dims = seq_along(dim(x))[-along_dim],
  method = c("percentage", "sqrt_percentage", "decibel", "zscore", "sqrt_zscore",
    "subtract_mean")
)

Arguments

Details

Consider a scenario where we want to baseline a bunch of signals recorded from different locations. For each location, we record n sessions. For each session, the signal is further decomposed into frequency-time domain. In this case, we have the input x in the following form:

$session x frequency x time x location$

Now we want to calibrate signals for each session, frequency and location using the first 100 time points as baseline points, then the code will be

$baseline_array(x, along_dim=3, 1:100, unit_dims=c(1,2,4))$

along_dim=3 is dimension of time, in this case, it's the third dimension of x. baseline_indexpoints=1:100, meaning the first 100 time points are used to calculate baseline. unit_dims defines the unit signal. Its value c(1,2,4) means the unit signal is per session (first dimension), per frequency (second) and per location (fourth).

In some other cases, we might want to calculate baseline across frequencies then the unit signal is $frequency x time$, i.e. signals that share the same session and location also share the same baseline. In this case, we assign unit_dims=c(1,4).

There are five baseline methods. They fit for different types of data. Denote $z$ is an unit signal, $z_0$ is its baseline slice. Then these baseline methods are:

"percentage"

$\frac{z - \bar{z_{0}}}{\bar{z_{0}}} \times 100\%$

"sqrt_percentage"

$\frac{\sqrt{z} - \bar{\sqrt{z_{0}}}}{\bar{\sqrt{z_{0}}}} \times 100\%$

"decibel"

$10 \times ( \log_{10}(z) - \bar{\log_{10}(z_{0})} )$

"zscore"

$\frac{z-\bar{z_{0}}}{sd(z_{0})}$

"sqrt_zscore"

$\frac{\sqrt{z}-\bar{\sqrt{z_{0}}}}{sd(\sqrt{z_{0}})}$

Value

Contrast array with the same dimension as x.

Examples

library(dipsaus)
set.seed(1)

# Generate sample data
dims = c(10,20,30,2)
x = array(rnorm(prod(dims))^2, dims)

# Set baseline window to be arbitrary 10 timepoints
baseline_window = sample(30, 10)

# ----- baseline percentage change ------

# Using base functions
re1 <- aperm(apply(x, c(1,2,4), function(y){
  m <- mean(y[baseline_window])
  (y/m - 1) * 100
}), c(2,3,1,4))

# Using dipsaus
re2 <- baseline_array(x, 3, baseline_window, c(1,2,4),
                      method = 'percentage')

# Check different, should be very tiny (double precisions)
range(re2 - re1)

# Check speed for large dataset
if(interactive()){
  dims = c(200,20,300,2)
  x = array(rnorm(prod(dims))^2, dims)
  # Set baseline window to be arbitrary 10 timepoints
  baseline_window = seq_len(100)
  f1 <- function(){
    aperm(apply(x, c(1,2,4), function(y){
      m <- mean(y[baseline_window])
      (y/m - 1) * 100
    }), c(2,3,1,4))
  }
  f2 <- function(){
    # equivalent as bl = x[,,baseline_window, ]
    #
    baseline_array(x, along_dim = 3,
                   baseline_indexpoints = baseline_window,
                   unit_dims = c(1,2,4), method = 'sqrt_percentage')
  }
  microbenchmark::microbenchmark(f1(), f2(), times = 3L)
}

Description

Evaluate expression and captures output as characters, then concatenate as one single string.

Usage

capture_expr(expr, collapse = "\n", type = c("output", "message"), ...)

Arguments

Value

Character of length 1: output captured by capture.output

Examples

x <- data.frame(a=1:10)
x_str <- capture_expr({
  print(x)
})

x_str

cat(x_str)

Description

Color Output

Usage

cat2(
  ...,
  level = "DEBUG",
  print_level = FALSE,
  file = "",
  sep = " ",
  fill = FALSE,
  labels = NULL,
  append = FALSE,
  end = "\n",
  pal = list(DEBUG = "grey60", INFO = "#1d9f34", WARNING = "#ec942c", ERROR = "#f02c2c",
    FATAL = "#763053", DEFAULT = "grey60"),
  use_cli = TRUE,
  bullet = "auto"
)

Arguments

Details

There are five levels of colors by default: 'DEBUG', 'INFO', 'WARNING', 'ERROR', or FATAL. Default colors are: 'DEBUG' (grey60), 'INFO' (#1d9f34), 'WARNING' (#ec942c), 'ERROR' (#f02c2c), 'FATAL' (#763053) and 'DEFAULT' (#000000, black). If level is not in preset five levels, the color will be "default"-black color.

Value

none.

Description

Check If Packages Are Installed, Returns Missing Packages

Usage

check_installed_packages(
  pkgs,
  libs = base::.libPaths(),
  auto_install = FALSE,
  ...
)

Arguments

Value

package names that are not installed

Description

Function to clear all elements within environment

Usage

clear_env(env, ...)

Arguments

Examples

env = new.env()
env$a = 1
print(as.list(env))

clear_env(env)
print(as.list(env))

Description

Convert color to Hex string

Usage

col2hexStr(col, alpha = NULL, prefix = "#", ...)

Arguments

Details

col2hexStr converts colors such as 1, 2, 3, "red", "blue", ... into hex strings that can be easily recognized by 'HTML', 'CSS' and 'JavaScript'. Internally this function uses adjustcolor with two differences:

1. the returned hex string does not contain alpha value if alpha is NULL;

2. the leading prefix "#" can be customized

Value

characters containing the hex value of each color. See details

See Also

adjustcolor

Examples

col2hexStr(1, prefix = '0x')      # "0x000000"
col2hexStr('blue')                # "#0000FF"

# Change default palette, see "grDevices::colors()"
grDevices::palette(c('orange3', 'skyblue1'))
col2hexStr(1)                     # Instead of #000000, #CD8500

Description

Collapse Sensors And Calculate Summations/Mean

Usage

collapse(x, keep, average = FALSE)

Arguments

Value

a collapsed array with values to be mean or summation along collapsing dimensions

Examples

# Example 1
x = matrix(1:16, 4)

# Keep the first dimension and calculate sums along the rest
collapse(x, keep = 1)
rowSums(x)  # Should yield the same result

# Example 2
x = array(1:120, dim = c(2,3,4,5))
result = collapse(x, keep = c(3,2))
compare = apply(x, c(3,2), sum)
sum(abs(result - compare)) # The same, yield 0 or very small number (1e-10)

# Example 3 (performance)
# Small data, no big difference, even slower
x = array(rnorm(240), dim = c(4,5,6,2))
microbenchmark::microbenchmark(
  result = collapse(x, keep = c(3,2)),
  compare = apply(x, c(3,2), sum),
  times = 1L, check = function(v){
    max(abs(range(do.call('-', v)))) < 1e-10
  }
)

# large data big difference
x = array(rnorm(prod(300,200,105)), c(300,200,105,1))
microbenchmark::microbenchmark(
  result = collapse(x, keep = c(3,2)),
  compare = apply(x, c(3,2), sum),
  times = 1L , check = function(v){
    max(abs(range(do.call('-', v)))) < 1e-10
  })

Description

Compound input that combines and extends shiny inputs

Usage

compoundInput2(
  inputId,
  label = "Group",
  components = shiny::tagList(),
  initial_ncomp = 1,
  min_ncomp = 0,
  max_ncomp = 10,
  value = NULL,
  label_color = NA,
  max_height = NULL,
  ...
)

Arguments

Value

'HTML' tags

See Also

updateCompoundInput2 for how to update inputs

Examples

library(shiny); library(dipsaus)
compoundInput2(
  'input_id', 'Group',
    div(
    textInput('text', 'Text Label'),
    sliderInput('sli', 'Slider Selector', value = 0, min = 1, max = 1)
  ),
  label_color = 1:10,
  value = list(
    list(text = '1'),  # Set text first group to be "1"
    list(),                # no settings for second group
    list(sli = 0.2)    # sli = 0.2 for the third group
  ))

# Source - system.file('demo/example-compountInput2.R', package='dipsaus')

# demo('example-compountInput2', package='dipsaus')

library(shiny)
library(dipsaus)
ui <- fluidPage(
  fluidRow(
    column(
      width = 4,
      compoundInput2(
        'compound', 'Group Label', label_color = c(NA,1:9),
        components = div(
          textInput('txt', 'Text'),
          selectInput('sel', 'Select', choices = 1:10, multiple = TRUE),
          sliderInput('sli', 'Slider', max=1, min=0, val=0.5)
        ),
        value = list(
          list(txt = '1'),  # Set text first group to be "1"
          '',                # no settings for second group
          list(sli = 0.2)    # sli = 0.2 for the third group
        )
      ),
      hr(),
      actionButton('action', 'Update compound input')
    )
  )
)

server <- function(input, output, session) {
  observe({
    print(input$compound)
  })
  observe({
    # Getting specific input at group 1
    print(input$compound_txt_1)
  })
  observeEvent(input$action, {
    updateCompoundInput2(
      session, 'compound',
      # Update values for each components
      value = lapply(1:5, function(ii){
        list(
          txt = sample(LETTERS, 1),
          sel = sample(1:10, 3),
          sli = runif(1)
        )
      }), ncomp = NULL, txt = list(label = as.character(Sys.time())))
  })
}

if( interactive() ){
  shinyApp(ui, server, options = list(launch.browser = TRUE))
}

Description

Python-style decorator

Usage

decorate_function(orig, decor, ...)

lhs %D% rhs

Arguments

Examples

# Example 1: basic usage
# Decorator that prints summary of results and return results itself
verbose_summary <- function(...){
  summary_args <- list(...)
  function(f){
    function(...){
      results <- f(...)


      print(do.call(
        summary,
        c(list(results), summary_args)
      ))
      results

    }
  }

}

# runs as.list, but through verbose_summary
as_list2 <- decorate_function(as.list, verbose_summary)

# run test
res <- as_list2(1:3)  # will verbose summary
identical(res, as.list(1:3))

# Example 2
x <- 1:20
y <- x + rnorm(20)

# decorator, add a line with slope 1 with given intercept
abline_xy <- function(b){
  function(f){
    function(...){
      f(...)
      intercept <- get_dots('intercept', 0, ...)
      abline(a = intercept, b = b)
    }
  }
}

# orig, plot whatever x vs jittered+intercept
plot_xy <- function(x, intercept = rnorm(1)){
  plot(x, jitter(x, amount = 3) + intercept)
}

# new function that decorate plot_xy with abline_xy, and
# returns the intercept
plot_xy2 <- decorate_function(plot_xy, abline_xy, b = 1)

# alternatively, you might also want to try
plot_xy2 <- plot_xy %D% abline_xy(b = 1)

plot_xy2(x = 1:20)

Description

Convert Integer Vectors To String

Usage

deparse_svec(
  nums,
  connect = "-",
  concatenate = TRUE,
  collapse = ",",
  max_lag = 1
)

Arguments

Value

strings representing the input vector. For example, c(1, 2, 3) returns "1-3".

See Also

parse_svec

Examples

deparse_svec(c(1:10, 15:18))

Description

Digest R object with source reference removed

Usage

digest2(object, ..., keep_source = FALSE)

Arguments

See Also

removeSource

Description

'RStudio' keyboard shortcuts is handy, however, it is non-trivial to set shortcuts that run customized code. The proposing functions allow 10 customized R expressions to be registered. The first five (1 to 5) are interactive shortcuts, the rest five (6 to 10) are non-interactive.

Usage

rs_add_insertion_shortcut(which, txt, force = FALSE)

rs_add_shortcut(which, expr, force = FALSE, quoted = FALSE)

rs_remove_shortcut(which)

rs_show_shortcut(which)

rs_quick_debug(env = globalenv())

Arguments

Details

There are two steps to register an 'RStudio' keyboard shortcut.

1. Please enable the shortcuts by opening 'Tools' > 'Modify Keyboard Shortcuts' in 'RStudio' menu bar; search and locate add-in items starting with 'Dipsaus'; register hot-keys of your choices, and then save. It is recommended that these keys are 'Alt' + 1 to 'Alt' + 0. On Apple, 'Alt' is equivalent to 'option' key.

2. run rs_add_insertion_shortcut or rs_add_shortcut to customize the behaviors of each shortcuts; see Examples.

Function rs_quick_debug provides quick way to debug a script or function without messing up the code. The script only works in 'RStudio'. When executing the quick-debug function, the cursor context will be automatically resolved and nearest debugging code blocks will be searched and executed. To enable this feature, add a line with "# DIPSAUS: DEBUG START" in your code, followed by debugging code blocks in comments. The script will figure it out. Since the 'RStudio' context will be obtained when executing the function, it is recommended to add this function to your shortcuts. By default, if the shortcut-1 is unset, this function will be executed.

Examples

## Not run: 

# Need to run in RStudio
# Please read the Section 'Details' carefully

# --------------------------------------------

# I assume the shortcuts are Alt+1,2,...,9,0,
# corresponding to shortcuts 1 - 10

# Adds an insertion to Alt+9
rs_add_insertion_shortcut(9, " %?<-% ", force = TRUE)
# restart RStudio and try `Alt+9`


# Adds an expression to Alt+2
rs_add_shortcut(2, {
  expr <- sprintf("system.time({\n%s\n})\n",
                  rstudioapi::selectionGet()$value)
  cat(expr)
  eval(parse(text = expr))
}, force = TRUE)

# Select any valid R code and press Alt+1

# --------------------------------------------

# run this to set your shortcut (one-time setup)
rs_add_shortcut(1, { dipsaus::rs_quick_debug() })

# Add debug feature: insert the following comment anywhere in your code
# You may open a new script in the RStudio

# DIPSAUS: DEBUG START
# message("Debugging...")
# a <- 1
# print(a)
# message("Finished")


# Place your cursor here, press the shortcut key


## End(Not run)

Description

A pipe-friendly wrapper of aggregate when using formula as input.

Usage

do_aggregate(x, ...)

Arguments

Value

Results from aggregate

See Also

aggregate

Examples

library(magrittr)
data(ToothGrowth)

ToothGrowth %>%
  do_aggregate(len ~ ., mean)

Description

A dummy function that literally does nothing

Usage

do_nothing(...)

Arguments

Value

Nothing

Description

Drop NULL values from list or vectors

Usage

drop_nulls(x, .invalids = list("is.null"))

Arguments

Value

list or vector containing no invalid values

Examples

x <- list(NULL,NULL,1,2)
drop_nulls(x)  # length of 2

Description

Evaluate expressions

Usage

eval_dirty(expr, env = parent.frame(), data = NULL, quoted = TRUE)

Arguments

Details

eval_dirty uses base::eval() function to evaluate expressions. Compare to rlang::eval_tidy, which won't affect original environment, eval_dirty causes changes to the environment. Therefore if expr contains assignment, environment will be changed in this case.

Value

the executed results of expr evaluated with side effects.

Examples

env = new.env(); env$a = 1
rlang::eval_tidy(quote({a <- 111}), env = env)
print(env$a)  # Will be 1. This is because eval_tidy has no side effect

eval_dirty(quote({a <- 111}), env)
print(env$a)  # 111, a is changed

# Unquoted case
eval_dirty({a <- 222}, env, quoted = FALSE)
print(env$a)

Description

Fancy drag and drop file upload for shiny apps.

Usage

fancyFileInput(
  inputId,
  label,
  width = NULL,
  after_content = "Drag & drop, or button",
  size = c("s", "m", "l", "xl"),
  ...
)

Arguments

Value

See fileInput

Examples

library(shiny)
library(dipsaus)

ui <- basicPage(
  fancyFileInput('file_input', "Please upload")
)

if(interactive()) {
  shinyApp(
    ui, server = function(input, output, session){},
    options = list(launch.browser = TRUE)
  )
}

Description

Speed up covariance calculation for large matrices. The default behavior is similar cov. Please remove any NA prior to calculation.

Usage

fastcov2(x, y = NULL, col1, col2, df)

Arguments

Value

A covariance matrix of x and y. Note that there is no NA handling. Any missing values will lead to NA in the resulting covariance matrices.

Examples

x <- matrix(rnorm(400), nrow = 100)

# Call `cov(x)` to compare
fastcov2(x)

# Calculate covariance of subsets
fastcov2(x, col1 = 1, col2 = 1:2)

# Speed comparison
x <- matrix(rnorm(100000), nrow = 1000)
microbenchmark::microbenchmark(
  fastcov2 = {
    fastcov2(x, col1 = 1:50, col2 = 51:100)
  },
  cov = {
    cov(x[,1:50], x[,51:100])
  },
  unit = 'ms', times = 10
)

Description

fastmap provides a key-value store where the keys are strings and the values are any R objects. It differs from normal environment that fastmap avoids memory leak. fastmap2 is a wrapper for fastmap, which provides several generic functions such that it has similar behaviors to lists or environments

Usage

fastmap2(missing_default = NULL)

## S3 method for class 'fastmap2'
x[[name]]

## S3 method for class 'fastmap2'
x$name

## S3 replacement method for class 'fastmap2'
x[[name]] <- value

## S3 replacement method for class 'fastmap2'
x$name <- value

## S3 method for class 'fastmap2'
x[i, j = NULL, ...]

## S3 replacement method for class 'fastmap2'
x[i, j = NULL, ...] <- value

## S3 method for class 'fastmap2'
names(x)

## S3 method for class 'fastmap2'
print(x, ...)

## S3 method for class 'fastmap2'
length(x)

## S3 method for class 'fastmap2'
as.list(x, recursive = FALSE, sorted = FALSE, ...)

Arguments

Value

A list of 'fastmap2' instance

Examples

## --------------------------- Basic Usage --------------------------
map <- fastmap2()
map$a = 1
map$b = 2
print(map)

map[c('a', 'b')]
# Alternative way
map['a', 'b']

map[c('c', 'd')] <- 3:4
# or
map['e', 'f'] <- 5:6

# The order is not guaranteed, unless sort=TRUE
as.list(map)
as.list(map, sort=TRUE)

names(map)
length(map)

## ----------------------- NULL value handles -----------------------
map$b <- NULL
names(map)   # 'b' still exists!
as.list(map) # 'b' is NULL, but still there

# to remove 'b', you have to use `@remove` method
map$`@remove`('b')

## ---------------- Native fastmap::fastmap methods -----------------

# whether map has 'a'
map$`@has`('a')

# Remove a name from list
map$`@remove`('a')

# remove all from list
map$`@reset`()
print(map)

Description

Slightly faster than quantile with na.rm=TRUE. The internal implementation uses the 'C++' function std::nth_element, which is significantly faster than base R implementation when the length of input x is less than 1e7.

Usage

fastquantile(x, q)

Arguments

Value

Identical to quantile(x, q, na.rm=TRUE)

Examples

# create input x with NAs
x <- rnorm(10000)
x[sample(10000, 10)] <- NA

# compute median
res <- fastquantile(x, 0.5)
res

# base method
res == quantile(x, 0.5, na.rm = TRUE)
res == median(x, na.rm = TRUE)

# Comparison
microbenchmark::microbenchmark(
  {
    fastquantile(x, 0.5)
  },{
    quantile(x, 0.5, na.rm = TRUE)
  },{
    median(x, na.rm = TRUE)
  }
)

Description

A Wrapper for fastmap::fastqueue

Usage

fastqueue2(init = 20L, missing_default = NULL)

## S3 method for class 'fastqueue2'
x[[i]]

## S3 method for class 'fastqueue2'
x[i, j = NULL, ...]

## S3 method for class 'fastqueue2'
print(x, ...)

## S3 method for class 'fastqueue2'
length(x)

## S3 method for class 'fastqueue2'
as.list(x, ...)

Arguments

Value

A list of 'fastqueue2' instance

Examples

x <- fastqueue2()

# add elements
x$madd(1, "b", function(){ "c" }, 4, "5")

# print information
print(x)

# get the second element without changing the queue
x[[2]]

# remove and get the first element
x$remove()

# the second item
x[[2]]

# first two items in a list
x[c(1,2)]

print(x)
as.list(x)

Description

Generate Shiny element with arrangement automatically

Usage

flex_div(..., ncols = "auto")

Arguments

Details

If multiple numbers of columns are specified, flex_div will guess the best size that will be applied. For button UI, flex_div automatically add "20px" on the top margin.

Value

HTML objects

Examples

ui <- flex_div(
  shiny::selectInput('sel', label = 'Select input',
                     choices = '', width = '100%'),
  shiny::textInput('id2', label = html_asis(' '), width = '100%',
                   value = 'Heights aligned'),
  actionButtonStyled('ok2', 'Button', width = '100%',),
  shiny::sliderInput('sl', 'Item 4', min = 1, max = 2,
                     value = 1.5, width = '100%'),
  shiny::fileInput('aa', 'item 5', width = '100%'),
  ncols = c(2,3) # Try to assign 2 or 3 items per column
)
if(interactive()){
  shiny::shinyApp(ui = shiny::fluidPage(shiny::fluidRow(ui)),
                  server = function(input, output, session){})
}

Description

Provide Python-style "for-else" that works as follows: for each element, execute "for" block, if there is break while executing "for" block, then just stop and ignore the "else" statement, otherwise run "else" block.

Usage

forelse(x, FUN, ALT_FUN = NULL)

Arguments

Value

If any FUN returns anything other than NULL, then the function returns the first none NULL object. If all x fed to FUN return NULL, then this function returns ALT_FUN (if ALT_FUN is not a function) or the result of ALT_FUN().

Examples

# --------------------------- Basic Usage ------------------------------

# 1. ALT_FUN get executed because FUN returns NULL for all items in x
forelse(
  1:10,
  function(x){
    cat('The input is ', x, end = '\n')
    if( x > 10) return(x) else return(NULL)
  },
  function(){
    cat('ALT_FUN is executed!\n')
    'wow'
  }
)

# 2. FUN returns non-NULL object
forelse(
  1:10,
  function(x){
    cat('The input is ', x, end = '\n')
    if( x %% 2 == 0 ) return(x) else return(NULL)
  },
  'wow'
)

# --------------------------- Performance ------------------------------
FUN <- function(x){
  Sys.sleep(0.01)
  if( x %% 2 == 0 ) return(x) else return(NULL)
}

microbenchmark::microbenchmark({
  forelse(1:10, FUN, 'wow')
}, {
  y <- unlist(lapply(1:10, FUN))
  if(length(y)){
    y <- y[[1]]
  }else{
    y <- 'wow'
  }
}, {
  y <- NULL
  for(x in 1:10){ y <- FUN(x) }
  if(is.null(y)){ y <- 'wow' }
}, times = 3)

Description

Defunct Functions in Package dipsaus The functions or variables listed here are no longer part of the package.

Usage

get_cpu()

Description

Please note that this function is not meant to be used in production. It is not meant to be used for highly secured cryptographic purposes.

Usage

get_credential(
  master_password,
  method = c("get_or_create", "replace", "query"),
  service = NULL,
  special_chr = "~`! @#$%^&*()_-+={[}]|:;'<,>.?/",
  tokenfile = NULL,
  verbose = FALSE
)

Arguments

Details

Please note that this function is not meant to be used in production or anything that requires high security level. This is most likely for my personal use since I am tired of storing the passwords on the cloud or having to buy the services.

The encryption adopts 'sha256' algorithm provided by digest function. To restore a password, you will need twp components: master_password, a token book ( tokenfile). If any of them is missing, then the password is lost. Please store the token book properly (for example, in 'Dropbox' vault).

The token book could be shared. Anyone who do not have master password will be unlikely to restore the service password. Do not share the master password with anyone other than yourself.

By default, method='get_or_create' will try to retrieve existing tokens to generate password. If the token is missing, then a new token will be generated. The method='replace' will ignore existing tokens and directly create a new one.

Value

If method is 'query', returns token map; otherwise returns the password itself

See Also

digest

Examples

tokenfile <- tempfile()

# ---------- Create a password and store the tokens to token book ------
pass1 <- get_credential(
  master_password = "my password",
  service = "google.com:my_username",
  special_chr = "@#$%^&*",
  tokenfile = tokenfile
)
print(pass1)

# ---------- Query existing tokens ------
token_params <- get_credential(
  method = "query",
  tokenfile = tokenfile,
  verbose = TRUE
)

print(token_params)

# ---------- retrieve stored password ----------
pass2 <- get_credential(
  master_password = "my password",
  service = "google.com",
  tokenfile = tokenfile
)
identical(pass1, pass2)

# Using wrong master password
pass3 <- get_credential(
  master_password = "wrong password",
  service = "google.com",
  tokenfile = tokenfile
)
identical(pass1, pass3)

# ---------- Replace token ----------
# Existing token will be replaced with a new token
pass4 <- get_credential(
  master_password = "my password",
  method = "replace",
  service = "google.com",
  special_chr = "@#$%^&*",
  tokenfile = tokenfile
)
print(pass4)
identical(pass1, pass4)

Description

Get information from '...' without evaluating the arguments.

Usage

get_dots(..name, ..default = NULL, ...)

missing_dots(envir = parent.frame())

Arguments

Value

missing_dots returns logical vector with lengths matching with dot lengths. get_dots returns value corresponding to the name.

Examples

# ------------------------ Basic Usage ---------------------------

# missing_dots(environment()) is a fixed usage

my_function <- function(...){
  missing_dots(environment())
}
my_function(,)

# get_dots
plot2 <- function(...){
  title = get_dots('main', 'There is no title', ...)
  plot(...)
  title
}

plot2(1:10)
plot2(1:10, main = 'Scatter Plot of 1:10')

# ------------------------ Comparisons ----------------------------
f1 <- function(...){ get_dots('x', ...) }
f2 <- function(...){ list(...)[['x']] }
delayedAssign('y', { cat('y is evaluated!') })

# y will not evaluate
f1(x = 1, y = y)

# y gets evaluated
f2(x = 1, y = y)

# -------------------- Decorator example --------------------------
ret_range <- function(which_range = 'y'){
  function(f){
    function(...){
      f(...)
      y_range <- range(get_dots(which_range, 0, ...))
      y_range
    }
  }
}
plot_ret_yrange <- plot %D% ret_range('y')
plot_ret_yrange(x = 1:10, y = rnorm(10))

Description

Get 'IP' address

Usage

get_ip(get_public = NA)

Arguments

Value

a list of 'IP' addresses

Description

Detect the type of operating system

Usage

get_os()

Value

The type of current operating system: 'windows', 'darwin', 'linux', 'solaris', or otherwise 'unknown'.

Examples

get_os()

Description

Get Memory Size

Usage

get_ram()

Details

The function get_ram only supports 'MacOS', 'Windows', and 'Linux'. 'Solaris' or other platforms will return NA. Here are the system commands used to detect memory limits:

'Windows'

Uses command 'wmic.exe' in the 'Windows' system folder. Notice this command-line tool might not exist on all 'Windows' machines. get_ram will return NA if it cannot locate the command-line tool.

'MacOS'

Uses command 'sysctl' located at '/usr/sbin/' or '/sbin/'. Alternatively, you can edit the environment variable 'PATH' to include the command-line tools if 'sysctl' is missing. get_ram will return NA if it cannot locate 'sysctl'.

'Linux'

Uses the file '/proc/meminfo', possibly the first entry 'MemTotal'. If the file is missing or entry 'MemTotal' cannot be located, get_ram will return NA.

Value

System RAM in bytes, or NA if not supported.

Examples

get_ram()

Description

Obtain registered input bindings

Usage

getInputBinding(fname, pkg = NULL, envir = parent.frame())

Arguments

Value

a list containing: 1. 'JavaScript' input binding name; 2. 'R' updating function name

Examples

library(dipsaus)

# Most recommended usage
getInputBinding('compoundInput2', pkg = 'dipsaus')

# Other usages
getInputBinding('shiny::textInput')


getInputBinding(shiny::textInput)

getInputBinding(compoundInput2, pkg = 'dipsaus')

# Bad usage, raise errors in some cases
## Not run: 
## You need to library(shiny), or set envir=asNamespace('shiny'), or pkg='shiny'
getInputBinding('textInput')
getInputBinding(textInput) # also fails

## Always fails
getInputBinding('dipsaus::compoundInput2', pkg = 'dipsaus')

## End(Not run)

Description

Create a group of named graphic devices

Usage

dev_create(..., env = parent.frame(), attributes = list())

get_dev_attr(which, dev = grDevices::dev.cur(), ifnotfound = NULL)

Arguments

Value

A list of functions to query, control, and switch between devices

Examples

## Not run:  ## Unix-specific example

# Create multiple named devices, setting attributes to the second graph
devs <- dev_create(
  line = X11(), points = x11(),
  attributes = list(points = list(pch = 16))
)

# switch to device named "points"

devs$dev_which('points')

# Plot points, with pch given as preset
plot(1:10, pch = get_dev_attr(which = 'pch', ifnotfound = 1))

# switch to "line" device
devs$dev_switch('line')
plot(1:100, type='l')

# Create another group with conflict name
dev_another <- dev_create(line = X11())

# Query device name with 'line'
dev_another$dev_which('line')  # 4
devs$dev_which('line')  # 2, doesn't conflict with the new groups

dev.list()
# close one or more device
dev_another$dev_off('line')
dev.list()

# close all devices
devs$dev_off()
dev.list()


## End(Not run)

Description

Handler for progress2 to support progressr::handlers. See examples for detailed use case

Usage

handler_dipsaus_progress(
  title = getOption("dipsaus.progressr.title", "Progress"),
  intrusiveness = getOption("progressr.intrusiveness.gui", 1),
  target = if (is.null(shiny::getDefaultReactiveDomain())) "terminal" else "gui",
  enable = interactive() || shiny_is_running(),
  ...
)

Arguments

Examples

library(progressr)
library(shiny)
library(future)

## ------------------------------ Setup! -------------------------------
handlers(handler_dipsaus_progress())

# ------------------------------ A simple usage ------------------------
xs <- 1:5
handlers(handler_dipsaus_progress())
with_progress({
  p <- progressor(along = xs)
  y <- lapply(xs, function(x) {
    p(sprintf("x=%g", x))
    Sys.sleep(0.1)
    sqrt(x)
  })
})

# ------------------------ A future.apply case -------------------------
plan(sequential)
# test it yourself with plan(multisession)

handlers(handler_dipsaus_progress())
with_progress({
  p <- progressor(along = xs)
  y <- future.apply::future_lapply(xs, function(x) {
    p(sprintf("x=%g", x))
    Sys.sleep(0.1)
    sqrt(x)
  })
})

# ------------------------ A shiny case --------------------------------

ui <- fluidPage(
  actionButton('ok', 'Run Demo')
)

server <- function(input, output, session) {
  handlers(handler_dipsaus_progress())
  make_forked_clusters()

  observeEvent(input$ok, {
    with_progress({
      p <- progressor(along = 1:100)
      y <- future.apply::future_lapply(1:100, function(x) {
        p(sprintf("Input %d|Result %d", x, x+1))
        Sys.sleep(1)
        x+1
      })
    })
  })
}

if(interactive()){
  shinyApp(ui, server)
}

Description

Escape HTML strings so that they will be displayed 'as-is' in websites.

Usage

html_asis(s, space = TRUE)

Arguments

Value

An R string

Examples

ui <- flex_div(
  shiny::textInput('id', ' ', width = '100%',
                   value = 'Height not aligned'),
  actionButtonStyled('ok', 'Button1', width = '100%',),
  shiny::textInput('id2', html_asis(' '), width = '100%',
                   value = 'Heights aligned'),
  actionButtonStyled('ok2', 'Button2', width = '100%',),
  ncols = 2
)
if(interactive()){
  shiny::shinyApp(ui = shiny::fluidPage(shiny::fluidRow(ui)),
                  server = function(input, output, session){})
}

Description

Combine 'HTML' classes to produce nice, clean 'HTML' class string via combine_html_class, or to remove a class via remove_html_class

Usage

combine_html_class(...)

remove_html_class(target, class)

Arguments

Value

A character string of new 'HTML' class

Examples

# Combine classes "a b c d e"
combine_html_class("a", "b  a", c("c", " d", "b"), list("e ", "a"))

# Remove class
remove_html_class("a b   c  e", c("b", "c "))

Description

Apply function with an index variable as the second input.

Usage

iapply(X, FUN, ..., .method = c("sapply", "lapply", "vapply"))

Arguments

Details

FUN will be further passed to the apply methods. Unlike lapply, FUN is expected to have at least two arguments. The first argument is each element of X, the second argument is the index number of the element.

Value

a list or matrix depends on .method. See lapply

Description

A coarse way to find if a function comes from a package.

Usage

is_from_namespace(x, recursive = TRUE)

Arguments

Value

logical true if x or its environment is defined in a namespace; returns false if the object is atomic, or defined in/from global environment, or an empty environment.

Examples

is_from_namespace(baseenv())        # TRUE
is_from_namespace(utils::read.csv)  # TRUE

x <- function(){}
is_from_namespace(NULL)             # FALSE
is_from_namespace(x)                # FALSE
is_from_namespace(emptyenv())       # FALSE

# Let environment of `x` be base environment
# (exception case)
environment(x) <- baseenv()
is_from_namespace(x)        # TRUE

Description

Apply, but in parallel

Usage

lapply_async2(
  x,
  FUN,
  FUN.args = list(),
  callback = NULL,
  plan = TRUE,
  future.chunk.size = NULL,
  future.seed = sample.int(1, n = 1e+05 - 1),
  ...
)

Arguments

Details

When plan is logical, FALSE means use current plan. If plan=TRUE, then it equals to plan='multicore'. For characters, plan can be 'multicore', 'callr', 'sequential', 'multisession', 'multiprocess', etc. Alternatively, you could pass future plan objects.

Value

same as with(FUN.args, lapply(x, function(el){eval(body(FUN))}))

See Also

make_forked_clusters

Examples

library(future)
plan(sequential)

# Use sequential plan
# 1. Change `plan` to 'multicore', 'multisession', or TRUE to enable
# multi-core, but still with progress information
# 2. Change plan=FALSE will use current future plan
res <- lapply_async2(100:200, function(x){
  return(x+1)
}, callback = function(e){
  sprintf('Input=%d', e)
}, plan = 'sequential')

# Disable callback message, then the function reduce to
# normal `future.apply::future_lapply`
res <- lapply_async2(100:200, function(x){
  return(x+1)
}, callback = NULL, plan = FALSE)

if(interactive()) {

  # PID are different, meaning executing in different sessions
  lapply_async2(1:4, function(x){
    Sys.getpid()
  })
}

Description

Apply function with rs_exec

Usage

lapply_callr(
  x,
  fun,
  ...,
  .callback = NULL,
  .globals = list(),
  .ncores = future::availableCores(),
  .packages = attached_packages(),
  .focus_on_console = TRUE,
  .rs = FALSE,
  .quiet = FALSE,
  .name = "",
  .wait = TRUE
)

Arguments

Value

When .wait=TRUE, returns a list that should be, in most of the cases, identical to lapply; when .wait=FALSE, returns a function that collects results.

See Also

rs_exec

Examples

if(interactive()){

  lapply_callr(1:3, function(x, a){
    c(Sys.getpid(), a, x)
  }, a = 1)

  lapply_callr(1:30, function(x)
    {
      Sys.sleep(0.1)
      sprintf("a + x = %d", a + x)
    }, .globals = list(a = 1),
    .callback = I, .name = "Test")

}

Description

Copy elements to fastmap2

Usage

list_to_fastmap2(li, map = NULL)

Arguments

Value

If map is not NULL, elements will be added to map and return map, otherwise create a new instance.

Description

Copy elements to fastqueue2

Usage

list_to_fastqueue2(li, queue = NULL)

Arguments

Value

If map is not NULL, elements will be added to map and return map, otherwise create a new instance.

Description

A wrapper for 'synchronicity' package, but user can interrupt the lock procedure anytime, and don't have to worry about whether the lock exists or not.

Usage

dipsaus_lock(name, timeout = 10, exclusive = TRUE)

dipsaus_unlock(name, timeout = 10, exclusive = TRUE)

dipsaus_resetlocks(name)

Arguments

Value

Logical, whether the operation succeed.

Examples

# Clear existing locks
dipsaus::dipsaus_resetlocks()

# unlock to prepare for the example
dipsaus_unlock('testlocker', timeout = 0.01)

# Create a locker, return TRUE
lock_success = dipsaus_lock('testlocker')
if(lock_success){
  cat2('testlocker has been locked')
}

# test whether locker has been locked
lock_success = dipsaus_lock('testlocker', timeout = 0.01)
if(!lock_success){
  cat2('attempt to lock testlocker failed')
}

# unlock
dipsaus_unlock('testlocker', timeout = 0.01)

# clean up
dipsaus::dipsaus_resetlocks()

Description

Creates forked clusters. If fails, then switch to alternative plan (default is "multisession").

Usage

make_forked_clusters(
  workers = future::availableCores(),
  on_failure = getOption("dipsaus.cluster.backup", "sequential"),
  clean = FALSE,
  ...
)

Arguments

Details

This was original designed as a wrapper for future::plan(future::multicore, ...). Forked clusters are discouraged when running in 'RStudio' because some pointers in 'RStudio' might be incorrectly handled, causing fork-bombs. However, forked process also has big advantages over other parallel methods: there is no data transfer needed, hence its speed is very fast. Many external pointers can also be shared using forked process. Since version 1.14.0, unfortunately, forked 'multicore' is banned by future package by default, and you usually need to enable it manually. This function provides a simple way of enable it and plan the future at the same time.

On windows, forked process is not supported, under this situation, the plan fall back to sequential, which might not be what you want. In such case, this function provides an alternative strategy that allows you to plan. You could also always enable the alternative strategy by setting dipsaus.no.fork option to true.

The parameter clean allows you to automatically clean the plan. This function allows you to reverse back to previous plan automatically once your function exits. For example, users might have already set up their own plans, clean=TRUE allows you to set the plan back to those original plans once function exit. To use this feature, please make sure this function is called within another function, and you must collect results before exiting the outer function.

Value

Current future plan

See Also

lapply_async2

Examples

if(interactive()){

  # ------ Basic example
  library(future)
  library(dipsaus)

  # sequential
  plan("sequential")

  make_forked_clusters()
  plan()  # multicore, or multisession (on windows)

  Sys.getpid()  # current main session PID
  value(future({Sys.getpid()}))  # sub-process PID, evaluated as multicore

  # ------ When fork is not supported

  # reset to default single core strategy
  plan("sequential")

  # Disable forked process
  options("dipsaus.no.fork" = TRUE)
  options("dipsaus.cluster.backup" = "multisession")

  # Not fall back to multisession
  make_forked_clusters()
  plan()

  # ------ Auto-clean

  # reset plan
  plan("sequential")
  options("dipsaus.no.fork" = FALSE)
  options("dipsaus.cluster.backup" = "multisession")

  # simple case:
  my_func <- function(){
    make_forked_clusters(clean = TRUE)

    fs <- lapply(1:4, function(i){
      future({Sys.getpid()})
    })

    unlist(value(fs))
  }

  my_func()    # The PIDs are different, meaning they ran in other sessions
  plan()       # The plan is sequential, auto reversed strategy

  # ------ Auto-clean with lapply_async2
  my_plan <- plan()

  # lapply_async2 version of the previous task
  lapply_async2(1:4, function(i){
    Sys.getpid()
  })

  identical(plan(), my_plan)

}

Description

Provides five types of map that fit in different use cases.

Usage

session_map(map = fastmap::fastmap())

rds_map(path = tempfile())

text_map(path = tempfile())

Arguments

Details

There are five types of map implemented. They all inherit class AbstractMap. There are several differences in use case scenarios and they backend implementations.

session_map

A session map takes a fastmap object. All objects are stored in current R session. This means you cannot access the map from other process nor parent process. The goal of this map is to share the data across different environments and to store global variables, as long as they share the same map object. If you are looking for maps that can be shared by different processes, check the rest map types. The closest map type is rds_map.

rds_map

An 'RDS' map uses file system to store values. The values are stored separately in '.rds' files. Compared to session maps, 'RDS' map can be shared across different R process. It's recommended to store large files in rds_map. If the value is not large in RAM, text_map is recommended.

text_map

A 'text' map uses file system to store values. Similar to rds_map, it can be stored across multiple processes as long as the maps share the same file directory. However, unlike rds_map, text_map the text_map can only store basic data values, namely atom data types. The supported types are: numeric, character, vector, list, matrix It's highly recommended to convert factors to characters. Do NOT use if the values are functions or environments. The recommended use case scenario is when the speed is not the major concern, and you want to preserve data with backward compatibility. Otherwise it's highly recommended to use rds_map.

Value

An R6 instance that inherits AbstractMap

Examples

# ----------------------Basic Usage ----------------------

# Define a path to your map.
path = tempfile()
map <- rds_map(path)

# Reset
map$reset()

# Check if the map is corrupted.
map$validate()

# You have not set any key-value pairs yet.
# Let's say two parallel processes (A and B) are sharing this map.
# Process A set values
map$keys()

# Start push
# set a normal message
map$set(key = 'a', value = 1)

# set a large object
map$set(key = 'b', value = rnorm(100000))

# set an object with hash of another object
map$set(key = 'c', value = 2, signature = list(
  parameter1 = 123,
  parameter2 = 124
))

# Check what's in the map from process B
mapB <- rds_map(path)
mapB$keys()
mapB$keys(include_signatures = TRUE)

# Number of key-values pairs in the map.
mapB$size()

# Check if key exists
mapB$has(c('1','a', 'c'))

# Check if key exists and signature also matches
mapB$has('c', signature = list(
  parameter1 = 123,
  parameter2 = 124
))

# Signature changed, then return FALSE. This is especially useful when
# value is really large and reading the value takes tons of time
mapB$has('c', signature = list(
  parameter1 = 1244444,
  parameter2 = 124
))

# Destroy the map's files altogether.
mapB$destroy()

## Not run: 
  # Once destroyed, validate will raise error
  mapB$validate()

## End(Not run)

Description

Modifies the default behavior of the function by adding one environment layer on top of input function. The masked variables are assigned directly to the environment.

Usage

mask_function2(f, ..., .list = list())

Arguments

Value

a masked function

Examples

a <- 123
f1 <- function(){
  a + 1
}
f1()   # 124

f2 <- mask_function2(f1, a = 1)
f2()   # a is masked with value 1, return 2

environment(f1)  # global env
environment(f2)  # masked env

env <- environment(f2)
identical(parent.env(env), environment(f1))  # true
env$a  # masked variables: a=1

Description

Recursively match calls and modify arguments

Usage

match_calls(
  call,
  recursive = TRUE,
  replace_args = list(),
  quoted = FALSE,
  envir = parent.frame(),
  ...
)

Arguments

Value

A nested call with all arguments matched

Examples

library(dipsaus); library(shiny)

# In shiny modules, we might want to add ns() to inputIds
# In this example, textInput(id) will become textInput(ns(id))
match_calls(lapply(1:20, function(i){
  textInput(paste('id_', i), paste('Label ', i))
}), replace_args = list(
  inputId = function(arg, call){ as.call(list(quote(ns), arg)) }
))

Description

Calculates mean and standard error of mean

Usage

mean_se(x, na.rm = FALSE, se_na_as_zero = na.rm)

Arguments

Value

A named vector containing the mean and standard error of mean (ste_mean).

See Also

ste_mean

Examples

# Mean should be near 0 (mean of standard normal)
# standard error of mean should be near 0.01
mean_se(rnorm(10000))

Description

Get max RAM size This is an experimental function that is designed for non-windows systems

Usage

mem_limit2()

Value

a list of total free memory.

Description

Create new function that supports 'quasi-quosure' syntax

Usage

new_function2(
  args = alist(),
  body = {
 },
  env = parent.frame(),
  quote_type = c("unquoted", "quote", "quo"),
  quasi_env = parent.frame()
)

Arguments