14 Jul 2017

Excel VBA User Defined Function for Transformation of Braun-Blanquet Values to Precentages of Vegetation Cover

Function Transf_BraunBlanquet(ByVal BB_Str As String) As String

'Transformation of Braun-Blanquet 'Artmächtigkeit' to percentage cover (similar to usage in TurboVeg or twinspan)
'The key value mapping can be altered depending on specific requirements
'This UDF is used in the UDF SumKum_BraunBlanquet(), which will apply the Transformation on a range of values and
'will sum the transformed percentages. This cumulative sum can be used to check if the Braun-Blanquet estimation for
'a vegetation layer is reasonable.

    With CreateObject("Scripting.Dictionary")
        '~~> first transfer your list in Dictionary
        .Add "r", "0"
        .Add "+", "0"
        .Add "1", "1"
        .Add "2m", "2"
        .Add "2a", "10"
        .Add "2b", "20"
        .Add "3", "37,5"
        .Add "4", "67,5"
        .Add "5", "87,5"
        
        If Len(BB_Str) = 0 Then
        '~~> case: empty cell
            Transf_BraunBlanquet = 0
            Exit Function
        End If
        
        For Each elem In .keys
            key = elem
            If key = BB_Str Then
                Transf_BraunBlanquet = .Item(elem) * 1
                Exit Function
            End If
        Next elem
        
    End With
    
End Function


Function SumKum_BraunBlanquet(Rng As Range) As Double
'See comments on Transf_BraunBlanquet() for explanations

    Dim Sum As Double
    Dim RngArr As Variant
    
    RngArr = Application.Transpose(Rng) 'dumps range values to array
    
    For Each elem In RngArr
        Sum = Sum + Transf_BraunBlanquet(elem)
    Next elem
    
    SumKum_BraunBlanquet = Sum
    
End Function

16 Dec 2016

VBA Macro to Export Data from Excel Spreadsheet to CSV

Resources: http://stackoverflow.com/questions/13496686/how-to-save-semi-colon-delimited-csv-file-using-vba
and: http://stackoverflow.com/questions/35655426/excel-vba-finding-recording-user-selection

Sub Export_CSV()

    '***************************************************************************************
    'author:    kay cichini
    'date:      26102014
    'update:    16122016
    'purpose:   export current spreadsheet to csv.file to the same file path as source file
    '
    ' !!NOTE!!  files with same name and path will be overwritten
    '***************************************************************************************
  
    Dim MyPath As String
    Dim MyFileName As String
    Dim WB1 As Workbook, WB2 As Workbook
    
    Set WB1 = ActiveWorkbook

    '(1) either used range in active sheet..
    'ActiveWorkbook.ActiveSheet.UsedRange.Copy
    
    '(2) or alternatively, user selected input range:
    Dim rng As Range
    Set rng = Application.InputBox("select cell range with changes", "Cells to be copied", Default:="Select Cell Range", Type:=8)
    Application.ScreenUpdating = False
    rng.Copy

    Set WB2 = Application.Workbooks.Add(1)
    WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
    
    MyFileName = "CSV_Export_" & Format(Date, "ddmmyyyy")
    FullPath = WB1.Path & "\" & MyFileName
    
    Application.DisplayAlerts = False
    If MsgBox("Data copied to " & WB1.Path & "\" & MyFileName & vbCrLf & _
    "Warning: Files in directory with same name will be overwritten!!", vbQuestion + vbYesNo) <> vbYes Then
        Exit Sub
    End If
    
    If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
    With WB2
        .SaveAs Filename:=FullPath, FileFormat:=xlCSV, CreateBackup:=False
        .Close False
    End With
    Application.DisplayAlerts = True
End Sub

18 Oct 2016

Collect GPX-Files from Subdirectories and Convert to Single KML File

Reference: https://cran.r-project.org/web/packages/sp/vignettes/intro_sp.pdf

library(sp)
library(rgdal)

# here, m ygpx files reside in subdirectories..
setwd("D:/WEB/gardaweb")

files <- dir(pattern="*.gpx$", recursive = T, include.dirs = T)

# extract spatial lines
spl <- lapply(files, function(x) {readOGR(x, "tracks")@lines[[1]]} )
str(spl)

# apply ID to ID slot for latter merge with attribute data
for(i in 1:length(spl)) {slot(spl[[i]], "ID") <- as.character(i)}
tracksSL <- SpatialLines(spl, proj4string = CRS("+proj=longlat +datum=WGS84"))

# view data
summary(tracksSL)
plot(tracksSL)

# make dataframe for merging with spatial data
names <- sub("[.]gpx$", "", basename(files))
df <- data.frame(names = names, row.names = sapply(slot(tracksSL, "lines"), function(x) slot(x, "ID")))

# spatial dataframe
tracksSLDF <- SpatialLinesDataFrame(tracksSL, data = df)

# write ressult to KML
writeOGR(tracksSLDF, dsn="tracks_collection.kml", layer= "Wolfi_Garda_Tracks", driver="KML", dataset_options=c("NameField=names"))