R/TopviewTopographicMap.R

Defines functions TopviewTopographicMap

Documented in TopviewTopographicMap

TopviewTopographicMap <- function(GeneralizedUmatrix,BestMatchingUnits,Cls,
                                  ClsColors=NULL,Imx=NULL,
                                  ClsNames=NULL,
                                  BmSize=6,DotLineWidth=2,alpha=1,...) {
  #author: Tim Schreier, Luis Winckelmann, MCT, QS
  
  #CopyCls = Cls
  #counter = 1
  #for(j in sort(unique(Cls))){
  #  CopyCls[which(Cls == j)] = counter
  #  counter = counter + 1
  #}
  #Cls = CopyCls
  #Cls <- CopyCls
  #Cls <<- CopyCls
  
  if(missing(GeneralizedUmatrix)) stop('TopviewTopographicMap: GeneralizedUmatrix is missing.')
  if(is.null(GeneralizedUmatrix)) stop('TopviewTopographicMap: GeneralizedUmatrix is missing.')
  
  
  udim <- dim(GeneralizedUmatrix)
  
  if (!requireNamespace('plotly',quietly = TRUE)) {
    message(
      'Subordinate clustering package (plotly) is missing. No computations are performed.
            Please install the package which is defined in "Suggests".'
    )
    return( "Subordinate clustering package (plotly) is missing.
                Please install the package which is defined in 'Suggests'." )
  }
  
  #Tiled needed for Imx
  if(!is.null(Imx)){
    Tiled=TRUE
  }
  
  # Error Catching ----
  if (missing(BestMatchingUnits)) {
    BestMatchingUnits = matrix(1, 2, 2)
    warning('TopviewTopographicMap: BestMatchingUnits are missing.Creating a dummy..')
  }
  if (!is.matrix(BestMatchingUnits))
    stop('TopviewTopographicMap: Bestmatches have to be a matrix')
  else
    b = dim(BestMatchingUnits)
  
  if (b[2] > 3 | b[2] < 2)
    stop(paste0('TopviewTopographicMap: Wrong number of Columns of Bestmatches: ', b[2]))
  if (b[2] == 3) {
    BestMatchingUnits = BestMatchingUnits[, 2:3]
  }

  if (missing(Cls))
    Cls = rep(1, b[1])
  
  d = dim(GeneralizedUmatrix)
  if (is.null(d)) {
    stop('TopviewTopographicMap: GeneralizedUmatrix Dimension is null. Please check Input')
  }
  
 # requireNamespace('matrixStats')
  mini=apply(BestMatchingUnits, 2, min,na.rm=TRUE)
  maxi=apply(BestMatchingUnits, 2, max,na.rm=TRUE)
  #mini = matrixStats::colMins(BestMatchingUnits, na.rm = TRUE)
 # maxi = matrixStats::colMaxs(BestMatchingUnits, na.rm = TRUE)
  if (sum(mini) < 2) {
    stop('TopviewTopographicMap: Some Bestmatches are below 1 in X or Y/Columns or Lines')
  }
  if (d[1] < maxi[1]) {
    stop(
      paste0(
        'TopviewTopographicMap: Range of Bestmatches',
        maxi[1],
        ' is higher than Range of GeneralizedUmatrix',
        d[1]
      )
    )
  }
  if (d[2] < maxi[2]) {
    stop(
      paste0(
        'TopviewTopographicMap: Range of Bestmatches',
        maxi[2],
        ' is higher than Range of GeneralizedUmatrix',
        d[2]
      )
    )
  }
  if (!is.vector(Cls)) {
    warning('TopviewTopographicMap: Cls is not a vector. Calling as.vector()')
    Cls = as.vector(Cls)
  }
  if (!is.numeric(Cls)) {
    warning('TopviewTopographicMap: Cls is not a numeric Calling as.numeric()')
    Cls = as.numeric(Cls)
  }
  if (sum(!is.finite(Cls)) > 0) {
    warning('TopviewTopographicMap: Not all values in Cls are finite. Generating nonfiniteclass with value 999')
    Cls[!is.finite(Cls)] = 999
  }

  if (length(Cls) != b[1]) {

    warning(
      paste0(
        'TopviewTopographicMap: Cls has the length ',
        length(Cls),
        ' which does not equal the number of the BestMatchingUnits: ',
        b[1],
        '. Plotting without Cls.'
      )
    )
    Cls = rep(1, b[1])
  }
  
  #Handle Color ----
  colormap = GeneralizedUmatrix::UmatrixColormap
  
  if (is.null(ClsColors)) {
    ClsColors = GeneralizedUmatrix::DefaultColorSequence
    ClsColors = ClsColors[-5] #green is not visible in plotly
  } else{
    if (length(unique(Cls)) > length(ClsColors)) {
      stop('TopviewTopographicMap: Length of vector of Clscolor does not match the number of unique Clusters in Cls.')
    }
  }
  
  ## Additional Arguments ----
  dots = list(...)
  #in case of pmatrix
  if (is.null(dots[["Tiled"]]))
    Tiled = FALSE
  else
    Tiled=dots[["Tiled"]]
  if(!is.null(Imx)){
    Tiled=TRUE
  }
  
  #axis with labels
  if (is.null(dots[["ShinyBinding"]]))
    ShinyBinding = FALSE
  else
    ShinyBinding=dots[["ShinyBinding"]]
  
  if (is.null(dots[["ShinyDimension"]]))
    ShinyDimension = 1
  else
    ShinyDimension=dots[["ShinyDimension"]]
  
  if (!is.null(dots[["Session"]]))
    session = dots[["Session"]]
  
  if (is.null(dots[["main"]]))
    main = "Topographic Map of Generalized U-Matrix"
  else
    main=dots[["main"]]
  
  if (is.null(dots[["LegendCex"]]))
    LegendCex = NULL
  else
    LegendCex=dots[["LegendCex"]]
  
  if (is.null(dots[["MainCex"]]))
    MainCex = NULL
  else
    MainCex=dots[["MainCex"]]

  if (is.null(dots[["NamesOrientation"]]))
    NamesOrientation = NULL
  else
    NamesOrientation=dots[["NamesOrientation"]]
  
  if (is.null(dots[["NamesTitle"]]))
    NamesTitle = NULL
  else
    NamesTitle=dots[["NamesTitle"]]
  
  #Helper Function ----
  addclass <- function(class, plotbmus, plot, bmu_cols, MarkerSize, my_counter,
                       ClsNames, DotLineWidth, alpha){
    inds <- which(Cls == class)
    x = as.numeric(plotbmus[inds, 2])
    y = as.numeric(plotbmus[inds, 1])
    # Color names to RGBA = RGB + Opacity
    if(is.character(bmu_cols)){
      #vecRGBA  = col2rgb(bmu_cols[class], 1)
      vecRGBA  = col2rgb(bmu_cols[my_counter], alpha)
      my_color = paste("rgba(", vecRGBA[1], ",", vecRGBA[2], ",",
                       vecRGBA[3], ",", alpha,")", sep="")
    }else{
      my_color = "rgba(80, 80, 80, .8)"
    }
    marker = list(size = MarkerSize,
                  color = my_color,#bmu_cols[class],
                  line = list(color="rgba(0, 0, 0, .8)", width = DotLineWidth))
                  #line = list(color="rgba(80, 80, 80, .8)", width = 3))

    if(is.null(ClsNames)){
      name = class
      #standard names
      plot <- plotly::add_markers(plot, x=x, y=y, marker = marker,
                                  name = paste("Cluster", name))
    }else{
      name = ClsNames[my_counter]
      #user names
      plot <- plotly::add_markers(plot, x=x, y=y, marker = marker,
                                  name = name)
    }

    return(plot)
  }
  
  
  PlotlyUmatrix = function(plotdim, plotumx, colormap, Nrlevels2, plotbmus,
                           class, ClsColors, MarkerSize, ShinyBinding,
                           ShinyDimension, Imx, Cls, DotLineWidth, alpha){
    # configure filter, so that every bestmatch stays in
    # put Imx on Umatrix and bestmatches if given
    if(!is.null(Imx)){
      if(!is.null(plotbmus)){
        BestMatchesFilter = rep(T,nrow(plotbmus)) # every Bestmatch stays
      }
      plotumx[which(Imx == 1)] = 0
      bigImx = Imx
      #print(str(BestMatchesFilter))
      #print(str(plotbmus))
      for(i in 1:nrow(Imx)){
        for(j in 1:ncol(Imx)){
          if(Imx[i,j] == 1){
            #plotumx[i,j] = NA
            if(!is.null(plotbmus)){
              BestMatchesFilter[(plotbmus[,1] == i) & (plotbmus[,2] == j)] = F
            }
          }
        }
      }
      #BestMatchesFilter = rep(T,nrow(plotbmus)) # every Bestmatch stays
      #print(str(BestMatchesFilter))
      if(!is.null(plotbmus)) plotbmus = plotbmus[BestMatchesFilter,]
      #print(str(class))
      #print(class)
      #todo, ohne globale variable loesen
      if(!is.null(Cls)) Cls <<- Cls[BestMatchesFilter]
      
      oceanLine = apply(plotumx, 1, function(x) all(x==0))
      startLine = min(which(!oceanLine),na.rm=T)
      endLine = length(oceanLine) - min(which(rev(!oceanLine)),na.rm=T) + 1
      
      oceanCol = apply(plotumx, 2, function(x) all(x==0))
      startCol = min(which(!oceanCol),na.rm=T)
      endCol = length(oceanCol) - min(which(rev(!oceanCol)),na.rm=T) + 1
   
      if(!is.null(plotbmus)){
        plotbmus <- plotbmus - cbind(rep(startLine-1,nrow(plotbmus)),rep(startCol-1,nrow(plotbmus)))
      }
      plotumx <- plotumx[startLine:endLine,startCol:endCol]
      Imx <- Imx[startLine:endLine,startCol:endCol]
      bigImx <- bigImx[startLine:endLine,startCol:endCol]
    }
    ax <- list(title = "", zeroline = FALSE, showline = FALSE, #showticklabels = FALSE,
               showgrid = FALSE
    )
    ay <- list(autorange = "reversed", title = "", zeroline = FALSE,
               showline = FALSE, #showticklabels = FALSE,
               showgrid = FALSE)
    if (isTRUE(ShinyBinding)) {
      width = (0.95 * as.numeric(ShinyDimension[1]))
      height = udim[1] / udim[2] * (width - 80)
      #print(width)
      plt <- plotly::plot_ly(width = width, height = height * 0.75)
    }else{
      plt <- plotly::plot_ly()
    }
    plt <- plotly::add_contour(plt, x = 1:plotdim[1], y = 1:plotdim[2], 
                               z = plotumx, showscale = FALSE, 
                               line = list(color = 'black', width = 0.5), 
                               contours = list(start=0, end=1, size=1/15),
                               colors = colorRamp(colormap[c(  1,2,
                                      seq(from=3, to=length(colormap)-30, 
                                          length.out = ceiling(Nrlevels2+1)-4),
                                      length(colormap), length(colormap))]),
                                # colors = colorRamp(colormap[c(rep(3, 6),
                                #                               seq(
                                #                                 from = 4,
                                #                                 to = length(colormap) - 30,
                                #                                 length.out = ceiling(Nrlevels2 + 1) - 7
                                #                               ),
                                #                               length(colormap))]),
                                name = "UMatrix")
                                # , showscale = FALSE
    my_counter = 1
    ClsColors = ClsColors[order(unique(Cls))]
    for(class in sort(unique(Cls), decreasing = F)){    # QS: Force stable order in the plot legend
      plt <- addclass(class, plotbmus, plt, ClsColors, MarkerSize, my_counter,
                      ClsNames, DotLineWidth, alpha)
      my_counter = my_counter + 1
    }#end add class
    plt <- plotly::layout(
      plt,
      xaxis = ax,
      yaxis = ay,
      dragmode = 'lasso',
      legend = list(orientation = 'h')#,font = list(size = LegendCex))
      #, showlegend = FALSE
    )
    
    #if (isTRUE(ShinyBinding)) {
    #  requireNamespace('shiny')
    #  shiny::updateSelectInput(session,
    #                    "ClsSelect",
    #                    label = "Select Class",
    #                    choices = unique(Cls))
    #}

    return(plt)
  }
  
  if (missing(Cls))
    Cls = rep(1, nrow(BestMatchingUnits))
  
  #Normalizing GeneralizedUmatrix ----
  
 
  quants = quantile(as.vector(GeneralizedUmatrix), c(0.01, 0.5, 0.99))
  minU = quants[1]
  maxU = quants[3]
  GeneralizedUmatrix = (GeneralizedUmatrix - minU)/(maxU -
                                                      minU)
   quants2 = quantile(as.vector(GeneralizedUmatrix), c(0.01, 
                                                      0.5, 0.99))
  minU2 = quants2[1]
  maxU2 = quants2[3]
  HeightScale = round(maxU2 / (2 * max(minU2, 0.05)), 0)
  stretchFactor = sqrt(nrow(GeneralizedUmatrix) ^ 2 + ncol(GeneralizedUmatrix) ^
                         2) / sqrt(50 ^ 2 + 80 ^ 2)
  Nrlevels2 = 2 * HeightScale * stretchFactor
  indMax = which(GeneralizedUmatrix > 1, arr.ind = T)
  indMin = which(GeneralizedUmatrix < 0, arr.ind = T)
  if (length(indMax) > 0)
    GeneralizedUmatrix[indMax] = 1
  if (length(indMin) > 0)
    GeneralizedUmatrix[indMin] = 0

  # GeneralizedUmatrix <- GeneralizedUmatrix * HeightScale * stretchFactor
  if (isTRUE(Tiled)) {
    
    tU <- tileGUM(GeneralizedUmatrix,BestMatchingUnits,Cls)
    GeneralizedUmatrix <- tU$GeneralizedUmatrix
    BestMatchingUnits <- tU$BestMatchingUnits[,2:3] #no key
    Cls <- tU$Cls
    qdim <- udim * 2
    #dmx  <- cbind(GeneralizedUmatrix, GeneralizedUmatrix)
    #qmx  <- rbind(dmx, dmx)
    #dbm  <-
    #  rbind(BestMatchingUnits,
    #        cbind(BestMatchingUnits[, 1], BestMatchingUnits[, 2] + udim[2]))
    #qbm  <- rbind(dbm, cbind(dbm[, 1] + udim[1], dbm[, 2]))
    plotumx <- tU$GeneralizedUmatrix
    plotbmus <- tU$BestMatchingUnits[,2:3] #no key
    plotCls <-  tU$Cls
  } else{
    if(is.null(dots[["ExtendBorders"]])){
      #nothing
    }else{
      ExtendBorders=dots$ExtendBorders
      V=ExtendToroidalUmatrix(GeneralizedUmatrix,BestMatchingUnits,ExtendBorders)
      GeneralizedUmatrix=V$Umatrix
      BestMatchingUnits=V$Bestmatches
    }
    plotumx <- GeneralizedUmatrix
    plotbmus <- BestMatchingUnits
    plotCls <- Cls
    qdim <- udim
  }
  
  plotdim <- qdim
  plt=PlotlyUmatrix(plotdim, plotumx, colormap, Nrlevels2, plotbmus, class,
                    ClsColors, BmSize, ShinyBinding, ShinyDimension, Imx, Cls,
                    DotLineWidth, alpha)
  
  if(!is.null(main))
    plt=plotly::layout(plt,title = list(text=main))
  
  if(!is.null(LegendCex))
    plt=plotly::layout(plt,legend = list(font = list(size = LegendCex)))
  
  if(!is.null(MainCex))
    plt=plotly::layout(plt,  title=list(font=list(size=MainCex)))
  
  if(!is.null(NamesOrientation))
    plt=plotly::layout(plt,    legend = list(orientation = NamesOrientation))
  
  if(!is.null(NamesTitle))
    plt=plotly::layout(plt,    legend = list(title = list(text=NamesTitle)))
  
  if(!is.null(LegendCex)&!is.null(NamesTitle))
    plt=plotly::layout(plt,    legend = list(title = list(texsize=LegendCex)))
  
  #if (isTRUE(ShinyBinding)) {
  #  PlotR <- plotly::renderPlotly({
  #    plt
  #  })
  #  return(list(Rendered=PlotR,single=plt))
  #} else{
  #}
  return(plt)
}

Try the GeneralizedUmatrix package in your browser

Any scripts or data that you put into this service are public.

GeneralizedUmatrix documentation built on May 31, 2023, 7:26 p.m.