R/RomProperty.R

In HARPgroup/hydro-tools: Data processing and accessors for VAHydro

#' Time Series data object
#' @description Object for storing single time series value or a description of
#'   another property or feature entity
#' @details Has standard methods for managing data and meta data including post,
#'   from_list, to_list, delete. See RomProperty code for all methods. Inherits
#'   other methods from RomEntity
#' @importFrom R6 R6Class
#' @param datasource optional RomDataSource for remote and local storage
#' @param config list of attributes to set. Allowable fields listed in empty
#'   propvalues data frame available in RomProperty after initialization e.g.
#'   (RomProperty$new())
#' @return reference class of type openmi.om.base e.g. a RomProperty that will
#'   have its essential fields stored on itself with REST or ODBC methods to
#'   post and delete base entity
#' @seealso RomEntity, RomFeature, RomDatasource
#' @examples NA
#' @export RomProperty
RomProperty <- R6Class(
  "RomProperty",
  inherit = RomEntity,
  public = list(
    #' @field base_entity_type kind of entity
    base_entity_type = 'dh_properties',
    #' @field pk_name the name of this entity's pk column
    pk_name = 'pid',
    #' @field pid unique ID in this RomDataSource
    pid = NA,
    #' @field featureid id of entity this is attached to
    featureid = NA,
    #' @field entity_type type of entity this is attached to
    entity_type = NA,
    #' @field has_vardef is pluggable?
    has_vardef = TRUE,
    #' @field propname locally unique name
    propname = NA,
    #' @field startdate begin timestamp
    startdate = NA,
    #' @field enddate end time stamp
    enddate = NA,
    #' @field propvalue numerical value
    propvalue = NA,
    #' @field propcode alphanumeric value
    propcode = NA,
    #' @field proptext alphanumeric value
    proptext = NA,
    #' @field data_matrix json matrix
    data_matrix = NA,
    #' @field varid variable ID from RomDataSource
    varid = NA,
    #' @field bundle (for future use)
    bundle = NA,
    #' @field uid user id of creator
    uid = NA,
    #' @field vid current revision (pk in dh_properties_revision)
    vid = NA,
    #' @field module related module (optional?) 
    module = NA,
    #' @field matrix_revision_id pk for foreign table 
    matrix_revision_id = NA,
    #' @field modified timestamp 
    modified = NA,
    #' @field datasource RomDataSource
    datasource = NA,
    #' @field tree_loaded - this is a switch to enable fast loading of export tree from local storage
    tree_loaded = FALSE,
    #' @field sql_select_from syntax to use to select via an odbc or other SQL based datasource
    sql_select_from = "
      select * from dh_properties_fielded
    ",
    #' @field base_only - how to export to list in case of complex multi table entity and ODBC
    base_only = FALSE,
    #' @return get_id the id of this entity alias to remote pkid, subclassed as function
    get_id = function() {
      return(self$pid)
    },
    #' @param datasource URL of some RESTful repository
    #' @param config list of attributes to set, see also: to_list() for format
    #' @param load_remote automatically query REST data source for matches?
    #' @return object instance
    initialize = function(datasource = NULL, config = list(), load_remote = FALSE) {
      # a config template can be generated by using the to_list() method 
      # of a blank object
      # todo: some of this can be handled by the RomDataSource?
      stopifnot(class(datasource)[[1]] == "RomDataSource")
      self$datasource <- datasource 
      # since we do not call the super class for this method we need to handle this setting
      if (self$datasource$connection_type == 'odbc') {
        self$base_only = TRUE
      }
      config <- self$handle_config(config)
      # if requested, we try to load
      # only the last one returned will be sent back to user if multiple
      if (load_remote) {
        prop <- self$datasource$get_prop(
          config = config, return_type = 'list',
          force_refresh = TRUE, obj = self)
        if (is.data.frame(prop)) {
          if (nrow(prop) >= 1) {
            prop <- as.list(prop[1,])
          } else {
            prop <- FALSE
          }
        }
        # merge config with prop
        #message("Found")
        if (!is.logical(prop)) {
          config <- prop
        }
      }
      self$load_data(config, load_remote)
      self$bundle = 'dh_properties'
      if (!is.logical(self$plugin)) {
        if (!is.logical(self$plugin$entity_bundle)) {
          self$bundle = self$plugin$entity_bundle
        }
      }
    },
    #' @param config 
    #' @returns an updated config if necessary or FALSE if it fails
    handle_config = function(config) {
      config = self$insure_varid(config)
      return(config)
    },
    #' @param config list of attributes to set, see also: to_list() for format
    #' @return NULL
    from_list = function(config) {
      for (i in names(config)) {
        if (i == "pid") {
          if (is.na(config$pid)) {
            self$pid = NA
          } else {
            self$pid = as.integer(as.character(config$pid))
          }
        } else if (i == "vid") {
          self$vid = as.integer(as.character(config$vid))
        } else if (i == "varid") {
          self$varid = as.integer(as.character(config$varid))
        } else if (i == "entity_type") {
          self$entity_type = as.character(config$entity_type)
        } else if (i == "featureid") {
          self$featureid = as.integer(as.character(config$featureid))
        } else if (i == "propname") {
          self$propname = as.character(config$propname)
        } else if (i == "startdate") {
          self$startdate = as.integer(as.character(config$startdate))
        } else if (i == "enddate") {
          self$enddate = as.integer(as.character(config$enddate))
        } else if (i == "propvalue") {
          self$propvalue = as.numeric(as.character(config$propvalue))
        } else if (i == "modified") {
          self$modified = as.integer(config$modified)
        } else if (i == "propcode") {
          self$propcode = as.character(config$propcode)
        } else if (i == "proptext") {
          # adding proptext support now.
          self$proptext = as.character(config$proptext)
        } else if (i == "bundle") {
          self$bundle = as.character(config$bundle)
        } else if (i == "data_matrix") {
          if (is.character(config$data_matrix)) {
            if (!is.null(config$matrix_revision_id)) {
              self$matrix_revision_id = as.integer(config$matrix_revision_id)
            } 
            mvalid <- jsonlite::validate(config$data_matrix)
            if (mvalid[1] == TRUE) {
              raw_data = jsonlite::fromJSON(config$data_matrix)
              if ("tabledata" %in% names(raw_data)) {
                data_header <- raw_data$tabledata[[1]]
                n <- 1
                for (h in data_header) {
                  if(is.null(h) || is.na(h)) {
                    data_header[[n]] <- paste0("V",n)
                  }
                  n <- n + 1
                }
                data_table <- as.data.frame(data_header)
                if (length(raw_data$tabledata) > 1) {
                  for (i in 2:length(raw_data$tabledata)) {
                    raw_row <- raw_data$tabledata[[i]]
                    drow <- as.data.frame(raw_data$tabledata[[i]])
                    data_table <- rbind(data_table, drow)
                  }
                }
                if ('weight' %in% names(data_table)) {
                  data_table$weight <- NULL
                }
                names(data_table) <- NULL
              } else {
                # assume the table is just raw json without the 
                # tabledata sub-array (and other stuff)
                data_table = raw_data
              }
              self$data_matrix = data_table
            } else {
              # it is either valid, or empty either way, assign it
              self$data_matrix <- config$data_matrix
            }
          }
        }
      }
    },
    #' @param base_only whether to only use base columns (TRUE) or add fields (FALSE)
    #' @return list of object attributes suitable for input to new() and from_list() methods
    to_list = function(base_only=FALSE) {
      # returns as a list, which can be set and fed back to 
      # from_list() or new(config)
      t_list <- list(
        pid = as.integer(as.character(self$pid)),
        vid = as.integer(as.character(self$vid)),
        module = as.character(self$module),
        entity_type = as.character(self$entity_type),
        varid = as.integer(as.character(self$varid)),
        bundle = as.character(self$bundle),
        featureid = as.integer(as.character(self$featureid)),
        propname = as.character(self$propname),
        startdate = as.character(self$startdate),
        enddate = as.character(self$enddate),
        propvalue = as.numeric(as.character(self$propvalue)),
        propcode = as.character(self$propcode)
        # todo
        #modified = self$modified,
        # todo:
        #tlid = self$tlid,
        # todo:
        # uid = self$uid
        # todo:
        # bundle = self$bundle
      )
      # accounts for ODBC
      if (base_only == FALSE) {
        t_list$proptext = as.character(self$proptext)
        if (is.list(self$data_matrix)) {
          t_list$data_matrix = as.character(jsonlite::toJSON(self$data_matrix))
        }
        if (is.null(self$bundle)) {
          self$bundle <- 'dh_properties'
          t_list$bundle <- 'dh_properties'
        }
        if (!nchar(self$bundle) > 0) {
          self$bundle <- 'dh_properties'
          t_list$bundle <- 'dh_properties'
        }
        t_list$matrix_revision_id = self$matrix_revision_id
      }
      return(t_list)
    },
    #' @param push_remote whether to automatically propagate changes to remote data source
    #' @return boolean TRUE on success, FALSE on failure
    save = function(push_remote=FALSE) {
      # object class responsibilities
      # - know the required elemenprop such as varid, featureid, entity_type
      #   fail if these required elemenprop are not available 
      pid = FALSE
      if (push_remote) {
        pl <- self$to_list(self$base_only)
        pl$modified = as.integer(now())
        if (!lubridate::is.Date(pl$startdate) & !is.integer(pl$startdate)) {
          # remove 
          pl[[which(names(pl) == 'startdate')]] <- NULL
        }
        if (!lubridate::is.Date(pl$enddate) & !is.integer(pl$enddate)) {
          # remove 
          pl[[which(names(pl) == 'enddate')]] <- NULL
        }
        vl <- pl
        # if this is an insert, add into revisions 
        if (is.na(pl$vid)) {
          vl$vid <- NULL # removes it from list
        } else {
          if (! (pl$vid > 0)) {
            vl$vid <- NULL # removes it from list
          }
        }
        # note: we must quit if given a bad varid
        if (is.na(pl$varid)) {
          message(
            paste0(
              "Error: bad varid given in", pl$propname,"$save(). Returning."
            )
          )
          return(FALSE)
        }
        pid = self$datasource$post('dh_properties', 'pid', pl)
        if (!is.logical(pid)) {
          self$pid = pid
          vl$pid = pid
        }
        # if this is ODBC, we need to manage the revisions
        # also, if we transition to *another* REST, we may also have to do so
        if (self$datasource$connection_type == 'odbc') {
          vid = self$datasource$post('dh_properties_revision', 'vid', vl)
          if (is.na(self$vid)) {
            self$vid = vid
            # set back the revision ID
            status = self$datasource$post('dh_properties', 'pid', list(pid=pid, vid=vid))
          }
        }
        # update fields
        self$save_matrix()
        self$save_field(
          "proptext", "field_data_proptext", 
          list(proptext_format = "plain_text", proptext_value = self$proptext)
        )
        # otherwise, update revisions, especially now that we are no longer 
        # dooing revisions.  THis is likely *not* important as drupal is 
        # the only thing that needs revisions, but since drupal will break if 
        # an entity lacks a revision, it is important in case we ever have to spin
        # it back up.
        # insert into dh_properties_revision (
        #   pid,propname,propcode,propvalue,startdate,featureid,entity_type,
        #   bundle,varid,status,module,uid,modified) 
        # select pid,propname,propcode,propvalue,startdate,featureid,entity_type,
        #   bundle,varid,status,module,uid,modified from dh_properties 
        # where pid = 7685242 RETURNING vid;
        # Returns 8332550, alternative, look for revision:
        #    select vid from dh_properties_revision where pid = 7685242;
        # update dh_properties set vid = 8332550 where pid = 7685242;
      }
      # we call set_prop without base_only because the local Datasource handles complex fields
      self$datasource$set_prop(self$to_list())
    },
    #' @return NULL
    save_matrix = function() {
      if (!is.logical(self$vid) & (self$datasource$connection_type == 'odbc')) {
        if ( is.data.frame(self$data_matrix)) {
          dhm_json <- as.character(jsonlite::toJSON(self$data_matrix))
          params <- list(
            field_dh_matrix_json=dhm_json, 
            entity_id = self$pid,
            bundle = self$bundle,
            entity_type = self$base_entity_type,
            language = 'und',
            delta = 0,
            revision_id=self$vid
          )
          pk = "revision_id" 
          # check the table to see if a record exists, if not nullify the rev id
          matrix_check <- self$datasource$get(
            'field_data_field_dh_matrix','revision_id',list(revision_id = self$vid)
          )
          if (is.logical(matrix_check) || (nrow(matrix_check) == 0)) {
            pk <- NA # forces insert
          }
          self$matrix_revision_id = self$datasource$post(
            'field_data_field_dh_matrix', pk, 
            params
          )
        }
      }
      if (is.na(self$vid) | is.logical(self$vid)) {
        message("Cannot save data matrix because property vid is null")
      }
    },
    #' @param class_field_name what is this field called on this object (deprecated)
    #' @param field_table table to insert into
    #' @param value_pairs attriutes to add to insert above the basic entity info (field value here)
    #' @param pkeys whether to automatically propagate changes to remote data source
    #' @return NULL
    save_field = function(class_field_name, field_table, value_pairs, pkeys=c('entity_type', 'entity_id')) {
      if (!is.logical(self$vid) & (self$datasource$connection_type == 'odbc')) {
        if (!(class_field_name %in% names(self))) {
          message(
            paste(
              "Warning: cannot set field named", class_field_name, 
              "because local property ", class_field_name, 
              "does not exist on object")
          )
          return(FALSE)
        }
        if ( !is.na(self[[class_field_name]])) {
          params <- list(
            entity_id = self$pid,
            bundle = self$bundle,
            entity_type = self$base_entity_type,
            language = 'und',
            delta = 0,
            revision_id=self$vid
          )
          for (k in names(value_pairs)) {
            params[[k]] = value_pairs[[k]]
          }
          check_list = list()
          for (k in pkeys) {
            check_list[[k]] = params[[k]]
          }
          #message("Check list:")
          #message(check_list)
          # check the table to see if a record exists, if not nullify the rev id
          field_check <- self$datasource$get(
            field_table,"", check_list
          )
          if (is.logical(field_check) || nrow(field_check) == 0) {
            pk <- NA # forces insert
          } else {
            # must delete first because our odbc updates are not sophisticated 
            # enough to handle multiple key matches
            pk <- NA # forces insert
            #message("Deleting old")
            fn_delete_odbc(field_table,"", check_list, self$datasource$connection, FALSE, TRUE)
            #self$datasource$delete(field_table,"", check_list)
          }
          #message("Inserting new")
          self$matrix_revision_id = self$datasource$post(
            field_table, pk, 
            params
          )
        }
      }
      if (is.na(self$vid) | is.logical(self$vid)) {
        message("Cannot save data matrix because property vid is null")
      }
    },
    #' @param delete_remote update locally only or push to remote database
    #' @return NULL
    delete = function(delete_remote=FALSE) {
      # object class responsibilities
      # - know the required elemenprop such as varid, featureid, entity_type
      #   fail if these required elemenprop are not available
      subprops <- self$propvalues()
      if (!is.logical(subprops) && nrow(subprops) > 0) {
        for (pvi in 1:nrow(subprops)) {
          pv <- subprops[pvi,]
          subprop <- RomProperty$new(self$datasource, list(pid=pv$pid), TRUE)
          subprop$delete(delete_remote)
        }
      }
      if (delete_remote) {
        finfo <- self$to_list()
        # we pass the pid, since if there are multiple revisions it will delete all
        fid = self$datasource$delete('dh_properties_revision', 'pid', finfo)
      }
      super$delete(delete_remote)
    },
    #'@description 
    #'Takes in a data frame where each column represents a row to store in the 
    #'data matrix of this object. This method tranposes that data frame while
    #'trying to maintain data strcutures and types
    #' @param row_cols A data frame of rows that will be transposed to meet final
    #' model or property structure e.g. \code{data.frame(c(1,'foo'), c(2,'bar'), c(3,'bingo'))}
    #' will be coerced to \code{data.frame(c(1,2,3), c('foo','bar','bingo'))}
    #' @return Nothing, but will set the data_matrix field on RomProperty
    #'   instance
    set_matrix = function(row_cols) {
      # expects a set of rows like this:
      # data.frame(c(1,'foo'), c(2,'bar'), c(3,'bingo'))
      #Transpose each row and then combine into one data frame. Previously we
      #had used t() on the entire data frame to do this all at once, but t()
      #required conversion to matrix which can only hold one data type and was
      #adding white space to vectors with both charaters and numerics as it
      #tried to keep consistent numbers of character
      row_cols <- mapply(
        FUN = function(df,coli){t(df[,coli])},
        coli = 1:ncol(row_cols),
        MoreArgs = list(df = row_cols),
        SIMPLIFY = FALSE)
      #Convert to data frame, but remove column names:
      row_cols <- as.data.frame(do.call(rbind,row_cols))
      names(row_cols) <- NULL
      self$data_matrix = row_cols
    },
    #' @param delete_remote update locally only or push to remote database
    #' @return NULL
    delete_fields = function(delete_remote=FALSE) {
      # object class responsibilities
      # - know the required elemenprop such as varid, featureid, entity_type
      #   fail if these required elemenprop are not available 
      if (delete_remote) {
        finfo <- self$to_list()
        # we pass the pid, since if there are multiple revisions it will delete all
        fid = self$datasource$delete(
          'field_data_dh_matrix', 'entity_id', 
          list(entity_id=self$pid, entity_type='dh_property')
        )
      }
      super$delete(delete_remote)
    }
  )
)