My Rprofile tweaks

.Rprofile

## vim: ft=r

.libPaths('~/.R/site-library')

if (interactive()) {

## rprofile environment ----------------------------------------

    # to be attached to search path
    rprofile_env <- environment()

    # # get attached packages for "restart"
    # assign('.base_packages', c(
    #         "package:stats",
    #         "package:graphics",
    #         "package:grDevices",
    #         "package:utils",
    #         "package:datasets",
    #         "package:methods",
    #         "package:base"), envir = rprofile_env)

## terminal appearance ----------------------------------------

    # show working directory in R prompt (setwd is masked)
    assign('update_terminal', function(...) {
        # update prompt
        # options(prompt = paste0(mount_prompt(), error_prompt(), "\033[0;32m ", system('pwd | sed "s=$HOME=~="', intern = TRUE), "\033[0m \033[1;33m>\033[0m "))
        options(prompt = paste0(mount_prompt(), error_prompt(), logging_prompt(),
                "\033[0;32m ", sub(Sys.getenv('HOME'), '~', getwd(), fixed = TRUE), "\033[0m \033[1;33m>\033[0m "))
        # update terminal width
        width <- as.integer(Sys.getenv('COLUMNS'))
        if (!is.na(width)) options(width = width)
        # return TRUE
        TRUE
    }, envir = rprofile_env)
    # call it after top-level tasks
    addTaskCallback(get('update_terminal', envir = rprofile_env))
    # check error function
    assign('error_prompt', function() {
        if (is.null(getOption('error'))) {
            ''
        } else {
            '\033[1;33m err'
        }
    }, envir = rprofile_env)
    # check logging function
    assign('logging_prompt', function() {
        if (getOption('tmux_logging', FALSE)) {
            '\033[1;31m %'
        } else {
            ''
        }
    }, envir = rprofile_env)
    # check LFE mounted function
    assign('mount_prompt', function() {
        if (length(suppressWarnings(
            system('grep -e "/mnt/smb-ceph" -e "mnt/smb.hdd.rbd/HAFL" /proc/mounts', intern = TRUE)
            )) == 0) {
            ''
        } else {
            '\033[1;34m *'
        }
    }, envir = rprofile_env)

    # # reset terminal width on resize
    # options(setWidthOnResize = TRUE)

    # continue in red
    options(continue = ' \033[1;31m+\033[0m ')

    # colorize terminal output (https://github.com/jalvesaq/colorout)
    require(colorout)

    # my colors
    setOutputColors(
        normal = 109, 
        number = 172, 
        negnum = 167, 
        zero = 226,
        date = 179, 
        string = 117,
        const = 131, 
        false = 202, 
        true = 150,
        infinite = 123, 
        index = 30, 
        stderror = 110,
    #     warn = c(1, 16, 196), 
    #     error = c(160, 231),
    #     zero.limit = NA,
        verbose = FALSE 
    )

    # custom patterns (copied from https://gist.github.com/kar9222/0e1130c15bfaba3a71f0cf6d1d08931f)
    # define colors
    lightgrey <- '\x1b[38;2;135;145;144m'
    lightblue <- '\x1b[38;2;143;188;187m'
    # custom patterns data.table
    # colorout::addPattern('[0-9]*:',  '\x1b[38;2;143;188;187m')  # Row num
    colorout::addPattern('[0-9]*:', lightgrey)  # Row num
    colorout::addPattern('---',      '\x1b[38;2;76;86;106m')    # Row splitter 
    colorout::addPattern('<[A-z]*>', lightgrey)  # Col class 

    # Fix <NA>
    colorout::addPattern('<NA>', 131)  # Col class 


    # Dates with my locale
    # mm/dd/YYYY is type char
    colorout::addPattern('[0-3][0-9]/[0-3][0-9]/[1-2][0-9][0-9][0-9]', 109)
    colorout::addPattern('[0-3][0-9]/[0-3][0-9]/[1-2][0-9][0-9][0-9] [0-2][0-9]:[0-5][0-9]', 109)
    # as is dd.mm.YYYY
    colorout::addPattern('[0-3][0-9].[0-3][0-9].[1-2][0-9][0-9][0-9]', 109)
    colorout::addPattern('[0-3][0-9].[0-3][0-9].[1-2][0-9][0-9][0-9] [0-2][0-9]:[0-5][0-9]', 109)
    # this is true date
    colorout::addPattern('[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9]', 179)
    # Date-Times
    colorout::addPattern('[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9] [0-2][0-9]:[0-5][0-9]:[0-5][0-9]', 179)
    colorout::addPattern('[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9] [0-2][0-9]:[0-5][0-9]:[0-5][0-9].[0-9][0-9][0-9]', 179)

    # Fix number ranges
    colorout::addPattern('[0-9]*:[0-9]*', 172)

    # ibts obj row names
    # ex: 2024-06-06 07:34:57.000 - 07:35:57.234 CEST
    colorout::addPattern(paste0(
            '[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9] ',
            '[0-2][0-9]:[0-5][0-9]:[0-5][0-9].[0-9][0-9][0-9]',
            ' - ',
            '[0-2][0-9]:[0-5][0-9]:[0-5][0-9].[0-9][0-9][0-9]',
            ' [ -~]*'
            ), lightgrey)  # Row date-times
    # ex: 2024-06-06 07:34:57 - 07:35:57 CEST
    colorout::addPattern(paste0(
            '[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9] ',
            '[0-2][0-9]:[0-5][0-9]:[0-5][0-9]',
            ' - ',
            '[0-2][0-9]:[0-5][0-9]:[0-5][0-9]',
            ' [ -~]*'
            ), lightgrey)  # Row date-times
    # ex: 2024-06-06 07:34 - 07:35 CEST
    colorout::addPattern(paste0(
            '[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9] ',
            '[0-2][0-9]:[0-5][0-9]',
            ' - ',
            '[0-2][0-9]:[0-5][0-9]',
            ' [ -~]*'
            ), lightgrey)  # Row date-times
    # ex: 2024-06-06 to 2024-06-07 CEST
    colorout::addPattern(paste0(
            '[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9]',
            ' to ',
            '[1-2][0-9][0-9][0-9]-[0-3][0-9]-[0-3][0-9]',
            ' [ -~]*'
            ), lightgrey)  # Row date-times
    colorout::addPattern('[[a-z]*]', lightgrey)  # Column class
    colorout::addPattern('***', lightgrey)  # Row snip
    colorout::addPattern('----', lightgrey)  # Percentage line
    colorout::addPattern('(100.0%)', lightgrey)  # Percentage 3 digits
    colorout::addPattern('([0-9][0-9].[0-9]%)', lightgrey)  # Percentage 2 digits
    colorout::addPattern('([0-9].[0-9]%)', lightgrey)  # Percentage 1 digit

    # librar(colorspaces)
    # hex(RGB(143/256, 188/256, 187/256))
    # round(hex2RGB("#86908F")@coords * 256)

    # custom patterns str
    ## List
    colorout::addPattern('List of [0-9]*', '\x1b[38;2;235;203;139;48;2;76;86;106;1m')
    ## Class
    classcol <- lightgrey
    colorout::addPattern(' num ',          classcol)
    colorout::addPattern(' int ',          classcol)
    colorout::addPattern(' dbl ',          classcol)
    colorout::addPattern(' chr ',          classcol)
    colorout::addPattern(' logi ',         classcol)
    colorout::addPattern(' lglc ',         classcol)
    colorout::addPattern(' Factor ',       classcol)
    colorout::addPattern(' Ord.factor ',   classcol)
    colorout::addPattern(' POSIXct, ',     classcol)
    colorout::addPattern('function ',      classcol)
    colorout::addPattern(' lgcl ',         classcol)
    colorout::addPattern(' cplx ',         classcol)
    # Misc
    colorout::addPattern('$ ',             '\x1b[38;2;76;86;106m')
    # comments
    colorout::addPattern('#[ -~]*',        '\x1b[38;2;76;86;106m')

    # remove colors
    rm(lightgrey, lightblue, classcol)

## add "aliases" ----------------------------------------

    # active binding helper
    assign_with_print <- function(nm, fun, env) {
        # assign class
        assign(nm, structure(list(), class = paste0('my_', nm)), envir = env)
        # register method
        registerS3method('print', paste0('my_', nm), fun, .GlobalEnv)
    }

    # exit R
    assign_with_print('exit', function(x, ...) q('no'), rprofile_env)

    # clear workspace
    assign_with_print('clear', function(x, ...) rm(list = ls(envir = .GlobalEnv), envir = .GlobalEnv), rprofile_env)

    # # restart R (crashes when using gc() afterwards, though!)
    # assign_with_print('restart', function(x, ...) {
    #         # get packages attached by user
    #         pkgs <- setdiff(grep('package:', search(), value = TRUE), .base_packages)
    #         # unload if any
    #         if (length(pkgs) > 0) {
    #             invisible(
    #                 lapply(pkgs, detach, unload = TRUE, character.only = TRUE, force = TRUE)
    #             )
    #         }
    #         # clear workspace completely
    #         rm(list = ls(all.names = TRUE, envir = .GlobalEnv), envir = .GlobalEnv)
    #         # detach rprofile_tweaks environment
    #         detach('rprofile_tweaks', character.only = TRUE)
    #         # source .Rprofile
    #         base::source('~/.Rprofile')
    #     }, rprofile_env)

    # close all devices
    assign_with_print('goff', function(x, ...) grDevices::graphics.off(), rprofile_env)

    # pseudo bash mode (passing command line to system)
    assign('sh', structure(function(path = getwd()){
        path <- path.expand(path)
        if (!dir.exists(path) && dir.exists(dn <- dirname(path))) {
            path <- dn
        } else if(!dir.exists(path)) {
            path <- getwd()
        }
        suppressWarnings(
            system(paste0('bash -c "cd ', path, '; bash --rcfile <(cat ~/.profile; echo \\"PROMPT_COMMAND=\'\';PS1=\'\\033[1;31m \\w $\\033[0m \'\\")"'))
            )
        invisible(NULL)
    }, class = 'my_sh'), envir = rprofile_env)
    # register method
    registerS3method('print', 'my_sh', function(x, ...){
        sh()
        invisible(NULL)
    }, envir = .GlobalEnv)

    # use geeqie from R to check figures
    assign('geeqie', structure(function(path = getwd()){
        path <- path.expand(path)
        pinfo <- file.info(path)
        if (is.na(pinfo$isdir)) {
            path <- getwd()
        }
        suppressWarnings(
            system(paste0('geeqie ', path), wait = FALSE)
            )
        cat('opening geeqie at "', path, '"...\n', sep = '')
        invisible(NULL)
    }, class = 'my_geeqie'), envir = rprofile_env)
    # register method
    registerS3method('print', 'my_geeqie', function(x, ...){
        geeqie()
        invisible(NULL)
    }, envir = .GlobalEnv)

    # use one single function for x11, pdf, png, ...
    # DOES NOT WORK INSIDE A BLOCK (and, obviously, in a script)! (due to the way of parsing code)
    # usage example:
    # dev()
    # # par(cex = 2)
    # plot(1)
    # #/
    options(dev.fu = 'x11')
    assign('dev', function(fu = getOption('dev.fu', 'x11'),
        width = 7, height = 7, units = 'in', res = 300, quality = 100, 
        file = paste0('Rplot%03d.', sub('postscript', 'ps', fu)),
        filename = paste0('Rplot%03d.', sub('postscript', 'ps', fu)),
        ...) {
        pframe <- parent.frame()
        # get function name
        if (!is.character(fu)) {
            fu <- deparse(substitute(fu))
        } 
        # check function and get argument names
        anames <- switch(fu
            , 'x11' = formalArgs(x11)
            , 'png' = 
            , 'jpeg' = 
            , 'tiff' = 
            , 'pdf' = 
            , 'postscript' = {
                # close device on exit
                on.exit(dev.off())
                formalArgs(fu)
            }
            , {
                # use first argument as filename if both 'file' and 'filename' are missing
                if (missing(file) && missing(filename)) {
                    file <- filename <- fu
                    fu <- getOption('dev.fu', 'x11')
                    if (fu != 'x11') on.exit(dev.off())
                    formalArgs(fu)
                } else {
                    stop('argument fu not valid')
                }
            }
            )
        # fix arguments
        if (missing(file)) file <- filename
        if (missing(filename)) filename <- file
        fixed_args <- list(width = width, height = height, 
            file = file, filename = filename,
            units = units, res = res, quality = quality)
        if ('...' %in% anames) {
            all_args <- c(fixed_args, '...' = list(...))
        } else {
            all_args <- c(fixed_args, list(...))
        }
        # call function
        do.call(fu, all_args[names(all_args) %in% anames])
        cmd <- ''
        while (TRUE) {
            cmd0 <- readline(paste0('\033[1;34m', fu, 
                    '()\033[1;35m: exit by "\033[0m\033[1;1m#/\033[1;35m" \033[1;34m>>\033[0m '))
            if (grepl('^\\s*#/\\s*$', cmd0)) break
            cmd <- paste(cmd, cmd0, sep = '\n')
            ecmd <- try(
                eval(parse(text = cmd), envir = pframe)
                , silent = TRUE)
            if (!inherits(ecmd, 'try-error')) {
                cmd <- ''
            }
        }
        eval(parse(text = cmd), envir = pframe)
        invisible(NULL)
    }, envir = rprofile_env)
    assign_with_print('setdev', function(x, ...) {
        fu <- getOption('dev.fu', 'x11')
        newfu <- 'undefined'
        while (!(newfu %in% c('x11', 'png', 'jpeg', 'tiff', 'pdf',
                'postscript', ''))) {
            newfu <- readline(paste0('\033[1;34m current device ', fu, 
                '()\033[1;35m - define new device:\033[0m '))
        }
        if (newfu == '') newfu <- 'x11'
        cat(paste0('\033[1;34mUsing device ', newfu, '()\033[0m\n'))
        options(dev.fu = newfu)
    }, rprofile_env)
    assign_with_print('checkdev', function(x, ...) {
        fu <- getOption('dev.fu', 'x11')
        cat(paste0('\033[1;34mUsing device ', fu, '()\033[0m\n'))
        invisible(NULL)
    }, rprofile_env)

    # pseudo bash commands (simplified passing commands to system)
    assign('%$%', function(x, y) {
        x <- substitute(x)
        y <- substitute(y)
        if (!is.character(x)) x <- deparse1(x)
        if (!is.character(y)) y <- deparse1(y)
        system(paste(x, y))
    }, envir = rprofile_env)

    # mount/unmount drives
    assign_with_print('md', function(x, ...) system('bash -i -c md'), rprofile_env)
    assign_with_print('umd', function(x, ...) system('bash -i -c umd'), rprofile_env)

    # open with neovim
    assign('nv', structure(function(file = getwd()){
        suppressWarnings(
            system(paste0('bash -il -c "nv \\"',
                    normalizePath(file), '\\""'))
            )
        invisible(NULL)
    }, class = 'my_nv'), envir = rprofile_env)
    # register method
    registerS3method('print', 'my_nv', function(x, ...){
        nv()
        invisible(NULL)
    }, envir = .GlobalEnv)

    # use sendmail to notify me from server
    assign('sendmail', function(subject = '', body = '', recipient = NULL) {
            if (is.null(recipient)) {
                recipient <- system('git config user.email', intern = TRUE)
            }
            msg <- paste0('EOF\n',
                'Subject: ', subject, '\n\n',
                body, '\nEOF')
            system(paste('sendmail', recipient, '<<', msg))
        }, envir = rprofile_env)


    # don't process code after error occured:
    # + show stack trace as described in https://renkun.me/2020/03/31/a-simple-way-to-show-stack-trace-on-error-in-r/
    # add option to turn on
    assign_with_print('err', function(x, ...) {
            options(error = function() {
                calls <- sys.calls()
                msg <- geterrmessage()
                ...error... <- ''
                while (interactive() & !grepl('^j+$', ...error...)) {
                    ...error... <- readline('\033[1;35merror:\033[0m type "\033[1;1mj\033[0m" to return: ')
                }
                cat(paste0("\033[1;37;41m", sub('\\n$', '', msg), "\033[0m", "\n"))
                if (length(calls) >= 2L) {
                    sink(stderr())
                    on.exit(sink(NULL))
                    cat("Backtrace:\n")
                    calls <- rev(calls[-length(calls)])
                    for (i in seq_along(calls)) {
                      cat(i, ": ", deparse(calls[[i]], nlines = 1L), "\n", sep = "")
                    }
                }
                if (!interactive()) {
                    q(status = 1)
                }
            })
        }, rprofile_env)
    # add option to turn off
    assign_with_print('noerr', function(x, ...) {
            options(error = NULL)
        }, rprofile_env)

    # log R session on tmux
    assign_with_print('toggle_logging', function(x, ...) {
            if (getOption('tmux_logging', FALSE)) {
                # stop logging
                system('tmux pipe-pane')
                options(tmux_logging = FALSE)
            } else {
                # start logging
                cmd <- paste0(
                    "for s in $(tmux list-windows -F '#{pane_tty}:#S:#I'); do ",
                        "s_tty=$(echo $s | sed -E 's=(.*):.*:.*$=\\1='); ",
                        "if [ \"$(tty)\" = \"$s_tty\" ]; then ",
                            "echo $s | sed -E 's=.*:(.*:.*)=\\1='; ",
                            "break; ",
                        "fi; ",
                    "done;"
                )
                current_session <- system(cmd, intern = TRUE, ignore.stderr = TRUE)
                if (length(current_session) == 0) {
                    cat('not inside a tmux session!\n')
                    return(invisible())
                }
                system(paste0("tmux pipe-pane 'cat >> ", file.path(getwd(), '#h_#S_#I_#P.rlog'), "'"))
                reg.finalizer(.GlobalEnv, function(x) system('tmux pipe-pane'))
                options(tmux_logging = TRUE)
            }
        }, rprofile_env)

    # improved ls
    assign('lsx', structure(function(sort_col = 1, class = NULL, envir = parent.frame(), ...) {
            ls_obj <- ls(envir = envir, ...)
            if (!length(ls_obj)) return(ls_obj)
            obj_info <- lapply(ls_obj, function(x) {
                obj <- get(x, envir = envir)
                cls <- class(obj)
                if (!is.null(class) && !any(class %in% cls)) return(NULL)
                if (length(cls) > 1) cls <- paste0(cls[1], ' (', paste(cls[-1], collapse = ','), ')')
                nr <- nrow(obj)
                if (is.null(nr)) nr <- '-'
                os <- object.size(obj)
                data.frame(
                    obj.name = x,
                    obj.class = cls,
                    obj.size = format(os, unit = 'auto'),
                    os = as.numeric(os),
                    nrows = nr,
                    'length/ncol' = length(obj),
                    'content' = deparse(obj, width.cutoff = 40, control = 
                        c('quoteExpressions', 'keepNA', 'niceNames'), nlines = 1L),
                    check.names = FALSE,
                    stringsAsFactors = FALSE
                    )
            })
            ind <- !sapply(obj_info, is.null)
            if (any(ind)) {
                obj_info <- obj_info[ind]
            } else {
                return(character(0))
            }
            out <- structure(do.call(rbind.data.frame, obj_info), class = c('lsx', 'data.frame'))
            # align classes
            maxpos <- max(unlist(regexec(' ', out[[2]])))
            if ((nch <- nchar(names(out)[2])) < maxpos) {
                names(out)[2] <- paste(c(
                        rep(' ', floor((maxpos - nch) / 2)),
                        names(out)[2]),
                        collapse = '')
            }
            out[[2]] <- align(out[[2]], ' ')
            # align sizes
            out[[3]] <- align(out[[3]], ' ')
            maxpos <- max(nchar(out[[3]]))
            if ((nch <- nchar(names(out)[3])) < maxpos) {
                names(out)[3] <- paste(c(
                        rep(' ', floor((maxpos - nch) / 2)),
                        names(out)[3]),
                        collapse = '')
            }
            # right align nrows
            al5 <- align(c(names(out)[5], out[[5]]), '$')
            out[[5]] <- al5[-1]
            names(out)[5] <- al5[1]
            # right align length/cols
            al6 <- align(c(names(out)[6], out[[6]]), '$')
            out[[6]] <- al6[-1]
            names(out)[6] <- al6[1]
            # sort
            if (!missing(sort_col)) {
                os <- out[[4]]
                out <- out[, -4]
                sb <- abs(sort_col)
                sig <- sign(sort_col)
                if (sb == 3) {
                    ind <- order(as.numeric(sub(' [a-zA-Z]+$', '', os)), decreasing = sig < 0)
                } else {
                    ind <- order(out[[sb]], decreasing = sig < 0)
                }
                out <- out[ind, ]
            } else {
                out <- out[, -4]
            }
            if (nrow(out) == 0) {
                NULL
            } else {
                out
            }
        }, class = 'my_lsx'), envir = rprofile_env)
    assign('align', function(x, pattern = '[.]') {
            nc <- unlist(regexec(pattern, x)) - 1
            nc <- nc + (nc < 0) * (nchar(x) + 2)
            mc <- max(nc)
            paste0(sapply(mc - nc, function(x) paste(rep(' ', x), collapse = '')), x)
        }, envir = rprofile_env)
    registerS3method('print', 'my_lsx', function(x, ...) {
        # print.data.frame(x, row.names = FALSE, right = FALSE, ...)
        print(lsx(envir = parent.frame(n = 2)))
        }, envir = .GlobalEnv)
    # ls printing
    assign('ls', structure(base::ls, class = 'my_ls'), envir = rprofile_env)
    registerS3method('print', 'my_ls', function(x, ...) {
        print(x(pos = parent.frame(n = 2)))
        }, envir = .GlobalEnv)
    # ll & la -> improved dir()
    assign('ll', structure(function(path = getwd()) {
            path <- path.expand(path)
            system(paste0('ls -lhF --color=auto "', path, '"'))
        }, class = 'my_ll'), envir = rprofile_env)
    registerS3method('print', 'my_ll', function(x, ...) {
        ll()
        }, envir = .GlobalEnv)
    assign('la', structure(function(path = getwd()) {
            path <- path.expand(path)
            system(paste0('ls -AlhF --color=auto "', path, '"'))
        }, class = 'my_la'), envir = rprofile_env)
    registerS3method('print', 'my_la', function(x, ...) {
        la()
        }, envir = .GlobalEnv)

    # rg -> find pattern in workspace object names
    assign('rg', function(pattern, which_classes = c('data.frame', 'list'), pos = -1L,
            envir = as.environment(pos), return_obj = FALSE, ...) {
        if (!is.environment(envir)) {
            if (inherits(envir, 'list') && is.character(envir[[1]]) && is.environment(envir[[2]])) {
                return(
                    setNames(
                        lapply(envir[[1]], function(x) rg(pattern, which_classes, 
                                envir = as.environment(get(x, envir = envir[[2]])),
                                return_obj, ...)),
                        envir[[1]]
                    )
                )
            }
            envir <- as.environment(envir)
        }
        obj_names <- ls(envir = envir)
        objs <- lapply(obj_names, function(x) {
            obj <- get(x, envir = envir)
            if (inherits(obj, which_classes)) {
                # grep(pattern, obj, ...)
                out <- grep(pattern, names(obj), value = TRUE)
                if (length(out)) {
                    if (return_obj) {
                        if (inherits(obj, 'data.table')) {
                            out <- obj[, out, with = FALSE]
                        } else if (inherits(obj, c('data.frame', 'matrix'))) {
                            out <- obj[, out]
                        } else {
                            out <- obj[out]
                        }
                    }
                    return(out)
                }
            }
            return(NULL)
            })
        ind <- !sapply(objs, is.null)
        if (any(ind)) {
            setNames(objs[ind], obj_names[ind])
        } else {
            NULL
        }
    }, envir = rprofile_env)

    # color name to hex
    assign('col2hex', function(name, alpha) {
            m <- col2rgb(name) / 255
            rgb(m[1, ], m[2, ], m[3,], alpha)
        }, envir = rprofile_env)

    # wrap x11() to allow for 'unfocused' graphic devices
    assign('x12', function(nofocus = TRUE, ...) {
        if (nofocus) {
            act_win <- sub('.*# ', '', system('xprop -root | grep _NET_ACTIVE_WINDOW\\(WINDOW\\)', intern = TRUE))
            grDevices::x11(...)
            system(paste('wmctrl -i -a', act_win))
        } else {
            grDevices::x11(...)
        }
    }, envir = rprofile_env)

    # tree visualization of lists
    assign('tree', function(x, l = Inf, pre = '', nc = 0) {
        if (isTRUE(class(x) == 'list') && sys.nframe() <= l) {
            nams <- names(x)
            nums <- seq_along(x)
            for (i in nums) {
                n <- 0
                if (pre == '') {
                    if (i == 1) {
                        pre2 <- paste0(pre, '\u2500\u2500\u2500\u2500\u2500 ')
                        n <- 1
                    } else {
                        pre2 <- paste0('\n', pre, '\u2500\u2500\u2500\u2500\u2500 ')
                    }
                } else if (i == max(nums)) {
                    pre2 <- paste0('\n', pre, '\u2514\u2500\u2500\u2500\u2500 ')
                } else {
                    pre2 <- paste0('\n', pre, '\u251C\u2500\u2500\u2500\u2500 ')
                }
                if (is.null(nams[i]) || nams[i] == '') {
                    cat(m <- paste0(pre2, '[[', i, ']]'))
                } else {
                    cat(m <- paste0(pre2, '[["', nams[i], '"]]'))
                }
                if (pre != '' && i != max(nums)) {
                    tree(x[[i]], l = l, pre = paste0(pre, '\u2502        '), nc = n + nchar(m))
                } else {
                    tree(x[[i]], l = l, pre = paste0(pre, '         '), nc = n + nchar(m))
                }
            }
        } else {
            nc <- max(nc, 60) - nc
            cat(paste0(
                    ' ',
                    paste(rep('.', nc), collapse = ''),
                    ' (', paste(class(x), collapse = ', '), ')'))
        }
        if (pre == '') {
            cat('\n')
        }
        invisible()
    }, envir = rprofile_env)

    # DISPLAY convenience functions
    assign('set_display', function(x) {
        if (missing(x)) {
            dstring <- system('tmux show-options -g update-environment > /dev/null && tmux show-env | grep ^DISPLAY', 
                intern = TRUE)
            x <- sub('DISPLAY=', '',  dstring)
        } else if (is.numeric(x)) {
            x <- sprintf('localhost:%1.0f.0', x)
        }
        cat('DISPLAY set to:', x, '\n')
        Sys.setenv(DISPLAY = x)
    }, envir = rprofile_env)
    assign('get_display', function(x = 10) {
        Sys.getenv('DISPLAY')
    }, envir = rprofile_env)

}

