R/add_start_pars.R

In taiawu/dsfworld_package: Visualizes and Analyzes Differential Scanning Fluorimetry Data

#' Generate named list of starting parameters for dsfworld models
#'
#' A wrapper function to apply get_start_pars across a tibble of nested dsf data, containg a column of calculated estimates for initial RFU and transitions, as added by add_estimates. Appends a column containing starting parameter estimates for a list of user-requested parameters (determined by the model to be fit).
#'
#' @param by_var A nested tibble, including estimate values, add_estimates().
#' @param ... additional named arguments, which are passed to get_start_pars. In a standard workflow, this would include the names of the requested parameters. It could also include a lsit to overwrite the defaults for pars_defaults.
#'
#' @return The input nested df, with an additional column named "pars", containing a names list of starting parameter estimates to be passed to nlsLM for model fitting.
#'
#' @export
add_start_pars <-
  function(by_var, ...) {
    by_var %>%
      mutate(pars =
               purrr::map(.data$est,
                          get_start_pars,
                          ...)[1])
  }

# --------- get start pars
#' Select and format estimates for model starting parameters
#'
#' @param estimates a tibble, as generated by get_estimates, containing rank-ordered estimates for transitions and intial RFUs for a singe trace of DSF data
#' @param which_pars a character vector, containing the names of all parameters for which starting parameters should be returned.
#' @param pars_defaults a named list, containing default values to provide for starting parameters for all possible parameters used in dsfworld models.
#' @param par_order a character vector, containing the names of the parameters to be output, in the order in which they will be expected in the downstream nlsLM. WRITE A CHECK FOR THIS.
#'
#' @param ... additional arguments, inherited from upstream functions such as add_start_pars, which can be ignored by this function.
#'
#' @return a named list of numbers, with names corresponding to parameters names of a dsfworld model, and values corresponding to starting parameter estimates. List element appear in the order in which nslLM expects them. WRITE A CHECK FOR THIS
#'
#' @importFrom dplyr mutate if_else filter bind_rows arrange
#' @importFrom tidyr unite
#' @importFrom tibble tibble
#' @importFrom purrr as_vector
#'
#' @export
get_start_pars <- #__translate estimates df to pars list for nlsLM
  function(estimates, # df with all estimate information
           which_pars, # all parameters desired
           pars_defaults = list(Asym1 = 1, xmid1 = 0.4, scal1 = 0.03, d1 = -0.5,
                                Asym2 = 0.5,  xmid2 = 0.6, scal2 = 0.03,  d2 = -1,
                                Asym3 = 0.3, xmid3 = 0.2, scal3 = 0.03, d3 = -1.5,
                                id_d1 = 0.2, id_b1 = -5), # not everything gets an estimate
           par_order = c("Asym1", "xmid1", "scal1", "d1", # par order must match final formula
                         "Asym2", "xmid2", "scal2", "d2",
                         "Asym3", "xmid3", "scal3", "d3",
                         "id_d1", "id_b1"),
           ...) {

    ##### work to do on this function ########
    # intelligent estimate of Asym from data?
    # improved ordering of xmid values -- when to use minor or major transtions?

    # dplyr mutate if_else filter bind_rows arrange
    # tidyr unite
    # tibble tibble
    # purrr as_vector

    ## match estimates to par names
    par_df <- # keep as intermediate - useful for additional intelligent ordering
      estimates %>%
      # match parameter names to forumula
      dplyr::mutate(par_type =
                      dplyr::if_else(.data$est_type %in% c("minor", "major"),
                                     true = "xmid",
                                     false = "id_d")) %>%
      tidyr::unite("par_name", c(.data$par_type, .data$est_rank),
                   sep = "", remove = FALSE) %>%

      # drop pars irrelevant or redundant to given formula
      dplyr::filter(.data$par_name %in% which_pars)

    ## create the final parameter list
    defaults <-
      tibble::tibble("par_name" = names(pars_defaults),
                     "est_val" =  pars_defaults %>% purrr::as_vector()) %>%
      dplyr::filter(.data$par_name %in% which_pars, # drop pars not in the model
                    ! .data$par_name %in% par_df$par_name) # drop pars supplied by estimates

    #-----PARAMETER LIST ORDER HAS TO MATCH FORMULA -----#
    df <- # combine estimated and default pars
      dplyr::bind_rows(par_df, defaults) %>%
      dplyr::mutate("par_f" = factor(.data$par_name, levels = par_order)) %>%
      dplyr::arrange(.data$par_f)

    #### HERE -- ADD A CHECK TO REPLACE THE ESTIMATES WITH THE DEFAULTS IF THEY ARE WHACKY ###

    ## nlsLM expects a list
    out <- as.list(df$est_val)
    names(out) <- df$par_name
    out # can be fed directly to nlsLM as start pars

  }