# source can handle wildcard if find exists
ope <- getOption("error")
sem <- getOption("show.error.messages")
options(show.error.messages = FALSE, error = function() return(1))
# try to call printf
out <- try(system(paste('printf "%s\\n"', normalizePath('~')), intern = TRUE, ignore.stderr = TRUE))
if (!inherits(out, 'try-error')) {
    assign('source', function(path, local = FALSE, verbose = TRUE, ...) {
        envir <- if (do_attach <- is.character(local) && length(local) == 1) {
            env_name <- local
            new.env()
        } else if (isTRUE(local)) {
            parent.frame()
        } else if (isFALSE(local)) {
            .GlobalEnv
        } else if (is.environment(local)) {
            local
        } else {
            stop("'local' must be TRUE, FALSE, search path name or an environment")
        }
        files <- system(paste('printf "%s\\n"', path), intern = TRUE)
        if (length(files) == 1 && !file.exists(files)) {
            stop('No files found!')
        }
        for (file in files) {
            if (verbose) cat('sourcing file:', file, '\n')
            base::source(file, local = envir, ...)
        }
        if (do_attach) {
            try(detach(env_name, character.only = TRUE), silent = TRUE)
            attach(envir, name = env_name)
            cat("Attaching environment '", env_name, "' to searchpaths().\n\nattached objects:\n",
                sep = '')
            print(ls(envir = envir))
            cat('\n')
        }
    }, envir = rprofile_env)
}
rm(out)
options(show.error.messages = sem, error = ope)
rm(ope, sem)



## general settings ----------------------------------------

options(
    # help as text
    help_type = "text",
    # don't use annoying guis to select from choices
    menu.graphics = FALSE,
    # bat as pager (https://github.com/sharkdp/bat)
    pager = "'bat --pager 'less -RF' -l 'RhelpPages' --theme gruvbox-rhelp --style plain'",
    # set shiny port for X forwarding
    shiny.port = 7207,
    # decrease datatable untruncated row print
    datatable.print.nrows = 30,
    # don't throw error on user interruption
    interrupt = function() {}
)

# set CRAN mirror
local({
    r <- getOption("repos")
    r["CRAN"] <- "https://cloud.r-project.org"
    options(repos = r)
})

# limit to one thread
if(interactive() && requireNamespace("RhpcBLASctl", quietly = TRUE)){
    set_blas_threads <- function(n)RhpcBLASctl::blas_set_num_threads(n)
    set_blas_threads(1)
    get_blas_threads <- RhpcBLASctl::blas_get_num_procs
}

## initialize objects ----------------------------------------
if (interactive()) {

    # attach environment
    attach(rprofile_env, name = 'user:.Rprofile', warn.conflicts = FALSE)

    # set error prompt if interactive
    print(err)

    # initialize prompt
    update_terminal()

    # clear workspace
    # rm(list = c(ls(envir = .GlobalEnv), '.base_packages'), envir = .GlobalEnv)
    rm(list = ls(envir = .GlobalEnv), envir = .GlobalEnv)

}